persistent 0.9.0.4 → 1.0.0
raw patch · 13 files changed
+213/−123 lines, 13 filesdep +monad-loggerdep +template-haskelldep ~conduit
Dependencies added: monad-logger, template-haskell
Dependency ranges changed: conduit
Files
- Database/Persist/EntityDef.hs +1/−0
- Database/Persist/GenericSql.hs +18/−13
- Database/Persist/GenericSql/Internal.hs +10/−2
- Database/Persist/GenericSql/Migration.hs +7/−6
- Database/Persist/GenericSql/Raw.hs +21/−26
- Database/Persist/Quasi.hs +7/−2
- Database/Persist/Query.hs +1/−0
- Database/Persist/Query/GenericSql.hs +31/−17
- Database/Persist/Query/Internal.hs +47/−16
- Database/Persist/Query/Join.hs +2/−2
- Database/Persist/Query/Join/Sql.hs +2/−1
- Database/Persist/Store.hs +62/−36
- persistent.cabal +4/−2
Database/Persist/EntityDef.hs view
@@ -25,6 +25,7 @@ , entityUniques :: [UniqueDef] , entityDerives :: [Text] , entityExtra :: Map Text [ExtraLine]+ , entitySum :: Bool } deriving (Show, Eq, Read, Ord)
Database/Persist/GenericSql.hs view
@@ -62,6 +62,7 @@ import Database.Persist.EntityDef import qualified Data.Conduit as C import qualified Data.Conduit.List as CL+import Control.Monad.Logger (MonadLogger) type ConnectionPool = Pool Connection @@ -73,7 +74,7 @@ Right (i, "") -> Just $ Key $ PersistInt64 i _ -> Nothing -execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()+execute' :: (MonadIO m, MonadLogger m) => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute -- | Get a connection from the pool, run the given action, and then return the@@ -91,7 +92,7 @@ liftIO $ commitC conn getter return x -instance (MonadBaseControl IO m, MonadIO m, C.MonadThrow m, C.MonadUnsafeIO m) => PersistStore SqlPersist m where+instance (MonadBaseControl IO m, MonadIO m, C.MonadThrow m, C.MonadUnsafeIO m, MonadLogger m) => PersistStore SqlPersist m where insert val = do conn <- SqlPersist ask let esql = insertSql conn (entityDB t) (map fieldDB $ entityFields t)@@ -123,8 +124,8 @@ , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE id=?" ]- execute' sql $ map toPersistValue (toPersistFields val)- `mappend` [unKey k]+ vals = map toPersistValue (toPersistFields val) `mappend` [unKey k]+ execute' sql vals where go conn x = escapeName conn x ++ "=?" @@ -147,7 +148,8 @@ , escapeName conn $ entityDB t , " WHERE id=?" ]- C.runResourceT $ R.withStmt sql [unKey k] C.$$ do+ vals' = [unKey k]+ C.runResourceT $ R.withStmt sql vals' C.$$ do res <- CL.head case res of Nothing -> return Nothing@@ -167,7 +169,7 @@ , " WHERE id=?" ] -insrepHelper :: (MonadIO m, PersistEntity val)+insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m) => Text -> Key SqlPersist val -> val@@ -191,10 +193,12 @@ ] vals = k : map toPersistValue (toPersistFields val) -instance (MonadBaseControl IO m, C.MonadUnsafeIO m, MonadIO m, C.MonadThrow m) => PersistUnique SqlPersist m where+instance (MonadBaseControl IO m, C.MonadUnsafeIO m, MonadIO m, C.MonadThrow m, MonadLogger m) => PersistUnique SqlPersist m where deleteBy uniq = do conn <- SqlPersist ask- execute' (sql conn) $ persistUniqueToValues uniq+ let sql' = sql conn+ vals = persistUniqueToValues uniq+ execute' sql' vals where t = entityDef $ dummyFromUnique uniq go = map snd . persistUniqueToFieldNames@@ -218,7 +222,8 @@ , " WHERE " , sqlClause conn ]- C.runResourceT $ R.withStmt sql (persistUniqueToValues uniq) C.$$ do+ vals' = persistUniqueToValues uniq+ C.runResourceT $ R.withStmt sql vals' C.$$ do row <- CL.head case row of Nothing -> return Nothing@@ -455,7 +460,7 @@ -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'.-rawSql :: (RawSql a, C.MonadUnsafeIO m, C.MonadThrow m, MonadIO m, MonadBaseControl IO m) =>+rawSql :: (RawSql a, C.MonadUnsafeIO m, C.MonadThrow m, MonadIO m, MonadBaseControl IO m, MonadLogger m) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> SqlPersist m [a]@@ -467,10 +472,10 @@ x = getType run process = rawSqlProcessRow - withStmt' colSubsts = R.withStmt $ T.concat $- makeSubsts colSubsts $- T.splitOn placeholder stmt+ withStmt' colSubsts params = do+ R.withStmt sql params where+ sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt placeholder = "??" makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts makeSubsts [] [] = []
Database/Persist/GenericSql/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE CPP #-}@@ -13,6 +14,7 @@ , createSqlPool , mkColumns , Column (..)+ , logSQL ) where import qualified Data.Map as Map@@ -29,6 +31,9 @@ import Data.Monoid (Monoid, mappend, mconcat) import Database.Persist.EntityDef import qualified Data.Conduit as C+import Language.Haskell.TH.Syntax (Q, Exp)+import Control.Monad.Logger (logOther)+import Data.Maybe (mapMaybe, listToMaybe) data Connection = Connection { prepare :: Text -> IO Statement@@ -106,8 +111,8 @@ go fd p = Column (fieldDB fd)- (nullable $ fieldAttrs fd)- (sqlType p)+ (nullable (fieldAttrs fd) || entitySum t)+ (maybe (sqlType p) SqlOther $ listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd) (def $ fieldAttrs fd) (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd))@@ -187,3 +192,6 @@ | x == s = ColumnDef x y z | otherwise = go rest -}++logSQL :: Q Exp+logSQL = [|\sql_foo params_foo -> $(logOther "SQL") $ T.pack $ show (sql_foo :: Text) ++ " " ++ show (params_foo :: [PersistValue])|]
Database/Persist/GenericSql/Migration.hs view
@@ -35,8 +35,9 @@ import Data.Text (Text, unpack, snoc) import qualified Data.Text.IO import System.IO+import Control.Monad.Logger (MonadLogger) -execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()+execute' :: (MonadIO m, MonadLogger m) => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute type Sql = Text@@ -77,20 +78,20 @@ mig <- parseMigration' m return $ allSql mig -runMigration :: (MonadIO m, MBCIO m)+runMigration :: (MonadIO m, MBCIO m, MonadLogger m) => Migration (SqlPersist m) -> SqlPersist m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: (MBCIO m, MonadIO m)+runMigrationSilent :: (MBCIO m, MonadIO m, MonadLogger m) => Migration (SqlPersist m) -> SqlPersist m [Text] runMigrationSilent m = runMigration' m True runMigration'- :: (MBCIO m, MonadIO m)+ :: (MBCIO m, MonadIO m, MonadLogger m) => Migration (SqlPersist m) -> Bool -- ^ is silent? -> SqlPersist m [Text]@@ -104,14 +105,14 @@ , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs ] -runMigrationUnsafe :: (MBCIO m, MonadIO m)+runMigrationUnsafe :: (MBCIO m, MonadIO m, MonadLogger m) => Migration (SqlPersist m) -> SqlPersist m () runMigrationUnsafe m = do mig <- parseMigration' m mapM_ (executeMigrate False) $ allSql mig -executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text+executeMigrate :: (MonadIO m, MonadLogger m) => Bool -> Text -> SqlPersist m Text executeMigrate silent s = do unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s execute' s []
Database/Persist/GenericSql/Raw.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}@@ -29,8 +30,9 @@ #define MBCIO MonadBaseControl IO import Data.Text (Text) import Control.Monad (MonadPlus)-import Control.Monad.Trans.Resource (MonadThrow (..), MonadResource (..))-import qualified Data.Conduit as C+import Control.Monad.Trans.Resource (MonadResource (..))+import Data.Conduit+import Control.Monad.Logger (MonadLogger (..)) newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)@@ -38,10 +40,10 @@ instance MonadThrow m => MonadThrow (SqlPersist m) where monadThrow = lift . monadThrow -instance MonadBase b m => MonadBase b (SqlPersist m) where+instance MonadBase backend m => MonadBase backend (SqlPersist m) where liftBase = lift . liftBase -instance MonadBaseControl b m => MonadBaseControl b (SqlPersist m) where+instance MonadBaseControl backend m => MonadBaseControl backend (SqlPersist m) where newtype StM (SqlPersist m) a = StMSP {unStMSP :: ComposeSt SqlPersist m a} liftBaseWith = defaultLiftBaseWith StMSP restoreM = defaultRestoreM unStMSP@@ -56,40 +58,33 @@ allocate a = lift . allocate a resourceMask = lift . resourceMask -class MonadIO m => MonadSqlPersist m where+class (MonadIO m, MonadLogger m) => MonadSqlPersist m where askSqlConn :: m Connection -instance MonadIO m => MonadSqlPersist (SqlPersist m) where+instance (MonadIO m, MonadLogger m) => MonadSqlPersist (SqlPersist m) where askSqlConn = SqlPersist ask-instance MonadSqlPersist m => MonadSqlPersist (C.ResourceT m) where+instance MonadSqlPersist m => MonadSqlPersist (ResourceT m) where askSqlConn = lift askSqlConn -- FIXME add a bunch of MonadSqlPersist instances for all transformers +instance MonadLogger m => MonadLogger (SqlPersist m) where+ monadLoggerLog a b c = lift $ monadLoggerLog a b c+ withStmt :: (MonadSqlPersist m, MonadResource m) => Text -> [PersistValue]- -> C.Source m [PersistValue]-withStmt sql vals = C.PipeM- (do- stmt <- getStmt sql- reset' <- register $ I.reset stmt- return $ pull reset' $ I.withStmt stmt vals)- (return ())- where- pull reset' (C.Done _ ()) = C.PipeM (do- release reset'- return $ C.Done Nothing ()) (release reset')- pull reset' (C.HaveOutput src close' x) = C.HaveOutput- (pull reset' src)- (release reset' >> close')- x- pull reset' (C.PipeM msrc close') = C.PipeM- (pull reset' `liftM` msrc)- (release reset' >> close')- pull reset' (C.NeedInput _ c) = pull reset' c+ -> Source m [PersistValue]+withStmt sql vals = do+ lift $ $logSQL sql vals+ conn <- lift askSqlConn+ bracketP+ (getStmt' conn sql)+ I.reset+ (flip I.withStmt vals) execute :: MonadSqlPersist m => Text -> [PersistValue] -> m () execute sql vals = do+ $logSQL sql vals stmt <- getStmt sql liftIO $ I.execute stmt vals liftIO $ reset stmt
Database/Persist/Quasi.hs view
@@ -185,12 +185,17 @@ -> EntityDef mkEntityDef ps name entattribs lines = EntityDef- (HaskellName name)- (DBName $ getDbName ps name entattribs)+ (HaskellName name')+ (DBName $ getDbName ps name' entattribs) (DBName $ idName entattribs) entattribs cols uniqs derives extras+ isSum where+ (isSum, name') =+ case T.uncons name of+ Just ('+', x) -> (True, x)+ _ -> (False, name) (attribs, extras) = splitExtras lines idName [] = "id" idName (t:ts) =
Database/Persist/Query.hs view
@@ -3,6 +3,7 @@ module Database.Persist.Query ( PersistQuery (..) , selectList+ , selectKeysList , deleteCascadeWhere , SelectOpt (..)
Database/Persist/Query/GenericSql.hs view
@@ -34,7 +34,7 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Data.Conduit as C+import Data.Conduit import qualified Data.Conduit.List as CL import Control.Monad.Trans.Resource (transResourceT) @@ -42,9 +42,10 @@ import qualified Data.Text as T import Database.Persist.EntityDef import Data.Monoid (Monoid, mappend, mconcat)+import Control.Monad.Logger (MonadLogger) -- orphaned instance for convenience of modularity-instance (C.MonadThrow m, MonadIO m, C.MonadUnsafeIO m, MonadBaseControl IO m) => PersistQuery SqlPersist m where+instance (MonadThrow m, MonadIO m, MonadUnsafeIO m, MonadBaseControl IO m, MonadLogger m) => PersistQuery SqlPersist m where update _ [] = return () update k upds = do conn <- SqlPersist ask@@ -77,17 +78,15 @@ , escapeName conn $ entityDB t , wher ]- C.runResourceT $ R.withStmt sql (getFiltsValues conn filts) C.$$ do+ runResourceT $ R.withStmt sql (getFiltsValues conn filts) $$ do Just [PersistInt64 i] <- CL.head return $ fromIntegral i where t = entityDef $ dummyFromFilts filts - selectSource filts opts = C.PipeM- (do- conn <- lift $ SqlPersist ask- return $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse)- (return ())+ selectSource filts opts = do+ conn <- lift $ lift $ SqlPersist ask+ R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where (limit, offset, orders) = limitOffsetOrder opts @@ -130,11 +129,9 @@ , off ] - selectKeys filts = C.PipeM- (do- conn <- lift $ SqlPersist ask- return $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse)- (return ())+ selectKeys filts opts = do+ conn <- lift $ lift $ SqlPersist ask+ R.withStmt (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where parse [PersistInt64 i] = return $ Key $ PersistInt64 i parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " ++ show y@@ -148,8 +145,25 @@ , " FROM " , escapeName conn $ entityDB t , wher conn+ , ord conn+ , lim conn+ , off ] + (limit, offset, orders) = limitOffsetOrder opts++ ord conn =+ case map (orderClause False conn) orders of+ [] -> ""+ ords -> " ORDER BY " ++ T.intercalate "," ords+ lim conn = case (limit, offset) of+ (0, 0) -> ""+ (0, _) -> T.cons ' ' $ noLimit conn+ (_, _) -> " LIMIT " ++ show limit+ off = if offset == 0+ then ""+ else " OFFSET " ++ show offset+ deleteWhere filts = do conn <- SqlPersist ask let t = entityDef $ dummyFromFilts filts@@ -195,7 +209,7 @@ dummyFromKey :: Key SqlPersist v -> v dummyFromKey _ = error "dummyFromKey" -execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()+execute' :: (MonadLogger m, MonadIO m) => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue]@@ -343,13 +357,13 @@ -- the environment inside a 'SqlPersist' monad, provide an explicit -- 'Connection'. This can allow you to use the returned 'Source' in an -- arbitrary monad.-selectSourceConn :: (PersistEntity val, SqlPersist ~ PersistEntityBackend val, C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m)+selectSourceConn :: (PersistEntity val, SqlPersist ~ PersistEntityBackend val, MonadThrow m, MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m, MonadLogger m) => Connection -> [Filter val] -> [SelectOpt val]- -> C.Source (C.ResourceT m) (Entity val)+ -> Source (ResourceT m) (Entity val) selectSourceConn conn fs opts =- C.transPipe (transResourceT $ flip runSqlConn conn) (selectSource fs opts)+ transPipe (transResourceT $ flip runSqlConn conn) (selectSource fs opts) dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts"
Database/Persist/Query/Internal.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Query.Internal ( -- re-exported as public PersistQuery (..) , selectList+ , selectKeysList -- just Internal , SelectOpt (..)@@ -14,39 +16,60 @@ , Update (..) , updateFieldDef , deleteCascadeWhere++ -- * Exceptions+ , UpdateGetException (..) ) where import Database.Persist.Store import Database.Persist.EntityDef import Control.Monad.Trans.Class (lift)+import Control.Monad.Base (liftBase)+import Control.Exception (Exception, throwIO)+import Data.Typeable (Typeable) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +data UpdateGetException = KeyNotFound String+ deriving Typeable+instance Show UpdateGetException where+ show (KeyNotFound key) = "Key not found during updateGet: " ++ key+instance Exception UpdateGetException -class PersistStore b m => PersistQuery b m where+class PersistStore backend m => PersistQuery backend m where -- | Update individual fields on a specific record.- update :: PersistEntity val => Key b val -> [Update val] -> b m ()+ update :: PersistEntity val => Key backend val -> [Update val] -> backend m () + -- | Update individual fields on a specific record, and retrieve the+ -- updated value from the database.+ --+ -- Note that this function will throw an exception if the given key is not+ -- found in the database.+ updateGet :: PersistEntity val => Key backend val -> [Update val] -> backend m val+ updateGet key ups = do+ update key ups+ get key >>= maybe (liftBase $ throwIO $ KeyNotFound $ show key) return+ -- | Update individual fields on any record matching the given criterion.- updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> b m ()+ updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> backend m () -- | Delete all records matching the given criterion.- deleteWhere :: PersistEntity val => [Filter val] -> b m ()+ deleteWhere :: PersistEntity val => [Filter val] -> backend m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource- :: (PersistEntity val, PersistEntityBackend val ~ b)+ :: (PersistEntity val, PersistEntityBackend val ~ backend) => [Filter val] -> [SelectOpt val]- -> C.Source (C.ResourceT (b m)) (Entity val)+ -> C.Source (C.ResourceT (backend m)) (Entity val) -- | get just the first record for the criterion- selectFirst :: (PersistEntity val, PersistEntityBackend val ~ b)+ selectFirst :: (PersistEntity val, PersistEntityBackend val ~ backend) => [Filter val] -> [SelectOpt val]- -> b m (Maybe (Entity val))+ -> backend m (Maybe (Entity val)) selectFirst filts opts = C.runResourceT $ selectSource filts ((LimitTo 1):opts) C.$$ CL.head @@ -54,10 +77,11 @@ -- | Get the 'Key's of all records matching the given criterion. selectKeys :: PersistEntity val => [Filter val]- -> C.Source (C.ResourceT (b m)) (Key b val)+ -> [SelectOpt val]+ -> C.Source (C.ResourceT (backend m)) (Key backend val) -- | The total number of records fulfilling the given criterion.- count :: PersistEntity val => [Filter val] -> b m Int+ count :: PersistEntity val => [Filter val] -> backend m Int -- | Filters which are available for 'select', 'updateWhere' and -- 'deleteWhere'. Each filter constructor specifies the field being@@ -77,13 +101,20 @@ | OffsetBy Int | LimitTo Int --- | Call 'select' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery b m, PersistEntityBackend val ~ b)+-- | Call 'selectSource' but return the result as a list.+selectList :: (PersistEntity val, PersistQuery backend m, PersistEntityBackend val ~ backend) => [Filter val] -> [SelectOpt val]- -> b m [Entity val]+ -> backend m [Entity val] selectList a b = C.runResourceT $ selectSource a b C.$$ CL.consume +-- | Call 'selectKeys' but return the result as a list.+selectKeysList :: (PersistEntity val, PersistQuery b m, PersistEntityBackend val ~ b)+ => [Filter val]+ -> [SelectOpt val]+ -> b m [Key b val]+selectKeysList a b = C.runResourceT $ selectKeys a b C.$$ CL.consume+ data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here deriving (Read, Show, Enum, Bounded) @@ -104,7 +135,7 @@ updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f -deleteCascadeWhere :: (DeleteCascade a b m, PersistQuery b m)- => [Filter a] -> b m ()+deleteCascadeWhere :: (DeleteCascade a backend m, PersistQuery backend m)+ => [Filter a] -> backend m () deleteCascadeWhere filts = do- C.runResourceT $ selectKeys filts C.$$ CL.mapM_ (lift . deleteCascade)+ C.runResourceT $ selectKeys filts [] C.$$ CL.mapM_ (lift . deleteCascade)
Database/Persist/Query/Join.hs view
@@ -16,9 +16,9 @@ import qualified Data.Map as Map import Data.List (foldl') -class PersistQuery b m => RunJoin a b m where+class PersistQuery backend m => RunJoin a backend m where type Result a- runJoin :: a -> b m (Result a)+ runJoin :: a -> backend m (Result a) data SelectOneMany backend one many = SelectOneMany { somFilterOne :: [Filter one]
Database/Persist/Query/Join/Sql.hs view
@@ -30,6 +30,7 @@ import qualified Data.Conduit.List as CL import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Logger (MonadLogger) fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity v) fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"@@ -40,7 +41,7 @@ fromPersistValuesId _ = Left "fromPersistValuesId: invalid ID" class RunJoin a where- runJoin :: (C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m) => a -> SqlPersist m (J.Result a)+ runJoin :: (C.MonadThrow m, C.MonadUnsafeIO m, MonadIO m, MonadBaseControl IO m, MonadLogger m) => a -> SqlPersist m (J.Result a) instance (PersistEntity one, PersistEntity many, Eq (Key SqlPersist one)) => RunJoin (SelectOneMany SqlPersist one many) where
Database/Persist/Store.hs view
@@ -30,6 +30,8 @@ , PersistFilter (..) , SomePersistField (..) + , ZT (..) -- ZonedTime wrapper+ , insertBy , getByValue , getJust@@ -55,20 +57,15 @@ import Prelude hiding ((++), show) import Data.Monoid (mappend) import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.ByteString.Char8 (ByteString, unpack) import Control.Applicative import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) -#if MIN_VERSION_blaze_html(0,5,0) import Text.Blaze.Html-import Text.Blaze.Internal (preEscapedText) import Text.Blaze.Html.Renderer.Text (renderHtml)-#else-import Text.Blaze (Html, preEscapedText)-import Text.Blaze.Renderer.Text (renderHtml)-#endif import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -122,6 +119,14 @@ instance Error PersistException where strMsg = PersistError . T.pack +-- | Avoid orphan instances.+newtype ZT = ZT ZonedTime deriving (Show, Read, Typeable)++instance Eq ZT where+ ZT a /= ZT b = zonedTimeToLocalTime a /= zonedTimeToLocalTime b || zonedTimeZone a /= zonedTimeZone b+instance Ord ZT where+ ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b+ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistText T.Text@@ -132,6 +137,7 @@ | PersistDay Day | PersistTimeOfDay TimeOfDay | PersistUTCTime UTCTime+ | PersistZonedTime ZT | PersistNull | PersistList [PersistValue] | PersistMap [(T.Text, PersistValue)]@@ -157,6 +163,7 @@ toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.cons 't' $ show t toJSON (PersistUTCTime u) = A.String $ T.cons 'u' $ show u+ toJSON (PersistZonedTime z) = A.String $ T.cons 'z' $ show z toJSON (PersistDay d) = A.String $ T.cons 'd' $ show d toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l@@ -172,6 +179,7 @@ $ B64.decode $ TE.encodeUtf8 t Just ('t', t) -> fmap PersistTimeOfDay $ readMay t Just ('u', t) -> fmap PersistUTCTime $ readMay t+ Just ('z', t) -> fmap PersistZonedTime $ readMay t Just ('d', t) -> fmap PersistDay $ readMay t Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId) $ B64.decode $ TE.encodeUtf8 t@@ -197,13 +205,15 @@ -- have different translations for these types. data SqlType = SqlString | SqlInt32- | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64+ | SqlInt64 | SqlReal | SqlBool | SqlDay | SqlTime | SqlDayTime+ | SqlDayTimeZoned | SqlBlob+ | SqlOther T.Text -- ^ a backend-specific name deriving (Show, Read, Eq, Typeable, Ord) -- | A value which can be marshalled to and from a 'PersistValue'.@@ -225,6 +235,7 @@ fromPersistValue (PersistDay d) = Right $ Prelude.show d fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d+ fromPersistValue (PersistZonedTime (ZT z)) = Right $ Prelude.show z fromPersistValue PersistNull = Left "Unexpected null" fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String"@@ -249,6 +260,7 @@ fromPersistValue (PersistDay d) = Right $ show d fromPersistValue (PersistTimeOfDay d) = Right $ show d fromPersistValue (PersistUTCTime d) = Right $ show d+ fromPersistValue (PersistZonedTime (ZT z)) = Right $ show z fromPersistValue PersistNull = Left "Unexpected null" fromPersistValue (PersistBool b) = Right $ show b fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text"@@ -258,7 +270,7 @@ instance PersistField Html where toPersistValue = PersistText . TL.toStrict . renderHtml- fromPersistValue = fmap preEscapedText . fromPersistValue+ fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue sqlType _ = SqlString instance PersistField Int where@@ -267,7 +279,7 @@ fromPersistValue x = Left $ "Expected Integer, received: " ++ show x sqlType x = case bitSize x of 32 -> SqlInt32- _ -> SqlInteger+ _ -> SqlInt64 instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral@@ -291,7 +303,7 @@ toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInteger+ sqlType _ = SqlInt64 instance PersistField Word8 where toPersistValue = PersistInt64 . fromIntegral@@ -309,13 +321,13 @@ toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInteger+ sqlType _ = SqlInt64 instance PersistField Word64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInteger+ sqlType _ = SqlInt64 instance PersistField Double where toPersistValue = PersistDouble@@ -372,6 +384,20 @@ fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x sqlType _ = SqlDayTime +instance PersistField ZonedTime where+ toPersistValue = PersistZonedTime . ZT+ fromPersistValue (PersistZonedTime (ZT z)) = Right z+ fromPersistValue x@(PersistText t) =+ case reads $ T.unpack t of+ (z, _):_ -> Right z+ _ -> Left $ "Expected ZonedTime, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (z, _):_ -> Right z+ _ -> Left $ "Expected ZonedTime, received " ++ show x+ fromPersistValue x = Left $ "Expected ZonedTime, received: " ++ show x+ sqlType _ = SqlDayTimeZoned+ instance PersistField a => PersistField (Maybe a) where toPersistValue Nothing = PersistNull toPersistValue (Just a) = toPersistValue a@@ -513,44 +539,44 @@ , entityVal :: entity } deriving (Eq, Ord, Show, Read) -class (MonadBaseControl IO m, MonadBaseControl IO (b m)) => PersistStore b m where+class (MonadBaseControl IO m, MonadBaseControl IO (backend m)) => PersistStore backend m where -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id).- insert :: PersistEntity val => val -> b m (Key b val)+ insert :: PersistEntity val => val -> backend m (Key backend val) -- | Create a new record in the database using the given key.- insertKey :: PersistEntity val => Key b val -> val -> b m ()+ insertKey :: PersistEntity val => Key backend val -> val -> backend m () -- | Put the record in the database with the given key. -- Unlike 'replace', if a record with the given key does not -- exist then a new record will be inserted.- repsert :: PersistEntity val => Key b val -> val -> b m ()+ repsert :: PersistEntity val => Key backend val -> val -> backend m () -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does -- not exist, so you must use 'insertKey' or 'repsert' in -- these cases.- replace :: PersistEntity val => Key b val -> val -> b m ()+ replace :: PersistEntity val => Key backend val -> val -> backend m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist.- delete :: PersistEntity val => Key b val -> b m ()+ delete :: PersistEntity val => Key backend val -> backend m () -- | Get a record by identifier, if available.- get :: PersistEntity val => Key b val -> b m (Maybe val)+ get :: PersistEntity val => Key backend val -> backend m (Maybe val) -class PersistStore b m => PersistUnique b m where+class PersistStore backend m => PersistUnique backend m where -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: (PersistEntityBackend val ~ b, PersistEntity val) => Unique val b -> b m (Maybe (Entity val))+ getBy :: (PersistEntityBackend val ~ backend, PersistEntity val) => Unique val backend -> backend m (Maybe (Entity val)) -- | Delete a specific record by unique key. Does nothing if no record -- matches.- deleteBy :: PersistEntity val => Unique val b -> b m ()+ deleteBy :: PersistEntity val => Unique val backend -> backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint.- insertUnique :: (b ~ PersistEntityBackend val, PersistEntity val) => val -> b m (Maybe (Key b val))+ insertUnique :: (backend ~ PersistEntityBackend val, PersistEntity val) => val -> backend m (Maybe (Key backend val)) insertUnique datum = do isUnique <- checkUnique datum if isUnique then Just `liftM` insert datum else return Nothing@@ -560,8 +586,8 @@ -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key' is returned as 'Right'.-insertBy :: (PersistEntity v, PersistStore b m, PersistUnique b m, b ~ PersistEntityBackend v)- => v -> b m (Either (Entity v) (Key b v))+insertBy :: (PersistEntity v, PersistStore backend m, PersistUnique backend m, backend ~ PersistEntityBackend v)+ => v -> backend m (Either (Entity v) (Key backend v)) insertBy val = go $ persistUniqueKeys val where@@ -576,8 +602,8 @@ -- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor.-getByValue :: (PersistEntity v, PersistUnique b m, PersistEntityBackend v ~ b)- => v -> b m (Maybe (Entity v))+getByValue :: (PersistEntity v, PersistUnique backend m, PersistEntityBackend v ~ backend)+ => v -> backend m (Maybe (Entity v)) getByValue val = go $ persistUniqueKeys val where@@ -591,23 +617,23 @@ -- | curry this to make a convenience function that loads an associated model -- > foreign = belongsTo foeignId belongsTo ::- (PersistStore b m+ (PersistStore backend m , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Maybe (Key b ent2)) -> ent1 -> b m (Maybe ent2)+ , PersistEntity ent2) => (ent1 -> Maybe (Key backend ent2)) -> ent1 -> backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of Nothing -> return Nothing Just f -> get f -- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe belongsToJust ::- (PersistStore b m+ (PersistStore backend m , PersistEntity ent1- , PersistEntity ent2) => (ent1 -> Key b ent2) -> ent1 -> b m ent2+ , PersistEntity ent2) => (ent1 -> Key backend ent2) -> ent1 -> backend m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model -- | Same as get, but for a non-null (not Maybe) foreign key -- Unsafe unless your database is enforcing that the foreign key is valid-getJust :: (PersistStore b m, PersistEntity val, Show (Key b val)) => Key b val -> b m val+getJust :: (PersistStore backend m, PersistEntity val, Show (Key backend val)) => Key backend val -> backend m val getJust key = get key >>= maybe (liftBase $ E.throwIO $ PersistForeignConstraintUnmet $ show key) return@@ -618,7 +644,7 @@ -- -- Returns 'True' if the entity would be unique, and could thus safely be -- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntityBackend val ~ b, PersistEntity val, PersistUnique b m) => val -> b m Bool+checkUnique :: (PersistEntityBackend val ~ backend, PersistEntity val, PersistUnique backend m) => val -> backend m Bool checkUnique val = go $ persistUniqueKeys val where@@ -633,13 +659,13 @@ | BackendSpecificFilter T.Text deriving (Read, Show) -class PersistEntity a => DeleteCascade a b m where- deleteCascade :: Key b a -> b m ()+class PersistEntity a => DeleteCascade a backend m where+ deleteCascade :: Key backend a -> backend m () instance PersistField PersistValue where toPersistValue = id fromPersistValue = Right- sqlType _ = SqlInteger -- since PersistValue should only be used like this for keys, which in SQL are Int64+ sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 -- | Represents a value containing all the configuration options for a specific -- backend. This abstraction makes it easier to write code that can easily swap
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.9.0.4+version: 1.0.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -32,18 +32,20 @@ , time >= 1.1.4 , text >= 0.8 && < 1 , containers >= 0.2- , conduit >= 0.4 && < 0.5+ , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4 , monad-control >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 , pool-conduit >= 0.1 && < 0.2 , path-pieces >= 0.1 && < 0.2 , aeson >= 0.5 && < 0.7+ , monad-logger >= 0.2 && < 0.3 , transformers-base , base64-bytestring , unordered-containers , vector , attoparsec+ , template-haskell if flag(blaze_html_0_5) build-depends: