persistent 1.2.3.0 → 1.2.3.1
raw patch · 14 files changed
+562/−193 lines, 14 files
Files
- Database/Persist/Class.hs +3/−0
- Database/Persist/Class/PersistEntity.hs +124/−45
- Database/Persist/Class/PersistField.hs +37/−24
- Database/Persist/Class/PersistUnique.hs +8/−6
- Database/Persist/Quasi.hs +98/−12
- Database/Persist/Sql.hs +2/−1
- Database/Persist/Sql/Class.hs +3/−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/Types.hs +5/−1
- Database/Persist/Types/Base.hs +53/−2
- persistent.cabal +1/−1
Database/Persist/Class.hs view
@@ -28,6 +28,9 @@ -- * PersistConfig , PersistConfig (..) + -- * JSON utilities+ , keyValueEntityToJSON, keyValueEntityFromJSON+ , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Class.DeleteCascade
Database/Persist/Class/PersistEntity.hs view
@@ -10,6 +10,9 @@ , Filter (..) , Key , Entity (..)++ , keyValueEntityToJSON, keyValueEntityFromJSON+ , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Types.Base@@ -17,67 +20,97 @@ 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.+-- its Haskell record representation. -- -- When using a SQL-based backend (such as SQLite or -- PostgreSQL), an 'Entity' may take any number of columns@@ -111,20 +144,66 @@ , 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 k v) = case toPersistValue v of- (PersistMap alist) -> PersistMap ((idField, toPersistValue k) : alist)+ 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
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/PersistUnique.hs view
@@ -44,8 +44,10 @@ -- -- 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 tryting to catch the correct exception and determing the column of failure.--- * an exception will automatically abort the current SQL transaction+--+-- * 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))@@ -91,10 +93,10 @@ 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 Unque violation+-- | 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)
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,9 +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/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 }@@ -80,6 +83,7 @@ instance Exception PersistentSqlException data SqlBackend+ deriving Typeable newtype SqlPersistT m a = SqlPersistT { unSqlPersistT :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)
Database/Persist/Types/Base.hs view
@@ -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,6 +261,7 @@ 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@@ -229,6 +277,7 @@ 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@@ -250,6 +299,8 @@ 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
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 1.2.3.0+version: 1.2.3.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>