diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -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 diff --git a/Database/Persist/Base.hs b/Database/Persist/Base.hs --- a/Database/Persist/Base.hs +++ b/Database/Persist/Base.hs @@ -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 diff --git a/Database/Persist/GenericSql.hs b/Database/Persist/GenericSql.hs --- a/Database/Persist/GenericSql.hs +++ b/Database/Persist/GenericSql.hs @@ -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 diff --git a/Database/Persist/GenericSql/Internal.hs b/Database/Persist/GenericSql/Internal.hs --- a/Database/Persist/GenericSql/Internal.hs +++ b/Database/Persist/GenericSql/Internal.hs @@ -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 diff --git a/Database/Persist/GenericSql/Raw.hs b/Database/Persist/GenericSql/Raw.hs --- a/Database/Persist/GenericSql/Raw.hs +++ b/Database/Persist/GenericSql/Raw.hs @@ -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 diff --git a/Database/Persist/Join.hs b/Database/Persist/Join.hs --- a/Database/Persist/Join.hs +++ b/Database/Persist/Join.hs @@ -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 []) diff --git a/Database/Persist/Join/Sql.hs b/Database/Persist/Join/Sql.hs --- a/Database/Persist/Join/Sql.hs +++ b/Database/Persist/Join/Sql.hs @@ -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 diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -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 diff --git a/Database/Persist/TH/Library.hs b/Database/Persist/TH/Library.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/TH/Library.hs @@ -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 diff --git a/Database/Persist/Util.hs b/Database/Persist/Util.hs --- a/Database/Persist/Util.hs +++ b/Database/Persist/Util.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,71 +1,72 @@ -name: persistent -version: 0.5.0 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -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 +maintainer: Michael Snoyman +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