persistent 2.2 → 2.2.1
raw patch · 17 files changed
+213/−114 lines, 17 filesdep ~resource-pool
Dependency ranges changed: resource-pool
Files
- ChangeLog.md +2/−0
- Database/Persist.hs +6/−1
- Database/Persist/Class.hs +2/−0
- Database/Persist/Class/PersistEntity.hs +115/−2
- Database/Persist/Class/PersistQuery.hs +0/−1
- Database/Persist/Class/PersistStore.hs +4/−18
- Database/Persist/Class/PersistUnique.hs +2/−8
- Database/Persist/Quasi.hs +0/−1
- Database/Persist/Sql/Class.hs +17/−17
- Database/Persist/Sql/Migration.hs +11/−9
- Database/Persist/Sql/Orphan/PersistStore.hs +18/−21
- Database/Persist/Sql/Raw.hs +1/−3
- Database/Persist/Sql/Run.hs +2/−8
- Database/Persist/Sql/Types.hs +1/−3
- Database/Persist/Sql/Util.hs +12/−11
- Database/Persist/Types/Base.hs +18/−9
- persistent.cabal +2/−2
ChangeLog.md view
@@ -1,3 +1,5 @@+* Migration failure message with context+ ## 2.2 * Add a `RawSql` instance for `Key`. This allows selecting primary keys using functions like `rawSql`. [#407](https://github.com/yesodweb/persistent/pull/407)
Database/Persist.hs view
@@ -67,7 +67,12 @@ infixl 3 ||. (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v]--- | the OR of two lists of filters+-- | the OR of two lists of filters. For example: +-- selectList([PersonAge >. 25, PersonAge <. 30] ||. [PersonIncome >. 15000, PersonIncome <. 25000]) []+-- will filter records where a person's age is between (25 and 30) OR a person's income is between (15,000 and 25000). +-- If you are looking for an &&. operator to do (A AND B AND (C OR D)) you can use the ++ operator instead as there is no &&. For example: +-- selectList([PersonAge >. 25, PersonAge <. 30] ++ ([PersonCategory ==. 1] ||. [PersonCategory ==. 5])) []+-- will filter records where a person's age is between (25 and 30) AND (person's category is either 1 or 5) a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] listToJSON :: [PersistValue] -> T.Text
Database/Persist/Class.hs view
@@ -33,6 +33,7 @@ , PersistField (..) -- * PersistConfig , PersistConfig (..)+ , entityValues -- * Lifting , HasPersistBackend (..)@@ -41,6 +42,7 @@ -- * JSON utilities , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON+ , toPersistValueJSON, fromPersistValueJSON ) where import Database.Persist.Class.DeleteCascade
Database/Persist/Class/PersistEntity.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..)@@ -12,19 +14,31 @@ , BackendSpecificFilter , Entity (..) + , entityValues , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON+ -- * PersistField based on other typeclasses+ , toPersistValueJSON, fromPersistValueJSON+ , toPersistValueEnum, fromPersistValueEnum ) 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 qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as TB+import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object))+import qualified Data.Aeson.Parser as AP+import Data.Aeson.Types (Parser,Result(Error,Success))+import Data.Aeson.Encode (encodeToTextBuilder)+import Data.Attoparsec.ByteString (parseOnly) import Control.Applicative ((<$>), (<*>)) import Data.Monoid (mappend) import qualified Data.HashMap.Strict as HM+import Data.Typeable (Typeable)+import Data.Maybe (isJust) -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)@@ -157,7 +171,21 @@ deriving instance (PersistEntity record, Ord (Key record), Ord record) => Ord (Entity record) deriving instance (PersistEntity record, Show (Key record), Show record) => Show (Entity record) deriving instance (PersistEntity record, Read (Key record), Read record) => Read (Entity record)+#if MIN_VERSION_base(4,7,0)+deriving instance Typeable Entity+#endif +entityValues :: PersistEntity record => Entity record -> [PersistValue]+entityValues (Entity k record) =+ if isJust (entityPrimary ent)+ then+ -- TODO: check against the key+ map toPersistValue (toPersistFields record)+ else+ keyToValues k ++ map toPersistValue (toPersistFields record)+ where+ ent = entityDef $ Just record+ -- | Predefined @toJSON@. The resulting JSON looks like -- @{\"key\": 1, \"value\": {\"name\": ...}}@. --@@ -243,3 +271,88 @@ -- so lets use MongoDB conventions idField :: Text idField = "_id"++-- | Convenience function for getting a free 'PersistField' instance+-- from a type with JSON instances.+--+--+-- Example usage in combination with`fromPersistValueJSON`:+--+-- @+-- instance PersistField MyData where+-- fromPersistValue = fromPersistValueJSON+-- toPersistValue = toPersistValueJSON+-- @+--+toPersistValueJSON :: ToJSON a => a -> PersistValue+toPersistValueJSON = PersistText . LT.toStrict . TB.toLazyText . encodeToTextBuilder . toJSON++-- | Convenience function for getting a free 'PersistField' instance+-- from a type with JSON instances. The JSON parser used will accept+-- JSON values other that object and arrays. So, if your instance+-- serializes the data to a JSON string, this will still work.+--+--+-- Example usage in combination with`toPersistValueJSON`:+--+-- @+-- instance PersistField MyData where+-- fromPersistValue = fromPersistValueJSON+-- toPersistValue = toPersistValueJSON+-- @+--+fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a+fromPersistValueJSON z = case z of+ PersistByteString bs -> mapLeft (T.append "Could not parse the JSON (was a PersistByteString): ")+ $ parseGo bs+ PersistText t -> mapLeft (T.append "Could not parse the JSON (was PersistText): ")+ $ parseGo (TE.encodeUtf8 t)+ a -> Left $ T.append "Expected PersistByteString, received: " (T.pack (show a))+ where parseGo bs = mapLeft T.pack $ case parseOnly AP.value bs of+ Left err -> Left err+ Right v -> case fromJSON v of+ Error err -> Left err+ Success a -> Right a+ mapLeft _ (Right a) = Right a+ mapLeft f (Left b) = Left (f b)++-- | Convenience function for getting a free 'PersistField' instance+-- from a type with an 'Enum' instance. The function 'derivePersistField'+-- from the persistent-template package should generally be preferred.+-- However, if you want to ensure that an @ORDER BY@ clause that uses+-- your field will order rows by the data constructor order, this is+-- a better choice.+--+-- Example usage in combination with `fromPersistValueEnum`:+--+-- @+-- data SeverityLevel = Low | Medium | Critical | High+-- deriving (Enum, Bounded)+-- instance PersistField SeverityLevel where+-- fromPersistValue = fromPersistValueEnum+-- toPersistValue = toPersistValueEnum+-- @+toPersistValueEnum :: Enum a => a -> PersistValue+toPersistValueEnum = toPersistValue . fromEnum++-- | Convenience function for getting a free 'PersistField' instance+-- from a type with an 'Enum' instance. This function also requires+-- a `Bounded` instance to improve the reporting of errors.+--+-- Example usage in combination with `toPersistValueEnum`:+--+-- @+-- data SeverityLevel = Low | Medium | Critical | High+-- deriving (Enum, Bounded)+-- instance PersistField SeverityLevel where+-- fromPersistValue = fromPersistValueEnum+-- toPersistValue = toPersistValueEnum+-- @+fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a+fromPersistValueEnum v = fromPersistValue v >>= go+ where go i = let res = toEnum i in+ if i >= fromEnum (asTypeOf minBound res) && i <= fromEnum (asTypeOf maxBound res)+ then Right res+ else Left ("The number " `mappend` T.pack (show i) `mappend` " was out of the "+ `mappend` "allowed bounds for an enum type")+
Database/Persist/Class/PersistQuery.hs view
@@ -16,7 +16,6 @@ import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity-import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with)
Database/Persist/Class/PersistStore.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..)@@ -14,21 +12,11 @@ , ToBackendKey(..) ) where -import qualified Prelude-import Prelude hiding ((++), show)- import qualified Data.Text as T--import Control.Monad.Trans.Error (Error (..)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception.Lifted (throwIO)--import Data.Conduit.Internal (Pipe, ConduitM)--import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Reader (MonadReader (ask), runReaderT)-- import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Types@@ -95,10 +83,8 @@ -- | Same as 'insertMany', but doesn't return any 'Key's. --- -- The MongoDB, PostgreSQL, and MySQL backends insert all records in+ -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query.- --- -- The SQLite backend inserts rows one-by-one. insertMany_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => [val] -> ReaderT backend m () insertMany_ x = insertMany x >> return ()@@ -151,7 +137,7 @@ => Key val -> [Update val] -> ReaderT backend m val updateGet key ups = do update key ups- get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ Prelude.show key) return+ get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return -- | Same as get, but for a non-null (not Maybe) foreign key@@ -163,7 +149,7 @@ , MonadIO m ) => Key val -> ReaderT backend m val getJust key = get key >>= maybe- (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key)+ (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) return -- | curry this to make a convenience function that loads an associated model
Database/Persist/Class/PersistUnique.hs view
@@ -10,17 +10,11 @@ ) where import Database.Persist.Types-import qualified Prelude-import Prelude hiding ((++))- import Control.Exception (throwIO) import Control.Monad (liftM, when)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (liftIO, MonadIO) import Data.List ((\\))--import Control.Monad.Trans.Reader ( ReaderT )-import Control.Monad.IO.Class (MonadIO)-+import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity import Data.Monoid (mappend)
Database/Persist/Quasi.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-} module Database.Persist.Quasi ( parse , PersistSettings (..)
Database/Persist/Sql/Class.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-} #endif@@ -21,10 +22,6 @@ import Data.Maybe (fromMaybe) import Data.Fixed import Data.Proxy (Proxy)--import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Class (MonadTrans)- import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Map as M@@ -65,24 +62,27 @@ ++ " columns" rawSqlProcessRow = keyFromValues -instance (PersistEntity a, PersistEntityBackend a ~ SqlBackend) => RawSql (Entity a) where- rawSqlCols escape = ((+1) . length . entityFields &&& process) . entityDef . Just . entityVal+instance (PersistEntity record, PersistEntityBackend record ~ SqlBackend)+ => RawSql (Entity record) where+ rawSqlCols escape ent = (length sqlFields, [intercalate ", " sqlFields]) where- process ed = (:[]) $- intercalate ", " $- map ((name ed <>) . escape) $- (fieldDB (entityId ed) :) $- map fieldDB $- entityFields ed- name ed = escape (entityDB ed) <> "."-+ sqlFields = map (((name <> ".") <>) . escape)+ $ map fieldDB+ -- Hacky for a composite key because+ -- it selects the same field multiple times+ $ entityKeyFields entDef ++ entityFields entDef+ name = escape (entityDB entDef)+ entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = case fst (rawSqlCols (error "RawSql") a) of 1 -> "one column for an 'Entity' data type without fields" n -> show n ++ " columns for an 'Entity' data type"- rawSqlProcessRow (idCol:ent) = Entity <$> fromPersistValue idCol- <*> fromPersistValues ent- rawSqlProcessRow _ = Left "RawSql (Entity a): wrong number of columns."+ rawSqlProcessRow row = case splitAt nKeyFields row of+ (rowKey, rowVal) -> Entity <$> keyFromValues rowKey+ <*> fromPersistValues rowVal+ where+ nKeyFields = length $ entityKeyFields entDef+ entDef = entityDef (Nothing :: Maybe record) -- | Since 1.0.1. instance RawSql a => RawSql (Maybe a) where
Database/Persist/Sql/Migration.hs view
@@ -30,8 +30,6 @@ allSql :: CautiousMigration -> [Sql] allSql = map snd-unsafeSql :: CautiousMigration -> [Sql]-unsafeSql = allSql . filter fst safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) @@ -83,13 +81,17 @@ -> ReaderT SqlBackend m [Text] runMigration' m silent = do mig <- parseMigration' m- case unsafeSql mig of- [] -> mapM (executeMigrate silent) $ sortMigrations $ safeSql mig- errs -> error $ concat- [ "\n\nDatabase migration: manual intervention required.\n"- , "The following actions are considered unsafe:\n\n"- , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs- ]+ if any fst mig+ then error $ concat+ [ "\n\nDatabase migration: manual intervention required.\n"+ , "The unsafe actions are prefixed by '***' below:\n\n"+ , unlines $ map displayMigration mig+ ]+ else mapM (executeMigrate silent) $ sortMigrations $ safeSql mig+ where+ displayMigration :: (Bool, Sql) -> String+ displayMigration (True, s) = "*** " ++ unpack s ++ ";"+ displayMigration (False, s) = " " ++ unpack s ++ ";" runMigrationUnsafe :: MonadIO m => Migration
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -20,6 +20,7 @@ import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw+import Database.Persist.Sql.Util (dbIdColumns, keyAndEntityColumnNames) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Text as T@@ -54,10 +55,11 @@ whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text whereStmtForKey conn k =- case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef- Nothing -> connEscapeName conn (fieldDB (entityId t)) <> "=?"- where t = entityDef $ dummyFromKey k+ T.intercalate " AND "+ $ map (<> "=? ")+ $ dbIdColumns conn entDef+ where+ entDef = entityDef $ dummyFromKey k -- | get the SQL string for the table that a PeristEntity represents@@ -169,10 +171,10 @@ Right k -> return k Left err -> throw $ "ISRInsertGet: keyFromValues failed: " `mappend` err ISRManyKeys sql fs -> do- rawExecute sql vals + rawExecute sql vals case entityPrimary t of Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql- Just pdef -> + Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs in case keyFromValues keyvals of@@ -214,11 +216,7 @@ , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t) , ")" ]-- -- SQLite only supports multi-row inserts in 3.7.11+ (see https://www.sqlite.org/releaselog/3_7_11.html).- if connRDBMS conn == "sqlite"- then mapM_ insert vals- else rawExecute sql (concat valss)+ rawExecute sql (concat valss) where t = entityDef vals valss = map (map toPersistValue . toPersistFields) vals@@ -296,24 +294,23 @@ -> Key val -> val -> ReaderT SqlBackend m ()-insrepHelper command k val = do+insrepHelper command k record = do conn <- ask- rawExecute (sql conn) vals+ let columnNames = keyAndEntityColumnNames entDef conn+ rawExecute (sql conn columnNames) vals where- t = entityDef $ Just val- sql conn = T.concat+ entDef = entityDef $ Just record+ sql conn columnNames = T.concat [ command , " INTO "- , connEscapeName conn (entityDB t)+ , connEscapeName conn (entityDB entDef) , "("- , T.intercalate ","- $ map (connEscapeName conn)- $ fieldDB (entityId t) : map fieldDB (entityFields t)+ , T.intercalate "," columnNames , ") VALUES("- , T.intercalate "," ("?" : map (const "?") (entityFields t))+ , T.intercalate "," (map (const "?") columnNames) , ")" ]- vals = keyToValues k ++ map toPersistValue (toPersistFields val)+ vals = entityValues (Entity k record) updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f
Database/Persist/Sql/Raw.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist.Sql.Raw where@@ -9,7 +8,6 @@ import qualified Data.Map as Map import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, MonadReader)-import Control.Monad.Trans.Resource (release) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO)@@ -19,7 +17,7 @@ import Data.Int (Int64) import qualified Data.Text as T import Data.Conduit-import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.Trans.Resource (MonadResource,release) rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env SqlBackend) => Text
Database/Persist/Sql/Run.hs view
@@ -10,18 +10,13 @@ import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Base-import Control.Exception.Lifted (onException)+import Control.Exception.Lifted (onException, bracket) import Control.Monad.IO.Class-import Control.Exception.Lifted (bracket) import Control.Exception (mask) import System.Timeout (timeout)-import Control.Monad.Trans.Control (control) import Data.IORef (readIORef, writeIORef, newIORef) import qualified Data.Map as Map-import Control.Exception.Lifted (throwIO)-import Control.Exception (mask) import Control.Monad (liftM)-import System.Timeout (timeout) -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool.@@ -76,8 +71,7 @@ -> (Pool SqlBackend -> m a) -> m a withSqlPool mkConn connCount f = do- pool <- createSqlPool mkConn connCount- f pool+ bracket (createSqlPool mkConn connCount) (liftIO . destroyAllResources) f createSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => (LogFunc -> IO SqlBackend)
Database/Persist/Sql/Types.hs view
@@ -10,15 +10,13 @@ module Database.Persist.Sql.Types where import Control.Exception (Exception)-import Control.Monad.Trans.Resource (MonadResource (..), ResourceT)+import Control.Monad.Trans.Resource (ResourceT) import Data.Acquire (Acquire) import Control.Monad.Logger (NoLoggingT)-import Control.Monad.Trans.Control import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Writer (WriterT) import Data.Typeable (Typeable)-import Control.Monad (liftM) import Database.Persist.Types import Database.Persist.Class (HasPersistBackend (..)) import Data.IORef (IORef)
Database/Persist/Sql/Util.hs view
@@ -2,6 +2,7 @@ module Database.Persist.Sql.Util ( parseEntityValues , entityColumnNames+ , keyAndEntityColumnNames , entityColumnCount , isIdField , hasCompositeKey@@ -15,13 +16,12 @@ import Data.Text (Text, pack) import Database.Persist ( Entity(Entity), EntityDef, EntityField, HaskellName(HaskellName)- , PersistEntity, PersistValue, PersistException(PersistMarshalError)+ , PersistEntity, PersistValue , keyFromValues, fromPersistValues, fieldDB, entityId, entityPrimary- , entityFields, fieldHaskell, compositeFields, persistFieldDef+ , entityFields, entityKeyFields, fieldHaskell, compositeFields, persistFieldDef+ , keyAndEntityFields , DBName) import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeName)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Exception (throwIO) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn =@@ -29,6 +29,9 @@ then [] else [connEscapeName conn $ fieldDB (entityId ent)]) <> map (connEscapeName conn . fieldDB) (entityFields ent) +keyAndEntityColumnNames :: EntityDef -> SqlBackend -> [Sql]+keyAndEntityColumnNames ent conn = map (connEscapeName conn . fieldDB) (keyAndEntityFields ent)+ entityColumnCount :: EntityDef -> Int entityColumnCount e = length (entityFields e) + if hasCompositeKey e then 0 else 1@@ -40,13 +43,11 @@ dbIdColumns conn = dbIdColumnsEsc (connEscapeName conn) dbIdColumnsEsc :: (DBName -> Text) -> EntityDef -> [Text]-dbIdColumnsEsc esc t = case entityPrimary t of- Just pdef -> map (esc . fieldDB) $ compositeFields pdef- Nothing -> [esc $ fieldDB (entityId t)]+dbIdColumnsEsc esc t = map (esc . fieldDB) $ entityKeyFields t dbColumns :: SqlBackend -> EntityDef -> [Text] dbColumns conn t = case entityPrimary t of- Just _ -> flds + Just _ -> flds Nothing -> escapeDB (entityId t) : flds where escapeDB = connEscapeName conn . fieldDB@@ -54,16 +55,16 @@ parseEntityValues :: PersistEntity record => EntityDef -> [PersistValue] -> Either Text (Entity record)-parseEntityValues t vals = +parseEntityValues t vals = case entityPrimary t of- Just pdef -> + Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd . filter ((`elem` pks) . fst) $ zip (map fieldHaskell $ entityFields t) vals in fromPersistValuesComposite' keyvals vals Nothing -> fromPersistValues' vals where- fromPersistValues' (kpv:xs) = -- oracle returns Double + fromPersistValues' (kpv:xs) = -- oracle returns Double case fromPersistValues xs of Left e -> Left e Right xs' ->
Database/Persist/Types/Base.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Database.Persist.Types.Base where@@ -125,6 +122,18 @@ CompositeRef c -> Just c _ -> Nothing +entityKeyFields :: EntityDef -> [FieldDef]+entityKeyFields ent = case entityPrimary ent of+ Nothing -> [entityId ent]+ Just pdef -> compositeFields pdef++keyAndEntityFields :: EntityDef -> [FieldDef]+keyAndEntityFields ent =+ case entityPrimary ent of+ Nothing -> entityId ent : entityFields ent+ Just _ -> entityFields ent++ type ExtraLine = [Text] newtype HaskellName = HaskellName { unHaskellName :: Text }@@ -268,23 +277,23 @@ -- -- @ -- 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) -- @
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.2+version: 2.2.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -34,7 +34,7 @@ , exceptions >= 0.6 , monad-control >= 0.3 , lifted-base >= 0.1- , resource-pool+ , resource-pool >= 0.2.2.0 , path-pieces >= 0.1 , aeson >= 0.5 , monad-logger >= 0.3