diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -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 diff --git a/Database/Persist/Class.hs b/Database/Persist/Class.hs --- a/Database/Persist/Class.hs +++ b/Database/Persist/Class.hs @@ -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 diff --git a/Database/Persist/Class/PersistEntity.hs b/Database/Persist/Class/PersistEntity.hs --- a/Database/Persist/Class/PersistEntity.hs +++ b/Database/Persist/Class/PersistEntity.hs @@ -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") + diff --git a/Database/Persist/Class/PersistQuery.hs b/Database/Persist/Class/PersistQuery.hs --- a/Database/Persist/Class/PersistQuery.hs +++ b/Database/Persist/Class/PersistQuery.hs @@ -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) diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -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 diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -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) diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskell #-} module Database.Persist.Quasi ( parse , PersistSettings (..) diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -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 diff --git a/Database/Persist/Sql/Migration.hs b/Database/Persist/Sql/Migration.hs --- a/Database/Persist/Sql/Migration.hs +++ b/Database/Persist/Sql/Migration.hs @@ -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 diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -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 diff --git a/Database/Persist/Sql/Raw.hs b/Database/Persist/Sql/Raw.hs --- a/Database/Persist/Sql/Raw.hs +++ b/Database/Persist/Sql/Raw.hs @@ -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 diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -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) diff --git a/Database/Persist/Sql/Types.hs b/Database/Persist/Sql/Types.hs --- a/Database/Persist/Sql/Types.hs +++ b/Database/Persist/Sql/Types.hs @@ -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) diff --git a/Database/Persist/Sql/Util.hs b/Database/Persist/Sql/Util.hs --- a/Database/Persist/Sql/Util.hs +++ b/Database/Persist/Sql/Util.hs @@ -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' -> diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -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) -- @ diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.2 +version: 2.2.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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