persistent 1.2.3.3 → 1.3.0
raw patch · 19 files changed
+794/−333 lines, 19 filesdep −scientificdep ~base
Dependencies removed: scientific
Dependency ranges changed: base
Files
- Database/Persist.hs +0/−94
- Database/Persist/Class.hs +30/−5
- Database/Persist/Class/DeleteCascade.hs +9/−0
- Database/Persist/Class/PersistEntity.hs +152/−45
- Database/Persist/Class/PersistField.hs +37/−24
- Database/Persist/Class/PersistQuery.hs +17/−0
- Database/Persist/Class/PersistStore.hs +37/−2
- Database/Persist/Class/PersistUnique.hs +84/−20
- Database/Persist/Quasi.hs +98/−12
- Database/Persist/Sql.hs +2/−1
- Database/Persist/Sql/Class.hs +8/−1
- Database/Persist/Sql/Internal.hs +9/−2
- Database/Persist/Sql/Orphan/PersistQuery.hs +170/−81
- Database/Persist/Sql/Orphan/PersistStore.hs +40/−14
- Database/Persist/Sql/Orphan/PersistUnique.hs +9/−3
- Database/Persist/Sql/Run.hs +1/−1
- Database/Persist/Sql/Types.hs +4/−1
- Database/Persist/Types/Base.hs +86/−24
- persistent.cabal +1/−3
Database/Persist.hs view
@@ -5,18 +5,6 @@ ( module Database.Persist.Class , module Database.Persist.Types - -- * Store functions- , insertBy- , getJust- , belongsTo- , belongsToJust- , getByValue-- -- * Query functions- , selectList- , selectKeysList- , deleteCascadeWhere- -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.)@@ -36,75 +24,11 @@ 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@@ -139,24 +63,6 @@ (||.) :: 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,11 +1,36 @@ module Database.Persist.Class- ( DeleteCascade (..)- , PersistEntity (..)- , PersistQuery (..)+ (+ -- * PersistStore+ PersistStore (..)+ , getJust+ , belongsTo+ , belongsToJust++ -- * PersistUnique , PersistUnique (..)- , PersistConfig (..)+ , getByValue+ , insertBy+ , replaceUnique++ -- * PersistQuery+ , PersistQuery (..)+ , selectList+ , selectKeysList++ -- * DeleteCascade+ , DeleteCascade (..)+ , deleteCascadeWhere++ -- * PersistEntity+ , PersistEntity (..)+ -- * PersistField , PersistField (..)- , PersistStore (..)+ -- * PersistConfig+ , PersistConfig (..)++ -- * JSON utilities+ , keyValueEntityToJSON, keyValueEntityFromJSON+ , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Class.DeleteCascade
Database/Persist/Class/DeleteCascade.hs view
@@ -2,10 +2,19 @@ {-# 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,74 +10,109 @@ , 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 --- | 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+-- | 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 :: * -> * - type PersistEntityBackend val+ -- | return meta-data for a given 'EntityField'+ persistFieldDef :: EntityField record typ -> FieldDef SqlType - -- | Unique keys in existence on this entity.- data Unique val+ -- | Persistent allows multiple different backends+ type PersistEntityBackend record - entityDef :: Monad m => m val -> EntityDef SqlType- toPersistFields :: val -> [SomePersistField]- fromPersistValues :: [PersistValue] -> Either Text val+ -- | Unique keys besided the Key+ data Unique record - persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)]- persistUniqueToValues :: Unique val -> [PersistValue]- persistUniqueKeys :: val -> [Unique val]+ -- | retrieve the EntityDef meta-data for the record+ entityDef :: Monad m => m record -> EntityDef SqlType - persistIdField :: EntityField val (Key val)+ -- | Get the database fields of a record+ toPersistFields :: record -> [SomePersistField] - fieldLens :: EntityField val field- -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val))+ -- | Convert from database values to a Haskell record+ fromPersistValues :: [PersistValue] -> Either Text record -data Update v = forall typ. PersistField typ => Update- { updateField :: EntityField v typ+ persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)]+ persistUniqueToValues :: Unique record -> [PersistValue]+ persistUniqueKeys :: record -> [Unique record]++ persistIdField :: EntityField record (Key record)++ fieldLens :: EntityField record field+ -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))++-- | updataing a database entity+--+-- Persistent users use combinators to create these+data Update record = forall typ. PersistField typ => Update+ { updateField :: EntityField record typ , updateValue :: typ- , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road+ -- FIXME Replace with expr down the road+ , updateUpdate :: PersistUpdate } -data SelectOpt v = forall typ. Asc (EntityField v typ)- | forall typ. Desc (EntityField v typ)- | OffsetBy Int- | LimitTo Int+-- | 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 -type family BackendSpecificFilter b v+type family BackendSpecificFilter backend record -- | 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 v = forall typ. PersistField typ => Filter- { filterField :: EntityField v typ+--+-- Persistent users use combinators to create these+data Filter record = forall typ. PersistField typ => Filter+ { filterField :: EntityField record typ , filterValue :: Either typ [typ] -- FIXME , filterFilter :: PersistFilter -- FIXME }- | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API- | FilterOr [Filter v]- | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v)+ | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API+ | FilterOr [Filter record]+ | BackendFilter+ (BackendSpecificFilter (PersistEntityBackend record) record) -- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@. -- -- Since 1.1.0-type Key val = KeyBackend (PersistEntityBackend val) val+type Key record = KeyBackend (PersistEntityBackend record) record --- | Datatype that represents an entity, with both its key and--- its Haskell representation.+-- | Datatype that represents an entity, with both its 'Key' and+-- its Haskell record representation. ----- When using the an SQL-based backend (such as SQLite or+-- When using a 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@@ -109,13 +144,85 @@ , entityVal :: entity } deriving (Eq, Ord, Show, Read) -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"+-- | 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"
Database/Persist/Class/PersistField.hs view
@@ -20,11 +20,12 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif import Data.Time.LocalTime (ZonedTime)-import Data.ByteString.Char8 (ByteString, unpack)+import Data.ByteString.Char8 (ByteString, unpack, readInt) 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 ((<>)) @@ -69,6 +70,7 @@ 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 @@ -91,28 +93,33 @@ instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x+ 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 instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x+ 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 instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x+ 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 instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x+ 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 instance PersistField Int64 where toPersistValue = PersistInt64 . fromIntegral- fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x+ 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 instance PersistField Word where toPersistValue = PersistInt64 . fromIntegral@@ -153,7 +160,7 @@ _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x)+ fromPersistValue x = Left $ "PersistField Fixed:Expected Rational, received: " <> T.pack (show x) instance PersistField Rational where toPersistValue = PersistRational@@ -163,12 +170,20 @@ [(a, "")] -> Right $ toRational (a :: Pico) _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i- fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x)+ 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) 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@@ -280,17 +295,15 @@ fromPersistMap :: PersistField v => [(T.Text, PersistValue)] -> Either T.Text (M.Map T.Text v)-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+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 getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)] getPersistMap (PersistMap kvs) = Right kvs
Database/Persist/Class/PersistQuery.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery ( PersistQuery (..)+ , selectList+ , selectKeysList ) where import Control.Exception (throwIO)@@ -83,6 +85,21 @@ -- | 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,16 +1,22 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-} 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)+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Monoid (Monoid)+import Control.Exception.Lifted (throwIO) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT)@@ -30,6 +36,7 @@ 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@@ -76,6 +83,34 @@ -- 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,7 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistUnique ( PersistUnique (..)+ , getByValue+ , insertBy+ , replaceUnique+ , checkUnique ) where import qualified Prelude@@ -11,6 +15,7 @@ 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)@@ -35,7 +40,14 @@ -- -- Please read the general Persistent documentation to learn how to create -- Unique keys.--- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field.+-- 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 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))@@ -48,9 +60,77 @@ -- couldn't be inserted because of a uniqueness constraint. insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val)) insertUnique datum = do- isUnique <- checkUnique datum- if isUnique then Just `liftM` insert datum else return Nothing+ 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)+ #define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique } #define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T) #define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T)@@ -74,19 +154,3 @@ #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,12 +18,13 @@ import Prelude hiding (lines) import Database.Persist.Types import Data.Char-import Data.Maybe (mapMaybe, fromMaybe)+import Data.Maybe (mapMaybe, fromMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&)) import qualified Data.Map as M-import Data.List (foldl')+import Data.List (foldl',find)+import Data.Monoid (mappend) data ParseState a = PSDone | PSFail | PSSuccess a Text @@ -179,14 +180,36 @@ -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> [Line] -> [EntityDef ()] parseLines ps lines =- toEnts lines+ fixForeignKeysAll $ 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@@ -198,7 +221,7 @@ (HaskellName name') (DBName $ getDbName ps name' entattribs) (DBName $ idName entattribs)- entattribs cols uniqs derives+ entattribs cols primary uniqs foreigns derives extras isSum where@@ -212,7 +235,17 @@ case T.stripPrefix "id=" t of Nothing -> idName ts Just s -> s- uniqs = mapMaybe (takeUniqs ps cols) attribs+ + (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' ++ "]"+ derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef ()]@@ -258,15 +291,45 @@ Nothing -> getDbName ps n as Just s -> s -takeUniqs :: PersistSettings+takeConstraint :: PersistSettings+ -> Text -> [FieldDef a] -> [Text]- -> Maybe UniqueDef-takeUniqs ps defs (n:rest)+ -> (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+ -> [FieldDef a]+ -> [Text]+ -> UniqueDef+takeUniq ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n)- = Just $ UniqueDef+ = UniqueDef (HaskellName n)- (DBName $ psToDBName ps n)+ (DBName $ psToDBName ps (tableName `T.append` n)) (map (HaskellName &&& getDBName defs) fields) attrs where@@ -275,7 +338,30 @@ getDBName (d:ds) t | fieldHaskell d == HaskellName t = fieldDB d | otherwise = getDBName ds t-takeUniqs _ _ _ = Nothing+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 takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest
Database/Persist/Sql.hs view
@@ -15,6 +15,7 @@ , getStmtConn -- * Internal , module Database.Persist.Sql.Internal+ , decorateSQLWithLimitOffset ) where import Database.Persist@@ -25,7 +26,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,4 +311,11 @@ n = 0 _mn = return n `asTypeOf` a instance PersistFieldSql Rational where- sqlType _ = SqlNumeric 22 12 -- FIXME: Ambigous, 12 is from Pico which is used to convert Rational to number string+ 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
Database/Persist/Sql/Internal.hs view
@@ -3,6 +3,7 @@ -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns+ , convertKey ) where import Database.Persist.Types@@ -15,9 +16,9 @@ import Database.Persist.Sql.Types -- | Create the list of columns for the given entity.-mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef])+mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t =- (cols, entityUniques t)+ (cols, entityUniques t, entityForeigns t) where cols :: [Column] cols = map go (entityFields t)@@ -35,6 +36,7 @@ SqlOther (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)) (def $ fieldAttrs fd)+ Nothing (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) @@ -77,3 +79,8 @@ 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,6 +4,7 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount+ , decorateSQLWithLimitOffset ) where import Database.Persist@@ -11,6 +12,7 @@ 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 (..), (<>))@@ -21,6 +23,9 @@ 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@@ -33,17 +38,20 @@ 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 "- , connEscapeName conn $ entityID t- , "=?"+ , wher ] rawExecute sql $- map updatePersistValue upds `mappend` [unKey k]+ map updatePersistValue upds `mappend` (convertKey composite k) where t = entityDef $ dummyFromKey k go x = (fieldDB $ updateFieldDef x, updateUpdate x)@@ -59,8 +67,15 @@ , wher ] rawQuery sql (getFiltsValues conn filts) $$ do- Just [PersistInt64 i] <- CL.head- return $ fromIntegral i+ 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++"]" where t = entityDef $ dummyFromFilts filts @@ -68,19 +83,38 @@ 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 fromPersistValues' vals of- Left s -> liftIO $ throwIO $ PersistMarshalError s- Right row -> return row+ 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 t = entityDef $ dummyFromFilts filts- fromPersistValues' (PersistInt64 x:xs) = do+ fromPersistValues' (PersistInt64 x:xs) = case fromPersistValues xs of Left e -> Left e Right xs' -> Right (Entity (Key $ PersistInt64 x) xs')- fromPersistValues' _ = Left "error in fromPersistValues'"+ 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')+ wher conn = if null filts then "" else filterClause False conn filts@@ -88,46 +122,37 @@ 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 ","- $ (connEscapeName conn $ entityID t)- : map (connEscapeName conn . fieldDB) (entityFields t)- sql conn = mconcat+ $ ((if composite then [] else [connEscapeName conn $ entityID t]) + <> map (connEscapeName conn . fieldDB) (entityFields t))+ sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ 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 = mconcat+ sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT "- , connEscapeName conn $ entityID t+ , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn- , lim conn- , off ] (limit, offset, orders) = limitOffsetOrder opts@@ -136,14 +161,18 @@ 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) + 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+ deleteWhere filts = do _ <- deleteWhereCount filts return ()@@ -241,53 +270,96 @@ go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs- 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)+ 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) + 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 @@ -358,3 +430,20 @@ 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,33 +7,53 @@ 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 (entityDB t) (map fieldDB $ entityFields t) (entityID t)- i <-+ let esql = connInsertSql conn t vals+ key <- case esql of ISRSingle sql -> rawQuery sql vals C.$$ do x <- CL.head case x of- Just [PersistInt64 i] -> return i+ Just [PersistInt64 i] -> return $ Key $ PersistInt64 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- Just [PersistInt64 i] <- CL.head- return i- return $ Key $ PersistInt64 i+ 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 where t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val@@ -66,19 +86,21 @@ 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 "- , connEscapeName conn $ entityID t- , "=?"+ , wher ]- vals' = [unKey k]- rawQuery sql vals' C.$$ do+ rawQuery sql (convertKey composite k) C.$$ do res <- CL.head case res of Nothing -> return Nothing@@ -89,15 +111,19 @@ delete k = do conn <- askSqlConn- rawExecute (sql conn) [unKey k]+ rawExecute (sql conn) (convertKey composite 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 "- , connEscapeName conn $ entityID t- , "=?"+ , wher conn ] dummyFromKey :: KeyBackend SqlBackend v -> Maybe v
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -32,8 +32,10 @@ getBy uniq = do conn <- askSqlConn- let cols = T.intercalate "," $ (connEscapeName conn $ entityID t)- : map (connEscapeName conn . fieldDB) (entityFields t)+ 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 sql = T.concat [ "SELECT " , cols@@ -51,7 +53,11 @@ case fromPersistValues vals of Left s -> error $ T.unpack s Right x -> return $ Just (Entity (Key $ PersistInt64 k) x)- Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"+ 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 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 $ runReaderT (unSqlPersistT x) conn+runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool
Database/Persist/Sql/Types.hs view
@@ -35,11 +35,12 @@ 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 :: DBName -> [DBName] -> DBName -> InsertSqlResult+ , connInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql@@ -53,6 +54,7 @@ , connEscapeName :: DBName -> Text , connNoLimit :: Text , connRDBMS :: Text+ , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text } data Statement = Statement@@ -69,6 +71,7 @@ , 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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-}@@ -21,14 +20,15 @@ import Data.Time (Day, TimeOfDay, UTCTime) import Data.Int (Int64) import qualified Data.Text.Read-import Data.ByteString (ByteString)+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.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32)-#if MIN_VERSION_aeson(0, 7, 0)-import qualified Data.Scientific-#endif+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,7 +106,9 @@ , entityID :: !DBName , entityAttrs :: ![Attr] , entityFields :: ![FieldDef sqlType]+ , entityPrimary :: Maybe PrimaryDef , entityUniques :: ![UniqueDef]+ , entityForeigns:: ![ForeignDef] , entityDerives :: ![Text] , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool@@ -148,6 +150,22 @@ } 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@@ -184,15 +202,44 @@ | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)]- | PersistObjectId ByteString -- ^ intended especially for MongoDB backend+ | 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)+-- @+-- 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- _ -> Just $ PersistText t+ _ -> case reads $ T.unpack t of+ [(fks, "")] -> Just $ PersistList fks+ _ -> Just $ PersistText t toPathPiece x = case fromPersistValueText x of Left e -> error e@@ -214,18 +261,13 @@ 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 toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i- toJSON (PersistDouble d) = A.Number $-#if MIN_VERSION_aeson(0, 7, 0)- Data.Scientific.fromFloatDigits-#else- AN.D-#endif- d+ toJSON (PersistDouble d) = A.Number $ AN.D d toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t@@ -235,12 +277,30 @@ 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 (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o+ 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+ 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@@ -249,25 +309,27 @@ Just ('z', t) -> fmap PersistZonedTime $ readMay t Just ('d', t) -> fmap PersistDay $ readMay t Just ('r', t) -> fmap PersistRational $ readMay t- Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId)- $ B64.decode $ TE.encodeUtf8 t+ Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId) $+ fmap (i2bs (8 * 12) . fst) $ headMay $ readHex $ T.unpack 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" -#if MIN_VERSION_aeson(0, 7, 0)- parseJSON (A.Number n) = return $- if fromInteger (floor n) == n- then PersistInt64 $ floor n- else PersistDouble $ fromRational $ toRational n-#else+ -- 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-#endif parseJSON (A.Bool b) = return $ PersistBool b parseJSON A.Null = return $ PersistNull parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 1.2.3.3+version: 1.3.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -43,7 +43,6 @@ , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , silently- , scientific exposed-modules: Database.Persist Database.Persist.Quasi@@ -95,7 +94,6 @@ , conduit , monad-control , blaze-html- , scientific cpp-options: -DTEST