persistent 1.2.3.1 → 1.2.3.2
raw patch · 19 files changed
+313/−794 lines, 19 filesdep ~monad-logger
Dependency ranges changed: monad-logger
Files
- Database/Persist.hs +94/−0
- Database/Persist/Class.hs +5/−30
- Database/Persist/Class/DeleteCascade.hs +0/−9
- Database/Persist/Class/PersistEntity.hs +45/−152
- Database/Persist/Class/PersistField.hs +24/−37
- Database/Persist/Class/PersistQuery.hs +0/−17
- Database/Persist/Class/PersistStore.hs +2/−37
- Database/Persist/Class/PersistUnique.hs +20/−84
- Database/Persist/Quasi.hs +12/−98
- Database/Persist/Sql.hs +1/−2
- Database/Persist/Sql/Class.hs +1/−8
- Database/Persist/Sql/Internal.hs +2/−9
- Database/Persist/Sql/Orphan/PersistQuery.hs +81/−170
- Database/Persist/Sql/Orphan/PersistStore.hs +14/−40
- Database/Persist/Sql/Orphan/PersistUnique.hs +3/−9
- Database/Persist/Sql/Run.hs +1/−1
- Database/Persist/Sql/Types.hs +1/−4
- Database/Persist/Types/Base.hs +6/−86
- persistent.cabal +1/−1
Database/Persist.hs view
@@ -5,6 +5,18 @@ ( module Database.Persist.Class , module Database.Persist.Types + -- * Store functions+ , insertBy+ , getJust+ , belongsTo+ , belongsToJust+ , getByValue++ -- * Query functions+ , selectList+ , selectKeysList+ , deleteCascadeWhere+ -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.)@@ -24,11 +36,75 @@ import Database.Persist.Class import Database.Persist.Class.PersistField (getPersistMap) import qualified Data.Text as T+import qualified Control.Exception as E+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Aeson (toJSON) import Data.Aeson.Encode (fromValue) +-- | Insert a value, checking for conflicts with any unique constraints. If a+-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the+-- new 'Key is returned as 'Right'.+insertBy :: (PersistEntity v, PersistStore m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v)+ => v -> m (Either (Entity 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, PersistUnique m, PersistEntityBackend v ~ PersistMonadBackend m)+ => v -> m (Maybe (Entity 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++-- | curry this to make a convenience function that loads an associated model+-- > foreign = belongsTo foeignId+belongsTo ::+ (PersistStore m+ , PersistEntity ent1+ , PersistEntity ent2+ , PersistMonadBackend m ~ PersistEntityBackend ent2+ ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)+belongsTo foreignKeyField model = case foreignKeyField model of+ Nothing -> return Nothing+ Just f -> get f++-- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe+belongsToJust ::+ (PersistStore m+ , PersistEntity ent1+ , PersistEntity ent2+ , PersistMonadBackend m ~ PersistEntityBackend ent2)+ => (ent1 -> Key ent2) -> ent1 -> m ent2+belongsToJust getForeignKey model = getJust $ getForeignKey model++-- | Same as get, but for a non-null (not Maybe) foreign key+-- Unsafe unless your database is enforcing that the foreign key is valid+getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val+getJust key = get key >>= maybe+ (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key)+ return+ infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v -- | assign a field a value@@ -63,6 +139,24 @@ (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | the OR of two lists of filters a ||. b = [FilterOr [FilterAnd a, FilterAnd b]]++-- | Call 'selectSource' but return the result as a list.+selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+ => [Filter val]+ -> [SelectOpt val]+ -> m [Entity val]+selectList a b = selectSource a b C.$$ CL.consume++-- | Call 'selectKeys' but return the result as a list.+selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)+ => [Filter val]+ -> [SelectOpt val]+ -> m [Key val]+selectKeysList a b = selectKeys a b C.$$ CL.consume++deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)+ => [Filter a] -> m ()+deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade listToJSON :: [PersistValue] -> T.Text listToJSON = toStrict . toLazyText . fromValue . toJSON
Database/Persist/Class.hs view
@@ -1,36 +1,11 @@ module Database.Persist.Class- (- -- * PersistStore- PersistStore (..)- , getJust- , belongsTo- , belongsToJust-- -- * PersistUnique- , PersistUnique (..)- , getByValue- , insertBy- , replaceUnique-- -- * PersistQuery- , PersistQuery (..)- , selectList- , selectKeysList-- -- * DeleteCascade- , DeleteCascade (..)- , deleteCascadeWhere-- -- * PersistEntity+ ( DeleteCascade (..) , PersistEntity (..)- -- * PersistField- , PersistField (..)- -- * PersistConfig+ , PersistQuery (..)+ , PersistUnique (..) , PersistConfig (..)-- -- * JSON utilities- , keyValueEntityToJSON, keyValueEntityFromJSON- , entityIdToJSON, entityIdFromJSON+ , PersistField (..)+ , PersistStore (..) ) where import Database.Persist.Class.DeleteCascade
Database/Persist/Class/DeleteCascade.hs view
@@ -2,19 +2,10 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.DeleteCascade ( DeleteCascade (..)- , deleteCascadeWhere ) where import Database.Persist.Class.PersistStore-import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistEntity -import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL- class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where deleteCascade :: Key a -> m ()--deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m)- => [Filter a] -> m ()-deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade
Database/Persist/Class/PersistEntity.hs view
@@ -10,109 +10,74 @@ , Filter (..) , Key , Entity (..)-- , keyValueEntityToJSON, keyValueEntityFromJSON- , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Data.Text (Text)-import qualified Data.Text as T import Data.Aeson (ToJSON (..), FromJSON (..), object, (.:), (.=), Value (Object))-import Data.Aeson.Types (Parser) import Control.Applicative ((<$>), (<*>))-import Data.Monoid (mappend)-import qualified Data.HashMap.Strict as HM --- | Persistent serialized Haskell records to the database.--- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)--- corresponds to a 'Key' plus a Haskell record.------ For every Haskell record type stored in the database there is a corresponding 'PersistEntity' instance.--- An instance of PersistEntity contains meta-data for the record.--- PersistEntity also helps abstract over different record types.--- That way the same query interface can return a 'PersistEntity', with each query returning different types of Haskell records.------ Some advanced type system capabilities are used to make this process type-safe.--- Persistent users usually don't need to understand the class associated data and functions.-class PersistEntity record where- -- | An 'EntityField' is parameterised by the Haskell record it belongs to- -- and the additional type of that field- data EntityField record :: * -> *-- -- | return meta-data for a given 'EntityField'- persistFieldDef :: EntityField record typ -> FieldDef SqlType-- -- | Persistent allows multiple different backends- type PersistEntityBackend record-- -- | Unique keys besided the Key- data Unique record+-- | A single database entity. For example, if writing a blog application, a+-- blog entry would be an entry, containing fields such as title and content.+class PersistEntity val where+ -- | Parameters: val and datatype of the field+ data EntityField val :: * -> *+ persistFieldDef :: EntityField val typ -> FieldDef SqlType - -- | retrieve the EntityDef meta-data for the record- entityDef :: Monad m => m record -> EntityDef SqlType+ type PersistEntityBackend val - -- | Get the database fields of a record- toPersistFields :: record -> [SomePersistField]+ -- | Unique keys in existence on this entity.+ data Unique val - -- | Convert from database values to a Haskell record- fromPersistValues :: [PersistValue] -> Either Text record+ entityDef :: Monad m => m val -> EntityDef SqlType+ toPersistFields :: val -> [SomePersistField]+ fromPersistValues :: [PersistValue] -> Either Text val - persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)]- persistUniqueToValues :: Unique record -> [PersistValue]- persistUniqueKeys :: record -> [Unique record]+ persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)]+ persistUniqueToValues :: Unique val -> [PersistValue]+ persistUniqueKeys :: val -> [Unique val] - persistIdField :: EntityField record (Key record)+ persistIdField :: EntityField val (Key val) - fieldLens :: EntityField record field- -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))+ fieldLens :: EntityField val field+ -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val)) --- | updataing a database entity------ Persistent users use combinators to create these-data Update record = forall typ. PersistField typ => Update- { updateField :: EntityField record typ+data Update v = forall typ. PersistField typ => Update+ { updateField :: EntityField v typ , updateValue :: typ- -- FIXME Replace with expr down the road- , updateUpdate :: PersistUpdate+ , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road } --- | query options------ Persistent users use these directly-data SelectOpt record = forall typ. Asc (EntityField record typ)- | forall typ. Desc (EntityField record typ)- | OffsetBy Int- | LimitTo Int+data SelectOpt v = forall typ. Asc (EntityField v typ)+ | forall typ. Desc (EntityField v typ)+ | OffsetBy Int+ | LimitTo Int -type family BackendSpecificFilter backend record+type family BackendSpecificFilter b v -- | 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.------ Persistent users use combinators to create these-data Filter record = forall typ. PersistField typ => Filter- { filterField :: EntityField record typ+data Filter v = forall typ. PersistField typ => Filter+ { filterField :: EntityField v typ , filterValue :: Either typ [typ] -- FIXME , filterFilter :: PersistFilter -- FIXME }- | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API- | FilterOr [Filter record]- | BackendFilter- (BackendSpecificFilter (PersistEntityBackend record) record)+ | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API+ | FilterOr [Filter v]+ | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v) -- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@. -- -- Since 1.1.0-type Key record = KeyBackend (PersistEntityBackend record) record+type Key val = KeyBackend (PersistEntityBackend val) val --- | Datatype that represents an entity, with both its 'Key' and--- its Haskell record representation.+-- | Datatype that represents an entity, with both its key and+-- its Haskell representation. ----- When using a SQL-based backend (such as SQLite or+-- When using the an SQL-based backend (such as SQLite or -- PostgreSQL), an 'Entity' may take any number of columns -- depending on how many fields it has. In order to reconstruct -- your entity on the Haskell side, @persistent@ needs all of@@ -144,85 +109,13 @@ , entityVal :: entity } deriving (Eq, Ord, Show, Read) --- | Predefined @toJSON@. The resulting JSON looks like--- @{\"key\": 1, \"value\": {\"name\": ...}}@.------ The typical usage is:------ @--- instance ToJSON User where--- toJSON = keyValueEntityToJSON--- @-keyValueEntityToJSON :: ToJSON e => Entity e -> Value-keyValueEntityToJSON (Entity key value) = object- [ "key" .= key- , "value" .= value- ]---- | Predefined @parseJSON@. The input JSON looks like--- @{\"key\": 1, \"value\": {\"name\": ...}}@.------ The typical usage is:------ @--- instance FromJSON User where--- parseJSON = keyValueEntityFromJSON--- @-keyValueEntityFromJSON :: FromJSON e => Value -> Parser (Entity e)-keyValueEntityFromJSON (Object o) = Entity- <$> o .: "key"- <*> o .: "value"-keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object"---- | Predefined @toJSON@. The resulting JSON looks like--- @{\"id\": 1, \"name\": ...}@.------ The typical usage is:------ @--- instance ToJSON User where--- toJSON = entityIdToJSON--- @-entityIdToJSON :: ToJSON e => Entity e -> Value-entityIdToJSON (Entity key value) = case toJSON value of- Object o -> Object $ HM.insert "id" (toJSON key) o- x -> x---- | Predefined @parseJSON@. The input JSON looks like--- @{\"id\": 1, \"name\": ...}@.------ The typical usage is:------ @--- instance FromJSON User where--- parseJSON = entityIdFromJSON--- @-entityIdFromJSON :: FromJSON e => Value -> Parser (Entity e)-entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value-entityIdFromJSON _ = fail "entityIdFromJSON: not an object"--instance PersistField entity => PersistField (Entity entity) where- toPersistValue (Entity key value) = case toPersistValue value of- (PersistMap alist) -> PersistMap ((idField, toPersistValue key) : alist)- _ -> error $ T.unpack $ errMsg "expected PersistMap"-- fromPersistValue (PersistMap alist) = case after of- [] -> Left $ errMsg $ "did not find " `mappend` idField `mappend` " field"- ("_id", k):afterRest ->- case fromPersistValue (PersistMap (before ++ afterRest)) of- Right record -> Right $ Entity (Key k) record- Left err -> Left err- _ -> Left $ errMsg $ "impossible id field: " `mappend` T.pack (show alist)- where- (before, after) = break ((== idField) . fst) alist-- fromPersistValue x = Left $- errMsg "Expected PersistMap, received: " `mappend` T.pack (show x)--errMsg :: Text -> Text-errMsg = mappend "PersistField entity fromPersistValue: "---- | Realistically this is only going to be used for MongoDB,--- so lets use MongoDB conventions-idField :: Text-idField = "_id"+instance ToJSON e => ToJSON (Entity e) where+ toJSON (Entity k v) = object+ [ "key" .= k+ , "value" .= v+ ]+instance FromJSON e => FromJSON (Entity e) where+ parseJSON (Object o) = Entity+ <$> o .: "key"+ <*> o .: "value"+ parseJSON _ = fail "FromJSON Entity: not an object"
Database/Persist/Class/PersistField.hs view
@@ -20,12 +20,11 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif import Data.Time.LocalTime (ZonedTime)-import Data.ByteString.Char8 (ByteString, unpack, readInt)+import Data.ByteString.Char8 (ByteString, unpack) import Control.Applicative import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word, Word8, Word16, Word32, Word64) import Data.Text (Text)-import Data.Text.Read (double) import Data.Fixed import Data.Monoid ((<>)) @@ -70,7 +69,6 @@ fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String"- fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif @@ -93,33 +91,28 @@ instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle- fromPersistValue x = Left $ T.pack $ "int Expected Integer, received: " ++ show x+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle- fromPersistValue x = Left $ T.pack $ "int8 Expected Integer, received: " ++ show x+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle- fromPersistValue x = Left $ T.pack $ "int16 Expected Integer, received: " ++ show x+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle- fromPersistValue x = Left $ T.pack $ "int32 Expected Integer, received: " ++ show x+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int64 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle- fromPersistValue x = Left $ T.pack $ "int64 Expected Integer, received: " ++ show x+ fromPersistValue (PersistInt64 i) = Right $ fromIntegral i+ fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Word where toPersistValue = PersistInt64 . fromIntegral@@ -160,7 +153,7 @@ _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "PersistField Fixed:Expected Rational, received: " <> T.pack (show x)+ fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x) instance PersistField Rational where toPersistValue = PersistRational@@ -170,20 +163,12 @@ [(a, "")] -> Right $ toRational (a :: Pico) _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue (PersistByteString bs) = case double $ T.cons '0' $ T.decodeUtf8With T.lenientDecode bs of - Right (ret,"") -> Right $ toRational ret- Right (a,b) -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show (a,b))- Left xs -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show xs)- fromPersistValue x = Left $ "PersistField Rational:Expected Rational, received: " <> T.pack (show x)+ fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x) instance PersistField Bool where toPersistValue = PersistBool fromPersistValue (PersistBool b) = Right b fromPersistValue (PersistInt64 i) = Right $ i /= 0- fromPersistValue (PersistByteString i) = case readInt i of - Just (0,"") -> Right False- Just (1,"") -> Right True- xs -> error $ "PersistField Bool failed parsing PersistByteString xs["++show xs++"] i["++show i++"]" fromPersistValue x = Left $ T.pack $ "Expected Bool, received: " ++ show x instance PersistField Day where@@ -295,15 +280,17 @@ fromPersistMap :: PersistField v => [(T.Text, PersistValue)] -> Either T.Text (M.Map T.Text v)-fromPersistMap = foldShortLeft fromPersistValue [] where- -- a fold that short-circuits on Left.- foldShortLeft f = go- where- go acc [] = Right $ M.fromList acc- go acc ((k, v):kvs) =- case f v of- Left e -> Left e- Right v' -> go ((k,v'):acc) kvs+fromPersistMap kvs =+ case (+ foldl (\eithAssocs (k,v) ->+ case (eithAssocs, fromPersistValue v) of+ (Left e, _) -> Left e+ (_, Left e) -> Left e+ (Right assocs, Right v') -> Right ((k,v'):assocs)+ ) (Right []) kvs+ ) of+ Right vs -> Right $ M.fromList vs+ Left e -> Left e getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)] getPersistMap (PersistMap kvs) = Right kvs
Database/Persist/Class/PersistQuery.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery ( PersistQuery (..)- , selectList- , selectKeysList ) where import Control.Exception (throwIO)@@ -85,21 +83,6 @@ -- | The total number of records fulfilling the given criterion. count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> m Int---- | Call 'selectSource' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)- => [Filter val]- -> [SelectOpt val]- -> m [Entity val]-selectList a b = selectSource a b C.$$ CL.consume---- | Call 'selectKeys' but return the result as a list.-selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m)- => [Filter val]- -> [SelectOpt val]- -> m [Key val]-selectKeysList a b = selectKeys a b C.$$ CL.consume- #define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count } #define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T)
Database/Persist/Class/PersistStore.hs view
@@ -1,22 +1,16 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistStore ( PersistStore (..)- , getJust- , belongsTo- , belongsToJust ) where import qualified Prelude import Prelude hiding ((++), show) -import qualified Data.Text as T- import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (MonadIO) import Data.Monoid (Monoid)-import Control.Exception.Lifted (throwIO) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT)@@ -36,7 +30,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Database.Persist.Class.PersistEntity-import Database.Persist.Types class MonadIO m => PersistStore m where type PersistMonadBackend m@@ -83,34 +76,6 @@ -- not exist. delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> m ()---- | Same as get, but for a non-null (not Maybe) foreign key--- Unsafe unless your database is enforcing that the foreign key is valid-getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val-getJust key = get key >>= maybe- (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key)- return---- | curry this to make a convenience function that loads an associated model--- > foreign = belongsTo foeignId-belongsTo ::- (PersistStore m- , PersistEntity ent1- , PersistEntity ent2- , PersistMonadBackend m ~ PersistEntityBackend ent2- ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2)-belongsTo foreignKeyField model = case foreignKeyField model of- Nothing -> return Nothing- Just f -> get f---- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe-belongsToJust ::- (PersistStore m- , PersistEntity ent1- , PersistEntity ent2- , PersistMonadBackend m ~ PersistEntityBackend ent2)- => (ent1 -> Key ent2) -> ent1 -> m ent2-belongsToJust getForeignKey model = getJust $ getForeignKey model #define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get } #define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T)
Database/Persist/Class/PersistUnique.hs view
@@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistUnique ( PersistUnique (..)- , getByValue- , insertBy- , replaceUnique- , checkUnique ) where import qualified Prelude@@ -15,7 +11,6 @@ import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid)-import Data.List ((\\)) import Data.Conduit.Internal (Pipe) import Control.Monad.Logger (LoggingT)@@ -40,14 +35,7 @@ -- -- Please read the general Persistent documentation to learn how to create -- Unique keys.--- SQL backends automatically create uniqueness constraints, but for MongoDB you must manually place a unique index on the field.------ Some functions in this module (insertUnique, insertBy, and replaceUnique) first query the unique indexes to check for conflicts.--- You could instead optimistically attempt to perform the operation (e.g. replace instead of replaceUnique). However,------ * there is some fragility to trying to catch the correct exception and determing the column of failure.------ * an exception will automatically abort the current SQL transaction+-- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field. class PersistStore m => PersistUnique m where -- | Get a record by unique key, if available. Returns also the identifier. getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val))@@ -60,76 +48,8 @@ -- couldn't be inserted because of a uniqueness constraint. insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val)) insertUnique datum = do- conflict <- checkUnique datum- case conflict of- Nothing -> Just `liftM` insert datum- Just _ -> return Nothing---- | 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 val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m)- => val -> m (Either (Entity val) (Key val))--insertBy val = do- res <- getByValue val- case res of- Nothing -> Right `liftM` insert val- 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 value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m)- => value -> m (Maybe (Entity value))-getByValue = checkUniques . persistUniqueKeys- where- checkUniques [] = return Nothing- checkUniques (x:xs) = do- y <- getBy x- case y of- Nothing -> checkUniques xs- Just z -> return $ Just z----- | Attempt to replace the record of the given key with the given new record.--- First query the unique fields to make sure the replacement maintains uniqueness constraints.--- Return 'Nothing' if the replacement was made.--- If uniqueness is violated, return a 'Just' with the 'Unique' violation------ Since 1.2.2.0-replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m)- => Key record -> record -> m (Maybe (Unique record))-replaceUnique key datumNew = getJust key >>= replaceOriginal- where- uniqueKeysNew = persistUniqueKeys datumNew- replaceOriginal original = do- conflict <- checkUniqueKeys changedKeys- case conflict of- Nothing -> replace key datumNew >> return Nothing- (Just conflictingKey) -> return $ Just conflictingKey- where- changedKeys = uniqueKeysNew \\ uniqueKeysOriginal- uniqueKeysOriginal = persistUniqueKeys original---- | Check whether there are any conflicts for unique keys with this entity and--- existing entities in the database.------ Returns 'Nothing' if the entity would be unique, and could thus safely be inserted.--- on a conflict returns the conflicting key-checkUnique :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m)- => record -> m (Maybe (Unique record))-checkUnique = checkUniqueKeys . persistUniqueKeys--checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m)- => [Unique record] -> m (Maybe (Unique record))-checkUniqueKeys [] = return Nothing-checkUniqueKeys (x:xs) = do- y <- getBy x- case y of- Nothing -> checkUniqueKeys xs- Just _ -> return (Just x)+ isUnique <- checkUnique datum+ if isUnique then Just `liftM` insert datum else return Nothing #define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique } #define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T)@@ -154,3 +74,19 @@ #undef DEF #undef GO #undef GOX++-- | 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 :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique 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
Database/Persist/Quasi.hs view
@@ -18,13 +18,12 @@ import Prelude hiding (lines) import Database.Persist.Types import Data.Char-import Data.Maybe (mapMaybe, fromMaybe, maybeToList)+import Data.Maybe (mapMaybe, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&)) import qualified Data.Map as M-import Data.List (foldl',find)-import Data.Monoid (mappend)+import Data.List (foldl') data ParseState a = PSDone | PSFail | PSSuccess a Text @@ -180,36 +179,14 @@ -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> [Line] -> [EntityDef ()] parseLines ps lines =- fixForeignKeysAll $ toEnts lines+ toEnts lines where toEnts (Line indent (name:entattribs) : rest) = let (x, y) = span ((> indent) . lineIndent) rest- in mkEntityDef ps name entattribs x : toEnts y+ in mkEntityDef ps name entattribs x : toEnts y toEnts (Line _ []:rest) = toEnts rest toEnts [] = [] -fixForeignKeysAll :: [EntityDef ()] -> [EntityDef ()]-fixForeignKeysAll ents = map fixForeignKeys ents- where fixForeignKeys :: EntityDef () -> EntityDef ()- fixForeignKeys ent = ent { entityForeigns = map (fixForeignKey ent) (entityForeigns ent) }- -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns- chktypes :: [FieldDef ()] -> HaskellName -> [FieldDef ()] -> HaskellName -> Bool- chktypes fflds fkey pflds pkey = case (filter ((== fkey) . fieldHaskell) fflds, filter ((== pkey) . fieldHaskell) pflds) of- ([ffld],[pfld]) -> fieldType ffld == fieldType pfld- xs -> error $ "unexpected result "++ show xs- fixForeignKey :: EntityDef () -> ForeignDef -> ForeignDef- fixForeignKey fent fdef = - case find ((== foreignRefTableHaskell fdef) . entityHaskell) ents of- Just pent -> case entityPrimary pent of- Just pdef -> if length (foreignFields fdef) == length (primaryFields pdef) - then fdef { foreignFields = zipWith (\(a,b,_,_) (a',b') -> - if chktypes (entityFields fent) a (entityFields pent) a' - then (a,b,a',b') - else error ("type mismatch between foreign key and primary column" ++ show (a,a') ++ " primary ent="++show pent ++ " foreign ent="++show fent)) (foreignFields fdef) (primaryFields pdef) }- else error $ "found " ++ show (length (foreignFields fdef)) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef - Nothing -> error $ "no explicit primary key fdef="++show fdef++ " fent="++show fent- Nothing -> error $ "could not find table " ++ show (foreignRefTableHaskell fdef) ++ " fdef=" ++ show fdef ++ " allnames=" ++ show (map (unHaskellName . entityHaskell) ents) ++ "\n\nents=" ++ show ents- -- | Construct an entity definition. mkEntityDef :: PersistSettings -> Text -- ^ name@@ -221,7 +198,7 @@ (HaskellName name') (DBName $ getDbName ps name' entattribs) (DBName $ idName entattribs)- entattribs cols primary uniqs foreigns derives+ entattribs cols uniqs derives extras isSum where@@ -235,17 +212,7 @@ case T.stripPrefix "id=" t of Nothing -> idName ts Just s -> s- - (primarys, uniqs, foreigns) = foldl' (\(a,b,c) attr -> - let (a',b',c') = takeConstraint ps name' cols attr - squish xs m = xs `mappend` maybeToList m- in (squish a a', squish b b', squish c c')) ([],[],[]) attribs- - primary = case primarys of - [] -> Nothing - [p] -> Just p- _ -> error $ "found more than one primary key in table[" ++ show name' ++ "]"- + uniqs = mapMaybe (takeUniqs ps cols) attribs derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef ()]@@ -291,45 +258,15 @@ Nothing -> getDbName ps n as Just s -> s -takeConstraint :: PersistSettings- -> Text- -> [FieldDef a]- -> [Text]- -> (Maybe PrimaryDef, Maybe UniqueDef, Maybe ForeignDef)-takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' - where takeConstraint' - | n == "Primary" = (Just $ takePrimary defs rest, Nothing, Nothing)- | n == "Unique" = (Nothing, Just $ takeUniq ps tableName defs rest, Nothing)- | n == "Foreign" = (Nothing, Nothing, Just $ takeForeign ps tableName defs rest)- | otherwise = (Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint-takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing)- -takePrimary :: [FieldDef a]- -> [Text]- -> PrimaryDef-takePrimary defs pkcols- = PrimaryDef- (map (HaskellName &&& getDBName defs) pkcols)- attrs- where- (_, attrs) = break ("!" `T.isPrefixOf`) pkcols- getDBName [] t = error $ "Unknown column in primary key constraint: " ++ show t- getDBName (d:ds) t- | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t- | fieldHaskell d == HaskellName t = fieldDB d- | otherwise = getDBName ds t---- Unique UppercaseConstraintName list of lowercasefields -takeUniq :: PersistSettings- -> Text+takeUniqs :: PersistSettings -> [FieldDef a] -> [Text]- -> UniqueDef-takeUniq ps tableName defs (n:rest)+ -> Maybe UniqueDef+takeUniqs ps defs (n:rest) | not (T.null n) && isUpper (T.head n)- = UniqueDef+ = Just $ UniqueDef (HaskellName n)- (DBName $ psToDBName ps (tableName `T.append` n))+ (DBName $ psToDBName ps n) (map (HaskellName &&& getDBName defs) fields) attrs where@@ -338,30 +275,7 @@ getDBName (d:ds) t | fieldHaskell d == HaskellName t = fieldDB d | otherwise = getDBName ds t-takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs--takeForeign :: PersistSettings- -> Text- -> [FieldDef a]- -> [Text]- -> ForeignDef-takeForeign ps tableName defs (refTableName:n:rest)- | not (T.null n) && isLower (T.head n)- = ForeignDef- (HaskellName refTableName)- (DBName $ psToDBName ps refTableName)- (HaskellName n)- (DBName $ psToDBName ps (tableName `T.append` n))- (map (\f -> (HaskellName f, getDBName defs f, HaskellName "", DBName "")) fields)- attrs- where- (fields,attrs) = break ("!" `T.isPrefixOf`) rest- getDBName [] t = error $ "Unknown column in foreign key constraint: " ++ show t- getDBName (d:ds) t- | nullable (fieldAttrs d) /= NotNullable = error $ "foreign key column cannot be nullable: " ++ show t- | fieldHaskell d == HaskellName t = fieldDB d- | otherwise = getDBName ds t-takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs+takeUniqs _ _ _ = Nothing takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest
Database/Persist/Sql.hs view
@@ -15,7 +15,6 @@ , getStmtConn -- * Internal , module Database.Persist.Sql.Internal- , decorateSQLWithLimitOffset ) where import Database.Persist@@ -26,7 +25,7 @@ import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal -import Database.Persist.Sql.Orphan.PersistQuery +import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore () import Database.Persist.Sql.Orphan.PersistUnique () import Control.Monad.IO.Class
Database/Persist/Sql/Class.hs view
@@ -311,11 +311,4 @@ n = 0 _mn = return n `asTypeOf` a instance PersistFieldSql Rational where- sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC---- perhaps a SQL user can figure this sqlType out?--- It is really intended for MongoDB though.-instance PersistField entity => PersistFieldSql (Entity entity) where- sqlType _ = SqlOther "embedded entity, hard to type"-instance PersistFieldSql (KeyBackend SqlBackend a) where- sqlType _ = SqlInt64+ sqlType _ = SqlNumeric 22 12 -- FIXME: Ambigous, 12 is from Pico which is used to convert Rational to number string
Database/Persist/Sql/Internal.hs view
@@ -3,7 +3,6 @@ -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns- , convertKey ) where import Database.Persist.Types@@ -16,9 +15,9 @@ import Database.Persist.Sql.Types -- | Create the list of columns for the given entity.-mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef], [ForeignDef])+mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef]) mkColumns allDefs t =- (cols, entityUniques t, entityForeigns t)+ (cols, entityUniques t) where cols :: [Column] cols = map go (entityFields t)@@ -36,7 +35,6 @@ SqlOther (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)) (def $ fieldAttrs fd)- Nothing (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) @@ -79,8 +77,3 @@ resolveTableName (e:es) hn | entityHaskell e == hn = entityDB e | otherwise = resolveTableName es hn--convertKey :: Bool -> KeyBackend t t1 -> [PersistValue]-convertKey True (Key (PersistList fks)) = fks-convertKey False (Key ret@(PersistInt64 _)) = [ret]-convertKey composite k = error $ "invalid key type " ++ show k ++ " composite=" ++ show composite
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -4,7 +4,6 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount- , decorateSQLWithLimitOffset ) where import Database.Persist@@ -12,7 +11,6 @@ import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore ()-import Database.Persist.Sql.Internal (convertKey) import qualified Data.Text as T import Data.Text (Text) import Data.Monoid (Monoid (..), (<>))@@ -23,9 +21,6 @@ import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit-import Data.ByteString.Char8 (readInteger)-import Data.Maybe (isJust)-import Data.List (transpose, inits, find) -- orphaned instance for convenience of modularity instance (MonadResource m, MonadLogger m) => PersistQuery (SqlPersistT m) where@@ -38,20 +33,17 @@ go'' n Multiply = T.concat [n, "=", n, "*?"] go'' n Divide = T.concat [n, "=", n, "/?"] let go' (x, pu) = go'' (connEscapeName conn x) pu- let composite = isJust $ entityPrimary t- let wher = case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?" let sql = T.concat [ "UPDATE " , connEscapeName conn $ entityDB t , " SET " , T.intercalate "," $ map (go' . go) upds , " WHERE "- , wher+ , connEscapeName conn $ entityID t+ , "=?" ] rawExecute sql $- map updatePersistValue upds `mappend` (convertKey composite k)+ map updatePersistValue upds `mappend` [unKey k] where t = entityDef $ dummyFromKey k go x = (fieldDB $ updateFieldDef x, updateUpdate x)@@ -67,15 +59,8 @@ , wher ] rawQuery sql (getFiltsValues conn filts) $$ do- mm <- CL.head- case mm of- Just [PersistInt64 i] -> return $ fromIntegral i- Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle- Just [PersistByteString i] -> case readInteger i of -- gb mssql - Just (ret,"") -> return $ fromIntegral ret- xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"- Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]"- Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]"+ Just [PersistInt64 i] <- CL.head+ return $ fromIntegral i where t = entityDef $ dummyFromFilts filts @@ -83,38 +68,19 @@ conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where- composite = isJust $ entityPrimary t (limit, offset, orders) = limitOffsetOrder opts parse vals =- case entityPrimary t of- Just pdef -> - let pks = map fst $ primaryFields pdef- keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) vals- in case fromPersistValuesComposite' keyvals vals of- Left s -> liftIO $ throwIO $ PersistMarshalError s- Right row -> return row- Nothing -> - case fromPersistValues' vals of- Left s -> liftIO $ throwIO $ PersistMarshalError s- Right row -> return row+ case fromPersistValues' vals of+ Left s -> liftIO $ throwIO $ PersistMarshalError s+ Right row -> return row t = entityDef $ dummyFromFilts filts- fromPersistValues' (PersistInt64 x:xs) = + fromPersistValues' (PersistInt64 x:xs) = do case fromPersistValues xs of Left e -> Left e Right xs' -> Right (Entity (Key $ PersistInt64 x) xs')- fromPersistValues' (PersistDouble x:xs) = -- oracle returns Double - case fromPersistValues xs of- Left e -> Left e- Right xs' -> Right (Entity (Key $ PersistInt64 (truncate x)) xs') -- convert back to int64- fromPersistValues' xs = Left $ T.pack ("error in fromPersistValues' xs=" ++ show xs)-- fromPersistValuesComposite' keyvals xs =- case fromPersistValues xs of- Left e -> Left e- Right xs' -> Right (Entity (Key $ PersistList keyvals) xs')-+ fromPersistValues' _ = Left "error in fromPersistValues'" wher conn = if null filts then "" else filterClause False conn filts@@ -122,37 +88,46 @@ case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords+ lim conn = case (limit, offset) of+ (0, 0) -> ""+ (0, _) -> T.cons ' ' $ connNoLimit conn+ (_, _) -> " LIMIT " <> T.pack (show limit)+ off = if offset == 0+ then ""+ else " OFFSET " <> T.pack (show offset) cols conn = T.intercalate ","- $ ((if composite then [] else [connEscapeName conn $ entityID t]) - <> map (connEscapeName conn . fieldDB) (entityFields t))- sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat+ $ (connEscapeName conn $ entityID t)+ : map (connEscapeName conn . fieldDB) (entityFields t)+ sql conn = mconcat [ "SELECT " , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn+ , lim conn+ , off ] selectKeys filts opts = do conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where+ parse [PersistInt64 i] = return $ Key $ PersistInt64 i+ parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " <> T.pack (show y) t = entityDef $ dummyFromFilts filts- cols conn = case entityPrimary t of - Just pdef -> T.intercalate "," $ map (connEscapeName conn . snd) $ primaryFields pdef- Nothing -> connEscapeName conn $ entityID t- wher conn = if null filts then "" else filterClause False conn filts- sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat+ sql conn = mconcat [ "SELECT "- , cols conn+ , connEscapeName conn $ entityID t , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn+ , lim conn+ , off ] (limit, offset, orders) = limitOffsetOrder opts@@ -161,17 +136,13 @@ case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords-- parse xs = case entityPrimary t of- Nothing -> - case xs of- [PersistInt64 x] -> return $ Key $ PersistInt64 x- [PersistDouble x] -> return $ Key $ PersistInt64 (truncate x) -- oracle returns Double - _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs)- Just pdef -> - let pks = map fst $ primaryFields pdef- keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs- in return $ Key $ PersistList keyvals+ lim conn = case (limit, offset) of+ (0, 0) -> ""+ (0, _) -> T.cons ' ' $ connNoLimit conn+ (_, _) -> " LIMIT " <> T.pack (show limit)+ off = if offset == 0+ then ""+ else " OFFSET " <> T.pack (show offset) deleteWhere filts = do _ <- deleteWhereCount filts@@ -270,96 +241,53 @@ go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs- go (Filter field value pfilter) = - let t = entityDef $ dummyFromFilts [Filter field value pfilter]- in case (fieldDB (persistFieldDef field) == DBName "id", entityPrimary t, allVals) of- -- need to check the id field in a safer way: entityId? - (True, Just pdef, (PersistList ys:_)) -> - if length (primaryFields pdef) /= length ys - then error $ "wrong number of entries in primaryFields vs PersistList allVals=" ++ show allVals- else- case (allVals, pfilter, isCompFilter pfilter) of- ([PersistList xs], Eq, _) -> - let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef))- in (wrapSql sqlcl,xs)- ([PersistList xs], Ne, _) -> - let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef))- in (wrapSql sqlcl,xs)- (_, In, _) -> - let xxs = transpose (map fromPersistList allVals)- sqls=map (\(a,xs) -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)- in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)- (_, NotIn, _) -> - let xxs = transpose (map fromPersistList allVals)- sqls=map (\(a,xs) -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)- in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)- ([PersistList xs], _, True) -> - let zs = tail (inits (primaryFields pdef))- sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs- sql2 islast a = connEscapeName conn (snd a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "- sqlcl = T.intercalate " or " sql1- in (wrapSql sqlcl, concat (tail (inits xs)))- (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"- _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals- (True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef-- _ -> case (isNull, pfilter, varCount) of- (True, Eq, _) -> (name <> " IS NULL", [])- (True, Ne, _) -> (name <> " IS NOT NULL", [])- (False, Ne, _) -> (T.concat- [ "("- , name- , " IS NULL OR "- , name- , " <> "- , qmarks- , ")"- ], notNullVals)- -- 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" <> orNullSuffix, [])- (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)- (True, In, _) -> (T.concat- [ "("- , name- , " IS NULL OR "- , name- , " IN "- , qmarks- , ")"- ], notNullVals)- (_, NotIn, 0) -> ("1=1", [])- (False, NotIn, _) -> (T.concat- [ "("- , name- , " IS NULL OR "- , name- , " NOT IN "- , qmarks- , ")"- ], notNullVals)- (True, NotIn, _) -> (T.concat- [ "("- , name- , " IS NOT NULL AND "- , name- , " NOT IN "- , qmarks- , ")"- ], notNullVals)- _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) -+ go (Filter field value pfilter) =+ case (isNull, pfilter, varCount) of+ (True, Eq, _) -> (name <> " IS NULL", [])+ (True, Ne, _) -> (name <> " IS NOT NULL", [])+ (False, Ne, _) -> (T.concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , " <> "+ , qmarks+ , ")"+ ], notNullVals)+ -- 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" <> orNullSuffix, [])+ (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)+ (True, In, _) -> (T.concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , " IN "+ , qmarks+ , ")"+ ], notNullVals)+ (_, NotIn, 0) -> ("1=1", [])+ (False, NotIn, _) -> (T.concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , " NOT IN "+ , qmarks+ , ")"+ ], notNullVals)+ (True, NotIn, _) -> (T.concat+ [ "("+ , name+ , " IS NOT NULL AND "+ , name+ , " NOT IN "+ , qmarks+ , ")"+ ], notNullVals)+ _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where- isCompFilter Lt = True- isCompFilter Le = True- isCompFilter Gt = True- isCompFilter Ge = True- isCompFilter _ = False- - wrapSql sqlcl = "(" <> sqlcl <> ")"- fromPersistList (PersistList xs) = xs- fromPersistList other = error $ "expected PersistList but found " ++ show other- filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] filterValueToPersistValues v = map toPersistValue $ either return id v @@ -430,20 +358,3 @@ dummyFromKey :: KeyBackend SqlBackend v -> Maybe v dummyFromKey _ = Nothing---- | Generates sql for limit and offset for postgres, sqlite and mysql.-decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text -decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = - let- lim = case (limit, offset) of- (0, 0) -> ""- (0, _) -> T.cons ' ' nolimit- (_, _) -> " LIMIT " <> T.pack (show limit)- off = if offset == 0- then ""- else " OFFSET " <> T.pack (show offset)- in mconcat- [ sql- , lim- , off- ]
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -7,53 +7,33 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Raw-import Database.Persist.Sql.Internal (convertKey) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.Logger import qualified Data.Text as T import Data.Text (Text, unpack)-import Data.Monoid (mappend, (<>))+import Data.Monoid (mappend) import Control.Monad.IO.Class-import Data.ByteString.Char8 (readInteger)-import Data.Maybe (isJust)-import Data.List (find) instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where type PersistMonadBackend (SqlPersistT m) = SqlBackend insert val = do conn <- askSqlConn- let esql = connInsertSql conn t vals- key <-+ let esql = connInsertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t)+ i <- case esql of ISRSingle sql -> rawQuery sql vals C.$$ do x <- CL.head case x of- Just [PersistInt64 i] -> return $ Key $ PersistInt64 i+ Just [PersistInt64 i] -> return i Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ISRInsertGet sql1 sql2 -> do rawExecute sql1 vals rawQuery sql2 [] C.$$ do- mm <- CL.head- case mm of- Just [PersistInt64 i] -> return $ Key $ PersistInt64 i- Just [PersistDouble i] ->return $ Key $ PersistInt64 $ truncate i -- oracle need this!- Just [PersistByteString i] -> case readInteger i of -- mssql- Just (ret,"") -> return $ Key $ PersistInt64 $ fromIntegral ret- xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"- Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]"- Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]"- ISRManyKeys sql fs -> do- rawExecute sql vals - case entityPrimary t of- Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql- Just pdef -> - let pks = map fst $ primaryFields pdef- keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs- in return $ Key $ PersistList keyvals-- return key+ Just [PersistInt64 i] <- CL.head+ return i+ return $ Key $ PersistInt64 i where t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val@@ -86,21 +66,19 @@ get k = do conn <- askSqlConn let t = entityDef $ dummyFromKey k- let composite = isJust $ entityPrimary t let cols = T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t- let wher = case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?" let sql = T.concat [ "SELECT " , cols , " FROM " , connEscapeName conn $ entityDB t , " WHERE "- , wher+ , connEscapeName conn $ entityID t+ , "=?" ]- rawQuery sql (convertKey composite k) C.$$ do+ vals' = [unKey k]+ rawQuery sql vals' C.$$ do res <- CL.head case res of Nothing -> return Nothing@@ -111,19 +89,15 @@ delete k = do conn <- askSqlConn- rawExecute (sql conn) (convertKey composite k)+ rawExecute (sql conn) [unKey k] where t = entityDef $ dummyFromKey k- composite = isJust $ entityPrimary t - wher conn = - case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t , " WHERE "- , wher conn+ , connEscapeName conn $ entityID t+ , "=?" ] dummyFromKey :: KeyBackend SqlBackend v -> Maybe v
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -32,10 +32,8 @@ getBy uniq = do conn <- askSqlConn- let flds = map (connEscapeName conn . fieldDB) (entityFields t)- let cols = case entityPrimary t of- Just _ -> T.intercalate "," flds- Nothing -> T.intercalate "," $ (connEscapeName conn $ entityID t) : flds+ let cols = T.intercalate "," $ (connEscapeName conn $ entityID t)+ : map (connEscapeName conn . fieldDB) (entityFields t) let sql = T.concat [ "SELECT " , cols@@ -53,11 +51,7 @@ case fromPersistValues vals of Left s -> error $ T.unpack s Right x -> return $ Just (Entity (Key $ PersistInt64 k) x)- Just (PersistDouble k:vals) -> -- oracle- case fromPersistValues vals of- Left s -> error $ T.unpack s- Right x -> return $ Just (Entity (Key $ PersistInt64 $ truncate k) x)- Just xs -> error $ "Database.Persist.GenericSql: Bad list in getBy xs="++show xs+ Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq
Database/Persist/Sql/Run.hs view
@@ -33,7 +33,7 @@ return x runSqlPersistM :: SqlPersistM a -> Connection -> IO a-runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn+runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runReaderT (unSqlPersistT x) conn runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool
Database/Persist/Sql/Types.hs view
@@ -35,12 +35,11 @@ data InsertSqlResult = ISRSingle Text | ISRInsertGet Text Text- | ISRManyKeys Text [PersistValue] data Connection = Connection { connPrepare :: Text -> IO Statement -- | table name, column names, id name, either 1 or 2 statements to run- , connInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult+ , connInsertSql :: DBName -> [DBName] -> DBName -> InsertSqlResult , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql@@ -54,7 +53,6 @@ , connEscapeName :: DBName -> Text , connNoLimit :: Text , connRDBMS :: Text- , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text } data Statement = Statement@@ -71,7 +69,6 @@ , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text)- , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name }
Database/Persist/Types/Base.hs view
@@ -20,15 +20,11 @@ import Data.Time (Day, TimeOfDay, UTCTime) import Data.Int (Int64) import qualified Data.Text.Read-import Data.ByteString (ByteString, foldl')-import Data.Bits (shiftL, shiftR)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8+import Data.ByteString (ByteString) import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32)-import Numeric (showHex, readHex) -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of@@ -106,9 +102,7 @@ , entityID :: !DBName , entityAttrs :: ![Attr] , entityFields :: ![FieldDef sqlType]- , entityPrimary :: Maybe PrimaryDef , entityUniques :: ![UniqueDef]- , entityForeigns:: ![ForeignDef] , entityDerives :: ![Text] , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool@@ -150,22 +144,6 @@ } deriving (Show, Eq, Read, Ord) -data PrimaryDef = PrimaryDef- { primaryFields :: ![(HaskellName, DBName)]- , primaryAttrs :: ![Attr]- }- deriving (Show, Eq, Read, Ord)--data ForeignDef = ForeignDef- { foreignRefTableHaskell :: !HaskellName- , foreignRefTableDBName :: !DBName- , foreignConstraintNameHaskell :: !HaskellName- , foreignConstraintNameDBName :: !DBName- , foreignFields :: ![(HaskellName, DBName, HaskellName, DBName)] -- foreignkey name gb our field plus corresponding other primary field:make this a real adt- , foreignAttrs :: ![Attr]- }- deriving (Show, Eq, Read, Ord)- data PersistException = PersistError Text -- ^ Generic Exception | PersistMarshalError Text@@ -202,44 +180,15 @@ | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)]- | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend- | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend--- For example, below is a simple example of the PostGIS geography type:------ @--- data Geo = Geo ByteString--- --- instance PersistField Geo where--- toPersistValue (Geo t) = PersistDbSpecific t--- --- fromPersistValue (PersistDbSpecific t) = Right $ Geo $ Data.ByteString.concat ["'", t, "'"]--- fromPersistValue _ = Left "Geo values must be converted from PersistDbSpecific"--- --- instance PersistFieldSql Geo where--- sqlType _ = SqlOther "GEOGRAPHY(POINT,4326)"--- --- toPoint :: Double -> Double -> Geo--- toPoint lat lon = Geo $ Data.ByteString.concat ["'POINT(", ps $ lon, " ", ps $ lat, ")'"]--- where ps = Data.Text.pack . show--- @--- --- If Foo has a geography field, we can then perform insertions like the following:--- --- @--- insert $ Foo (toPoint 44 44)--- @---+ | PersistObjectId ByteString -- ^ intended especially for MongoDB backend deriving (Show, Read, Eq, Typeable, Ord) - instance PathPiece PersistValue where fromPathPiece t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, t') | T.null t' -> Just $ PersistInt64 i- _ -> case reads $ T.unpack t of- [(fks, "")] -> Just $ PersistList fks- _ -> Just $ PersistText t+ _ -> Just $ PersistText t toPathPiece x = case fromPersistValueText x of Left e -> error e@@ -261,7 +210,6 @@ fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text"-fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text" instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t@@ -277,30 +225,12 @@ toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map (second A.toJSON) m- toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b- toJSON (PersistObjectId o) =- A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) ""- where- (four, eight) = BS8.splitAt 4 o-- -- taken from crypto-api- bs2i :: ByteString -> Integer- bs2i bs = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs- {-# INLINE bs2i #-}-- -- showHex of n padded with leading zeros if necessary to fill d digits- -- taken from Data.BSON- showHexLen :: (Show n, Integral n) => Int -> n -> ShowS- showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where- sigDigits 0 = 1- sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1+ toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o instance A.FromJSON PersistValue where parseJSON (A.String t0) = case T.uncons t0 of Nothing -> fail "Null string"- Just ('p', t) -> either (fail "Invalid base64") (return . PersistDbSpecific)- $ B64.decode $ TE.encodeUtf8 t Just ('s', t) -> return $ PersistText t Just ('b', t) -> either (fail "Invalid base64") (return . PersistByteString) $ B64.decode $ TE.encodeUtf8 t@@ -309,25 +239,15 @@ Just ('z', t) -> fmap PersistZonedTime $ readMay t Just ('d', t) -> fmap PersistDay $ readMay t Just ('r', t) -> fmap PersistRational $ readMay t- Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId) $- fmap (i2bs (8 * 12) . fst) $ headMay $ readHex $ T.unpack t+ Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId)+ $ B64.decode $ TE.encodeUtf8 t Just (c, _) -> fail $ "Unknown prefix: " ++ [c] where- headMay [] = Nothing- headMay (x:_) = Just x readMay :: (Read a, Monad m) => T.Text -> m a readMay t = case reads $ T.unpack t of (x, _):_ -> return x [] -> fail "Could not read"-- -- taken from crypto-api- -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).- i2bs :: Int -> Integer -> BS.ByteString- i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8)- {-# INLINE i2bs #-}-- parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i parseJSON (A.Number (AN.D d)) = return $ PersistDouble d parseJSON (A.Bool b) = return $ PersistBool b
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 1.2.3.1+version: 1.2.3.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>