persistent 0.0.0.1 → 0.1.0
raw patch · 8 files changed
+871/−796 lines, 8 filesdep +blaze-htmldep +parsecdep +transformersdep −hamletdep ~timedep ~web-routes-quasi
Dependencies added: blaze-html, parsec, transformers
Dependencies removed: hamlet
Dependency ranges changed: time, web-routes-quasi
Files
- Database/Persist.hs +7/−240
- Database/Persist/Base.hs +300/−0
- Database/Persist/GenericSql.hs +130/−208
- Database/Persist/Helper.hs +0/−326
- Database/Persist/Pool.hs +85/−0
- Database/Persist/Quasi.hs +34/−17
- Database/Persist/TH.hs +306/−0
- persistent.cabal +9/−5
Database/Persist.hs view
@@ -1,244 +1,11 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}---- | This defines the API for performing database actions. There are two levels--- to this API: dealing with fields, and dealing with entities. In SQL, a field--- corresponds to a column, and should be a single, non-composite value. An--- entity corresponds to a SQL table. In other words: An entity is a--- collection of fields. module Database.Persist- ( -- * Fields- PersistValue (..)- , SqlType (..)- , PersistField (..)- -- * Entities+ ( PersistField (..) , PersistEntity (..)+ , PersistBackend (..)+ , mkPersist+ , persist ) where -import Data.Time (Day, TimeOfDay, UTCTime)-import Data.ByteString.Char8 (ByteString, unpack)-import qualified Data.ByteString.UTF8 as BSU-import Control.Applicative-import Data.Typeable (Typeable)-import Data.Int (Int64)-import Text.Hamlet-import qualified Data.Text as T-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)---- | A raw value which can be stored in any backend and can be marshalled to--- and from a 'PersistField'.-data PersistValue = PersistString String- | PersistByteString ByteString- | PersistInt64 Int64- | PersistDouble Double- | PersistBool Bool- | PersistDay Day- | PersistTimeOfDay TimeOfDay- | PersistUTCTime UTCTime- | PersistNull- deriving (Show, Read, Eq, Typeable)---- | A SQL data type. Naming attempts to reflect the underlying Haskell--- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may--- have different translations for these types.-data SqlType = SqlString- | SqlInteger- | SqlReal- | SqlBool- | SqlDay- | SqlTime- | SqlDayTime- | SqlBlob- deriving (Show, Read, Eq, Typeable)---- | A value which can be marshalled to and from a 'PersistValue'.-class PersistField a where- toPersistValue :: a -> PersistValue- fromPersistValue :: PersistValue -> Either String a- sqlType :: a -> SqlType- isNullable :: a -> Bool- isNullable _ = False--instance PersistField String where- toPersistValue = PersistString- fromPersistValue (PersistString s) = Right s- fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs- fromPersistValue (PersistInt64 i) = Right $ show i- fromPersistValue (PersistDouble d) = Right $ show d- fromPersistValue (PersistDay d) = Right $ show d- fromPersistValue (PersistTimeOfDay d) = Right $ show d- fromPersistValue (PersistUTCTime d) = Right $ show d- fromPersistValue PersistNull = Left "Unexpected null"- fromPersistValue (PersistBool b) = Right $ show b- sqlType _ = SqlString--instance PersistField ByteString where- toPersistValue = PersistByteString- fromPersistValue (PersistByteString bs) = Right bs- fromPersistValue x = BSU.fromString <$> fromPersistValue x- sqlType _ = SqlBlob--instance PersistField T.Text where- toPersistValue = PersistString . T.unpack- fromPersistValue = fmap T.pack . fromPersistValue- sqlType _ = SqlString--instance PersistField (Html ()) where- toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml- fromPersistValue = fmap unsafeByteString . fromPersistValue- sqlType _ = SqlString--instance PersistField Int where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInteger--instance PersistField Int64 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInteger--instance PersistField Double where- toPersistValue = PersistDouble- fromPersistValue (PersistDouble d) = Right d- fromPersistValue x = Left $ "Expected Double, received: " ++ show x- sqlType _ = SqlReal--instance PersistField Bool where- toPersistValue = PersistBool- fromPersistValue (PersistBool b) = Right b- fromPersistValue (PersistInt64 i) = Right $ i /= 0- fromPersistValue x = Left $ "Expected Bool, received: " ++ show x- sqlType _ = SqlBool--instance PersistField Day where- toPersistValue = PersistDay- fromPersistValue (PersistDay d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of- (d, _):_ -> Right d- _ -> Left $ "Expected Day, received " ++ show x- fromPersistValue x@(PersistByteString s) =- case reads $ unpack s of- (d, _):_ -> Right d- _ -> Left $ "Expected Day, received " ++ show x- fromPersistValue x = Left $ "Expected Day, received: " ++ show x- sqlType _ = SqlDay--instance PersistField TimeOfDay where- toPersistValue = PersistTimeOfDay- fromPersistValue (PersistTimeOfDay d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of- (d, _):_ -> Right d- _ -> Left $ "Expected TimeOfDay, received " ++ show x- fromPersistValue x@(PersistByteString s) =- case reads $ unpack s of- (d, _):_ -> Right d- _ -> Left $ "Expected TimeOfDay, received " ++ show x- fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x- sqlType _ = SqlTime--instance PersistField UTCTime where- toPersistValue = PersistUTCTime- fromPersistValue (PersistUTCTime d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of- (d, _):_ -> Right d- _ -> Left $ "Expected UTCTime, received " ++ show x- fromPersistValue x@(PersistByteString s) =- case reads $ unpack s of- (d, _):_ -> Right d- _ -> Left $ "Expected UTCTime, received " ++ show x- fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x- sqlType _ = SqlDayTime--instance PersistField a => PersistField (Maybe a) where- toPersistValue Nothing = PersistNull- toPersistValue (Just a) = toPersistValue a- fromPersistValue PersistNull = Right Nothing- fromPersistValue x = fmap Just $ fromPersistValue x- sqlType _ = sqlType (error "this is the problem" :: a)- isNullable _ = True---- | A single database entity. For example, if writing a blog application, a--- blog entry would be an entry, containing fields such as title and content.-class PersistEntity val where- -- | The monad transformer in which actions for this entity must occur. For- -- example, entities declared to work with a sqlite backend would most- -- likely use a ReaderT monad transformer holding onto a database- -- connection.- --- -- By using a monad transformer here, users can allow arbitrary effects to- -- exist in the underlying monad. For example, Yesod applications can embed- -- a Handler monad here. The only restriction on that underlying monad is- -- it must be an instance of 'MonadCatchIO'.- type PersistMonad val :: (* -> *) -> * -> *-- -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\".- data Key val- -- | Fields which can be updated using the 'update' and 'updateWhere'- -- functions.- data Update val- -- | Filters which are available for 'select', 'updateWhere' and- -- 'deleteWhere'. Each filter constructor specifies the field being- -- filtered on, the type of comparison applied (equals, not equals, etc)- -- and the argument for the comparison.- data Filter val- -- | How you can sort the results of a 'select'.- data Order val- -- | Unique keys in existence on this entity.- data Unique val-- -- | Prepare database for this entity, if necessary. In SQL, this creates- -- values and indices if they don't exist. The first argument is not used,- -- so you can used 'undefined'.- initialize :: MonadCatchIO m => val -> (PersistMonad val) m ()-- -- | Create a new record in the database, returning the newly created- -- identifier.- insert :: MonadCatchIO m => val -> (PersistMonad val) m (Key val)-- -- | Replace the record in the database with the given key. Result is- -- undefined if such a record does not exist.- replace :: MonadCatchIO m => Key val -> val -> (PersistMonad val) m ()-- -- | Update individual fields on a specific record.- update :: MonadCatchIO m => Key val -> [Update val]- -> (PersistMonad val) m ()-- -- | Update individual fields on any record matching the given criterion.- updateWhere :: MonadCatchIO m => [Filter val] -> [Update val]- -> (PersistMonad val) m ()-- -- | Delete a specific record by identifier. Does nothing if record does- -- not exist.- delete :: MonadCatchIO m => Key val -> (PersistMonad val) m ()-- -- | Delete a specific record by unique key. Does nothing if no record- -- matches.- deleteBy :: MonadCatchIO m => Unique val -> (PersistMonad val) m ()-- -- | Delete all records matching the given criterion.- deleteWhere :: MonadCatchIO m => [Filter val] -> (PersistMonad val) m ()-- -- | Get a record by identifier, if available.- get :: MonadCatchIO m => Key val -> (PersistMonad val) m (Maybe val)-- -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: MonadCatchIO m => Unique val- -> (PersistMonad val) m (Maybe (Key val, val))-- -- | Get all records matching the given criterion in the specified order.- -- Returns also the identifiers.- select :: MonadCatchIO m => [Filter val] -> [Order val]- -> (PersistMonad val) m [(Key val, val)]+import Database.Persist.Base+import Database.Persist.TH+import Database.Persist.Quasi
+ Database/Persist/Base.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ExistentialQuantification #-}++-- | This defines the API for performing database actions. There are two levels+-- to this API: dealing with fields, and dealing with entities. In SQL, a field+-- corresponds to a column, and should be a single, non-composite value. An+-- entity corresponds to a SQL table. In other words: An entity is a+-- collection of fields.+module Database.Persist.Base+ ( PersistValue (..)+ , SqlType (..)+ , PersistField (..)+ , PersistEntity (..)+ , EntityDef (..)+ , PersistBackend (..)+ , PersistFilter (..)+ , PersistOrder (..)+ , SomePersistField (..)+ ) where++import Language.Haskell.TH.Syntax+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.ByteString.Char8 (ByteString, unpack)+import qualified Data.ByteString.UTF8 as BSU+import Control.Applicative+import Data.Typeable (Typeable)+import Data.Int (Int64)+import Text.Blaze+import qualified Data.Text as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++-- | A raw value which can be stored in any backend and can be marshalled to+-- and from a 'PersistField'.+data PersistValue = PersistString String+ | PersistByteString ByteString+ | PersistInt64 Int64+ | PersistDouble Double+ | PersistBool Bool+ | PersistDay Day+ | PersistTimeOfDay TimeOfDay+ | PersistUTCTime UTCTime+ | PersistNull+ deriving (Show, Read, Eq, Typeable)++-- | A SQL data type. Naming attempts to reflect the underlying Haskell+-- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may+-- have different translations for these types.+data SqlType = SqlString+ | SqlInteger+ | SqlReal+ | SqlBool+ | SqlDay+ | SqlTime+ | SqlDayTime+ | SqlBlob+ deriving (Show, Read, Eq, Typeable)++-- | A value which can be marshalled to and from a 'PersistValue'.+class PersistField a where+ toPersistValue :: a -> PersistValue+ fromPersistValue :: PersistValue -> Either String a+ sqlType :: a -> SqlType+ isNullable :: a -> Bool+ isNullable _ = False++instance PersistField String where+ toPersistValue = PersistString+ fromPersistValue (PersistString s) = Right s+ fromPersistValue (PersistByteString bs) = Right $ BSU.toString bs+ fromPersistValue (PersistInt64 i) = Right $ show i+ fromPersistValue (PersistDouble d) = Right $ show d+ fromPersistValue (PersistDay d) = Right $ show d+ fromPersistValue (PersistTimeOfDay d) = Right $ show d+ fromPersistValue (PersistUTCTime d) = Right $ show d+ fromPersistValue PersistNull = Left "Unexpected null"+ fromPersistValue (PersistBool b) = Right $ show b+ sqlType _ = SqlString++instance PersistField ByteString where+ toPersistValue = PersistByteString+ fromPersistValue (PersistByteString bs) = Right bs+ fromPersistValue x = BSU.fromString <$> fromPersistValue x+ sqlType _ = SqlBlob++instance PersistField T.Text where+ toPersistValue = PersistString . T.unpack+ fromPersistValue = fmap T.pack . fromPersistValue+ sqlType _ = SqlString++instance PersistField (Html ()) where+ toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml+ fromPersistValue = fmap unsafeByteString . fromPersistValue+ sqlType _ = SqlString++instance PersistField Int where+ toPersistValue = PersistInt64 . fromIntegral+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ "Expected Integer, received: " ++ show x+ sqlType _ = SqlInteger++instance PersistField Int64 where+ toPersistValue = PersistInt64 . fromIntegral+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ "Expected Integer, received: " ++ show x+ sqlType _ = SqlInteger++instance PersistField Double where+ toPersistValue = PersistDouble+ fromPersistValue (PersistDouble d) = Right d+ fromPersistValue x = Left $ "Expected Double, received: " ++ show x+ sqlType _ = SqlReal++instance PersistField Bool where+ toPersistValue = PersistBool+ fromPersistValue (PersistBool b) = Right b+ fromPersistValue (PersistInt64 i) = Right $ i /= 0+ fromPersistValue x = Left $ "Expected Bool, received: " ++ show x+ sqlType _ = SqlBool++instance PersistField Day where+ toPersistValue = PersistDay+ fromPersistValue (PersistDay d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected Day, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected Day, received " ++ show x+ fromPersistValue x = Left $ "Expected Day, received: " ++ show x+ sqlType _ = SqlDay++instance PersistField TimeOfDay where+ toPersistValue = PersistTimeOfDay+ fromPersistValue (PersistTimeOfDay d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected TimeOfDay, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected TimeOfDay, received " ++ show x+ fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x+ sqlType _ = SqlTime++instance PersistField UTCTime where+ toPersistValue = PersistUTCTime+ fromPersistValue (PersistUTCTime d) = Right d+ fromPersistValue x@(PersistString s) =+ case reads s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected UTCTime, received " ++ show x+ fromPersistValue x@(PersistByteString s) =+ case reads $ unpack s of+ (d, _):_ -> Right d+ _ -> Left $ "Expected UTCTime, received " ++ show x+ fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x+ sqlType _ = SqlDayTime++instance PersistField a => PersistField (Maybe a) where+ toPersistValue Nothing = PersistNull+ toPersistValue (Just a) = toPersistValue a+ fromPersistValue PersistNull = Right Nothing+ fromPersistValue x = fmap Just $ fromPersistValue x+ sqlType _ = sqlType (error "this is the problem" :: a)+ isNullable _ = True++-- | A single database entity. For example, if writing a blog application, a+-- blog entry would be an entry, containing fields such as title and content.+class PersistEntity val where+ -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\".+ data Key val+ -- | Fields which can be updated using the 'update' and 'updateWhere'+ -- functions.+ data Update val+ -- | Filters which are available for 'select', 'updateWhere' and+ -- 'deleteWhere'. Each filter constructor specifies the field being+ -- filtered on, the type of comparison applied (equals, not equals, etc)+ -- and the argument for the comparison.+ data Filter val+ -- | How you can sort the results of a 'select'.+ data Order val+ -- | Unique keys in existence on this entity.+ data Unique val++ entityDef :: val -> EntityDef+ toPersistFields :: val -> [SomePersistField]+ fromPersistValues :: [PersistValue] -> Either String val+ halfDefined :: val+ toPersistKey :: Int64 -> Key val+ fromPersistKey :: Key val -> Int64+ showPersistKey :: Key val -> String++ persistFilterToFieldName :: Filter val -> String+ persistFilterToFilter :: Filter val -> PersistFilter+ persistFilterIsNull :: Filter val -> Bool+ persistFilterToValue :: Filter val -> PersistValue++ persistOrderToFieldName :: Order val -> String+ persistOrderToOrder :: Order val -> PersistOrder++ persistUpdateToFieldName :: Update val -> String+ persistUpdateToValue :: Update val -> PersistValue++ persistUniqueToFieldNames :: Unique val -> [String]+ persistUniqueToValues :: Unique val -> [PersistValue]++data SomePersistField = forall a. PersistField a => SomePersistField a+instance PersistField SomePersistField where+ toPersistValue (SomePersistField a) = toPersistValue a+ fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)+ sqlType (SomePersistField a) = sqlType a++class PersistBackend m where+ -- | Prepare database for this entity, if necessary. In SQL, this creates+ -- values and indices if they don't exist. The first argument is not used,+ -- so you can used 'undefined'.+ initialize :: PersistEntity val => val -> m ()++ -- | Create a new record in the database, returning the newly created+ -- identifier.+ insert :: PersistEntity val => val -> m (Key val)++ -- | Replace the record in the database with the given key. Result is+ -- undefined if such a record does not exist.+ replace :: PersistEntity val => Key val -> val -> m ()++ -- | Update individual fields on a specific record.+ update :: PersistEntity val => Key val -> [Update val] -> m ()++ -- | Update individual fields on any record matching the given criterion.+ updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> m ()++ -- | Delete a specific record by identifier. Does nothing if record does+ -- not exist.+ delete :: PersistEntity val => Key val -> m ()++ -- | Delete a specific record by unique key. Does nothing if no record+ -- matches.+ deleteBy :: PersistEntity val => Unique val -> m ()++ -- | Delete all records matching the given criterion.+ deleteWhere :: PersistEntity val => [Filter val] -> m ()++ -- | Get a record by identifier, if available.+ get :: PersistEntity val => Key val -> m (Maybe val)++ -- | Get a record by unique key, if available. Returns also the identifier.+ getBy :: PersistEntity val => Unique val -> m (Maybe (Key val, val))++ -- | Get all records matching the given criterion in the specified order.+ -- Returns also the identifiers.+ select :: PersistEntity val => [Filter val] -> [Order val]+ -> m [(Key val, val)]++data EntityDef = EntityDef+ { entityName :: String+ , entityAttribs :: [String]+ , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs+ , entityUniques :: [(String, [String])] -- ^ name, columns+ , entityDerives :: [String]+ }+ deriving Show++instance Lift EntityDef where+ lift (EntityDef a b c d e) = do+ x <- [|EntityDef|]+ a' <- lift a+ b' <- lift b+ c' <- lift c+ d' <- lift d+ e' <- lift e+ return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e'++data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le+ deriving (Read, Show)++instance Lift PersistFilter where+ lift Eq = [|Eq|]+ lift Ne = [|Ne|]+ lift Gt = [|Gt|]+ lift Lt = [|Lt|]+ lift Ge = [|Ge|]+ lift Le = [|Le|]++data PersistOrder = Asc | Desc+ deriving (Read, Show)++instance Lift PersistOrder where+ lift Asc = [|Asc|]+ lift Desc = [|Desc|]
Database/Persist/GenericSql.hs view
@@ -8,24 +8,25 @@ -- | This is a helper module for creating SQL backends. Regular users do not -- need to use this module. module Database.Persist.GenericSql- ( Int64- , module Database.Persist.Helper- , persist- , deriveGenericSql+ ( GenericSql (..) , RowPopper- , GenericSql (..)+ , initialize+ , insert+ , get+ , replace+ , select+ , deleteWhere+ , update+ , updateWhere+ , getBy+ , delete+ , deleteBy ) where -import Database.Persist (PersistEntity, Key, Order, Filter, Update,- Unique, SqlType (..), PersistValue (..),- PersistField (..))-import Database.Persist.Helper-import Language.Haskell.TH.Syntax hiding (lift)-import qualified Language.Haskell.TH.Syntax as TH+import Database.Persist.Base hiding (PersistBackend (..)) import Data.List (intercalate) import Control.Monad (unless, liftM) import Data.Int (Int64)-import Database.Persist.Quasi import Control.Arrow (second) data GenericSql m = GenericSql@@ -35,100 +36,13 @@ , gsInsert :: String -> [String] -> [PersistValue] -> m Int64 , gsEntityDefExists :: String -> m Bool , gsKeyType :: String+ , gsShowSqlType :: SqlType -> String } type RowPopper m = m (Maybe [PersistValue]) -deriveGenericSql :: Type -> Exp -> EntityDef -> Q [Dec]-deriveGenericSql monad gs t = do- let name = entityName t- let dt = dataTypeDec t-- fsv <- mkFromPersistValues t- let sq =- InstanceD [] (ConT ''FromPersistValues `AppT` ConT (mkName name))- [ FunD (mkName "fromPersistValues") fsv- ]-- let keysyn = TySynD (mkName $ name ++ "Id") [] $- ConT ''Key `AppT` ConT (mkName name)-- t' <- TH.lift t- let mkFun s e = FunD (mkName s) [Clause [] (NormalB $ e `AppE` t') []]-- let gs' = fmap (`AppE` gs)- init' <- gs' [|initialize|]- insert' <- gs' [|insert|]- replace' <- gs' [|replace|]- get' <- gs' [|get|]- getBy' <- gs' [|getBy|]- select' <- gs' [|select|]- deleteWhere' <- gs' [|deleteWhere|]- delete' <- gs' [|delete|]- deleteBy' <- gs' [|deleteBy|]- update' <- gs' [|update|]- updateWhere' <- gs' [|updateWhere|]-- let inst =- InstanceD- []- (ConT ''PersistEntity `AppT` ConT (mkName name))- [ persistMonadTypeDec monad t- , keyTypeDec (name ++ "Id") "Int64" t- , filterTypeDec t- , updateTypeDec t- , orderTypeDec t- , uniqueTypeDec t- , mkFun "initialize" $ init'- , mkFun "insert" $ insert'- , mkFun "replace" $ replace'- , mkFun "get" $ get'- , mkFun "getBy" $ getBy'- , mkFun "select" $ select'- , mkFun "deleteWhere" $ deleteWhere'- , mkFun "delete" $ delete'- , mkFun "deleteBy" $ deleteBy'- , mkFun "update" $ update'- , mkFun "updateWhere" $ updateWhere'- ]-- tops <- mkToPersistFields (ConT $ mkName name)- [(name, length $ tableColumns t)]- topsUn <- mkToPersistFields (ConT ''Unique `AppT` ConT (mkName name))- $ map (\(x, y) -> (x, length y))- $ entityUniques t-- return- [ dt, sq, inst, keysyn, tops, topsUn- , mkToFieldName (ConT ''Update `AppT` ConT (mkName name))- $ map (\(s, _, _) -> (name ++ upperFirst s, s))- $ entityUpdates t- , mkPersistField (ConT ''Update `AppT` ConT (mkName name))- $ map (\(s, _, _) -> name ++ upperFirst s) $ entityUpdates t- , mkToFieldNames (ConT ''Unique `AppT` ConT (mkName name))- $ entityUniques t- , mkPersistField (ConT ''Filter `AppT` ConT (mkName name))- $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)- $ entityFilters t- , mkToFieldName (ConT ''Filter `AppT` ConT (mkName name))- $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))- $ entityFilters t- , mkToFilter (ConT ''Filter `AppT` ConT (mkName name))- $ map (\(x, _, z, y) ->- (name ++ upperFirst x ++ show y, y, z))- $ entityFilters t- , mkToFieldName (ConT ''Order `AppT` ConT (mkName name))- $ map (\(x, y) -> (name ++ upperFirst x ++ y, x))- $ entityOrders t- , mkToOrder (ConT ''Order `AppT` ConT (mkName name))- $ map (\(x, y) -> (name ++ upperFirst x ++ y, y))- $ entityOrders t- , mkHalfDefined (ConT $ mkName name) name $ length $ tableColumns t- ]--initialize :: (ToPersistFields v, Monad m, HalfDefined v)- => GenericSql m -> EntityDef -> v -> m ()-initialize gs t v = do+initialize :: (Monad m, PersistEntity v) => GenericSql m -> v -> m ()+initialize gs v = do doesExist <- gsEntityDefExists gs $ tableName t unless doesExist $ do let cols = zip (tableColumns t) $ toPersistFields@@ -139,90 +53,67 @@ gsExecute gs sql [] mapM_ go $ tableUniques' t where+ t = entityDef v go' ((colName, _, as), p) = concat [ "," , colName , " "- , showSqlType $ sqlType p+ , gsShowSqlType gs $ sqlType p , if "null" `elem` as then " NULL" else " NOT NULL" ] go (index, fields) = do let sql = "CREATE UNIQUE INDEX " ++ index ++ " ON " ++ tableName t ++ "(" ++ intercalate "," fields ++ ")" gsExecute gs sql []- showSqlType SqlString = "VARCHAR"- showSqlType SqlInteger = "INTEGER"- showSqlType SqlReal = "REAL"- showSqlType SqlDay = "DATE"- showSqlType SqlTime = "TIME"- showSqlType SqlDayTime = "TIMESTAMP"- showSqlType SqlBlob = "BLOB"- showSqlType SqlBool = "BOOLEAN" -mkFromPersistValues :: EntityDef -> Q [Clause]-mkFromPersistValues t = do- nothing <- [|Left "Invalid fromPersistValues input"|]- let cons = ConE $ mkName $ entityName t- xs <- mapM (const $ newName "x") $ entityColumns t- fs <- [|fromPersistValue|]- let xs' = map (AppE fs . VarE) xs- let pat = ListP $ map VarP xs- ap' <- [|apE|]- just <- [|Right|]- let cons' = just `AppE` cons- return- [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []- , Clause [WildP] (NormalB nothing) []- ]- where- go ap' x y = InfixE (Just x) ap' (Just y)--insert :: (Monad m, ToPersistFields val, Num (Key val))- => GenericSql m -> EntityDef -> val -> m (Key val)-insert gs t = liftM fromIntegral+insert :: (Monad m, PersistEntity val)+ => GenericSql m -> val -> m (Key val)+insert gs v = liftM toPersistKey . gsInsert gs (tableName t) (map fst3 $ tableColumns t)- . toPersistValues+ . map toPersistValue . toPersistFields+ $ v where fst3 (x, _, _) = x+ t = entityDef v -replace :: (Integral (Key v), ToPersistFields v, Monad m)- => GenericSql m -> EntityDef -> Key v -> v -> m ()-replace gs t k val = do+replace :: (PersistEntity v, Monad m)+ => GenericSql m -> Key v -> v -> m ()+replace gs k val = do+ let t = entityDef val let sql = "UPDATE " ++ tableName t ++ " SET " ++ intercalate "," (map (go . fst3) $ tableColumns t) ++ " WHERE id=?" gsExecute gs sql $ map toPersistValue (toPersistFields val)- ++ [PersistInt64 (fromIntegral k)]+ ++ [PersistInt64 $ fromPersistKey k] where go = (++ "=?") fst3 (x, _, _) = x -get :: (Integral (Key v), FromPersistValues v, Monad m)- => GenericSql m -> EntityDef -> Key v -> m (Maybe v)-get gs t k = do+dummyFromKey :: Key v -> v+dummyFromKey _ = error "dummyFromKey"++get :: (PersistEntity v, Monad m)+ => GenericSql m -> Key v -> m (Maybe v)+get gs k = do+ let t = entityDef $ dummyFromKey k let sql = "SELECT * FROM " ++ tableName t ++ " WHERE id=?"- gsWithStmt gs sql [PersistInt64 $ fromIntegral k] $ \pop -> do+ gsWithStmt gs sql [PersistInt64 $ fromPersistKey k] $ \pop -> do res <- pop case res of Nothing -> return Nothing Just (_:vals) -> case fromPersistValues vals of- Left e -> error $ "get " ++ show k ++ ": " ++ e+ Left e -> error $ "get " ++ showPersistKey k ++ ": " ++ e Right v -> return $ Just v Just [] -> error "Database.Persist.GenericSql: Empty list in get" -select :: ( FromPersistValues val, Num key- , PersistField (Filter val), ToFieldName (Filter val)- , ToFilter (Filter val), ToFieldName (Order val)- , ToOrder (Order val), Monad m- )+select :: (PersistEntity val, Monad m) => GenericSql m- -> EntityDef -> [Filter val] -> [Order val]- -> m [(key, val)]-select gs t filts ords = do+ -> m [(Key val, val)]+select gs filts ords = do let wher = if null filts then "" else " WHERE " ++@@ -232,15 +123,17 @@ else " ORDER BY " ++ intercalate "," (map orderClause ords) let sql = "SELECT * FROM " ++ tableName t ++ wher ++ ord- gsWithStmt gs sql (map toPersistValue filts) $ flip go id+ gsWithStmt gs sql (map persistFilterToValue filts) $ flip go id where- orderClause o = toFieldName' o ++ case toOrder o of+ t = entityDef $ dummyFromFilts filts+ orderClause o = getFieldName t (persistOrderToFieldName o)+ ++ case persistOrderToOrder o of Asc -> "" Desc -> " DESC" fromPersistValues' (PersistInt64 x:xs) = do case fromPersistValues xs of Left e -> Left e- Right xs' -> Right (fromIntegral x, xs')+ Right xs' -> Right (toPersistKey x, xs') fromPersistValues' _ = Left "error in fromPersistValues'" go pop front = do res <- pop@@ -251,14 +144,16 @@ Left _ -> go pop front -- FIXME error? Right row -> go pop $ front . (:) row -filterClause :: (ToFilter f, ToFieldName f) => f -> String-filterClause f = if isNull f then nullClause else mainClause+filterClause :: PersistEntity val => Filter val -> String+filterClause f = if persistFilterIsNull f then nullClause else mainClause where- mainClause = toFieldName' f ++ showSqlFilter (toFilter f) ++ "?"+ t = entityDef $ dummyFromFilts [f]+ name = getFieldName t $ persistFilterToFieldName f+ mainClause = name ++ showSqlFilter (persistFilterToFilter f) ++ "?" nullClause =- case toFilter f of- Eq -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NULL)"- Ne -> '(' : mainClause ++ " OR " ++ toFieldName' f ++ " IS NOT NULL)"+ case persistFilterToFilter f of+ Eq -> '(' : mainClause ++ " OR " ++ name ++ " IS NULL)"+ Ne -> '(' : mainClause ++ " OR " ++ name ++ " IS NOT NULL)" _ -> mainClause showSqlFilter Eq = "=" showSqlFilter Ne = "<>"@@ -267,90 +162,117 @@ showSqlFilter Ge = ">=" showSqlFilter Le = "<=" -delete :: (Integral (Key v), Monad m)- => GenericSql m -> EntityDef -> Key v -> m ()-delete gs t k =- gsExecute gs sql [PersistInt64 $ fromIntegral k]+delete :: (PersistEntity v, Monad m) => GenericSql m -> Key v -> m ()+delete gs k =+ gsExecute gs sql [PersistInt64 $ fromPersistKey k] where+ t = entityDef $ dummyFromKey k sql = "DELETE FROM " ++ tableName t ++ " WHERE id=?" -deleteWhere :: (PersistField (Filter v), ToFilter (Filter v),- ToFieldName (Filter v), Monad m)- => GenericSql m -> EntityDef -> [Filter v] -> m ()-deleteWhere gs t filts = do+dummyFromFilts :: [Filter v] -> v+dummyFromFilts _ = error "dummyFromFilts"++deleteWhere :: (PersistEntity v, Monad m)+ => GenericSql m -> [Filter v] -> m ()+deleteWhere gs filts = do+ let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" else " WHERE " ++ intercalate " AND " (map filterClause filts) sql = "DELETE FROM " ++ tableName t ++ wher- gsExecute gs sql $ map toPersistValue filts+ gsExecute gs sql $ map persistFilterToValue filts -deleteBy :: (ToPersistFields (Unique v), ToFieldNames (Unique v), Monad m)- => GenericSql m -> EntityDef -> Unique v -> m ()-deleteBy gs t uniq = do- let sql = "DELETE FROM " ++ tableName t ++ " WHERE " ++- intercalate " AND " (map (++ "=?") $ toFieldNames' uniq)- gsExecute gs sql $ map toPersistValue $ toPersistFields uniq+deleteBy :: (PersistEntity v, Monad m) => GenericSql m -> Unique v -> m ()+deleteBy gs uniq =+ gsExecute gs sql $ persistUniqueToValues uniq+ where+ t = entityDef $ dummyFromUnique uniq+ go = map (getFieldName t) . persistUniqueToFieldNames+ sql = "DELETE FROM " ++ tableName t ++ " WHERE " +++ intercalate " AND " (map (++ "=?") $ go uniq) -update :: ( Integral (Key v), PersistField (Update v), ToFieldName (Update v)- , Monad m)- => GenericSql m -> EntityDef -> Key v -> [Update v] -> m ()-update _ _ _ [] = return ()-update gs t k upds = do+update :: (PersistEntity v, Monad m)+ => GenericSql m -> Key v -> [Update v] -> m ()+update _ _ [] = return ()+update gs k upds = do let sql = "UPDATE " ++ tableName t ++ " SET " ++- intercalate "," (map (++ "=?") $ map toFieldName' upds) +++ intercalate "," (map (++ "=?") $ map go upds) ++ " WHERE id=?" gsExecute gs sql $- map toPersistValue upds ++ [PersistInt64 $ fromIntegral k]+ map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k]+ where+ t = entityDef $ dummyFromKey k+ go = getFieldName t . persistUpdateToFieldName -updateWhere :: (PersistField (Filter v), PersistField (Update v),- ToFieldName (Update v), ToFilter (Filter v),- ToFieldName (Filter v), Monad m)- => GenericSql m- -> EntityDef -> [Filter v] -> [Update v] -> m ()-updateWhere _ _ _ [] = return ()-updateWhere gs t filts upds = do+updateWhere :: (PersistEntity v, Monad m)+ => GenericSql m -> [Filter v] -> [Update v] -> m ()+updateWhere _ _ [] = return ()+updateWhere gs filts upds = do let wher = if null filts then "" else " WHERE " ++ intercalate " AND " (map filterClause filts) let sql = "UPDATE " ++ tableName t ++ " SET " ++- intercalate "," (map (++ "=?") $ map toFieldName' upds) ++ wher- let dat = map toPersistValue upds ++ map toPersistValue filts+ intercalate "," (map (++ "=?") $ map go upds) ++ wher+ let dat = map persistUpdateToValue upds+ ++ map persistFilterToValue filts gsWithStmt gs sql dat $ const $ return ()+ where+ t = entityDef $ dummyFromFilts filts+ go = getFieldName t . persistUpdateToFieldName -getBy :: (Num (Key v), FromPersistValues v, Monad m,- ToPersistFields (Unique v), ToFieldNames (Unique v))- => GenericSql m- -> EntityDef -> Unique v -> m (Maybe (Key v, v))-getBy gs t uniq = do+getBy :: (PersistEntity v, Monad m)+ => GenericSql m -> Unique v -> m (Maybe (Key v, v))+getBy gs uniq = do let sql = "SELECT * FROM " ++ tableName t ++ " WHERE " ++ sqlClause- gsWithStmt gs sql (toPersistValues uniq) $ \pop -> do+ gsWithStmt gs sql (persistUniqueToValues uniq) $ \pop -> do row <- pop case row of Nothing -> return Nothing Just (PersistInt64 k:vals) -> case fromPersistValues vals of Left _ -> return Nothing- Right x -> return $ Just (fromIntegral k, x)+ Right x -> return $ Just (toPersistKey k, x) Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" where sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq+ t = entityDef $ dummyFromUnique uniq+ toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames +dummyFromUnique :: Unique v -> v+dummyFromUnique _ = error "dummyFromUnique"+ tableName :: EntityDef -> String-tableName t = "tbl" ++ entityName t+tableName t =+ case getSqlValue $ entityAttribs t of+ Nothing -> "tbl" ++ entityName t+ Just x -> x -toField :: String -> String-toField = (++) "fld"+toField :: (String, String, [String]) -> String+toField (n, _, as) =+ case getSqlValue as of+ Just x -> x+ Nothing -> "fld" ++ n -tableColumns :: EntityDef -> [(String, String, [String])]-tableColumns = map (\(x, y, z) -> (toField x, y, z)) . entityColumns+getFieldName :: EntityDef -> String -> String+getFieldName t s = toField $ tableColumn t s -tableUniques' :: EntityDef -> [(String, [String])]-tableUniques' = map (second $ map toField) . entityUniques+getSqlValue :: [String] -> Maybe String+getSqlValue (('s':'q':'l':'=':x):_) = Just x+getSqlValue (_:x) = getSqlValue x+getSqlValue [] = Nothing -toFieldName' :: ToFieldName x => x -> String-toFieldName' = toField . toFieldName+tableColumns :: EntityDef -> [(String, String, [String])]+tableColumns = map (\a@(x, y, z) -> (toField a, y, z)) . entityColumns -toFieldNames' :: ToFieldNames x => x -> [String]-toFieldNames' = map toField . toFieldNames+tableColumn :: EntityDef -> String -> (String, String, [String])+tableColumn t s = go $ entityColumns t+ where+ go [] = error $ "Unknown table column: " ++ s+ go ((x, y, z):rest)+ | x == s = (x, y, z)+ | otherwise = go rest++tableUniques' :: EntityDef -> [(String, [String])]+tableUniques' t = map (second $ map $ getFieldName t) $ entityUniques t
− Database/Persist/Helper.hs
@@ -1,326 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ExistentialQuantification #-}--- | This module provides utilities for creating backends. Regular users do not--- need to use this module.-module Database.Persist.Helper- ( recName- , upperFirst- -- * High level design- , EntityDef (..)- , entityOrders- , entityFilters- , entityUpdates- -- * TH datatype helpers- , dataTypeDec- , persistMonadTypeDec- , keyTypeDec- , filterTypeDec- , updateTypeDec- , orderTypeDec- , uniqueTypeDec- -- * TH typeclass helpers- , mkToPersistFields- , mkToFieldNames- , mkToFieldName- , mkPersistField- , mkToFilter- , mkToOrder- , mkHalfDefined- -- * Type classes- , SomePersistField (..)- , ToPersistFields (..)- , FromPersistValues (..)- , toPersistValues- , ToFieldNames (..)- , ToOrder (..)- , PersistOrder (..)- , ToFieldName (..)- , PersistFilter (..)- , ToFilter (..)- , HalfDefined (..)- -- * Utils- , apE- , addIsNullable- ) where--import Database.Persist-import Language.Haskell.TH.Syntax-import Data.Char (toLower, toUpper)-import Data.Maybe (fromJust, mapMaybe)-import Web.Routes.Quasi (SinglePiece)--data EntityDef = EntityDef- { entityName :: String- , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs- , entityUniques :: [(String, [String])] -- ^ name, columns- , entityDerives :: [String]- }- deriving Show--instance Lift EntityDef where- lift (EntityDef a b c d) = do- e <- [|EntityDef|]- a' <- lift a- b' <- lift b- c' <- lift c- d' <- lift d- return $ e `AppE` a' `AppE` b' `AppE` c' `AppE` d'--recName :: String -> String -> String-recName dt f = lowerFirst dt ++ upperFirst f--lowerFirst :: String -> String-lowerFirst (x:xs) = toLower x : xs-lowerFirst [] = []--upperFirst :: String -> String-upperFirst (x:xs) = toUpper x : xs-upperFirst [] = []--dataTypeDec :: EntityDef -> Dec-dataTypeDec t =- let name = mkName $ entityName t- cols = map (mkCol $ entityName t) $ entityColumns t- in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t- where- mkCol x (n, ty, as) =- (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as))--persistMonadTypeDec :: Type -> EntityDef -> Dec-persistMonadTypeDec monad t =- TySynInstD ''PersistMonad [ConT $ mkName $ entityName t] monad--keyTypeDec :: String -> String -> EntityDef -> Dec-keyTypeDec constr typ t =- NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]- (NormalC (mkName constr) [(NotStrict, ConT $ mkName typ)])- [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,- ''Real, ''PersistField, ''SinglePiece]--filterTypeDec :: EntityDef -> Dec-filterTypeDec t =- DataInstD [] ''Filter [ConT $ mkName $ entityName t]- (map (mkFilter $ entityName t) filts)- (if null filts then [] else [''Show, ''Read, ''Eq])- where- filts = entityFilters t--entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]-entityFilters = mapMaybe go' . concatMap go . entityColumns- where- go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as- go' (x, y, z, a) =- case readMay a of- Nothing -> Nothing- Just a' -> Just (x, y, z, a')- readMay s =- case reads s of- (x, _):_ -> Just x- [] -> Nothing--mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con-mkFilter x (s, ty, isNull', filt) =- NormalC (mkName $ x ++ upperFirst s ++ show filt)- [(NotStrict, pairToType (ty, isNull'))]--updateTypeDec :: EntityDef -> Dec-updateTypeDec t =- DataInstD [] ''Update [ConT $ mkName $ entityName t]- (map (mkUpdate $ entityName t) tu)- (if null tu then [] else [''Show, ''Read, ''Eq])- where- tu = entityUpdates t--entityUpdates :: EntityDef -> [(String, String, Bool)]-entityUpdates = mapMaybe go . entityColumns- where- go (name, typ, attribs)- | "update" `elem` attribs =- Just (name, typ, "null" `elem` attribs)- | otherwise = Nothing--mkUpdate :: String -> (String, String, Bool) -> Con-mkUpdate x (s, ty, isBool) =- NormalC (mkName $ x ++ upperFirst s)- [(NotStrict, pairToType (ty, isBool))]--orderTypeDec :: EntityDef -> Dec-orderTypeDec t =- DataInstD [] ''Order [ConT $ mkName $ entityName t]- (map (mkOrder $ entityName t) ords)- (if null ords then [] else [''Show, ''Read, ''Eq])- where- ords = entityOrders t--entityOrders :: EntityDef -> [(String, String)]-entityOrders = concatMap go . entityColumns- where- go (x, _, ys) = mapMaybe (go' x) ys- go' x "Asc" = Just (x, "Asc")- go' x "Desc" = Just (x, "Desc")- go' _ _ = Nothing--mkOrder :: String -> (String, String) -> Con-mkOrder x (s, ad) = NormalC (mkName $ x ++ upperFirst s ++ ad) []--uniqueTypeDec :: EntityDef -> Dec-uniqueTypeDec t =- DataInstD [] ''Unique [ConT $ mkName $ entityName t]- (map (mkUnique t) $ entityUniques t)- (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])--mkUnique :: EntityDef -> (String, [String]) -> Con-mkUnique t (constr, fields) =- NormalC (mkName constr) types- where- types = map (go . fromJust . flip lookup3 (entityColumns t)) fields- go (_, True) = error "Error: cannot have nullables in unique"- go x = (NotStrict, pairToType x)- lookup3 _ [] = Nothing- lookup3 x ((x', y, z):rest)- | x == x' = Just (y, "null" `elem` z)- | otherwise = lookup3 x rest--pairToType :: (String, Bool) -> Type-pairToType (s, False) = ConT $ mkName s-pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)--data SomePersistField = forall a. PersistField a => SomePersistField a-instance PersistField SomePersistField where- toPersistValue (SomePersistField a) = toPersistValue a- fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)- sqlType (SomePersistField a) = sqlType a--class ToPersistFields a where- toPersistFields :: a -> [SomePersistField]--degen :: [Clause] -> [Clause]-degen [] =- let err = VarE (mkName "error") `AppE` LitE (StringL- "Degenerate case, should never happen")- in [Clause [WildP] (NormalB err) []]-degen x = x--mkToPersistFields :: Type- -> [(String, Int)]- -> Q Dec-mkToPersistFields typ pairs = do- clauses <- mapM go pairs- return $ InstanceD [] (ConT ''ToPersistFields `AppT` typ)- [FunD (mkName "toPersistFields") $ degen clauses]- where- go (constr, fields) = do- xs <- sequence $ replicate fields $ newName "x"- let pat = ConP (mkName constr) $ map VarP xs- sp <- [|SomePersistField|]- let bod = ListE $ map (AppE sp . VarE) xs- return $ Clause [pat] (NormalB bod) []--class FromPersistValues a where- fromPersistValues :: [PersistValue] -> Either String a--toPersistValues :: ToPersistFields a => a -> [PersistValue]-toPersistValues = map toPersistValue . toPersistFields--class ToFieldNames a where- toFieldNames :: a -> [String]--mkToFieldNames :: Type -> [(String, [String])] -> Dec-mkToFieldNames typ pairs =- InstanceD [] (ConT ''ToFieldNames `AppT` typ)- [FunD (mkName "toFieldNames") $ degen $ map go pairs]- where- go (constr, names) =- Clause [RecP (mkName constr) []]- (NormalB $ ListE $ map (LitE . StringL) names)- []--class ToFieldName a where- toFieldName :: a -> String--mkToFieldName :: Type -> [(String, String)] -> Dec-mkToFieldName typ pairs =- InstanceD [] (ConT ''ToFieldName `AppT` typ)- [FunD (mkName "toFieldName") $ degen $ map go pairs]- where- go (constr, name) =- Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []--data PersistOrder = Asc | Desc-class ToOrder a where- toOrder :: a -> PersistOrder--mkToOrder :: Type -> [(String, String)] -> Dec-mkToOrder typ pairs =- InstanceD [] (ConT ''ToOrder `AppT` typ)- [FunD (mkName "toOrder") $ degen $ map go pairs]- where- go (constr, val) =- Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName val) []--data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le- deriving (Read, Show)-class ToFilter a where- toFilter :: a -> PersistFilter- isNull :: a -> Bool--mkToFilter :: Type -> [(String, PersistFilter, Bool)] -> Dec-mkToFilter typ pairs =- InstanceD [] (ConT ''ToFilter `AppT` typ)- [ FunD (mkName "toFilter") $ degen $ map go pairs- , FunD (mkName "isNull") $ degen $ concatMap go' pairs- ]- where- go (constr, pf, _) =- Clause [RecP (mkName constr) []] (NormalB $ ConE $ mkName $ show pf) []- go' (constr, _, False) =- [Clause [RecP (mkName constr) []]- (NormalB $ ConE $ mkName "False") []]- go' (constr, _, True) =- [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]- (NormalB $ ConE $ mkName "True") []- , Clause [ConP (mkName constr) [WildP]]- (NormalB $ ConE $ mkName "False") []- ]--mkPersistField :: Type -> [String] -> Dec-mkPersistField typ constrs =- InstanceD [] (ConT ''PersistField `AppT` typ)- $ fpv : map go- [ "toPersistValue"- , "sqlType"- , "isNullable"- ]- where- go func = FunD (mkName func) $ degen $ map (go' func) constrs- go' func constr =- let x = mkName "x"- in Clause [ConP (mkName constr) [VarP x]]- (NormalB $ VarE (mkName func) `AppE` VarE x)- []- fpv = FunD (mkName "fromPersistValue")- [Clause [WildP] (NormalB $ VarE (mkName "error")- `AppE` LitE (StringL "fromPersistValue")) []]--class HalfDefined a where- halfDefined :: a--mkHalfDefined :: Type -> String -> Int -> Dec-mkHalfDefined typ constr count =- InstanceD [] (ConT ''HalfDefined `AppT` typ)- [FunD (mkName "halfDefined")- [Clause [] (NormalB- $ foldl AppE (ConE $ mkName constr)- (replicate count $ VarE $ mkName "undefined")) []]]--apE :: Either x (y -> z) -> Either x y -> Either x z-apE (Left x) _ = Left x-apE _ (Left x) = Left x-apE (Right f) (Right y) = Right $ f y--addIsNullable :: EntityDef -> (String, (String, String))- -> (String, (String, Bool))-addIsNullable ed (col, (name, typ)) =- case filter (\(x, _, _) -> x == col) $ entityColumns ed of- [] -> error $ "Missing columns: " ++ col ++ ", " ++ show ed- (_, _, attribs):_ -> (name, (typ, "null" `elem` attribs))
+ Database/Persist/Pool.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PackageImports #-}+module Database.Persist.Pool+ ( createPool+ , withPool+ , withPool'+ , Pool+ ) where++import Control.Concurrent.MVar hiding (modifyMVar, modifyMVar_)+import Control.Exception (throwIO)+import Data.Typeable+import "MonadCatchIO-transformers" Control.Monad.CatchIO+import Control.Monad.IO.Class+import Control.Monad++data PoolData a = PoolData+ { poolAvail :: [a]+ , poolCreated :: Int+ }++data Pool a = Pool+ { poolMax :: Int+ , poolData :: MVar (PoolData a)+ , poolMake :: IO a+ }++createPool :: MonadCatchIO m+ => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b+createPool mk fr mx f = do+ pd <- liftIO $ newMVar $ PoolData [] 0+ finally (f $ Pool mx pd mk) $ do+ mress <- liftIO $ tryTakeMVar pd+ case mress of+ Nothing -> return ()+ Just (PoolData ress _) -> liftIO $ mapM_ fr ress++data PoolExhaustedException = PoolExhaustedException+ deriving (Show, Typeable)+instance Exception PoolExhaustedException++withPool' :: MonadCatchIO m => Pool a -> (a -> m b) -> m b+withPool' p f = do+ x <- withPool p f+ case x of+ Nothing -> liftIO $ throwIO PoolExhaustedException+ Just x' -> return x'++withPool :: MonadCatchIO m => Pool a -> (a -> m b) -> m (Maybe b)+withPool p f = block $ do+ eres <- modifyMVar (poolData p) $ \pd -> do+ case poolAvail pd of+ (x:xs) -> return (pd { poolAvail = xs }, Right x)+ [] -> return (pd, Left $ poolCreated pd)+ case eres of+ Left pc ->+ if pc >= poolMax p+ then return Nothing+ else bracket+ (liftIO $ poolMake p)+ (insertResource 1)+ (liftM Just . unblock . f)+ Right res -> finally+ (liftM Just $ unblock $ f res)+ (insertResource 0 res)+ where+ insertResource i x = modifyMVar_ (poolData p) $ \pd ->+ return pd { poolAvail = x : poolAvail pd+ , poolCreated = i + poolCreated pd+ }++modifyMVar :: MonadCatchIO m => MVar a -> (a -> m (a,b)) -> m b+modifyMVar m io =+ block $ do+ a <- liftIO $ takeMVar m+ (a',b) <- unblock (io a) `onException` liftIO (putMVar m a)+ liftIO $ putMVar m a'+ return b++modifyMVar_ :: MonadCatchIO m => MVar a -> (a -> m a) -> m ()+modifyMVar_ m io =+ block $ do+ a <- liftIO $ takeMVar m+ a' <- unblock (io a) `onException` liftIO (putMVar m a)+ liftIO $ putMVar m a'
Database/Persist/Quasi.hs view
@@ -1,24 +1,23 @@-module Database.Persist.Quasi- ( persist- ) where+module Database.Persist.Quasi (persist) where import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax-import Database.Persist.Helper+import Database.Persist.Base import Data.Char import Data.Maybe (mapMaybe)+import Text.ParserCombinators.Parsec hiding (token) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be--- used as input to the backend-specific template haskell generation code.+-- used as input to the template haskell generation code (mkPersist). persist :: QuasiQuoter persist = QuasiQuoter- { quoteExp = lift . parse+ { quoteExp = lift . parse_ , quotePat = error "Cannot quasi-quote a Persist pattern." } -parse :: String -> [EntityDef]-parse = map parse' . nest . map words' . filter (not . null)- . map killCarriage . lines+parse_ :: String -> [EntityDef]+parse_ = map parse' . nest . map words' . filter (not . null)+ . map killCarriage . lines killCarriage :: String -> String killCarriage "" = ""@@ -27,19 +26,37 @@ | otherwise = s words' :: String -> (Bool, [String])-words' (' ':x) = (True, words x)-words' x = (False, words x)+words' s = case parse words'' s s of+ Left e -> error $ show e+ Right x -> x -nest :: [(Bool, [String])] -> [(String, [[String]])]-nest ((False, [name]):rest) =+words'' :: Parser (Bool, [String])+words'' = do+ s <- fmap (not . null) $ many space+ t <- many token+ eof+ return (s, t)+ where+ token = do+ t <- (char '"' >> quoted) <|> unquoted+ spaces+ return t+ quoted = do+ s <- many1 $ noneOf "\""+ _ <- char '"'+ return s+ unquoted = many1 $ noneOf " \t"++nest :: [(Bool, [String])] -> [(String, [String], [[String]])]+nest ((False, name:entattribs):rest) = let (x, y) = break (not . fst) rest- in (name, map snd x) : nest y-nest ((False, _):_) = error "First line in block must have exactly one word"+ in (name, entattribs, map snd x) : nest y nest ((True, _):_) = error "Blocks must begin with non-indented lines" nest [] = [] -parse' :: (String, [[String]]) -> EntityDef-parse' (name, attribs) = EntityDef name cols uniqs derives+parse' :: (String, [String], [[String]]) -> EntityDef+parse' (name, entattribs, attribs) =+ EntityDef name entattribs cols uniqs derives where cols = concatMap takeCols attribs uniqs = concatMap takeUniqs attribs
+ Database/Persist/TH.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | This module provides utilities for creating backends. Regular users do not+-- need to use this module.+module Database.Persist.TH (mkPersist) where++import Database.Persist.Base+import Language.Haskell.TH.Syntax+import Data.Char (toLower, toUpper)+import Data.Maybe (mapMaybe, catMaybes)+import Web.Routes.Quasi (SinglePiece)+import Data.Int (Int64)++-- | Create data types and appropriate 'PersistEntity' instances for the given+-- 'EntityDef's. Works well with the persist quasi-quoter.+mkPersist :: [EntityDef] -> Q [Dec]+mkPersist = fmap concat . mapM mkEntity++recName :: String -> String -> String+recName dt f = lowerFirst dt ++ upperFirst f++lowerFirst :: String -> String+lowerFirst (x:xs) = toLower x : xs+lowerFirst [] = []++upperFirst :: String -> String+upperFirst (x:xs) = toUpper x : xs+upperFirst [] = []++dataTypeDec :: EntityDef -> Dec+dataTypeDec t =+ let name = mkName $ entityName t+ cols = map (mkCol $ entityName t) $ entityColumns t+ in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t+ where+ mkCol x (n, ty, as) =+ (mkName $ recName x n, NotStrict, pairToType (ty, "null" `elem` as))++keyTypeDec :: String -> Name -> EntityDef -> Dec+keyTypeDec constr typ t =+ NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]+ (NormalC (mkName constr) [(NotStrict, ConT typ)])+ [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,+ ''Real, ''PersistField, ''SinglePiece]++filterTypeDec :: EntityDef -> Dec+filterTypeDec t =+ DataInstD [] ''Filter [ConT $ mkName $ entityName t]+ (map (mkFilter $ entityName t) filts)+ (if null filts then [] else [''Show, ''Read, ''Eq])+ where+ filts = entityFilters t++entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]+entityFilters = mapMaybe go' . concatMap go . entityColumns+ where+ go (x, y, as) = map (\a -> (x, y, "null" `elem` as, a)) as+ go' (x, y, z, a) =+ case readMay a of+ Nothing -> Nothing+ Just a' -> Just (x, y, z, a')+ readMay s =+ case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con+mkFilter x (s, ty, isNull', filt) =+ NormalC (mkName $ x ++ upperFirst s ++ show filt)+ [(NotStrict, pairToType (ty, isNull'))]++updateTypeDec :: EntityDef -> Dec+updateTypeDec t =+ DataInstD [] ''Update [ConT $ mkName $ entityName t]+ (map (mkUpdate $ entityName t) tu)+ (if null tu then [] else [''Show, ''Read, ''Eq])+ where+ tu = entityUpdates t++entityUpdates :: EntityDef -> [(String, String, Bool)]+entityUpdates = mapMaybe go . entityColumns+ where+ go (name, typ, attribs)+ | "update" `elem` attribs =+ Just (name, typ, "null" `elem` attribs)+ | otherwise = Nothing++mkUpdate :: String -> (String, String, Bool) -> Con+mkUpdate x (s, ty, isBool) =+ NormalC (mkName $ x ++ upperFirst s)+ [(NotStrict, pairToType (ty, isBool))]++orderTypeDec :: EntityDef -> Q Dec+orderTypeDec t = do+ ords <- entityOrders t+ return $ DataInstD [] ''Order [ConT $ mkName $ entityName t]+ (map (mkOrder $ entityName t) ords)+ (if null ords then [] else [''Show, ''Read, ''Eq])++entityOrders :: EntityDef -> Q [(String, String, Exp)]+entityOrders = fmap concat . mapM go . entityColumns+ where+ go (x, _, ys) = fmap catMaybes $ mapM (go' x) ys+ go' x s =+ case reads s of+ (y, _):_ -> do+ z <- lift (y :: PersistOrder)+ return $ Just (x, s, z)+ _ -> return Nothing++mkOrder :: String -> (String, String, Exp) -> Con+mkOrder x (s, ad, _) = NormalC (mkName $ x ++ upperFirst s ++ ad) []++uniqueTypeDec :: EntityDef -> Dec+uniqueTypeDec t =+ DataInstD [] ''Unique [ConT $ mkName $ entityName t]+ (map (mkUnique t) $ entityUniques t)+ (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])++mkUnique :: EntityDef -> (String, [String]) -> Con+mkUnique t (constr, fields) =+ NormalC (mkName constr) types+ where+ types = map (go . flip lookup3 (entityColumns t)) fields+ go (_, True) = error "Error: cannot have nullables in unique"+ go x = (NotStrict, pairToType x)+ lookup3 s [] =+ error $ "Column not found: " ++ s ++ " in unique " ++ constr+ lookup3 x ((x', y, z):rest)+ | x == x' = (y, "null" `elem` z)+ | otherwise = lookup3 x rest++pairToType :: (String, Bool) -> Type+pairToType (s, False) = ConT $ mkName s+pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)++degen :: [Clause] -> [Clause]+degen [] =+ let err = VarE (mkName "error") `AppE` LitE (StringL+ "Degenerate case, should never happen")+ in [Clause [WildP] (NormalB err) []]+degen x = x++mkToPersistFields :: [(String, Int)] -> Q Dec+mkToPersistFields pairs = do+ clauses <- mapM go pairs+ return $ FunD (mkName "toPersistFields") $ degen clauses+ where+ go (constr, fields) = do+ xs <- sequence $ replicate fields $ newName "x"+ let pat = ConP (mkName constr) $ map VarP xs+ sp <- [|SomePersistField|]+ let bod = ListE $ map (AppE sp . VarE) xs+ return $ Clause [pat] (NormalB bod) []++mkToFieldNames :: [(String, [String])] -> Dec+mkToFieldNames pairs =+ FunD (mkName "persistUniqueToFieldNames") $ degen $ map go pairs+ where+ go (constr, names) =+ Clause [RecP (mkName constr) []]+ (NormalB $ ListE $ map (LitE . StringL) names)+ []++mkUniqueToValues :: [(String, [String])] -> Q Dec+mkUniqueToValues pairs = do+ pairs' <- mapM go pairs+ return $ FunD (mkName "persistUniqueToValues") $ degen pairs'+ where+ go (constr, names) = do+ xs <- mapM (const $ newName "x") names+ let pat = ConP (mkName constr) $ map VarP xs+ tpv <- [|toPersistValue|]+ let bod = ListE $ map (AppE tpv . VarE) xs+ return $ Clause [pat] (NormalB bod) []++mkToFieldName :: String -> [(String, String)] -> Dec+mkToFieldName func pairs =+ FunD (mkName func) $ degen $ map go pairs+ where+ go (constr, name) =+ Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []++mkToOrder :: [(String, Exp)] -> Dec+mkToOrder pairs =+ FunD (mkName "persistOrderToOrder") $ degen $ map go pairs+ where+ go (constr, val) =+ Clause [RecP (mkName constr) []] (NormalB val) []++mkToFilter :: [(String, PersistFilter, Bool)] -> Q [Dec]+mkToFilter pairs = do+ c1 <- mapM go pairs+ let c2 = concatMap go' pairs+ return+ [ FunD (mkName "persistFilterToFilter") $ degen c1+ , FunD (mkName "persistFilterIsNull") $ degen c2+ ]+ where+ go (constr, pf, _) = do+ pf' <- lift pf+ return $ Clause [RecP (mkName constr) []] (NormalB pf') []+ go' (constr, _, False) =+ [Clause [RecP (mkName constr) []]+ (NormalB $ ConE $ mkName "False") []]+ go' (constr, _, True) =+ [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]+ (NormalB $ ConE $ mkName "True") []+ , Clause [ConP (mkName constr) [WildP]]+ (NormalB $ ConE $ mkName "False") []+ ]++mkToValue :: String -> [String] -> Dec+mkToValue func = FunD (mkName func) . degen . map go+ where+ go constr =+ let x = mkName "x"+ in Clause [ConP (mkName constr) [VarP x]]+ (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x)+ []++mkHalfDefined :: String -> Int -> Dec+mkHalfDefined constr count =+ FunD (mkName "halfDefined")+ [Clause [] (NormalB+ $ foldl AppE (ConE $ mkName constr)+ (replicate count $ VarE $ mkName "undefined")) []]++apE :: Either x (y -> z) -> Either x y -> Either x z+apE (Left x) _ = Left x+apE _ (Left x) = Left x+apE (Right f) (Right y) = Right $ f y++mkFromPersistValues :: EntityDef -> Q [Clause]+mkFromPersistValues t = do+ nothing <- [|Left "Invalid fromPersistValues input"|]+ let cons = ConE $ mkName $ entityName t+ xs <- mapM (const $ newName "x") $ entityColumns t+ fs <- [|fromPersistValue|]+ let xs' = map (AppE fs . VarE) xs+ let pat = ListP $ map VarP xs+ ap' <- [|apE|]+ just <- [|Right|]+ let cons' = just `AppE` cons+ return+ [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []+ , Clause [WildP] (NormalB nothing) []+ ]+ where+ go ap' x y = InfixE (Just x) ap' (Just y)++mkEntity :: EntityDef -> Q [Dec]+mkEntity t = do+ t' <- lift t+ let name = entityName t+ let clazz = ConT ''PersistEntity `AppT` ConT (mkName $ entityName t)+ tpf <- mkToPersistFields [(name, length $ entityColumns t)]+ fpv <- mkFromPersistValues t+ fromIntegral' <- [|fromIntegral|]+ utv <- mkUniqueToValues $ entityUniques t+ show' <- [|show|]+ entityOrders' <- entityOrders t+ otd <- orderTypeDec t+ tf <- mkToFilter+ (map (\(x, _, z, y) ->+ (name ++ upperFirst x ++ show y, y, z))+ $ entityFilters t)+ return+ [ dataTypeDec t+ , TySynD (mkName $ entityName t ++ "Id") [] $+ ConT ''Key `AppT` ConT (mkName $ entityName t)+ , InstanceD [] clazz $+ [ keyTypeDec (entityName t ++ "Id") ''Int64 t+ , filterTypeDec t+ , updateTypeDec t+ , otd+ , uniqueTypeDec t+ , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []]+ , tpf+ , FunD (mkName "fromPersistValues") fpv+ , mkHalfDefined name $ length $ entityColumns t+ , FunD (mkName "toPersistKey") [Clause [] (NormalB fromIntegral') []]+ , FunD (mkName "fromPersistKey") [Clause [] (NormalB fromIntegral') []]+ , FunD (mkName "showPersistKey") [Clause [] (NormalB show') []]+ , mkToFieldName "persistOrderToFieldName"+ $ map (\(x, y, _) -> (name ++ upperFirst x ++ y, x))+ entityOrders'+ , mkToOrder+ $ map (\(x, y, z) -> (name ++ upperFirst x ++ y, z))+ entityOrders'+ , mkToFieldName "persistUpdateToFieldName"+ $ map (\(s, _, _) -> (name ++ upperFirst s, s))+ $ entityUpdates t+ , mkToValue "persistUpdateToValue"+ $ map (\(s, _, _) -> name ++ upperFirst s)+ $ entityUpdates t+ , mkToFieldName "persistFilterToFieldName"+ $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))+ $ entityFilters t+ , mkToValue "persistFilterToValue"+ $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)+ $ entityFilters t+ , mkToFieldNames $ entityUniques t+ , utv+ ] ++ tf+ ]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.0.0.1+version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -17,15 +17,19 @@ template-haskell >= 2.4 && < 2.5, bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.2 && < 0.3,- time >= 1.1.4 && < 1.2,+ transformers >= 0.2.1 && < 0.3,+ time >= 1.1.4 && < 1.3, utf8-string >= 0.3.4 && < 0.4, text >= 0.7.1 && < 0.8,- hamlet >= 0.3.1 && < 0.4,- web-routes-quasi >= 0.4.0 && < 0.5+ blaze-html >= 0.1 && < 0.2,+ web-routes-quasi >= 0.5.0 && < 0.6,+ parsec >= 2.1 && < 4 exposed-modules: Database.Persist- Database.Persist.Helper+ Database.Persist.Base+ Database.Persist.TH Database.Persist.Quasi Database.Persist.GenericSql+ Database.Persist.Pool ghc-options: -Wall source-repository head