persistent 0.5.0 → 0.5.1
raw patch · 13 files changed
+1572/−1552 lines, 13 filessetup-changed
Files
- Database/Persist.hs +11/−11
- Database/Persist/Base.hs +454/−454
- Database/Persist/GenericSql.hs +427/−427
- Database/Persist/GenericSql/Internal.hs +249/−249
- Database/Persist/GenericSql/Raw.hs +54/−54
- Database/Persist/Join.hs +55/−55
- Database/Persist/Join/Sql.hs +98/−98
- Database/Persist/Quasi.hs +84/−84
- Database/Persist/TH/Library.hs +19/−0
- Database/Persist/Util.hs +17/−17
- LICENSE +25/−25
- Setup.lhs +7/−7
- persistent.cabal +72/−71
Database/Persist.hs view
@@ -1,11 +1,11 @@-module Database.Persist- ( PersistField (..)- , PersistEntity (..)- , PersistBackend (..)- , selectList- , insertBy- , getByValue- , checkUnique- ) where--import Database.Persist.Base+module Database.Persist + ( PersistField (..) + , PersistEntity (..) + , PersistBackend (..) + , selectList + , insertBy + , getByValue + , checkUnique + ) where + +import Database.Persist.Base
Database/Persist/Base.hs view
@@ -1,454 +1,454 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}---- | 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 (..)- , PersistUpdate (..)- , PersistOrder (..)- , SomePersistField (..)- , selectList- , insertBy- , getByValue- , checkUnique- , DeleteCascade (..)- , deleteCascadeWhere- , PersistException (..)- ) where--import Data.Time (Day, TimeOfDay, UTCTime)-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)-import Text.Blaze (Html, unsafeByteString)-import Text.Blaze.Renderer.Utf8 (renderHtml)-import qualified Data.Text as T-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Enumerator hiding (consume)-import Data.Enumerator.List (consume)-import qualified Control.Exception as E-import Data.Bits (bitSize)-import Control.Monad (liftM)--import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T---- | A raw value which can be stored in any backend and can be marshalled to--- and from a 'PersistField'.-data PersistValue = PersistText T.Text- | PersistByteString ByteString- | PersistInt64 Int64- | PersistDouble Double- | PersistBool Bool- | PersistDay Day- | PersistTimeOfDay TimeOfDay- | PersistUTCTime UTCTime- | PersistNull- | PersistList [PersistValue]- | PersistMap [(T.Text, PersistValue)]- | PersistForeignKey ByteString -- ^ intended especially for MongoDB backend- deriving (Show, Read, Eq, Typeable, Ord)---- | 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- | SqlInt32- | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64- | 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 = PersistText . T.pack- fromPersistValue (PersistText s) = Right $ T.unpack s- fromPersistValue (PersistByteString bs) =- Right $ T.unpack $ T.decodeUtf8With T.lenientDecode 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- fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String"- fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String"- fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to String"- sqlType _ = SqlString--instance PersistField ByteString where- toPersistValue = PersistByteString- fromPersistValue (PersistByteString bs) = Right bs- fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x- sqlType _ = SqlBlob--instance PersistField T.Text where- toPersistValue = PersistText- fromPersistValue (PersistText s) = Right s- fromPersistValue (PersistByteString bs) =- Right $ T.decodeUtf8With T.lenientDecode bs- fromPersistValue (PersistInt64 i) = Right $ T.pack $ show i- fromPersistValue (PersistDouble d) = Right $ T.pack $ show d- fromPersistValue (PersistDay d) = Right $ T.pack $ show d- fromPersistValue (PersistTimeOfDay d) = Right $ T.pack $ show d- fromPersistValue (PersistUTCTime d) = Right $ T.pack $ show d- fromPersistValue PersistNull = Left "Unexpected null"- fromPersistValue (PersistBool b) = Right $ T.pack $ show b- fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text"- fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text"- fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to Text"- 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 x = case bitSize x of- 32 -> SqlInt32- _ -> SqlInteger--instance PersistField Int8 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInt32--instance PersistField Int16 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInt32--instance PersistField Int32 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Integer, received: " ++ show x- sqlType _ = SqlInt32--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 Word8 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInt32--instance PersistField Word16 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInt32--instance PersistField Word32 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x- sqlType _ = SqlInteger--instance PersistField Word64 where- toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Wordeger, 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@(PersistText t) =- case reads $ T.unpack t 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@(PersistText t) =- case reads $ T.unpack t 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@(PersistText t) =- case reads $ T.unpack t 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 Show (Key val) => 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 :: PersistValue -> Key val- fromPersistKey :: Key val -> PersistValue-- persistFilterToFieldName :: Filter val -> String- persistFilterToFilter :: Filter val -> PersistFilter- persistFilterToValue :: Filter val -> Either PersistValue [PersistValue]-- persistOrderToFieldName :: Order val -> String- persistOrderToOrder :: Order val -> PersistOrder-- persistUpdateToFieldName :: Update val -> String- persistUpdateToUpdate :: Update val -> PersistUpdate- persistUpdateToValue :: Update val -> PersistValue-- persistUniqueToFieldNames :: Unique val -> [String]- persistUniqueToValues :: Unique val -> [PersistValue]- persistUniqueKeys :: val -> [Unique val]--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 Monad m => PersistBackend m where- -- | 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.- selectEnum- :: PersistEntity val- => [Filter val]- -> [Order val]- -> Int -- ^ limit- -> Int -- ^ offset- -> Enumerator (Key val, val) m a-- -- | Get the 'Key's of all records matching the given criterion.- selectKeys :: PersistEntity val- => [Filter val]- -> Enumerator (Key val) m a-- -- | The total number of records fulfilling the given criterion.- count :: PersistEntity val => [Filter val] -> m Int---- | 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, PersistBackend m)- => v -> m (Either (Key v, v) (Key v))-insertBy val =- go $ persistUniqueKeys val- where- go [] = Right `liftM` insert val- go (x:xs) = do- y <- getBy x- case y of- Nothing -> go xs- Just z -> return $ Left z---- | A modification of 'getBy', which takes the 'PersistEntity' itself instead--- 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, PersistBackend m)- => v -> m (Maybe (Key v, v))-getByValue val =- go $ persistUniqueKeys val- where- go [] = return Nothing- go (x:xs) = do- y <- getBy x- case y of- Nothing -> go xs- Just z -> return $ Just z---- | Check whether there are any conflicts for unique keys with this entity and--- existing entities in the database.------ Returns 'True' if the entity would be unique, and could thus safely be--- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntity val, PersistBackend m) => val -> m Bool-checkUnique val =- go $ persistUniqueKeys val- where- go [] = return True- go (x:xs) = do- y <- getBy x- case y of- Nothing -> go xs- Just _ -> return False---- | Call 'select' but return the result as a list.-selectList :: (PersistEntity val, PersistBackend m, Monad m)- => [Filter val]- -> [Order val]- -> Int -- ^ limit- -> Int -- ^ offset- -> m [(Key val, val)]-selectList a b c d = do- res <- run $ selectEnum a b c d ==<< consume- case res of- Left e -> error $ show e- Right x -> return x--data EntityDef = EntityDef- { entityName :: String- , entityAttribs :: [String]- , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs- , entityUniques :: [(String, [String])] -- ^ name, columns- , entityDerives :: [String]- }- deriving Show--data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn- deriving (Read, Show)--data PersistOrder = Asc | Desc- deriving (Read, Show)--class PersistEntity a => DeleteCascade a where- deleteCascade :: PersistBackend m => Key a -> m ()--deleteCascadeWhere :: (DeleteCascade a, PersistBackend m)- => [Filter a] -> m ()-deleteCascadeWhere filts = do- res <- run $ selectKeys filts $ Continue iter- case res of- Left e -> error $ show e- Right () -> return ()- where- iter EOF = Iteratee $ return $ Yield () EOF- iter (Chunks keys) = Iteratee $ do- mapM_ deleteCascade keys- return $ Continue iter--data PersistException = PersistMarshalException String- deriving (Show, Typeable)-instance E.Exception PersistException--data PersistUpdate = Update | Add | Subtract | Multiply | Divide- deriving (Read, Show)--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+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | 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 (..) + , PersistUpdate (..) + , PersistOrder (..) + , SomePersistField (..) + , selectList + , insertBy + , getByValue + , checkUnique + , DeleteCascade (..) + , deleteCascadeWhere + , PersistException (..) + ) where + +import Data.Time (Day, TimeOfDay, UTCTime) +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) +import Text.Blaze (Html, unsafeByteString) +import Text.Blaze.Renderer.Utf8 (renderHtml) +import qualified Data.Text as T +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Enumerator hiding (consume) +import Data.Enumerator.List (consume) +import qualified Control.Exception as E +import Data.Bits (bitSize) +import Control.Monad (liftM) + +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +-- | A raw value which can be stored in any backend and can be marshalled to +-- and from a 'PersistField'. +data PersistValue = PersistText T.Text + | PersistByteString ByteString + | PersistInt64 Int64 + | PersistDouble Double + | PersistBool Bool + | PersistDay Day + | PersistTimeOfDay TimeOfDay + | PersistUTCTime UTCTime + | PersistNull + | PersistList [PersistValue] + | PersistMap [(T.Text, PersistValue)] + | PersistForeignKey ByteString -- ^ intended especially for MongoDB backend. FIXME: rename to PersistObjectId + deriving (Show, Read, Eq, Typeable, Ord) + +-- | 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 + | SqlInt32 + | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64 + | 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 = PersistText . T.pack + fromPersistValue (PersistText s) = Right $ T.unpack s + fromPersistValue (PersistByteString bs) = + Right $ T.unpack $ T.decodeUtf8With T.lenientDecode 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 + fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String" + fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String" + fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to String" + sqlType _ = SqlString + +instance PersistField ByteString where + toPersistValue = PersistByteString + fromPersistValue (PersistByteString bs) = Right bs + fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x + sqlType _ = SqlBlob + +instance PersistField T.Text where + toPersistValue = PersistText + fromPersistValue (PersistText s) = Right s + fromPersistValue (PersistByteString bs) = + Right $ T.decodeUtf8With T.lenientDecode bs + fromPersistValue (PersistInt64 i) = Right $ T.pack $ show i + fromPersistValue (PersistDouble d) = Right $ T.pack $ show d + fromPersistValue (PersistDay d) = Right $ T.pack $ show d + fromPersistValue (PersistTimeOfDay d) = Right $ T.pack $ show d + fromPersistValue (PersistUTCTime d) = Right $ T.pack $ show d + fromPersistValue PersistNull = Left "Unexpected null" + fromPersistValue (PersistBool b) = Right $ T.pack $ show b + fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text" + fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text" + fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to Text" + 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 x = case bitSize x of + 32 -> SqlInt32 + _ -> SqlInteger + +instance PersistField Int8 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Int16 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Int32 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Integer, received: " ++ show x + sqlType _ = SqlInt32 + +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 Word8 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Word16 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInt32 + +instance PersistField Word32 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x + sqlType _ = SqlInteger + +instance PersistField Word64 where + toPersistValue = PersistInt64 . fromIntegral + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue x = Left $ "Expected Wordeger, 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@(PersistText t) = + case reads $ T.unpack t 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@(PersistText t) = + case reads $ T.unpack t 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@(PersistText t) = + case reads $ T.unpack t 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 Show (Key val) => 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 :: PersistValue -> Key val + fromPersistKey :: Key val -> PersistValue + + persistFilterToFieldName :: Filter val -> String + persistFilterToFilter :: Filter val -> PersistFilter + persistFilterToValue :: Filter val -> Either PersistValue [PersistValue] + + persistOrderToFieldName :: Order val -> String + persistOrderToOrder :: Order val -> PersistOrder + + persistUpdateToFieldName :: Update val -> String + persistUpdateToUpdate :: Update val -> PersistUpdate + persistUpdateToValue :: Update val -> PersistValue + + persistUniqueToFieldNames :: Unique val -> [String] + persistUniqueToValues :: Unique val -> [PersistValue] + persistUniqueKeys :: val -> [Unique val] + +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 Monad m => PersistBackend m where + -- | 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. + selectEnum + :: PersistEntity val + => [Filter val] + -> [Order val] + -> Int -- ^ limit + -> Int -- ^ offset + -> Enumerator (Key val, val) m a + + -- | Get the 'Key's of all records matching the given criterion. + selectKeys :: PersistEntity val + => [Filter val] + -> Enumerator (Key val) m a + + -- | The total number of records fulfilling the given criterion. + count :: PersistEntity val => [Filter val] -> m Int + +-- | 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, PersistBackend m) + => v -> m (Either (Key v, v) (Key v)) +insertBy val = + go $ persistUniqueKeys val + where + go [] = Right `liftM` insert val + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just z -> return $ Left z + +-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead +-- 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, PersistBackend m) + => v -> m (Maybe (Key v, v)) +getByValue val = + go $ persistUniqueKeys val + where + go [] = return Nothing + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just z -> return $ Just z + +-- | Check whether there are any conflicts for unique keys with this entity and +-- existing entities in the database. +-- +-- Returns 'True' if the entity would be unique, and could thus safely be +-- 'insert'ed; returns 'False' on a conflict. +checkUnique :: (PersistEntity val, PersistBackend m) => val -> m Bool +checkUnique val = + go $ persistUniqueKeys val + where + go [] = return True + go (x:xs) = do + y <- getBy x + case y of + Nothing -> go xs + Just _ -> return False + +-- | Call 'select' but return the result as a list. +selectList :: (PersistEntity val, PersistBackend m, Monad m) + => [Filter val] + -> [Order val] + -> Int -- ^ limit + -> Int -- ^ offset + -> m [(Key val, val)] +selectList a b c d = do + res <- run $ selectEnum a b c d ==<< consume + case res of + Left e -> error $ show e + Right x -> return x + +data EntityDef = EntityDef + { entityName :: String + , entityAttribs :: [String] + , entityColumns :: [(String, String, [String])] -- ^ name, type, attribs + , entityUniques :: [(String, [String])] -- ^ name, columns + , entityDerives :: [String] + } + deriving Show + +data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn + deriving (Read, Show) + +data PersistOrder = Asc | Desc + deriving (Read, Show) + +class PersistEntity a => DeleteCascade a where + deleteCascade :: PersistBackend m => Key a -> m () + +deleteCascadeWhere :: (DeleteCascade a, PersistBackend m) + => [Filter a] -> m () +deleteCascadeWhere filts = do + res <- run $ selectKeys filts $ Continue iter + case res of + Left e -> error $ show e + Right () -> return () + where + iter EOF = Iteratee $ return $ Yield () EOF + iter (Chunks keys) = Iteratee $ do + mapM_ deleteCascade keys + return $ Continue iter + +data PersistException = PersistMarshalException String + deriving (Show, Typeable) +instance E.Exception PersistException + +data PersistUpdate = Update | Add | Subtract | Multiply | Divide + deriving (Read, Show) + +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
Database/Persist/GenericSql.hs view
@@ -1,427 +1,427 @@-{-# LANGUAGE PackageImports #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | This is a helper module for creating SQL backends. Regular users do not--- need to use this module.-module Database.Persist.GenericSql- ( SqlPersist (..)- , Connection- , ConnectionPool- , Statement- , runSqlConn- , runSqlPool- , Migration- , parseMigration- , parseMigration'- , printMigration- , getMigration- , runMigration- , runMigrationSilent- , runMigrationUnsafe- , migrate- ) where--import Database.Persist.Base-import Data.List (intercalate)-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class (MonadTrans (..))-import Data.Pool-import Control.Monad.Trans.Writer-import System.IO-import Database.Persist.GenericSql.Internal-import qualified Database.Persist.GenericSql.Raw as R-import Database.Persist.GenericSql.Raw (SqlPersist (..))-import Control.Monad (liftM, unless)-import Data.Enumerator (Stream (..), Iteratee (..), Step (..))-import Control.Monad.IO.Control (MonadControlIO)-import Control.Exception.Control (onException)-import Control.Exception (toException)-import Data.Text (Text, pack, unpack)--type ConnectionPool = Pool Connection--withStmt' :: MonadControlIO m => Text -> [PersistValue]- -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a-withStmt' = R.withStmt--execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()-execute' = R.execute--runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a-runSqlPool r pconn = withPool' pconn $ runSqlConn r--runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a-runSqlConn (SqlPersist r) conn = do- let getter = R.getStmt' conn- liftIO $ begin conn getter- x <- onException- (runReaderT r conn)- (liftIO $ rollback conn getter)- liftIO $ commit conn getter- return x--instance MonadControlIO m => PersistBackend (SqlPersist m) where- insert val = do- conn <- SqlPersist ask- let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)- i <-- case esql of- Left sql -> withStmt' sql vals $ \pop -> do- Just [i] <- pop- return i- Right (sql1, sql2) -> do- execute' sql1 vals- withStmt' sql2 [] $ \pop -> do- Just [i] <- pop- return i- return $ toPersistKey i- where- fst3 (x, _, _) = x- t = entityDef val- vals = map toPersistValue $ toPersistFields val-- replace k val = do- conn <- SqlPersist ask- let t = entityDef val- let sql = pack $ concat- [ "UPDATE "- , escapeName conn (rawTableName t)- , " SET "- , intercalate "," (map (go conn . fst3) $ tableColumns t)- , " WHERE id=?"- ]- execute' sql $ map toPersistValue (toPersistFields val)- ++ [fromPersistKey k]- where- go conn x = escapeName conn x ++ "=?"- fst3 (x, _, _) = x-- get k = do- conn <- SqlPersist ask- let t = entityDef $ dummyFromKey k- let cols = intercalate ","- $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t- let sql = pack $ concat- [ "SELECT "- , cols- , " FROM "- , escapeName conn $ rawTableName t- , " WHERE id=?"- ]- withStmt' sql [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- Right v -> return $ Just v-- count filts = do- conn <- SqlPersist ask- let wher = if null filts- then ""- else " WHERE " ++- intercalate " AND " (map (filterClause False conn) filts)- let sql = pack $ concat- [ "SELECT COUNT(*) FROM "- , escapeName conn $ rawTableName t- , wher- ]- withStmt' sql (getFiltsValues filts) $ \pop -> do- Just [PersistInt64 i] <- pop- return $ fromIntegral i- where- t = entityDef $ dummyFromFilts filts-- selectEnum filts ords limit offset =- Iteratee . start- where- start x = do- conn <- SqlPersist ask- withStmt' (sql conn) (getFiltsValues filts) $ loop x- loop (Continue k) pop = do- res <- pop- case res of- Nothing -> return $ Continue k- Just vals -> do- case fromPersistValues' vals of- Left s -> return $ Error $ toException- $ PersistMarshalException s- Right row -> do- step <- runIteratee $ k $ Chunks [row]- loop step pop- loop step _ = return step- t = entityDef $ dummyFromFilts filts- fromPersistValues' (x:xs) = do- case fromPersistValues xs of- Left e -> Left e- Right xs' -> Right (toPersistKey x, xs')- fromPersistValues' _ = Left "error in fromPersistValues'"- wher conn = if null filts- then ""- else " WHERE " ++- intercalate " AND " (map (filterClause False conn) filts)- ord conn = if null ords- then ""- else " ORDER BY " ++- intercalate "," (map (orderClause False conn) ords)- lim conn = case (limit, offset) of- (0, 0) -> ""- (0, _) -> ' ' : noLimit conn- (_, _) -> " LIMIT " ++ show limit- off = if offset == 0- then ""- else " OFFSET " ++ show offset- cols conn = intercalate "," $ "id"- : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- sql conn = pack $ concat- [ "SELECT "- , cols conn- , " FROM "- , escapeName conn $ rawTableName t- , wher conn- , ord conn- , lim conn- , off- ]--- selectKeys filts =- Iteratee . start- where- start x = do- conn <- SqlPersist ask- withStmt' (sql conn) (getFiltsValues filts) $ loop x- loop (Continue k) pop = do- res <- pop- case res of- Nothing -> return $ Continue k- Just [i] -> do- step <- runIteratee $ k $ Chunks [toPersistKey i]- loop step pop- Just y -> return $ Error $ toException $ PersistMarshalException- $ "Unexpected in selectKeys: " ++ show y- loop step _ = return step- t = entityDef $ dummyFromFilts filts- wher conn = if null filts- then ""- else " WHERE " ++- intercalate " AND " (map (filterClause False conn) filts)- sql conn = pack $ concat- [ "SELECT id FROM "- , escapeName conn $ rawTableName t- , wher conn- ]-- delete k = do- conn <- SqlPersist ask- execute' (sql conn) [fromPersistKey k]- where- t = entityDef $ dummyFromKey k- sql conn = pack $ concat- [ "DELETE FROM "- , escapeName conn $ rawTableName t- , " WHERE id=?"- ]-- deleteWhere filts = do- conn <- SqlPersist ask- let t = entityDef $ dummyFromFilts filts- let wher = if null filts- then ""- else " WHERE " ++- intercalate " AND " (map (filterClause False conn) filts)- sql = pack $ concat- [ "DELETE FROM "- , escapeName conn $ rawTableName t- , wher- ]- execute' sql $ getFiltsValues filts-- deleteBy uniq = do- conn <- SqlPersist ask- execute' (sql conn) $ persistUniqueToValues uniq- where- t = entityDef $ dummyFromUnique uniq- go = map (getFieldName t) . persistUniqueToFieldNames- go' conn x = escapeName conn x ++ "=?"- sql conn = pack $ concat- [ "DELETE FROM "- , escapeName conn $ rawTableName t- , " WHERE "- , intercalate " AND " $ map (go' conn) $ go uniq- ]-- update _ [] = return ()- update k upds = do- conn <- SqlPersist ask- let go'' n Update = n ++ "=?"- go'' n Add = n ++ '=' : n ++ "+?"- go'' n Subtract = n ++ '=' : n ++ "-?"- go'' n Multiply = n ++ '=' : n ++ "*?"- go'' n Divide = n ++ '=' : n ++ "/?"- let go' (x, pu) = go'' (escapeName conn x) pu- let sql = pack $ concat- [ "UPDATE "- , escapeName conn $ rawTableName t- , " SET "- , intercalate "," $ map (go' . go) upds- , " WHERE id=?"- ]- execute' sql $- map persistUpdateToValue upds ++ [fromPersistKey k]- where- t = entityDef $ dummyFromKey k- go x = ( getFieldName t $ persistUpdateToFieldName x- , persistUpdateToUpdate x- )-- updateWhere _ [] = return ()- updateWhere filts upds = do- conn <- SqlPersist ask- let wher = if null filts- then ""- else " WHERE " ++- intercalate " AND " (map (filterClause False conn) filts)- let sql = pack $ concat- [ "UPDATE "- , escapeName conn $ rawTableName t- , " SET "- , intercalate "," $ map (go' conn . go) upds- , wher- ]- let dat = map persistUpdateToValue upds ++ getFiltsValues filts- execute' sql dat- where- t = entityDef $ dummyFromFilts filts- go'' n Update = n ++ "=?"- go'' n Add = n ++ '=' : n ++ "+?"- go'' n Subtract = n ++ '=' : n ++ "-?"- go'' n Multiply = n ++ '=' : n ++ "*?"- go'' n Divide = n ++ '=' : n ++ "/?"- go' conn (x, pu) = go'' (escapeName conn x) pu- go x = ( getFieldName t $ persistUpdateToFieldName x- , persistUpdateToUpdate x- )-- getBy uniq = do- conn <- SqlPersist ask- let cols = intercalate "," $ "id"- : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- let sql = pack $ concat- [ "SELECT "- , cols- , " FROM "- , escapeName conn $ rawTableName t- , " WHERE "- , sqlClause conn- ]- withStmt' sql (persistUniqueToValues uniq) $ \pop -> do- row <- pop- case row of- Nothing -> return Nothing- Just (k:vals) ->- case fromPersistValues vals of- Left s -> error s- Right x -> return $ Just (toPersistKey k, x)- Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"- where- sqlClause conn =- intercalate " AND " $ map (go conn) $ toFieldNames' uniq- go conn x = escapeName conn x ++ "=?"- t = entityDef $ dummyFromUnique uniq- toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames--dummyFromUnique :: Unique v -> v-dummyFromUnique _ = error "dummyFromUnique"--dummyFromKey :: Key v -> v-dummyFromKey _ = error "dummyFromKey"---type Sql = Text---- Bool indicates if the Sql is safe-type CautiousMigration = [(Bool, Sql)]-allSql :: CautiousMigration -> [Sql]-allSql = map snd-unsafeSql :: CautiousMigration -> [Sql]-unsafeSql = allSql . filter fst-safeSql :: CautiousMigration -> [Sql]-safeSql = allSql . filter (not . fst)--type Migration m = WriterT [Text] (WriterT CautiousMigration m) ()--parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration)-parseMigration =- liftM go . runWriterT . execWriterT- where- go ([], sql) = Right sql- go (errs, _) = Left errs---- like parseMigration, but call error or return the CautiousMigration-parseMigration' :: Monad m => Migration m -> m (CautiousMigration)-parseMigration' m = do- x <- parseMigration m- case x of- Left errs -> error $ unlines $ map unpack errs- Right sql -> return sql--printMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m ()-printMigration m = do- mig <- parseMigration' m- mapM_ (liftIO . putStrLn . unpack) (allSql mig)--getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]-getMigration m = do- mig <- parseMigration' m- return $ allSql mig--runMigration :: MonadControlIO 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 :: MonadControlIO m- => Migration (SqlPersist m)- -> SqlPersist m [Text]-runMigrationSilent m = runMigration' m True--runMigration' :: MonadControlIO m- => Migration (SqlPersist m)- -> Bool -- ^ is silent?- -> SqlPersist m [Text]-runMigration' m silent = do- mig <- parseMigration' m- case unsafeSql mig of- [] -> mapM (executeMigrate silent) $ safeSql mig- errs -> error $ concat- [ "\n\nDatabase migration: manual intervention required.\n"- , "The following actions are considered unsafe:\n\n"- , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs- ]--runMigrationUnsafe :: MonadControlIO 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 silent s = do- unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s- execute' s []- return s--migrate :: (MonadControlIO m, PersistEntity val)- => val- -> Migration (SqlPersist m)-migrate val = do- conn <- lift $ lift $ SqlPersist ask- let getter = R.getStmt' conn- res <- liftIO $ migrateSql conn getter val- either tell (lift . tell) res+{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This is a helper module for creating SQL backends. Regular users do not +-- need to use this module. +module Database.Persist.GenericSql + ( SqlPersist (..) + , Connection + , ConnectionPool + , Statement + , runSqlConn + , runSqlPool + , Migration + , parseMigration + , parseMigration' + , printMigration + , getMigration + , runMigration + , runMigrationSilent + , runMigrationUnsafe + , migrate + ) where + +import Database.Persist.Base +import Data.List (intercalate) +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Pool +import Control.Monad.Trans.Writer +import System.IO +import Database.Persist.GenericSql.Internal +import qualified Database.Persist.GenericSql.Raw as R +import Database.Persist.GenericSql.Raw (SqlPersist (..)) +import Control.Monad (liftM, unless) +import Data.Enumerator (Stream (..), Iteratee (..), Step (..)) +import Control.Monad.IO.Control (MonadControlIO) +import Control.Exception.Control (onException) +import Control.Exception (toException) +import Data.Text (Text, pack, unpack) + +type ConnectionPool = Pool Connection + +withStmt' :: MonadControlIO m => Text -> [PersistValue] + -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a +withStmt' = R.withStmt + +execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () +execute' = R.execute + +runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a +runSqlPool r pconn = withPool' pconn $ runSqlConn r + +runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a +runSqlConn (SqlPersist r) conn = do + let getter = R.getStmt' conn + liftIO $ begin conn getter + x <- onException + (runReaderT r conn) + (liftIO $ rollback conn getter) + liftIO $ commit conn getter + return x + +instance MonadControlIO m => PersistBackend (SqlPersist m) where + insert val = do + conn <- SqlPersist ask + let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t) + i <- + case esql of + Left sql -> withStmt' sql vals $ \pop -> do + Just [i] <- pop + return i + Right (sql1, sql2) -> do + execute' sql1 vals + withStmt' sql2 [] $ \pop -> do + Just [i] <- pop + return i + return $ toPersistKey i + where + fst3 (x, _, _) = x + t = entityDef val + vals = map toPersistValue $ toPersistFields val + + replace k val = do + conn <- SqlPersist ask + let t = entityDef val + let sql = pack $ concat + [ "UPDATE " + , escapeName conn (rawTableName t) + , " SET " + , intercalate "," (map (go conn . fst3) $ tableColumns t) + , " WHERE id=?" + ] + execute' sql $ map toPersistValue (toPersistFields val) + ++ [fromPersistKey k] + where + go conn x = escapeName conn x ++ "=?" + fst3 (x, _, _) = x + + get k = do + conn <- SqlPersist ask + let t = entityDef $ dummyFromKey k + let cols = intercalate "," + $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t + let sql = pack $ concat + [ "SELECT " + , cols + , " FROM " + , escapeName conn $ rawTableName t + , " WHERE id=?" + ] + withStmt' sql [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 + Right v -> return $ Just v + + count filts = do + conn <- SqlPersist ask + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map (filterClause False conn) filts) + let sql = pack $ concat + [ "SELECT COUNT(*) FROM " + , escapeName conn $ rawTableName t + , wher + ] + withStmt' sql (getFiltsValues filts) $ \pop -> do + Just [PersistInt64 i] <- pop + return $ fromIntegral i + where + t = entityDef $ dummyFromFilts filts + + selectEnum filts ords limit offset = + Iteratee . start + where + start x = do + conn <- SqlPersist ask + withStmt' (sql conn) (getFiltsValues filts) $ loop x + loop (Continue k) pop = do + res <- pop + case res of + Nothing -> return $ Continue k + Just vals -> do + case fromPersistValues' vals of + Left s -> return $ Error $ toException + $ PersistMarshalException s + Right row -> do + step <- runIteratee $ k $ Chunks [row] + loop step pop + loop step _ = return step + t = entityDef $ dummyFromFilts filts + fromPersistValues' (x:xs) = do + case fromPersistValues xs of + Left e -> Left e + Right xs' -> Right (toPersistKey x, xs') + fromPersistValues' _ = Left "error in fromPersistValues'" + wher conn = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map (filterClause False conn) filts) + ord conn = if null ords + then "" + else " ORDER BY " ++ + intercalate "," (map (orderClause False conn) ords) + lim conn = case (limit, offset) of + (0, 0) -> "" + (0, _) -> ' ' : noLimit conn + (_, _) -> " LIMIT " ++ show limit + off = if offset == 0 + then "" + else " OFFSET " ++ show offset + cols conn = intercalate "," $ "id" + : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t) + sql conn = pack $ concat + [ "SELECT " + , cols conn + , " FROM " + , escapeName conn $ rawTableName t + , wher conn + , ord conn + , lim conn + , off + ] + + + selectKeys filts = + Iteratee . start + where + start x = do + conn <- SqlPersist ask + withStmt' (sql conn) (getFiltsValues filts) $ loop x + loop (Continue k) pop = do + res <- pop + case res of + Nothing -> return $ Continue k + Just [i] -> do + step <- runIteratee $ k $ Chunks [toPersistKey i] + loop step pop + Just y -> return $ Error $ toException $ PersistMarshalException + $ "Unexpected in selectKeys: " ++ show y + loop step _ = return step + t = entityDef $ dummyFromFilts filts + wher conn = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map (filterClause False conn) filts) + sql conn = pack $ concat + [ "SELECT id FROM " + , escapeName conn $ rawTableName t + , wher conn + ] + + delete k = do + conn <- SqlPersist ask + execute' (sql conn) [fromPersistKey k] + where + t = entityDef $ dummyFromKey k + sql conn = pack $ concat + [ "DELETE FROM " + , escapeName conn $ rawTableName t + , " WHERE id=?" + ] + + deleteWhere filts = do + conn <- SqlPersist ask + let t = entityDef $ dummyFromFilts filts + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map (filterClause False conn) filts) + sql = pack $ concat + [ "DELETE FROM " + , escapeName conn $ rawTableName t + , wher + ] + execute' sql $ getFiltsValues filts + + deleteBy uniq = do + conn <- SqlPersist ask + execute' (sql conn) $ persistUniqueToValues uniq + where + t = entityDef $ dummyFromUnique uniq + go = map (getFieldName t) . persistUniqueToFieldNames + go' conn x = escapeName conn x ++ "=?" + sql conn = pack $ concat + [ "DELETE FROM " + , escapeName conn $ rawTableName t + , " WHERE " + , intercalate " AND " $ map (go' conn) $ go uniq + ] + + update _ [] = return () + update k upds = do + conn <- SqlPersist ask + let go'' n Update = n ++ "=?" + go'' n Add = n ++ '=' : n ++ "+?" + go'' n Subtract = n ++ '=' : n ++ "-?" + go'' n Multiply = n ++ '=' : n ++ "*?" + go'' n Divide = n ++ '=' : n ++ "/?" + let go' (x, pu) = go'' (escapeName conn x) pu + let sql = pack $ concat + [ "UPDATE " + , escapeName conn $ rawTableName t + , " SET " + , intercalate "," $ map (go' . go) upds + , " WHERE id=?" + ] + execute' sql $ + map persistUpdateToValue upds ++ [fromPersistKey k] + where + t = entityDef $ dummyFromKey k + go x = ( getFieldName t $ persistUpdateToFieldName x + , persistUpdateToUpdate x + ) + + updateWhere _ [] = return () + updateWhere filts upds = do + conn <- SqlPersist ask + let wher = if null filts + then "" + else " WHERE " ++ + intercalate " AND " (map (filterClause False conn) filts) + let sql = pack $ concat + [ "UPDATE " + , escapeName conn $ rawTableName t + , " SET " + , intercalate "," $ map (go' conn . go) upds + , wher + ] + let dat = map persistUpdateToValue upds ++ getFiltsValues filts + execute' sql dat + where + t = entityDef $ dummyFromFilts filts + go'' n Update = n ++ "=?" + go'' n Add = n ++ '=' : n ++ "+?" + go'' n Subtract = n ++ '=' : n ++ "-?" + go'' n Multiply = n ++ '=' : n ++ "*?" + go'' n Divide = n ++ '=' : n ++ "/?" + go' conn (x, pu) = go'' (escapeName conn x) pu + go x = ( getFieldName t $ persistUpdateToFieldName x + , persistUpdateToUpdate x + ) + + getBy uniq = do + conn <- SqlPersist ask + let cols = intercalate "," $ "id" + : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t) + let sql = pack $ concat + [ "SELECT " + , cols + , " FROM " + , escapeName conn $ rawTableName t + , " WHERE " + , sqlClause conn + ] + withStmt' sql (persistUniqueToValues uniq) $ \pop -> do + row <- pop + case row of + Nothing -> return Nothing + Just (k:vals) -> + case fromPersistValues vals of + Left s -> error s + Right x -> return $ Just (toPersistKey k, x) + Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" + where + sqlClause conn = + intercalate " AND " $ map (go conn) $ toFieldNames' uniq + go conn x = escapeName conn x ++ "=?" + t = entityDef $ dummyFromUnique uniq + toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames + +dummyFromUnique :: Unique v -> v +dummyFromUnique _ = error "dummyFromUnique" + +dummyFromKey :: Key v -> v +dummyFromKey _ = error "dummyFromKey" + + +type Sql = Text + +-- Bool indicates if the Sql is safe +type CautiousMigration = [(Bool, Sql)] +allSql :: CautiousMigration -> [Sql] +allSql = map snd +unsafeSql :: CautiousMigration -> [Sql] +unsafeSql = allSql . filter fst +safeSql :: CautiousMigration -> [Sql] +safeSql = allSql . filter (not . fst) + +type Migration m = WriterT [Text] (WriterT CautiousMigration m) () + +parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration) +parseMigration = + liftM go . runWriterT . execWriterT + where + go ([], sql) = Right sql + go (errs, _) = Left errs + +-- like parseMigration, but call error or return the CautiousMigration +parseMigration' :: Monad m => Migration m -> m (CautiousMigration) +parseMigration' m = do + x <- parseMigration m + case x of + Left errs -> error $ unlines $ map unpack errs + Right sql -> return sql + +printMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m () +printMigration m = do + mig <- parseMigration' m + mapM_ (liftIO . putStrLn . unpack) (allSql mig) + +getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql] +getMigration m = do + mig <- parseMigration' m + return $ allSql mig + +runMigration :: MonadControlIO 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 :: MonadControlIO m + => Migration (SqlPersist m) + -> SqlPersist m [Text] +runMigrationSilent m = runMigration' m True + +runMigration' :: MonadControlIO m + => Migration (SqlPersist m) + -> Bool -- ^ is silent? + -> SqlPersist m [Text] +runMigration' m silent = do + mig <- parseMigration' m + case unsafeSql mig of + [] -> mapM (executeMigrate silent) $ safeSql mig + errs -> error $ concat + [ "\n\nDatabase migration: manual intervention required.\n" + , "The following actions are considered unsafe:\n\n" + , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs + ] + +runMigrationUnsafe :: MonadControlIO 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 silent s = do + unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s + execute' s [] + return s + +migrate :: (MonadControlIO m, PersistEntity val) + => val + -> Migration (SqlPersist m) +migrate val = do + conn <- lift $ lift $ SqlPersist ask + let getter = R.getStmt' conn + res <- liftIO $ migrateSql conn getter val + either tell (lift . tell) res
Database/Persist/GenericSql/Internal.hs view
@@ -1,249 +1,249 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PackageImports #-}--- | Code that is only needed for writing GenericSql backends.-module Database.Persist.GenericSql.Internal- ( Connection (..)- , Statement (..)- , withSqlConn- , withSqlPool- , RowPopper- , mkColumns- , Column (..)- , UniqueDef- , refName- , tableColumns- , rawFieldName- , rawTableName- , RawName (..)- , filterClause- , getFieldName- , dummyFromFilts- , getFiltsValues- , orderClause- ) where--import qualified Data.Map as Map-import Data.IORef-import Control.Monad.IO.Class-import Data.Pool-import Database.Persist.Base-import Data.Maybe (fromJust)-import Control.Arrow-import Control.Monad.IO.Control (MonadControlIO)-import Control.Exception.Control (bracket)-import Database.Persist.Util (nullable)-import Data.List (intercalate)-import Data.Text (Text)--type RowPopper m = m (Maybe [PersistValue])--data Connection = Connection- { prepare :: Text -> IO Statement- , insertSql :: RawName -> [RawName] -> Either Text (Text, Text)- , stmtMap :: IORef (Map.Map Text Statement)- , close :: IO ()- , migrateSql :: forall v. PersistEntity v- => (Text -> IO Statement) -> v- -> IO (Either [Text] [(Bool, Text)])- , begin :: (Text -> IO Statement) -> IO ()- , commit :: (Text -> IO Statement) -> IO ()- , rollback :: (Text -> IO Statement) -> IO ()- , escapeName :: RawName -> String- , noLimit :: String- }-data Statement = Statement- { finalize :: IO ()- , reset :: IO ()- , execute :: [PersistValue] -> IO ()- , withStmt :: forall a m. MonadControlIO m- => [PersistValue] -> (RowPopper m -> m a) -> m a- }--withSqlPool :: MonadControlIO m- => IO Connection -> Int -> (Pool Connection -> m a) -> m a-withSqlPool mkConn = createPool mkConn close'--withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a-withSqlConn open = bracket (liftIO open) (liftIO . close')--close' :: Connection -> IO ()-close' conn = do- readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems- close conn---- | Create the list of columns for the given entity.-mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef])-mkColumns val =- (cols, uniqs)- where- colNameMap = map ((\(x, _, _) -> x) &&& rawFieldName) $ entityColumns t- uniqs = map (RawName *** map (fromJust . flip lookup colNameMap))- $ entityUniques t -- FIXME don't use fromJust- cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val- t = entityDef val- tn = rawTableName t- go (name, t', as) p =- Column name (nullable as) (sqlType p) (def as) (ref name t' as)- def [] = Nothing- def (('d':'e':'f':'a':'u':'l':'t':'=':d):_) = Just d- def (_:rest) = def rest- ref c t' [] =- let l = length t'- (f, b) = splitAt (l - 2) t'- in if b == "Id"- then Just (RawName f, refName tn c)- else Nothing- ref _ _ ("noreference":_) = Nothing- ref c _ (('r':'e':'f':'e':'r':'e':'n':'c':'e':'=':x):_) =- Just (RawName x, refName tn c)- ref c x (_:y) = ref c x y--refName :: RawName -> RawName -> RawName-refName (RawName table) (RawName column) =- RawName $ table ++ '_' : column ++ "_fkey"--data Column = Column- { cName :: RawName- , cNull :: Bool- , cType :: SqlType- , cDefault :: Maybe String- , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name- }--getSqlValue :: [String] -> Maybe String-getSqlValue (('s':'q':'l':'=':x):_) = Just x-getSqlValue (_:x) = getSqlValue x-getSqlValue [] = Nothing--tableColumns :: EntityDef -> [(RawName, String, [String])]-tableColumns = map (\a@(_, y, z) -> (rawFieldName a, y, z)) . entityColumns--type UniqueDef = (RawName, [RawName])--rawFieldName :: (String, String, [String]) -> RawName-rawFieldName (n, _, as) = RawName $- case getSqlValue as of- Just x -> x- Nothing -> n--rawTableName :: EntityDef -> RawName-rawTableName t = RawName $- case getSqlValue $ entityAttribs t of- Nothing -> entityName t- Just x -> x--newtype RawName = RawName { unRawName :: String } -- FIXME Text- deriving (Eq, Ord)--filterClause :: PersistEntity val- => Bool -- ^ include table name?- -> Connection -> Filter val -> String-filterClause includeTable conn f =- case (isNull, persistFilterToFilter f, varCount) of- (True, Eq, _) -> name ++ " IS NULL"- (True, Ne, _) -> name ++ " IS NOT NULL"- (False, Ne, _) -> concat- [ "("- , name- , " IS NULL OR "- , name- , "<>?)"- ]- -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since- -- not all databases support those words directly.- (_, In, 0) -> "1=2"- (False, In, _) -> name ++ " IN " ++ qmarks- (True, In, _) -> concat- [ "("- , name- , " IS NULL OR "- , name- , " IN "- , qmarks- , ")"- ]- (_, NotIn, 0) -> "1=1"- (False, NotIn, _) -> concat- [ "("- , name- , " IS NULL OR "- , name- , " NOT IN "- , qmarks- , ")"- ]- (True, NotIn, _) -> concat- [ "("- , name- , " IS NOT NULL AND "- , name- , " NOT IN "- , qmarks- , ")"- ]- _ -> name ++ showSqlFilter (persistFilterToFilter f) ++ "?"- where- isNull = any (== PersistNull)- $ either return id- $ persistFilterToValue f- t = entityDef $ dummyFromFilts [f]- name =- (if includeTable- then (++) (escapeName conn (rawTableName t) ++ ".")- else id)- $ escapeName conn $ getFieldName t $ persistFilterToFieldName f- qmarks = case persistFilterToValue f of- Left _ -> "?"- Right x ->- let x' = filter (/= PersistNull) x- in '(' : intercalate "," (map (const "?") x') ++ ")"- varCount = case persistFilterToValue f of- Left _ -> 1- Right x -> length x- showSqlFilter Eq = "="- showSqlFilter Ne = "<>"- showSqlFilter Gt = ">"- showSqlFilter Lt = "<"- showSqlFilter Ge = ">="- showSqlFilter Le = "<="- showSqlFilter In = " IN "- showSqlFilter NotIn = " NOT IN "--dummyFromFilts :: [Filter v] -> v-dummyFromFilts _ = error "dummyFromFilts"--getFieldName :: EntityDef -> String -> RawName-getFieldName t s = rawFieldName $ tableColumn t s--tableColumn :: EntityDef -> String -> (String, String, [String])-tableColumn _ "id" = ("id", "Int64", [])-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--getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue]-getFiltsValues =- concatMap $ go . persistFilterToValue- where- go (Left PersistNull) = []- go (Left x) = [x]- go (Right xs) = filter (/= PersistNull) xs--dummyFromOrder :: Order a -> a-dummyFromOrder _ = undefined--orderClause :: PersistEntity val => Bool -> Connection -> Order val -> String-orderClause includeTable conn o =- name ++ case persistOrderToOrder o of- Asc -> ""- Desc -> " DESC"- where- t = entityDef $ dummyFromOrder o- name =- (if includeTable- then (++) (escapeName conn (rawTableName t) ++ ".")- else id)- $ escapeName conn $ getFieldName t $ persistOrderToFieldName o+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} +-- | Code that is only needed for writing GenericSql backends. +module Database.Persist.GenericSql.Internal + ( Connection (..) + , Statement (..) + , withSqlConn + , withSqlPool + , RowPopper + , mkColumns + , Column (..) + , UniqueDef + , refName + , tableColumns + , rawFieldName + , rawTableName + , RawName (..) + , filterClause + , getFieldName + , dummyFromFilts + , getFiltsValues + , orderClause + ) where + +import qualified Data.Map as Map +import Data.IORef +import Control.Monad.IO.Class +import Data.Pool +import Database.Persist.Base +import Data.Maybe (fromJust) +import Control.Arrow +import Control.Monad.IO.Control (MonadControlIO) +import Control.Exception.Control (bracket) +import Database.Persist.Util (nullable) +import Data.List (intercalate) +import Data.Text (Text) + +type RowPopper m = m (Maybe [PersistValue]) + +data Connection = Connection + { prepare :: Text -> IO Statement + , insertSql :: RawName -> [RawName] -> Either Text (Text, Text) + , stmtMap :: IORef (Map.Map Text Statement) + , close :: IO () + , migrateSql :: forall v. PersistEntity v + => (Text -> IO Statement) -> v + -> IO (Either [Text] [(Bool, Text)]) + , begin :: (Text -> IO Statement) -> IO () + , commit :: (Text -> IO Statement) -> IO () + , rollback :: (Text -> IO Statement) -> IO () + , escapeName :: RawName -> String + , noLimit :: String + } +data Statement = Statement + { finalize :: IO () + , reset :: IO () + , execute :: [PersistValue] -> IO () + , withStmt :: forall a m. MonadControlIO m + => [PersistValue] -> (RowPopper m -> m a) -> m a + } + +withSqlPool :: MonadControlIO m + => IO Connection -> Int -> (Pool Connection -> m a) -> m a +withSqlPool mkConn = createPool mkConn close' + +withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a +withSqlConn open = bracket (liftIO open) (liftIO . close') + +close' :: Connection -> IO () +close' conn = do + readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems + close conn + +-- | Create the list of columns for the given entity. +mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef]) +mkColumns val = + (cols, uniqs) + where + colNameMap = map ((\(x, _, _) -> x) &&& rawFieldName) $ entityColumns t + uniqs = map (RawName *** map (fromJust . flip lookup colNameMap)) + $ entityUniques t -- FIXME don't use fromJust + cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val + t = entityDef val + tn = rawTableName t + go (name, t', as) p = + Column name (nullable as) (sqlType p) (def as) (ref name t' as) + def [] = Nothing + def (('d':'e':'f':'a':'u':'l':'t':'=':d):_) = Just d + def (_:rest) = def rest + ref c t' [] = + let l = length t' + (f, b) = splitAt (l - 2) t' + in if b == "Id" + then Just (RawName f, refName tn c) + else Nothing + ref _ _ ("noreference":_) = Nothing + ref c _ (('r':'e':'f':'e':'r':'e':'n':'c':'e':'=':x):_) = + Just (RawName x, refName tn c) + ref c x (_:y) = ref c x y + +refName :: RawName -> RawName -> RawName +refName (RawName table) (RawName column) = + RawName $ table ++ '_' : column ++ "_fkey" + +data Column = Column + { cName :: RawName + , cNull :: Bool + , cType :: SqlType + , cDefault :: Maybe String + , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name + } + +getSqlValue :: [String] -> Maybe String +getSqlValue (('s':'q':'l':'=':x):_) = Just x +getSqlValue (_:x) = getSqlValue x +getSqlValue [] = Nothing + +tableColumns :: EntityDef -> [(RawName, String, [String])] +tableColumns = map (\a@(_, y, z) -> (rawFieldName a, y, z)) . entityColumns + +type UniqueDef = (RawName, [RawName]) + +rawFieldName :: (String, String, [String]) -> RawName +rawFieldName (n, _, as) = RawName $ + case getSqlValue as of + Just x -> x + Nothing -> n + +rawTableName :: EntityDef -> RawName +rawTableName t = RawName $ + case getSqlValue $ entityAttribs t of + Nothing -> entityName t + Just x -> x + +newtype RawName = RawName { unRawName :: String } -- FIXME Text + deriving (Eq, Ord) + +filterClause :: PersistEntity val + => Bool -- ^ include table name? + -> Connection -> Filter val -> String +filterClause includeTable conn f = + case (isNull, persistFilterToFilter f, varCount) of + (True, Eq, _) -> name ++ " IS NULL" + (True, Ne, _) -> name ++ " IS NOT NULL" + (False, Ne, _) -> concat + [ "(" + , name + , " IS NULL OR " + , name + , "<>?)" + ] + -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since + -- not all databases support those words directly. + (_, In, 0) -> "1=2" + (False, In, _) -> name ++ " IN " ++ qmarks + (True, In, _) -> concat + [ "(" + , name + , " IS NULL OR " + , name + , " IN " + , qmarks + , ")" + ] + (_, NotIn, 0) -> "1=1" + (False, NotIn, _) -> concat + [ "(" + , name + , " IS NULL OR " + , name + , " NOT IN " + , qmarks + , ")" + ] + (True, NotIn, _) -> concat + [ "(" + , name + , " IS NOT NULL AND " + , name + , " NOT IN " + , qmarks + , ")" + ] + _ -> name ++ showSqlFilter (persistFilterToFilter f) ++ "?" + where + isNull = any (== PersistNull) + $ either return id + $ persistFilterToValue f + t = entityDef $ dummyFromFilts [f] + name = + (if includeTable + then (++) (escapeName conn (rawTableName t) ++ ".") + else id) + $ escapeName conn $ getFieldName t $ persistFilterToFieldName f + qmarks = case persistFilterToValue f of + Left _ -> "?" + Right x -> + let x' = filter (/= PersistNull) x + in '(' : intercalate "," (map (const "?") x') ++ ")" + varCount = case persistFilterToValue f of + Left _ -> 1 + Right x -> length x + showSqlFilter Eq = "=" + showSqlFilter Ne = "<>" + showSqlFilter Gt = ">" + showSqlFilter Lt = "<" + showSqlFilter Ge = ">=" + showSqlFilter Le = "<=" + showSqlFilter In = " IN " + showSqlFilter NotIn = " NOT IN " + +dummyFromFilts :: [Filter v] -> v +dummyFromFilts _ = error "dummyFromFilts" + +getFieldName :: EntityDef -> String -> RawName +getFieldName t s = rawFieldName $ tableColumn t s + +tableColumn :: EntityDef -> String -> (String, String, [String]) +tableColumn _ "id" = ("id", "Int64", []) +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 + +getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue] +getFiltsValues = + concatMap $ go . persistFilterToValue + where + go (Left PersistNull) = [] + go (Left x) = [x] + go (Right xs) = filter (/= PersistNull) xs + +dummyFromOrder :: Order a -> a +dummyFromOrder _ = undefined + +orderClause :: PersistEntity val => Bool -> Connection -> Order val -> String +orderClause includeTable conn o = + name ++ case persistOrderToOrder o of + Asc -> "" + Desc -> " DESC" + where + t = entityDef $ dummyFromOrder o + name = + (if includeTable + then (++) (escapeName conn (rawTableName t) ++ ".") + else id) + $ escapeName conn $ getFieldName t $ persistOrderToFieldName o
Database/Persist/GenericSql/Raw.hs view
@@ -1,54 +1,54 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-module Database.Persist.GenericSql.Raw- ( withStmt- , execute- , SqlPersist (..)- , getStmt'- , getStmt- ) where--import qualified Database.Persist.GenericSql.Internal as I-import Database.Persist.GenericSql.Internal hiding (execute, withStmt)-import Database.Persist.Base (PersistValue)-import Data.IORef-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import qualified Data.Map as Map-import Control.Applicative (Applicative)-import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.IO.Control (MonadControlIO (..))-import Data.Text (Text)--newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO)--withStmt :: MonadControlIO m => Text -> [PersistValue]- -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a-withStmt sql vals pop = do- stmt <- getStmt sql- ret <- I.withStmt stmt vals pop- liftIO $ reset stmt- return ret--execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()-execute sql vals = do- stmt <- getStmt sql- liftIO $ I.execute stmt vals- liftIO $ reset stmt--getStmt :: MonadIO m => Text -> SqlPersist m Statement-getStmt sql = do- conn <- SqlPersist ask- liftIO $ getStmt' conn sql--getStmt' :: Connection -> Text -> IO Statement-getStmt' conn sql = do- smap <- liftIO $ readIORef $ stmtMap conn- case Map.lookup sql smap of- Just stmt -> return stmt- Nothing -> do- stmt <- liftIO $ prepare conn sql- liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap- return stmt+{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Database.Persist.GenericSql.Raw + ( withStmt + , execute + , SqlPersist (..) + , getStmt' + , getStmt + ) where + +import qualified Database.Persist.GenericSql.Internal as I +import Database.Persist.GenericSql.Internal hiding (execute, withStmt) +import Database.Persist.Base (PersistValue) +import Data.IORef +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.Map as Map +import Control.Applicative (Applicative) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.IO.Control (MonadControlIO (..)) +import Data.Text (Text) + +newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a } + deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO) + +withStmt :: MonadControlIO m => Text -> [PersistValue] + -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a +withStmt sql vals pop = do + stmt <- getStmt sql + ret <- I.withStmt stmt vals pop + liftIO $ reset stmt + return ret + +execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () +execute sql vals = do + stmt <- getStmt sql + liftIO $ I.execute stmt vals + liftIO $ reset stmt + +getStmt :: MonadIO m => Text -> SqlPersist m Statement +getStmt sql = do + conn <- SqlPersist ask + liftIO $ getStmt' conn sql + +getStmt' :: Connection -> Text -> IO Statement +getStmt' conn sql = do + smap <- liftIO $ readIORef $ stmtMap conn + case Map.lookup sql smap of + Just stmt -> return stmt + Nothing -> do + stmt <- liftIO $ prepare conn sql + liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap + return stmt
Database/Persist/Join.hs view
@@ -1,55 +1,55 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-module Database.Persist.Join- ( -- * Typeclass- RunJoin (..)- -- * One-to-many relation- , SelectOneMany (..)- , selectOneMany- ) where--import Database.Persist.Base-import Data.Maybe (mapMaybe)-import qualified Data.Map as Map-import Data.List (foldl')--class RunJoin a where- type Result a- runJoin :: PersistBackend m => a -> m (Result a)--data SelectOneMany one many = SelectOneMany- { somFilterOne :: [Filter one]- , somOrderOne :: [Order one]- , somFilterMany :: [Filter many]- , somOrderMany :: [Order many]- , somFilterKeys :: [Key one] -> Filter many- , somGetKey :: many -> Key one- , somIncludeNoMatch :: Bool- }--selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many-selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False-instance (PersistEntity one, PersistEntity many, Ord (Key one))- => RunJoin (SelectOneMany one many) where- type Result (SelectOneMany one many) =- [((Key one, one), [(Key many, many)])]- runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do- x <- selectList oneF oneO 0 0- -- FIXME use select instead of selectList- y <- selectList (eq (map fst x) : manyF) manyO 0 0- let y' = foldl' go Map.empty y- return $ mapMaybe (go' y') x- where- go m many@(_, many') =- Map.insert (getKey many')- (case Map.lookup (getKey many') m of- Nothing -> (:) many- Just v -> v . (:) many- ) m- go' y' one@(k, _) =- case Map.lookup k y' of- Nothing ->- if isOuter- then Just (one, [])- else Nothing- Just many -> Just (one, many [])+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Database.Persist.Join + ( -- * Typeclass + RunJoin (..) + -- * One-to-many relation + , SelectOneMany (..) + , selectOneMany + ) where + +import Database.Persist.Base +import Data.Maybe (mapMaybe) +import qualified Data.Map as Map +import Data.List (foldl') + +class RunJoin a where + type Result a + runJoin :: PersistBackend m => a -> m (Result a) + +data SelectOneMany one many = SelectOneMany + { somFilterOne :: [Filter one] + , somOrderOne :: [Order one] + , somFilterMany :: [Filter many] + , somOrderMany :: [Order many] + , somFilterKeys :: [Key one] -> Filter many + , somGetKey :: many -> Key one + , somIncludeNoMatch :: Bool + } + +selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many +selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False +instance (PersistEntity one, PersistEntity many, Ord (Key one)) + => RunJoin (SelectOneMany one many) where + type Result (SelectOneMany one many) = + [((Key one, one), [(Key many, many)])] + runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do + x <- selectList oneF oneO 0 0 + -- FIXME use select instead of selectList + y <- selectList (eq (map fst x) : manyF) manyO 0 0 + let y' = foldl' go Map.empty y + return $ mapMaybe (go' y') x + where + go m many@(_, many') = + Map.insert (getKey many') + (case Map.lookup (getKey many') m of + Nothing -> (:) many + Just v -> v . (:) many + ) m + go' y' one@(k, _) = + case Map.lookup k y' of + Nothing -> + if isOuter + then Just (one, []) + else Nothing + Just many -> Just (one, many [])
Database/Persist/Join/Sql.hs view
@@ -1,98 +1,98 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module Database.Persist.Join.Sql- ( RunJoin (..)- ) where--import Database.Persist.Join hiding (RunJoin (..))-import qualified Database.Persist.Join as J-import Database.Persist.Base-import Control.Monad (liftM)-import Data.Maybe (mapMaybe)-import Data.List (intercalate, groupBy)-import Database.Persist.GenericSql (SqlPersist (SqlPersist))-import Database.Persist.GenericSql.Internal hiding (withStmt)-import Database.Persist.GenericSql.Raw (withStmt)-import Control.Monad.Trans.Reader (ask)-import Control.Monad.IO.Control (MonadControlIO)-import Data.Function (on)-import Control.Arrow ((&&&))-import Data.Text (pack)--fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key v, v)-fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"-fromPersistValuesId (i:rest) =- case fromPersistValues rest of- Left e -> Left e- Right x -> Right (toPersistKey i, x)--class RunJoin a where- runJoin :: MonadControlIO m => a -> SqlPersist m (J.Result a)--instance (PersistEntity one, PersistEntity many, Eq (Key one))- => RunJoin (SelectOneMany one many) where- runJoin = selectOneMany'--selectOneMany' :: (MonadControlIO m,- PersistEntity d,- PersistEntity val1,- PersistEntity val,- PersistEntity b,- Eq (Key b)) =>- SelectOneMany val val1 -> SqlPersist m [((Key b, b), [(Key d, d)])]-selectOneMany' (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do- conn <- SqlPersist ask- liftM go $ withStmt (sql conn) (getFiltsValues oneF ++ getFiltsValues manyF) $ loop id- where- go :: Eq a => [((a, b), Maybe (c, d))] -> [((a, b), [(c, d)])]- go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (fst . fst))- loop front popper = do- x <- popper- case x of- Nothing -> return $ front []- Just vals -> do- let (y, z) = splitAt oneCount vals- case (fromPersistValuesId y, fromPersistValuesId z) of- (Right y', Right z') -> loop (front . (:) (y', Just z')) popper- (Left e, _) -> error $ "selectOneMany: " ++ e- (Right y', Left e) ->- case z of- PersistNull:_ -> loop (front . (:) (y', Nothing)) popper- _ -> error $ "selectOneMany: " ++ e- oneCount = 1 + length (tableColumns $ entityDef one)- one = dummyFromFilts oneF- many = dummyFromFilts manyF- sql conn = pack $ concat- [ "SELECT "- , intercalate "," $ colsPlusId conn one ++ colsPlusId conn many- , " FROM "- , escapeName conn $ rawTableName $ entityDef one- , if isOuter then " LEFT JOIN " else " INNER JOIN "- , escapeName conn $ rawTableName $ entityDef many- , " ON "- , escapeName conn $ rawTableName $ entityDef one- , ".id = "- , escapeName conn $ rawTableName $ entityDef many- , "."- , escapeName conn $ RawName $ persistFilterToFieldName $ eq undefined- , if null filts- then ""- else " WHERE " ++ intercalate " AND " filts- , if null ords- then ""- else " ORDER BY " ++ intercalate ", " ords- ]- where- filts = map (filterClause True conn) oneF ++ map (filterClause True conn) manyF- ords = map (orderClause True conn) oneO ++ map (orderClause True conn) manyO--addTable :: PersistEntity val =>- Connection -> val -> [Char] -> [Char]-addTable conn e s = concat [escapeName conn $ rawTableName $ entityDef e, ".", s]--colsPlusId :: PersistEntity e => Connection -> e -> [String]-colsPlusId conn e =- map (addTable conn e) $- "id" : (map (\(x, _, _) -> escapeName conn x) cols)- where- cols = tableColumns $ entityDef e+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Database.Persist.Join.Sql + ( RunJoin (..) + ) where + +import Database.Persist.Join hiding (RunJoin (..)) +import qualified Database.Persist.Join as J +import Database.Persist.Base +import Control.Monad (liftM) +import Data.Maybe (mapMaybe) +import Data.List (intercalate, groupBy) +import Database.Persist.GenericSql (SqlPersist (SqlPersist)) +import Database.Persist.GenericSql.Internal hiding (withStmt) +import Database.Persist.GenericSql.Raw (withStmt) +import Control.Monad.Trans.Reader (ask) +import Control.Monad.IO.Control (MonadControlIO) +import Data.Function (on) +import Control.Arrow ((&&&)) +import Data.Text (pack) + +fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key v, v) +fromPersistValuesId [] = Left "fromPersistValuesId: No values provided" +fromPersistValuesId (i:rest) = + case fromPersistValues rest of + Left e -> Left e + Right x -> Right (toPersistKey i, x) + +class RunJoin a where + runJoin :: MonadControlIO m => a -> SqlPersist m (J.Result a) + +instance (PersistEntity one, PersistEntity many, Eq (Key one)) + => RunJoin (SelectOneMany one many) where + runJoin = selectOneMany' + +selectOneMany' :: (MonadControlIO m, + PersistEntity d, + PersistEntity val1, + PersistEntity val, + PersistEntity b, + Eq (Key b)) => + SelectOneMany val val1 -> SqlPersist m [((Key b, b), [(Key d, d)])] +selectOneMany' (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do + conn <- SqlPersist ask + liftM go $ withStmt (sql conn) (getFiltsValues oneF ++ getFiltsValues manyF) $ loop id + where + go :: Eq a => [((a, b), Maybe (c, d))] -> [((a, b), [(c, d)])] + go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (fst . fst)) + loop front popper = do + x <- popper + case x of + Nothing -> return $ front [] + Just vals -> do + let (y, z) = splitAt oneCount vals + case (fromPersistValuesId y, fromPersistValuesId z) of + (Right y', Right z') -> loop (front . (:) (y', Just z')) popper + (Left e, _) -> error $ "selectOneMany: " ++ e + (Right y', Left e) -> + case z of + PersistNull:_ -> loop (front . (:) (y', Nothing)) popper + _ -> error $ "selectOneMany: " ++ e + oneCount = 1 + length (tableColumns $ entityDef one) + one = dummyFromFilts oneF + many = dummyFromFilts manyF + sql conn = pack $ concat + [ "SELECT " + , intercalate "," $ colsPlusId conn one ++ colsPlusId conn many + , " FROM " + , escapeName conn $ rawTableName $ entityDef one + , if isOuter then " LEFT JOIN " else " INNER JOIN " + , escapeName conn $ rawTableName $ entityDef many + , " ON " + , escapeName conn $ rawTableName $ entityDef one + , ".id = " + , escapeName conn $ rawTableName $ entityDef many + , "." + , escapeName conn $ RawName $ persistFilterToFieldName $ eq undefined + , if null filts + then "" + else " WHERE " ++ intercalate " AND " filts + , if null ords + then "" + else " ORDER BY " ++ intercalate ", " ords + ] + where + filts = map (filterClause True conn) oneF ++ map (filterClause True conn) manyF + ords = map (orderClause True conn) oneO ++ map (orderClause True conn) manyO + +addTable :: PersistEntity val => + Connection -> val -> [Char] -> [Char] +addTable conn e s = concat [escapeName conn $ rawTableName $ entityDef e, ".", s] + +colsPlusId :: PersistEntity e => Connection -> e -> [String] +colsPlusId conn e = + map (addTable conn e) $ + "id" : (map (\(x, _, _) -> escapeName conn x) cols) + where + cols = tableColumns $ entityDef e
Database/Persist/Quasi.hs view
@@ -1,84 +1,84 @@-module Database.Persist.Quasi- ( parse - ) where--import Database.Persist.Base-import Data.Char-import Data.Maybe (mapMaybe)-import Text.ParserCombinators.Parsec hiding (parse, token)-import qualified Text.ParserCombinators.Parsec as Parsec---- | Parses a quasi-quoted syntax into a list of entity definitions.-parse :: String -> [EntityDef]-parse = map parse' . nest . map words'- . removeLeadingSpaces- . map killCarriage- . lines--removeLeadingSpaces :: [String] -> [String]-removeLeadingSpaces x =- let y = filter (not . null) x- in if all isSpace (map head y)- then removeLeadingSpaces (map tail y)- else y--killCarriage :: String -> String-killCarriage "" = ""-killCarriage s- | last s == '\r' = init s- | otherwise = s--words' :: String -> (Bool, [String])-words' s = case Parsec.parse words'' s s of- Left e -> error $ show e- Right x -> x--words'' :: Parser (Bool, [String])-words'' = do- s <- fmap (not . null) $ many space- t <- many token- eof- return (s, takeWhile (/= "--") 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, entattribs, map snd x) : nest y-nest ((False, []):_) = error "Indented line must contain at least name"-nest ((True, _):_) = error "Blocks must begin with non-indented lines"-nest [] = []--parse' :: (String, [String], [[String]]) -> EntityDef-parse' (name, entattribs, attribs) =- EntityDef name entattribs cols uniqs derives- where- cols = concatMap takeCols attribs- uniqs = concatMap takeUniqs attribs- derives = case mapMaybe takeDerives attribs of- [] -> ["Show", "Read", "Eq"]- x -> concat x--takeCols :: [String] -> [(String, String, [String])]-takeCols ("deriving":_) = []-takeCols (n@(f:_):ty:rest)- | isLower f = [(n, ty, rest)]-takeCols _ = []--takeUniqs :: [String] -> [(String, [String])]-takeUniqs (n@(f:_):rest)- | isUpper f = [(n, rest)]-takeUniqs _ = []--takeDerives :: [String] -> Maybe [String]-takeDerives ("deriving":rest) = Just rest-takeDerives _ = Nothing+module Database.Persist.Quasi + ( parse + ) where + +import Database.Persist.Base +import Data.Char +import Data.Maybe (mapMaybe) +import Text.ParserCombinators.Parsec hiding (parse, token) +import qualified Text.ParserCombinators.Parsec as Parsec + +-- | Parses a quasi-quoted syntax into a list of entity definitions. +parse :: String -> [EntityDef] +parse = map parse' . nest . map words' + . removeLeadingSpaces + . map killCarriage + . lines + +removeLeadingSpaces :: [String] -> [String] +removeLeadingSpaces x = + let y = filter (not . null) x + in if all isSpace (map head y) + then removeLeadingSpaces (map tail y) + else y + +killCarriage :: String -> String +killCarriage "" = "" +killCarriage s + | last s == '\r' = init s + | otherwise = s + +words' :: String -> (Bool, [String]) +words' s = case Parsec.parse words'' s s of + Left e -> error $ show e + Right x -> x + +words'' :: Parser (Bool, [String]) +words'' = do + s <- fmap (not . null) $ many space + t <- many token + eof + return (s, takeWhile (/= "--") 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, entattribs, map snd x) : nest y +nest ((False, []):_) = error "Indented line must contain at least name" +nest ((True, _):_) = error "Blocks must begin with non-indented lines" +nest [] = [] + +parse' :: (String, [String], [[String]]) -> EntityDef +parse' (name, entattribs, attribs) = + EntityDef name entattribs cols uniqs derives + where + cols = concatMap takeCols attribs + uniqs = concatMap takeUniqs attribs + derives = case mapMaybe takeDerives attribs of + [] -> ["Show", "Read", "Eq"] + x -> concat x + +takeCols :: [String] -> [(String, String, [String])] +takeCols ("deriving":_) = [] +takeCols (n@(f:_):ty:rest) + | isLower f = [(n, ty, rest)] +takeCols _ = [] + +takeUniqs :: [String] -> [(String, [String])] +takeUniqs (n@(f:_):rest) + | isUpper f = [(n, rest)] +takeUniqs _ = [] + +takeDerives :: [String] -> Maybe [String] +takeDerives ("deriving":rest) = Just rest +takeDerives _ = Nothing
+ Database/Persist/TH/Library.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-} +#include "cabal_macros.h" +module Database.Persist.TH.Library + ( apE + ) where + +#if MIN_VERSION_base(4,3,0) +import Control.Applicative +#endif + +apE :: Either x (y -> z) -> Either x y -> Either x z + +#if MIN_VERSION_base(4,3,0) +apE = (<*>) +#else +apE (Left x) _ = Left x +apE _ (Left x) = Left x +apE (Right f) (Right y) = Right (f y) +#endif
Database/Persist/Util.hs view
@@ -1,17 +1,17 @@-module Database.Persist.Util- ( nullable- , deprecate- ) where--import System.IO.Unsafe (unsafePerformIO)--nullable :: [String] -> Bool-nullable s- | "Maybe" `elem` s = True- | "null" `elem` s = deprecate "Please replace null with Maybe" True- | otherwise = False--deprecate :: String -> a -> a-deprecate s x = unsafePerformIO $ do- putStrLn $ "DEPRECATED: " ++ s- return x+module Database.Persist.Util + ( nullable + , deprecate + ) where + +import System.IO.Unsafe (unsafePerformIO) + +nullable :: [String] -> Bool +nullable s + | "Maybe" `elem` s = True + | "null" `elem` s = deprecate "Please replace null with Maybe" True + | otherwise = False + +deprecate :: String -> a -> a +deprecate s x = unsafePerformIO $ do + putStrLn $ "DEPRECATED: " ++ s + return x
LICENSE view
@@ -1,25 +1,25 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2010, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
persistent.cabal view
@@ -1,71 +1,72 @@-name: persistent-version: 0.5.0-license: BSD3-license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Type-safe, non-relational, multi-backend persistence.-description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.-category: Database, Yesod-stability: Stable-cabal-version: >= 1.6-build-type: Simple-homepage: http://docs.yesodweb.com/book/persistent--library- if flag(test)- Buildable: False- build-depends: base >= 4 && < 5- , bytestring >= 0.9 && < 0.10- , transformers >= 0.2.1 && < 0.3- , time >= 1.1.4 && < 1.3- , text >= 0.8 && < 0.12- , containers >= 0.2 && < 0.5- , parsec >= 2.1 && < 4- , enumerator >= 0.4.9 && < 0.5- , monad-control >= 0.2 && < 0.3- , pool >= 0.1 && < 0.2- , blaze-html >= 0.4 && < 0.5- exposed-modules: Database.Persist- Database.Persist.Base- Database.Persist.Quasi- Database.Persist.GenericSql- Database.Persist.GenericSql.Internal- Database.Persist.GenericSql.Raw- Database.Persist.Util- Database.Persist.Join- Database.Persist.Join.Sql- ghc-options: -Wall--Flag test- Description: Build the runtests executables.- Default: False--Flag test-postgresql- Description: Build the runtests executable with Postgresql support.- Default: True--executable runtests- if flag(test)- Buildable: True- build-depends: haskell98,- HUnit,- test-framework,- test-framework-hunit,- base >= 4 && < 5,- template-haskell >= 2.4 && < 2.6,- HDBC-postgresql,- HDBC,- web-routes-quasi >= 0.7 && < 0.8- if flag(test-postgresql)- cpp-options: -DWITH_POSTGRESQL- else- Buildable: False- hs-source-dirs: ., packages/template, backends/sqlite, backends/postgresql- main-is: runtests.hs- ghc-options: -Wall- extra-libraries: sqlite3--source-repository head- type: git- location: git://github.com/snoyberg/persistent.git+name: persistent +version: 0.5.1 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman <michael@snoyman.com> +maintainer: Michael Snoyman <michael@snoyman.com> +synopsis: Type-safe, non-relational, multi-backend persistence. +description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful. +category: Database, Yesod +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://docs.yesodweb.com/book/persistent + +library + if flag(test) + Buildable: False + build-depends: base >= 4 && < 5 + , bytestring >= 0.9 && < 0.10 + , transformers >= 0.2.1 && < 0.3 + , time >= 1.1.4 && < 1.3 + , text >= 0.8 && < 0.12 + , containers >= 0.2 && < 0.5 + , parsec >= 2.1 && < 4 + , enumerator >= 0.4.9 && < 0.5 + , monad-control >= 0.2 && < 0.3 + , pool >= 0.1 && < 0.2 + , blaze-html >= 0.4 && < 0.5 + exposed-modules: Database.Persist + Database.Persist.Base + Database.Persist.Quasi + Database.Persist.GenericSql + Database.Persist.GenericSql.Internal + Database.Persist.GenericSql.Raw + Database.Persist.TH.Library + Database.Persist.Util + Database.Persist.Join + Database.Persist.Join.Sql + ghc-options: -Wall + +Flag test + Description: Build the runtests executables. + Default: False + +Flag test-postgresql + Description: Build the runtests executable with Postgresql support. + Default: True + +executable runtests + if flag(test) + Buildable: True + build-depends: haskell98, + HUnit, + test-framework, + test-framework-hunit, + base >= 4 && < 5, + template-haskell >= 2.4 && < 2.6, + HDBC-postgresql, + HDBC, + web-routes-quasi >= 0.7 && < 0.8 + if flag(test-postgresql) + cpp-options: -DWITH_POSTGRESQL + else + Buildable: False + hs-source-dirs: ., packages/template, backends/sqlite, backends/postgresql + main-is: runtests.hs + ghc-options: -Wall + extra-libraries: sqlite3 + +source-repository head + type: git + location: git://github.com/snoyberg/persistent.git