persistent-postgresql-2.10.1.2/Database/0000755000000000000000000000000013167222713016232 5ustar0000000000000000persistent-postgresql-2.10.1.2/Database/Persist/0000755000000000000000000000000013606232107017657 5ustar0000000000000000persistent-postgresql-2.10.1.2/Database/Persist/Postgresql/0000755000000000000000000000000013577776556022056 5ustar0000000000000000persistent-postgresql-2.10.1.2/test/0000755000000000000000000000000013606232107015501 5ustar0000000000000000persistent-postgresql-2.10.1.2/Database/Persist/Postgresql.hs0000644000000000000000000015215713606232107022371 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | A postgresql backend for persistent. module Database.Persist.Postgresql ( withPostgresqlPool , withPostgresqlPoolWithVersion , withPostgresqlConn , withPostgresqlConnWithVersion , createPostgresqlPool , createPostgresqlPoolModified , createPostgresqlPoolModifiedWithVersion , module Database.Persist.Sql , ConnectionString , PostgresConf (..) , openSimpleConn , openSimpleConnWithVersion , tableName , fieldName , mockMigration , migrateEnableExtension ) where import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Simple as PG import qualified Database.PostgreSQL.Simple.Internal as PG import qualified Database.PostgreSQL.Simple.FromField as PGFF import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.Transaction as PG import qualified Database.PostgreSQL.Simple.Types as PG import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import Database.PostgreSQL.Simple.Ok (Ok (..)) import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad (forM) import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import Data.Conduit import qualified Data.Conduit.List as CL import Data.Data import Data.Either (partitionEithers) import Data.Fixed (Pico) import Data.Function (on) import Data.Int (Int64) import qualified Data.IntMap as I import Data.IORef import Data.List (find, sort, groupBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe import Data.Monoid ((<>)) import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Text.Read (rational) import Data.Time (utc, localTimeToUTC) import Data.Typeable (Typeable) import System.Environment (getEnvironment) import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test -- dbname=test password=test\"@. Please read libpq's -- documentation at -- -- for more details on how to create such strings. type ConnectionString = ByteString -- | PostgresServerVersionError exception. This is thrown when persistent -- is unable to find the version of the postgreSQL server. data PostgresServerVersionError = PostgresServerVersionError String deriving Data.Typeable.Typeable instance Show PostgresServerVersionError where show (PostgresServerVersionError uniqueMsg) = "Unexpected PostgreSQL server version, got " <> uniqueMsg instance Exception PostgresServerVersionError -- | Create a PostgreSQL connection pool and run the given action. The pool is -- properly released after the action finishes using it. Note that you should -- not use the given 'ConnectionPool' outside the action since it may already -- have been released. -- The provided action should use 'runSqlConn' and *not* 'runReaderT' because -- the former brackets the database action with transaction begin/commit. withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m) => ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in -- the pool. -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the -- connection pool. -> m a withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci -- | Same as 'withPostgresPool', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2 withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in -- the pool. -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the -- connection pool. -> m a withPostgresqlPoolWithVersion getVer ci = withSqlPool $ open' (const $ return ()) getVer ci -- | Create a PostgreSQL connection pool. Note that it's your -- responsibility to properly close the connection pool when -- unneeded. Use 'withPostgresqlPool' for an automatic resource -- control. createPostgresqlPool :: (MonadUnliftIO m, MonadLogger m) => ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open -- in the pool. -> m (Pool SqlBackend) createPostgresqlPool = createPostgresqlPoolModified (const $ return ()) -- | Same as 'createPostgresqlPool', but additionally takes a callback function -- for some connection-specific tweaking to be performed after connection -- creation. This could be used, for example, to change the schema. For more -- information, see: -- -- -- -- @since 2.1.3 createPostgresqlPoolModified :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool. -> m (Pool SqlBackend) createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServerVersion -- | Same as other similarly-named functions in this module, but takes callbacks for obtaining -- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking -- (to change the schema). -- -- @since 2.6.2 createPostgresqlPoolModifiedWithVersion :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool. -> m (Pool SqlBackend) createPostgresqlPoolModifiedWithVersion getVer modConn ci = createSqlPool $ open' modConn getVer ci -- | Same as 'withPostgresqlPool', but instead of opening a pool -- of connections, only one connection is opened. -- The provided action should use 'runSqlConn' and *not* 'runReaderT' because -- the former brackets the database action with transaction begin/commit. withPostgresqlConn :: (MonadUnliftIO m, MonadLogger m) => ConnectionString -> (SqlBackend -> m a) -> m a withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion -- | Same as 'withPostgresqlConn', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2 withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -> ConnectionString -> (SqlBackend -> m a) -> m a withPostgresqlConnWithVersion getVer = withSqlConn . open' (const $ return ()) getVer open' :: (PG.Connection -> IO ()) -> (PG.Connection -> IO (Maybe Double)) -> ConnectionString -> LogFunc -> IO SqlBackend open' modConn getVer cstr logFunc = do conn <- PG.connectPostgreSQL cstr modConn conn ver <- getVer conn smap <- newIORef $ Map.empty return $ createBackend logFunc ver smap conn -- | Gets the PostgreSQL server version getServerVersion :: PG.Connection -> IO (Maybe Double) getServerVersion conn = do [PG.Only version] <- PG.query_ conn "show server_version"; let version' = rational version --- λ> rational "9.8.3" --- Right (9.8,".3") --- λ> rational "9.8.3.5" --- Right (9.8,".3.5") case version' of Right (a,_) -> return $ Just a Left err -> throwIO $ PostgresServerVersionError err -- | Choose upsert sql generation function based on postgresql version. -- PostgreSQL version >= 9.5 supports native upsert feature, -- so depending upon that we have to choose how the sql query is generated. -- upsertFunction :: Double -> Maybe (EntityDef -> Text -> Text) upsertFunction :: a -> Double -> Maybe a upsertFunction f version = if (version >= 9.5) then Just f else Nothing -- | Generate a 'SqlBackend' from a 'PG.Connection'. openSimpleConn :: LogFunc -> PG.Connection -> IO SqlBackend openSimpleConn = openSimpleConnWithVersion getServerVersion -- | Generate a 'SqlBackend' from a 'PG.Connection', but takes a callback for -- obtaining the server version. -- -- @since 2.9.1 openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend openSimpleConnWithVersion getVer logFunc conn = do smap <- newIORef $ Map.empty serverVersion <- getVer conn return $ createBackend logFunc serverVersion smap conn -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection. createBackend :: LogFunc -> Maybe Double -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = do SqlBackend { connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = insertSql' , connInsertManySql = Just insertManySql' , connUpsertSql = serverVersion >>= upsertFunction upsertSql' , connPutManySql = serverVersion >>= upsertFunction putManySql , connClose = PG.close conn , connMigrateSql = migrate' , connBegin = \_ mIsolation -> case mIsolation of Nothing -> PG.begin conn Just iso -> PG.beginLevel (case iso of ReadUncommitted -> PG.ReadCommitted -- PG Upgrades uncommitted reads to committed anyways ReadCommitted -> PG.ReadCommitted RepeatableRead -> PG.RepeatableRead Serializable -> PG.Serializable) conn , connCommit = const $ PG.commit conn , connRollback = const $ PG.rollback conn , connEscapeName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" , connLogFunc = logFunc , connMaxParams = Nothing , connRepsertManySql = serverVersion >>= upsertFunction repsertManySql } prepare' :: PG.Connection -> Text -> IO Statement prepare' conn sql = do let query = PG.Query (T.encodeUtf8 sql) return Statement { stmtFinalize = return () , stmtReset = return () , stmtExecute = execute' conn query , stmtQuery = withStmt' conn query } insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = let sql = T.concat [ "INSERT INTO " , escape $ entityDB ent , if null (entityFields ent) then " DEFAULT VALUES" else T.concat [ "(" , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent , ") VALUES(" , T.intercalate "," (map (const "?") $ entityFields ent) , ")" ] ] in case entityPrimary ent of Just _pdef -> ISRManyKeys sql vals Nothing -> ISRSingle (sql <> " RETURNING " <> escape (fieldDB (entityId ent))) upsertSql' :: EntityDef -> NonEmpty UniqueDef -> Text -> Text upsertSql' ent uniqs updateVal = T.concat [ "INSERT INTO " , escape (entityDB ent) , "(" , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent , ") VALUES (" , T.intercalate "," $ map (const "?") (entityFields ent) , ") ON CONFLICT (" , T.intercalate "," $ concat $ map (\x -> map escape (map snd $ uniqueFields x)) (entityUniques ent) , ") DO UPDATE SET " , updateVal , " WHERE " , wher , " RETURNING ??" ] where wher = T.intercalate " AND " $ map singleCondition $ NEL.toList uniqs singleCondition :: UniqueDef -> Text singleCondition udef = T.intercalate " AND " (map singleClause $ map snd (uniqueFields udef)) singleClause :: DBName -> Text singleClause field = escape (entityDB ent) <> "." <> (escape field) <> " =?" -- | SQL for inserting multiple rows at once and returning their primary keys. insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult insertManySql' ent valss = let sql = T.concat [ "INSERT INTO " , escape (entityDB ent) , "(" , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent , ") VALUES (" , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields ent) , ") RETURNING " , Util.commaSeparated $ Util.dbIdColumnsEsc escape ent ] in ISRSingle sql execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 execute' conn query vals = PG.execute conn query (map P vals) withStmt' :: MonadIO m => PG.Connection -> PG.Query -> [PersistValue] -> Acquire (ConduitM () [PersistValue] m ()) withStmt' conn query vals = pull `fmap` mkAcquire openS closeS where openS = do -- Construct raw query rawquery <- PG.formatQuery conn query (map P vals) -- Take raw connection (rt, rr, rc, ids) <- PG.withConnection conn $ \rawconn -> do -- Execute query mret <- LibPQ.exec rawconn rawquery case mret of Nothing -> do merr <- LibPQ.errorMessage rawconn fail $ case merr of Nothing -> "Postgresql.withStmt': unknown error" Just e -> "Postgresql.withStmt': " ++ B8.unpack e Just ret -> do -- Check result status status <- LibPQ.resultStatus ret case status of LibPQ.TuplesOk -> return () _ -> PG.throwResultError "Postgresql.withStmt': bad result status " ret status -- Get number and type of columns cols <- LibPQ.nfields ret oids <- forM [0..cols-1] $ \col -> fmap ((,) col) (LibPQ.ftype ret col) -- Ready to go! rowRef <- newIORef (LibPQ.Row 0) rowCount <- LibPQ.ntuples ret return (ret, rowRef, rowCount, oids) let getters = map (\(col, oid) -> getGetter conn oid $ PG.Field rt col oid) ids return (rt, rr, rc, getters) closeS (ret, _, _, _) = LibPQ.unsafeFreeResult ret pull x = do y <- liftIO $ pullS x case y of Nothing -> return () Just z -> yield z >> pull x pullS (ret, rowRef, rowCount, getters) = do row <- atomicModifyIORef rowRef (\r -> (r+1, r)) if row == rowCount then return Nothing else fmap Just $ forM (zip getters [0..]) $ \(getter, col) -> do mbs <- LibPQ.getvalue' ret row col case mbs of Nothing -> -- getvalue' verified that the value is NULL. -- However, that does not mean that there are -- no NULL values inside the value (e.g., if -- we're dealing with an array of optional values). return PersistNull Just bs -> do ok <- PGFF.runConversion (getter mbs) conn bs `seq` case ok of Errors (exc:_) -> throw exc Errors [] -> error "Got an Errors, but no exceptions" Ok v -> return v -- | Avoid orphan instances. newtype P = P PersistValue instance PGTF.ToField P where toField (P (PersistText t)) = PGTF.toField t toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) toField (P (PersistInt64 i)) = PGTF.toField i toField (P (PersistDouble d)) = PGTF.toField d toField (P (PersistRational r)) = PGTF.Plain $ BBB.fromString $ show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field toField (P (PersistBool b)) = PGTF.toField b toField (P (PersistDay d)) = PGTF.toField d toField (P (PersistTimeOfDay t)) = PGTF.toField t toField (P (PersistUTCTime t)) = PGTF.toField t toField (P PersistNull) = PGTF.toField PG.Null toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m toField (P (PersistDbSpecific s)) = PGTF.toField (Unknown s) toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" newtype Unknown = Unknown { unUnknown :: ByteString } deriving (Eq, Show, Read, Ord, Typeable) instance PGFF.FromField Unknown where fromField f mdata = case mdata of Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField Unknown" Just dat -> return (Unknown dat) instance PGTF.ToField Unknown where toField (Unknown a) = PGTF.Escape a type Getter a = PGFF.FieldParser a convertPV :: PGFF.FromField a => (a -> b) -> Getter b convertPV f = (fmap f .) . PGFF.fromField builtinGetters :: I.IntMap (Getter PersistValue) builtinGetters = I.fromList [ (k PS.bool, convertPV PersistBool) , (k PS.bytea, convertPV (PersistByteString . unBinary)) , (k PS.char, convertPV PersistText) , (k PS.name, convertPV PersistText) , (k PS.int8, convertPV PersistInt64) , (k PS.int2, convertPV PersistInt64) , (k PS.int4, convertPV PersistInt64) , (k PS.text, convertPV PersistText) , (k PS.xml, convertPV PersistText) , (k PS.float4, convertPV PersistDouble) , (k PS.float8, convertPV PersistDouble) , (k PS.money, convertPV PersistRational) , (k PS.bpchar, convertPV PersistText) , (k PS.varchar, convertPV PersistText) , (k PS.date, convertPV PersistDay) , (k PS.time, convertPV PersistTimeOfDay) , (k PS.timestamp, convertPV (PersistUTCTime. localTimeToUTC utc)) , (k PS.timestamptz, convertPV PersistUTCTime) , (k PS.bit, convertPV PersistInt64) , (k PS.varbit, convertPV PersistInt64) , (k PS.numeric, convertPV PersistRational) , (k PS.void, \_ _ -> return PersistNull) , (k PS.json, convertPV (PersistByteString . unUnknown)) , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) , (k PS.unknown, convertPV (PersistByteString . unUnknown)) -- Array types: same order as above. -- The OIDs were taken from pg_type. , (1000, listOf PersistBool) , (1001, listOf (PersistByteString . unBinary)) , (1002, listOf PersistText) , (1003, listOf PersistText) , (1016, listOf PersistInt64) , (1005, listOf PersistInt64) , (1007, listOf PersistInt64) , (1009, listOf PersistText) , (143, listOf PersistText) , (1021, listOf PersistDouble) , (1022, listOf PersistDouble) , (1023, listOf PersistUTCTime) , (1024, listOf PersistUTCTime) , (791, listOf PersistRational) , (1014, listOf PersistText) , (1015, listOf PersistText) , (1182, listOf PersistDay) , (1183, listOf PersistTimeOfDay) , (1115, listOf PersistUTCTime) , (1185, listOf PersistUTCTime) , (1561, listOf PersistInt64) , (1563, listOf PersistInt64) , (1231, listOf PersistRational) -- no array(void) type , (2951, listOf (PersistDbSpecific . unUnknown)) , (199, listOf (PersistByteString . unUnknown)) , (3807, listOf (PersistByteString . unUnknown)) -- no array(unknown) either ] where k (PGFF.typoid -> i) = PG.oid2int i -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert -- the values to Haskell-land. The @Maybe@ is important -- because the usual way of checking NULLs -- (c.f. withStmt') won't check for NULL inside -- arrays---or any other compound structure for that matter. listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) where nullable = maybe PersistNull getGetter :: PG.Connection -> PG.Oid -> Getter PersistValue getGetter _conn oid = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters where defaultGetter = convertPV (PersistDbSpecific . unUnknown) unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x doesTableExist :: (Text -> IO Statement) -> DBName -- ^ table name -> IO Bool doesTableExist getter (DBName name) = do stmt <- getter sql with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) where sql = "SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" <> " AND schemaname != 'information_schema' AND tablename=?" vals = [PersistText name] start = await >>= maybe (error "No results when checking doesTableExist") start' start' [PersistInt64 0] = finish False start' [PersistInt64 1] = finish True start' res = error $ "doesTableExist returned unexpected result: " ++ show res finish x = await >>= maybe (return x) (error "Too many rows returned in doesTableExist") migrate' :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do old <- getColumns getter entity newcols' case partitionEithers old of ([], old'') -> do exists <- if null old then doesTableExist getter name else return True return $ Right $ migrationText exists old'' (errs, _) -> return $ Left errs where name = entityDB entity (newcols', udefs, fdefs) = mkColumns allDefs entity migrationText exists old'' = if not exists then createText newcols fdefs udspair else let (acs, ats) = getAlters allDefs entity (newcols, udspair) $ excludeForeignKeys $ old' acs' = map (AlterColumn name) acs ats' = map (AlterTable name) ats in acs' ++ ats' where old' = partitionEithers old'' newcols = filter (not . safeToRemove entity . cName) newcols' udspair = map udToPair udefs excludeForeignKeys (xs,ys) = (map excludeForeignKey xs,ys) excludeForeignKey c = case cReference c of Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> c { cReference = Nothing } Nothing -> c Nothing -> c -- Check for table existence if there are no columns, workaround -- for https://github.com/yesodweb/persistent/issues/152 createText newcols fdefs udspair = (addTable newcols entity) : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> getAddReference allDefs name refTblName cname (cReference c)) $ filter (isJust . cReference) newcols foreignsAlt = flip map fdefs (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields))) addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ T.concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! , escape name , "(" , idtxt , if null cols then "" else "," , T.intercalate "," $ map showColumn cols , ")" ] where name = entityDB entity idtxt = case entityPrimary entity of Just pdef -> T.concat [" PRIMARY KEY (", T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef, ")"] Nothing -> let defText = defaultAttribute $ fieldAttrs $ entityId entity sType = fieldSqlType $ entityId entity in T.concat [ escape $ fieldDB (entityId entity) , maySerial sType defText , " PRIMARY KEY UNIQUE" , mayDefault defText ] maySerial :: SqlType -> Maybe Text -> Text maySerial SqlInt64 Nothing = " SERIAL8 " maySerial sType _ = " " <> showSqlType sType mayDefault :: Maybe Text -> Text mayDefault def = case def of Nothing -> "" Just d -> " DEFAULT " <> d type SafeToRemove = Bool data AlterColumn = ChangeType SqlType Text | IsNull | NotNull | Add' Column | Drop SafeToRemove | Default Text | NoDefault | Update' Text | AddReference DBName [DBName] [Text] | DropReference DBName type AlterColumn' = (DBName, AlterColumn) data AlterTable = AddUniqueConstraint DBName [DBName] | DropConstraint DBName data AlterDB = AddTable Text | AlterColumn DBName AlterColumn' | AlterTable DBName AlterTable -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) -> EntityDef -> [Column] -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def cols = do let sqlv=T.concat ["SELECT " ,"column_name " ,",is_nullable " ,",COALESCE(domain_name, udt_name)" -- See DOMAINS below ,",column_default " ,",numeric_precision " ,",numeric_scale " ,",character_maximum_length " ,"FROM information_schema.columns " ,"WHERE table_catalog=current_database() " ,"AND table_schema=current_schema() " ,"AND table_name=? " ,"AND column_name <> ?"] -- DOMAINS Postgres supports the concept of domains, which are data types with optional constraints. -- An app might make an "email" domain over the varchar type, with a CHECK that the emails are valid -- In this case the generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN foo TYPE email -- This code exists to use the domain name (email), instead of the underlying type (varchar). -- This is tested in EquivalentTypeTest.hs stmt <- getter sqlv let vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB (entityId def) ] cs <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| helper) let sqlc = T.concat ["SELECT " ,"c.constraint_name, " ,"c.column_name " ,"FROM information_schema.key_column_usage c, " ,"information_schema.table_constraints k " ,"WHERE c.table_catalog=current_database() " ,"AND c.table_catalog=k.table_catalog " ,"AND c.table_schema=current_schema() " ,"AND c.table_schema=k.table_schema " ,"AND c.table_name=? " ,"AND c.table_name=k.table_name " ,"AND c.column_name <> ? " ,"AND c.constraint_name=k.constraint_name " ,"AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " ,"ORDER BY c.constraint_name, c.column_name"] stmt' <- getter sqlc us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) return $ cs ++ us where refMap = Map.fromList $ foldl ref [] cols where ref rs c = case cReference c of Nothing -> rs (Just r) -> (unDBName $ cName c, r) : rs getAll front = do x <- CL.head case x of Nothing -> return $ front [] Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col)) Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) Just o -> error $ "unexpected datatype returned for postgres o="++show o helperU = do rows <- getAll id return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) $ groupBy ((==) `on` fst) rows helper = do x <- CL.head case x of Nothing -> return [] Just x'@((PersistText cname):_) -> do col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) let col' = case col of Left e -> Left e Right c -> Right $ Left c cols <- helper return $ col' : cols -- | Check if a column name is listed as the "safe to remove" in the entity -- list. safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) = any (elem "SafeToRemove" . fieldAttrs) $ filter ((== DBName colName) . fieldDB) $ entityFields def getAlters :: [EntityDef] -> EntityDef -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable]) getAlters defs def (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where getAltersC [] old = map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old getAltersC (new:news) old = let (alters, old') = findAlters defs (entityDB def) new old in alters ++ getAltersC news old' getAltersU :: [(DBName, [DBName])] -> [(DBName, [DBName])] -> [AlterTable] getAltersU [] old = map DropConstraint $ filter (not . isManual) $ map fst old getAltersU ((name, cols):news) old = case lookup name old of Nothing -> AddUniqueConstraint name cols : getAltersU news old Just ocols -> let old' = filter (\(x, _) -> x /= name) old in if sort cols == sort ocols then getAltersU news old' else DropConstraint name : AddUniqueConstraint name cols : getAltersU news old' -- Don't drop constraints which were manually added. isManual (DBName x) = "__manual_" `T.isPrefixOf` x getColumn :: (Text -> IO Statement) -> DBName -> [PersistValue] -> Maybe (DBName, DBName) -> IO (Either Text Column) getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = case d' of Left s -> return $ Left s Right d'' -> let typeStr = case maxlen of PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] _ -> typeName in case getType typeStr of Left s -> return $ Left s Right t -> do let cname = DBName columnName ref <- getRef cname refName return $ Right Column { cName = cname , cNull = isNullable == "YES" , cSqlType = t , cDefault = fmap stripSuffixes d'' , cDefaultConstraintName = Nothing , cMaxLen = Nothing , cReference = ref } where stripSuffixes t = loop' [ "::character varying" , "::text" ] where loop' [] = t loop' (p:ps) = case T.stripSuffix p t of Nothing -> loop' ps Just t' -> t' getRef _ Nothing = return Nothing getRef cname (Just (_, refName')) = do let sql = T.concat ["SELECT DISTINCT " ,"ccu.table_name, " ,"tc.constraint_name " ,"FROM information_schema.constraint_column_usage ccu, " ,"information_schema.key_column_usage kcu, " ,"information_schema.table_constraints tc " ,"WHERE tc.constraint_type='FOREIGN KEY' " ,"AND kcu.constraint_name=tc.constraint_name " ,"AND ccu.constraint_name=kcu.constraint_name " ,"AND kcu.ordinal_position=1 " ,"AND kcu.table_name=? " ,"AND kcu.column_name=? " ,"AND tc.constraint_name=?"] stmt <- getter sql cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' ,PersistText $ unDBName cname ,PersistText $ unDBName refName']) (\src -> runConduit $ src .| CL.consume) case cntrs of [] -> return Nothing [[PersistText table, PersistText constraint]] -> return $ Just (DBName table, DBName constraint) xs -> error $ mconcat [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " , T.unpack (unDBName tableName') , " and column: " , T.unpack (unDBName cname) , " but got: " , show xs ] d' = case defaultValue of PersistNull -> Right Nothing PersistText t -> Right $ Just t _ -> Left $ T.pack $ "Invalid default column: " ++ show defaultValue getType "int4" = Right SqlInt32 getType "int8" = Right SqlInt64 getType "varchar" = Right SqlString getType "text" = Right SqlString getType "date" = Right SqlDay getType "bool" = Right SqlBool getType "timestamptz" = Right SqlDayTime getType "float4" = Right SqlReal getType "float8" = Right SqlReal getType "bytea" = Right SqlBlob getType "time" = Right SqlTime getType "numeric" = getNumeric numericPrecision numericScale getType a = Right $ SqlOther a getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) getNumeric PersistNull PersistNull = Left $ T.concat [ "No precision and scale were specified for the column: " , columnName , " in table: " , unDBName tableName' , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," , " which is probably not what you intended." , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] getNumeric a b = Left $ T.concat [ "Can not get numeric field precision for the column: " , columnName , " in table: " , unDBName tableName' , ". Expected an integer for both precision and scale, " , "got: " , T.pack $ show a , " and " , T.pack $ show b , ", respectively." , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] getColumn _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName -- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer sqlTypeEq :: SqlType -> SqlType -> Bool sqlTypeEq x y = T.toCaseFold (showSqlType x) == T.toCaseFold (showSqlType y) findAlters :: [EntityDef] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = case filter (\c -> cName c == name) cols of [] -> ([(name, Add' col)], cols) Column _ isNull' sqltype' def' _defConstraintName' _maxLen' ref':_ -> let refDrop Nothing = [] refDrop (Just (_, cname)) = [(name, DropReference cname)] refAdd Nothing = [] refAdd (Just (tname, a)) = case find ((==tname) . entityDB) defs of Just refdef -> [(tname, AddReference a [name] (Util.dbIdColumnsEsc escape refdef))] Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" modRef = if fmap snd ref == fmap snd ref' then [] else refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of (True, False) -> [(name, IsNull)] (False, True) -> let up = case def of Nothing -> id Just s -> (:) (name, Update' s) in up [(name, NotNull)] _ -> [] modType | sqlTypeEq sqltype sqltype' = [] -- When converting from Persistent pre-2.0 databases, we -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is -- treated as UTC. | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" = [(name, ChangeType sqltype $ T.concat [ " USING " , escape name , " AT TIME ZONE 'UTC'" ])] | otherwise = [(name, ChangeType sqltype "")] modDef = if def == def' then [] else case def of Nothing -> [(name, NoDefault)] Just s -> [(name, Default s)] in (modRef ++ modDef ++ modNull ++ modType, filter (\c -> cName c /= name) cols) -- | Get the references to be added to a table for the given column. getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing Just (s, constraintName) -> Just $ AlterColumn table (s, AddReference constraintName [cname] id_) where id_ = fromMaybe (error $ "Could not find ID of entity " ++ show reftable) $ do entDef <- find ((== reftable) . entityDB) allDefs return $ Util.dbIdColumnsEsc escape entDef showColumn :: Column -> Text showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat [ escape n , " " , showSqlType sqlType' , " " , if nu then "NULL" else "NOT NULL" , case def of Nothing -> "" Just s -> " DEFAULT " <> s ] showSqlType :: SqlType -> Text showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INT4" showSqlType SqlInt64 = "INT8" showSqlType SqlReal = "DOUBLE PRECISION" showSqlType (SqlNumeric s prec) = T.concat [ "NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")" ] showSqlType SqlDay = "DATE" showSqlType SqlTime = "TIME" showSqlType SqlDayTime = "TIMESTAMP WITH TIME ZONE" showSqlType SqlBlob = "BYTEA" showSqlType SqlBool = "BOOLEAN" -- Added for aliasing issues re: https://github.com/yesodweb/yesod/issues/682 showSqlType (SqlOther (T.toLower -> "integer")) = "INT4" showSqlType (SqlOther t) = t showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, s) showAlterDb (AlterColumn t (c, ac)) = (isUnsafe ac, showAlter t (c, ac)) where isUnsafe (Drop safeRemove) = not safeRemove isUnsafe _ = False showAlterDb (AlterTable t at) = (False, showAlterTable t at) showAlterTable :: DBName -> AlterTable -> Text showAlterTable table (AddUniqueConstraint cname cols) = T.concat [ "ALTER TABLE " , escape table , " ADD CONSTRAINT " , escape cname , " UNIQUE(" , T.intercalate "," $ map escape cols , ")" ] showAlterTable table (DropConstraint cname) = T.concat [ "ALTER TABLE " , escape table , " DROP CONSTRAINT " , escape cname ] showAlter :: DBName -> AlterColumn' -> Text showAlter table (n, ChangeType t extra) = T.concat [ "ALTER TABLE " , escape table , " ALTER COLUMN " , escape n , " TYPE " , showSqlType t , extra ] showAlter table (n, IsNull) = T.concat [ "ALTER TABLE " , escape table , " ALTER COLUMN " , escape n , " DROP NOT NULL" ] showAlter table (n, NotNull) = T.concat [ "ALTER TABLE " , escape table , " ALTER COLUMN " , escape n , " SET NOT NULL" ] showAlter table (_, Add' col) = T.concat [ "ALTER TABLE " , escape table , " ADD COLUMN " , showColumn col ] showAlter table (n, Drop _) = T.concat [ "ALTER TABLE " , escape table , " DROP COLUMN " , escape n ] showAlter table (n, Default s) = T.concat [ "ALTER TABLE " , escape table , " ALTER COLUMN " , escape n , " SET DEFAULT " , s ] showAlter table (n, NoDefault) = T.concat [ "ALTER TABLE " , escape table , " ALTER COLUMN " , escape n , " DROP DEFAULT" ] showAlter table (n, Update' s) = T.concat [ "UPDATE " , escape table , " SET " , escape n , "=" , s , " WHERE " , escape n , " IS NULL" ] showAlter table (reftable, AddReference fkeyname t2 id2) = T.concat [ "ALTER TABLE " , escape table , " ADD CONSTRAINT " , escape fkeyname , " FOREIGN KEY(" , T.intercalate "," $ map escape t2 , ") REFERENCES " , escape reftable , "(" , T.intercalate "," id2 , ")" ] showAlter table (_, DropReference cname) = T.concat [ "ALTER TABLE " , escape table , " DROP CONSTRAINT " , escape cname ] -- | Get the SQL string for the table that a PeristEntity represents. -- Useful for raw SQL queries. tableName :: (PersistEntity record) => record -> Text tableName = escape . tableDBName -- | Get the SQL string for the field that an EntityField represents. -- Useful for raw SQL queries. fieldName :: (PersistEntity record) => EntityField record typ -> Text fieldName = escape . fieldDBName escape :: DBName -> Text escape (DBName s) = T.pack $ '"' : go (T.unpack s) ++ "\"" where go "" = "" go ('"':xs) = "\"\"" ++ go xs go (x:xs) = x : go xs -- | Information required to connect to a PostgreSQL database -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withPostgresqlPool'. data PostgresConf = PostgresConf { pgConnStr :: ConnectionString -- ^ The connection string. , pgPoolSize :: Int -- ^ How many connections should be held in the connection pool. } deriving (Show, Read, Data, Typeable) instance FromJSON PostgresConf where parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $ flip (withObject "PostgresConf") v $ \o -> do database <- o .: "database" host <- o .: "host" port <- o .:? "port" .!= 5432 user <- o .: "user" password <- o .: "password" pool <- o .: "poolsize" let ci = PG.ConnectInfo { PG.connectHost = host , PG.connectPort = port , PG.connectUser = user , PG.connectPassword = password , PG.connectDatabase = database } cstr = PG.postgreSQLConnectionString ci return $ PostgresConf cstr pool instance PersistConfig PostgresConf where type PersistConfigBackend PostgresConf = SqlPersistT type PersistConfigPool PostgresConf = ConnectionPool createPoolConfig (PostgresConf cs size) = runNoLoggingT $ createPostgresqlPool cs size -- FIXME runPool _ = runSqlPool loadConfig = parseJSON applyEnv c0 = do env <- getEnvironment return $ addUser env $ addPass env $ addDatabase env $ addPort env $ addHost env c0 where addParam param val c = c { pgConnStr = B8.concat [pgConnStr c, " ", param, "='", pgescape val, "'"] } pgescape = B8.pack . go where go ('\'':rest) = '\\' : '\'' : go rest go ('\\':rest) = '\\' : '\\' : go rest go ( x :rest) = x : go rest go [] = [] maybeAddParam param envvar env = maybe id (addParam param) $ lookup envvar env addHost = maybeAddParam "host" "PGHOST" addPort = maybeAddParam "port" "PGPORT" addUser = maybeAddParam "user" "PGUSER" addPass = maybeAddParam "password" "PGPASS" addDatabase = maybeAddParam "dbname" "PGDATABASE" udToPair :: UniqueDef -> (DBName, [DBName]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) mockMigrate :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do case partitionEithers [] of ([], old'') -> return $ Right $ migrationText False old'' (errs, _) -> return $ Left errs where name = entityDB entity migrationText exists old'' = if not exists then createText newcols fdefs udspair else let (acs, ats) = getAlters allDefs entity (newcols, udspair) old' acs' = map (AlterColumn name) acs ats' = map (AlterTable name) ats in acs' ++ ats' where old' = partitionEithers old'' (newcols', udefs, fdefs) = mkColumns allDefs entity newcols = filter (not . safeToRemove entity . cName) newcols' udspair = map udToPair udefs -- Check for table existence if there are no columns, workaround -- for https://github.com/yesodweb/persistent/issues/152 createText newcols fdefs udspair = (addTable newcols entity) : uniques ++ references ++ foreignsAlt where uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> getAddReference allDefs name refTblName cname (cReference c)) $ filter (isJust . cReference) newcols foreignsAlt = flip map fdefs (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields))) -- | Mock a migration even when the database is not present. -- This function performs the same functionality of 'printMigration' -- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do smap <- newIORef $ Map.empty let sqlbackend = SqlBackend { connPrepare = \_ -> do return Statement { stmtFinalize = return () , stmtReset = return () , stmtExecute = undefined , stmtQuery = \_ -> return $ return () }, connInsertManySql = Nothing, connInsertSql = undefined, connUpsertSql = Nothing, connPutManySql = Nothing, connStmtMap = smap, connClose = undefined, connMigrateSql = mockMigrate, connBegin = undefined, connCommit = undefined, connRollback = undefined, connEscapeName = escape, connNoLimit = undefined, connRDBMS = undefined, connLimitOffset = undefined, connLogFunc = undefined, connMaxParams = Nothing, connRepsertManySql = Nothing } result = runReaderT $ runWriterT $ runWriterT mig resp <- result sqlbackend mapM_ T.putStrLn $ map snd $ snd resp putManySql :: EntityDef -> Int -> Text putManySql ent n = putManySql' conflictColumns fields ent n where fields = entityFields ent conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent) repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' conflictColumns fields ent n where fields = keyAndEntityFields ent conflictColumns = escape . fieldDB <$> entityKeyFields ent putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns fields ent n = q where fieldDbToText = escape . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] table = escape . entityDB $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields q = T.concat [ "INSERT INTO " , table , Util.parenWrapped columns , " VALUES " , Util.commaSeparated . replicate n . Util.parenWrapped . Util.commaSeparated $ placeholders , " ON CONFLICT " , Util.parenWrapped . Util.commaSeparated $ conflictColumns , " DO UPDATE SET " , Util.commaSeparated updates ] -- | Enable a Postgres extension. See https://www.postgresql.org/docs/current/static/contrib.html -- for a list. migrateEnableExtension :: Text -> Migration migrateEnableExtension extName = WriterT $ WriterT $ do res :: [Single Int] <- rawSql "SELECT COUNT(*) FROM pg_catalog.pg_extension WHERE extname = ?" [PersistText extName] if res == [Single 0] then return (((), []) , [(False, "CREATe EXTENSION \"" <> extName <> "\"")]) else return (((), []), []) persistent-postgresql-2.10.1.2/Database/Persist/Postgresql/JSON.hs0000644000000000000000000003041713577776556023170 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Filter operators for JSON values added to PostgreSQL 9.4 module Database.Persist.Postgresql.JSON ( (@>.) , (<@.) , (?.) , (?|.) , (?&.) , Value() ) where import Data.Aeson (FromJSON, ToJSON, Value, encode, eitherDecodeStrict) import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding as TE (encodeUtf8) import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..)) import Database.Persist.Sql (PersistFieldSql(..), SqlType(..)) import Database.Persist.Types (FilterValue(..)) infix 4 @>., <@., ?., ?|., ?&. -- | This operator checks inclusion of the JSON value -- on the right hand side in the JSON value on the left -- hand side. -- -- === __Objects__ -- -- An empty Object matches any object -- -- @ -- {} \@> {} == True -- {"a":1,"b":false} \@> {} == True -- @ -- -- Any key-value will be matched top-level -- -- @ -- {"a":1,"b":{"c":true"}} \@> {"a":1} == True -- {"a":1,"b":{"c":true"}} \@> {"b":1} == False -- {"a":1,"b":{"c":true"}} \@> {"b":{}} == True -- {"a":1,"b":{"c":true"}} \@> {"c":true} == False -- {"a":1,"b":{"c":true"}} \@> {"b":{c":true}} == True -- @ -- -- === __Arrays__ -- -- An empty Array matches any array -- -- @ -- [] \@> [] == True -- [1,2,"hi",false,null] \@> [] == True -- @ -- -- Any array has to be a sub-set. -- Any object or array will also be compared as being a subset of. -- -- @ -- [1,2,"hi",false,null] \@> [1] == True -- [1,2,"hi",false,null] \@> [null,"hi"] == True -- [1,2,"hi",false,null] \@> ["hi",true] == False -- [1,2,"hi",false,null] \@> ["hi",2,null,false,1] == True -- [1,2,"hi",false,null] \@> [1,2,"hi",false,null,{}] == False -- @ -- -- Arrays and objects inside arrays match the same way they'd -- be matched as being on their own. -- -- @ -- [1,"hi",[false,3],{"a":[null]}] \@> [{}] == True -- [1,"hi",[false,3],{"a":[null]}] \@> [{"a":[]}] == True -- [1,"hi",[false,3],{"a":[null]}] \@> [{"b":[null]}] == False -- [1,"hi",[false,3],{"a":[null]}] \@> [[]] == True -- [1,"hi",[false,3],{"a":[null]}] \@> [[3]] == True -- [1,"hi",[false,3],{"a":[null]}] \@> [[true,3]] == False -- @ -- -- A regular value has to be a member -- -- @ -- [1,2,"hi",false,null] \@> 1 == True -- [1,2,"hi",false,null] \@> 5 == False -- [1,2,"hi",false,null] \@> "hi" == True -- [1,2,"hi",false,null] \@> false == True -- [1,2,"hi",false,null] \@> "2" == False -- @ -- -- An object will never match with an array -- -- @ -- [1,2,"hi",[false,3],{"a":null}] \@> {} == False -- [1,2,"hi",[false,3],{"a":null}] \@> {"a":null} == False -- @ -- -- === __Other values__ -- -- For any other JSON values the `(\@>.)` operator -- functions like an equivalence operator. -- -- @ -- "hello" \@> "hello" == True -- "hello" \@> \"Hello" == False -- "hello" \@> "h" == False -- "hello" \@> {"hello":1} == False -- "hello" \@> ["hello"] == False -- -- 5 \@> 5 == True -- 5 \@> 5.00 == True -- 5 \@> 1 == False -- 5 \@> 7 == False -- 12345 \@> 1234 == False -- 12345 \@> 2345 == False -- 12345 \@> "12345" == False -- 12345 \@> [1,2,3,4,5] == False -- -- true \@> true == True -- true \@> false == False -- false \@> true == False -- true \@> "true" == False -- -- null \@> null == True -- null \@> 23 == False -- null \@> "null" == False -- null \@> {} == False -- @ -- -- @since 2.8.2 (@>.) :: EntityField record Value -> Value -> Filter record (@>.) field val = Filter field (FilterValue val) $ BackendSpecificFilter " @> " -- | Same as '@>.' except the inclusion check is reversed. -- i.e. is the JSON value on the left hand side included -- in the JSON value of the right hand side. -- -- @since 2.8.2 (<@.) :: EntityField record Value -> Value -> Filter record (<@.) field val = Filter field (FilterValue val) $ BackendSpecificFilter " <@ " -- | This operator takes a column and a string to find a -- top-level key/field in an object. -- -- @column ?. string@ -- -- N.B. This operator might have some unexpected interactions -- with non-object values. Please reference the examples. -- -- === __Objects__ -- -- @ -- {"a":null} ? "a" == True -- {"test":false,"a":500} ? "a" == True -- {"b":{"a":[]}} ? "a" == False -- {} ? "a" == False -- {} ? "{}" == False -- {} ? "" == False -- {"":9001} ? "" == True -- @ -- -- === __Arrays__ -- -- This operator will match an array if the string to be matched -- is an element of that array, but nothing else. -- -- @ -- ["a"] ? "a" == True -- [["a"]] ? "a" == False -- [9,false,"1",null] ? "1" == True -- [] ? "[]" == False -- [{"a":true}] ? "a" == False -- @ -- -- === __Other values__ -- -- This operator functions like an equivalence operator on strings only. -- Any other value does not match. -- -- @ -- "a" ? "a" == True -- "1" ? "1" == True -- "ab" ? "a" == False -- 1 ? "1" == False -- null ? "null" == False -- true ? "true" == False -- 1.5 ? "1.5" == False -- @ -- -- @since 2.10.0 (?.) :: EntityField record Value -> Text -> Filter record (?.) = jsonFilter " ?? " -- | This operator takes a column and a list of strings to -- test whether ANY of the elements of the list are top -- level fields in an object. -- -- @column ?|. list@ -- -- /N.B. An empty list __will never match anything__. Also, this/ -- /operator might have some unexpected interactions with/ -- /non-object values. Please reference the examples./ -- -- === __Objects__ -- -- @ -- {"a":null} ?| ["a","b","c"] == True -- {"test":false,"a":500} ?| ["a","b","c"] == True -- {} ?| ["a","{}"] == False -- {"b":{"a":[]}} ?| ["a","c"] == False -- {"b":{"a":[]},"test":null} ?| [] == False -- @ -- -- === __Arrays__ -- -- This operator will match an array if __any__ of the elements -- of the list are matching string elements of the array. -- -- @ -- ["a"] ?| ["a","b","c"] == True -- [["a"]] ?| ["a","b","c"] == False -- [9,false,"1",null] ?| ["a","false"] == False -- [] ?| ["a","b","c"] == False -- [] ?| [] == False -- [{"a":true}] ?| ["a","b","c"] == False -- [null,4,"b",[]] ?| ["a","b","c"] == True -- @ -- -- === __Other values__ -- -- This operator functions much like an equivalence operator -- on strings only. If a string matches with __any__ element of -- the given list, the comparison matches. No other values match. -- -- @ -- "a" ?| ["a","b","c"] == True -- "1" ?| ["a","b","1"] == True -- "ab" ?| ["a","b","c"] == False -- 1 ?| ["a","1"] == False -- null ?| ["a","null"] == False -- true ?| ["a","true"] == False -- "a" ?| [] == False -- @ -- -- @since 2.10.0 (?|.) :: EntityField record Value -> [Text] -> Filter record (?|.) field = jsonFilter " ??| " field . PostgresArray -- | This operator takes a column and a list of strings to -- test whether ALL of the elements of the list are top -- level fields in an object. -- -- @column ?&. list@ -- -- /N.B. An empty list __will match anything__. Also, this/ -- /operator might have some unexpected interactions with/ -- /non-object values. Please reference the examples./ -- -- === __Objects__ -- -- @ -- {"a":null} ?& ["a"] == True -- {"a":null} ?& ["a","a"] == True -- {"test":false,"a":500} ?& ["a"] == True -- {"test":false,"a":500} ?& ["a","b"] == False -- {} ?& ["{}"] == False -- {"b":{"a":[]}} ?& ["a"] == False -- {"b":{"a":[]},"c":false} ?& ["a","c"] == False -- {"a":1,"b":2,"c":3,"d":4} ?& ["b","d"] == True -- {} ?& [] == True -- {"b":{"a":[]},"test":null} ?& [] == True -- @ -- -- === __Arrays__ -- -- This operator will match an array if __all__ of the elements -- of the list are matching string elements of the array. -- -- @ -- ["a"] ?& ["a"] == True -- ["a"] ?& ["a","a"] == True -- [["a"]] ?& ["a"] == False -- ["a","b","c"] ?& ["a","b","d"] == False -- [9,"false","1",null] ?& ["1","false"] == True -- [] ?& ["a","b"] == False -- [{"a":true}] ?& ["a"] == False -- ["a","b","c","d"] ?& ["b","c","d"] == True -- [null,4,{"test":false}] ?& [] == True -- [] ?& [] == True -- @ -- -- === __Other values__ -- -- This operator functions much like an equivalence operator -- on strings only. If a string matches with all elements of -- the given list, the comparison matches. -- -- @ -- "a" ?& ["a"] == True -- "1" ?& ["a","1"] == False -- "b" ?& ["b","b"] == True -- "ab" ?& ["a","b"] == False -- 1 ?& ["1"] == False -- null ?& ["null"] == False -- true ?& ["true"] == False -- 31337 ?& [] == True -- true ?& [] == True -- null ?& [] == True -- @ -- -- @since 2.10.0 (?&.) :: EntityField record Value -> [Text] -> Filter record (?&.) field = jsonFilter " ??& " field . PostgresArray jsonFilter :: PersistField a => Text -> EntityField record Value -> a -> Filter record jsonFilter op field a = Filter field (UnsafeValue a) $ BackendSpecificFilter op ----------------- -- AESON VALUE -- ----------------- instance PersistField Value where toPersistValue = toPersistValueJsonB fromPersistValue = fromPersistValueJsonB instance PersistFieldSql Value where sqlType = sqlTypeJsonB -- FIXME: PersistText might be a bit more efficient, -- but needs testing/profiling before changing it. -- (When entering into the DB the type isn't as important as fromPersistValue) toPersistValueJsonB :: ToJSON a => a -> PersistValue toPersistValueJsonB = PersistDbSpecific . BSL.toStrict . encode fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a fromPersistValueJsonB (PersistText t) = case eitherDecodeStrict $ TE.encodeUtf8 t of Left str -> Left $ fromPersistValueParseError "FromJSON" t $ T.pack str Right v -> Right v fromPersistValueJsonB (PersistByteString bs) = case eitherDecodeStrict bs of Left str -> Left $ fromPersistValueParseError "FromJSON" bs $ T.pack str Right v -> Right v fromPersistValueJsonB x = Left $ fromPersistValueError "FromJSON" "string or bytea" x -- Constraints on the type might not be necessary, -- but better to leave them in. sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType sqlTypeJsonB _ = SqlOther "JSONB" fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". -> PersistValue -- ^ Incorrect value -> Text -- ^ Error message fromPersistValueError haskellType databaseType received = T.concat [ "Failed to parse Haskell type `" , haskellType , "`; expected " , databaseType , " from database, but received: " , T.pack (show received) , ". Potential solution: Check that your database schema matches your Persistent model definitions." ] fromPersistValueParseError :: (Show a) => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" -> a -- ^ Received value -> Text -- ^ Additional error -> Text -- ^ Error message fromPersistValueParseError haskellType received err = T.concat [ "Failed to parse Haskell type `" , haskellType , "`, but received " , T.pack (show received) , " | with error: " , err ] newtype PostgresArray a = PostgresArray [a] instance PersistField a => PersistField (PostgresArray a) where toPersistValue (PostgresArray ts) = PersistArray $ toPersistValue <$> ts fromPersistValue (PersistArray as) = PostgresArray <$> traverse fromPersistValue as fromPersistValue wat = Left $ fromPersistValueError "PostgresArray" "array" wat persistent-postgresql-2.10.1.2/test/main.hs0000644000000000000000000001327613603714112016770 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} import PgInit import Data.Aeson import qualified Data.ByteString as BS import Data.IntMap (IntMap) import Data.Fixed import qualified Data.Text as T import Data.Time import Test.QuickCheck -- FIXME: should probably be used? -- import qualified ArrayAggTest import qualified CompositeTest import qualified CustomPersistFieldTest import qualified CustomPrimaryKeyReferenceTest import qualified DataTypeTest import qualified EmbedOrderTest import qualified EmbedTest import qualified EmptyEntityTest import qualified EquivalentTypeTestPostgres import qualified HtmlTest import qualified JSONTest import qualified LargeNumberTest import qualified MaxLenTest import qualified MigrationColumnLengthTest import qualified MigrationOnlyTest import qualified MpsNoPrefixTest import qualified PersistentTest import qualified PersistUniqueTest import qualified PrimaryTest import qualified RawSqlTest import qualified ReadWriteTest import qualified Recursive import qualified RenameTest import qualified SumTypeTest import qualified TransactionLevelTest import qualified TreeTest import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest type Tuple = (,) -- Test lower case names share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| DataTypeTable no-json text Text textMaxLen Text maxlen=100 bytes ByteString bytesTextTuple (Tuple ByteString Text) bytesMaxLen ByteString maxlen=100 int Int intList [Int] intMap (IntMap Int) double Double bool Bool day Day pico Pico time TimeOfDay utc UTCTime jsonb Value |] instance Arbitrary DataTypeTable where arbitrary = DataTypeTable <$> arbText -- text <*> (T.take 100 <$> arbText) -- textManLen <*> arbitrary -- bytes <*> liftA2 (,) arbitrary arbText -- bytesTextTuple <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen <*> arbitrary -- int <*> arbitrary -- intList <*> arbitrary -- intMap <*> arbitrary -- double <*> arbitrary -- bool <*> arbitrary -- day <*> arbitrary -- pico <*> (arbitrary) -- utc <*> (truncateUTCTime =<< arbitrary) -- utc <*> arbitrary -- value setup :: MonadIO m => Migration -> ReaderT SqlBackend m () setup migration = do printMigration migration runMigrationUnsafe migration main :: IO () main = do runConn $ do mapM_ setup [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , EmbedTest.embedMigrate , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate , UniqueTest.uniqueMigrate , MaxLenTest.maxlenMigrate , Recursive.recursiveMigrate , CompositeTest.compositeMigrate , TreeTest.treeMigrate , PersistUniqueTest.migration , RenameTest.migration , CustomPersistFieldTest.customFieldMigrate , PrimaryTest.migration , CustomPrimaryKeyReferenceTest.migration , MigrationColumnLengthTest.migration , TransactionLevelTest.migration ] PersistentTest.cleanDB hspec $ do RenameTest.specsWith db DataTypeTest.specsWith db (Just (runMigrationSilent dataTypeMigrate)) [ TestFn "text" dataTypeTableText , TestFn "textMaxLen" dataTypeTableTextMaxLen , TestFn "bytes" dataTypeTableBytes , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen , TestFn "int" dataTypeTableInt , TestFn "intList" dataTypeTableIntList , TestFn "intMap" dataTypeTableIntMap , TestFn "bool" dataTypeTableBool , TestFn "day" dataTypeTableDay , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) , TestFn "jsonb" dataTypeTableJsonb ] [ ("pico", dataTypeTablePico) ] dataTypeTableDouble HtmlTest.specsWith db (Just (runMigrationSilent HtmlTest.htmlMigrate)) EmbedTest.specsWith db EmbedOrderTest.specsWith db LargeNumberTest.specsWith db UniqueTest.specsWith db MaxLenTest.specsWith db Recursive.specsWith db SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) MigrationOnlyTest.specsWith db (Just $ runMigrationSilent MigrationOnlyTest.migrateAll1 >> runMigrationSilent MigrationOnlyTest.migrateAll2 ) PersistentTest.specsWith db ReadWriteTest.specsWith db PersistentTest.filterOrSpecs db RawSqlTest.specsWith db UpsertTest.specsWith db UpsertTest.Don'tUpdateNull UpsertTest.UpsertPreserveOldKey MpsNoPrefixTest.specsWith db EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) CompositeTest.specsWith db TreeTest.specsWith db PersistUniqueTest.specsWith db PrimaryTest.specsWith db CustomPersistFieldTest.specsWith db CustomPrimaryKeyReferenceTest.specsWith db MigrationColumnLengthTest.specsWith db EquivalentTypeTestPostgres.specs TransactionLevelTest.specsWith db JSONTest.specs CustomConstraintTest.specs db -- FIXME: not used, probably should? -- ArrayAggTest.specs db persistent-postgresql-2.10.1.2/test/PgInit.hs0000644000000000000000000000744213577776556017272 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PgInit ( runConn , MonadIO , persistSettings , MkPersistSettings (..) , db , BackendKey(..) , GenerateKey(..) -- re-exports , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql , module Database.Persist , module Database.Persist.Sql.Raw.QQ , module Init , module Test.Hspec , module Test.HUnit , BS.ByteString , Int32, Int64 , liftIO , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase , SomeException , Text , TestFn(..) ) where import Init ( TestFn(..), truncateTimeOfDay, truncateUTCTime , truncateToMicro, arbText, liftA2, GenerateKey(..) , (@/=), (@==), (==@), MonadFail , assertNotEqual, assertNotEmpty, assertEmpty, asIO , isTravis, RunDb ) -- re-exports import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) import Control.Monad.Trans.Reader import Data.Aeson (Value(..)) import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) import Database.Persist.Sql.Raw.QQ import Database.Persist.Postgresql.JSON() import Test.Hspec import Test.QuickCheck.Instances () -- testing import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) import Test.QuickCheck import Control.Monad (unless, (>=>)) import Control.Monad.IO.Class import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import Data.Int (Int32, Int64) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import System.Environment (getEnvironment) import System.Log.FastLogger (fromLogStr) import Database.Persist import Database.Persist.Postgresql import Database.Persist.Sql import Database.Persist.TH () _debugOn :: Bool _debugOn = False dockerPg :: IO (Maybe BS.ByteString) dockerPg = do env <- liftIO getEnvironment return $ case lookup "POSTGRES_NAME" env of Just _name -> Just "postgres" -- /persistent/postgres _ -> Nothing persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () runConn f = do travis <- liftIO isTravis let debugPrint = not travis && _debugOn let printDebug = if debugPrint then print . fromLogStr else void . return flip runLoggingT (\_ _ _ s -> printDebug s) $ do _ <- if travis then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f else do host <- fromMaybe "localhost" <$> liftIO dockerPg withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f return () db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do runResourceT $ runConn $ actions >> transactionUndo instance Arbitrary Value where arbitrary = frequency [ (1, pure Null) , (1, Bool <$> arbitrary) , (2, Number <$> arbitrary) , (2, String <$> arbText) , (3, Array <$> limitIt 4 arbitrary) , (3, Object <$> arbObject) ] where limitIt i x = sized $ \n -> do let m = if n > i then i else n resize m x arbObject = limitIt 4 -- Recursion can make execution divergent $ fmap HM.fromList -- HashMap -> [(,)] . listOf -- [(,)] -> (,) . liftA2 (,) arbText -- (,) -> Text and Value $ limitIt 4 arbitrary -- Again, precaution against divergent recursion. persistent-postgresql-2.10.1.2/test/ArrayAggTest.hs0000644000000000000000000000360713603712257020406 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module ArrayAggTest where import Control.Monad.IO.Class (MonadIO) import Data.Aeson import Data.List (sort) import qualified Data.Text as T import Test.Hspec.Expectations () import PersistentTestModels import PgInit share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| TestValue json Value |] cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m () cleanDB = deleteWhere ([] :: [Filter TestValue]) emptyArr :: Value emptyArr = toJSON ([] :: [Value]) specs :: RunDb SqlBackend IO -> Spec specs runDb = do describe "rawSql/array_agg" $ do let runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion runArrayAggTest dbField expected = runDb $ do void $ insertMany [ UserPT "a" $ Just "b" , UserPT "c" $ Just "d" , UserPT "e" Nothing , UserPT "g" $ Just "h" ] escape <- ((. DBName) . connEscapeName) `fmap` ask let query = T.concat [ "SELECT array_agg(", escape dbField, ") " , "FROM ", escape "UserPT" ] [Single xs] <- rawSql query [] liftIO $ sort xs @?= expected it "works for [Text]" $ do runArrayAggTest "ident" ["a", "c", "e", "g" :: Text] it "works for [Maybe Text]" $ do runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text] persistent-postgresql-2.10.1.2/test/EquivalentTypeTestPostgres.hs0000644000000000000000000000260613603712257023415 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module EquivalentTypeTestPostgres (specs) where import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Text as T import Database.Persist.TH import PgInit share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| EquivalentType sql=equivalent_types field1 Int field2 T.Text sqltype=text field3 T.Text sqltype=us_postal_code deriving Eq Show |] share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| EquivalentType2 sql=equivalent_types field1 Int field2 T.Text field3 T.Text sqltype=us_postal_code deriving Eq Show |] specs :: Spec specs = describe "doesn't migrate equivalent types" $ do it "works" $ asIO $ runResourceT $ runConn $ do _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code CASCADE" [] _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" [] _ <- runMigrationSilent migrateAll1 xs <- getMigration migrateAll2 liftIO $ xs @?= [] persistent-postgresql-2.10.1.2/test/JSONTest.hs0000644000000000000000000004510313603712257017457 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module JSONTest where import Control.Monad.IO.Class (MonadIO) import Data.Aeson import qualified Data.Vector as V (fromList) import Test.HUnit (assertBool) import Test.Hspec.Expectations () import Database.Persist import Database.Persist.Postgresql.JSON import PgInit share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| TestValue json Value deriving Show |] cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m () cleanDB = deleteWhere ([] :: [Filter TestValue]) emptyArr :: Value emptyArr = toJSON ([] :: [Value]) insert' :: (MonadIO m, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) => Value -> ReaderT backend m (Key TestValue) insert' = insert . TestValue (=@=) :: MonadIO m => String -> Bool -> m () s =@= b = liftIO $ assertBool s b matchKeys :: (Show record, Show (Key record), MonadIO m, Eq (Key record)) => String -> [Key record] -> [Entity record] -> m () matchKeys s ys xs = do msg1 =@= (xLen == yLen) forM_ ys $ \y -> msg2 y =@= (y `elem` ks) where ks = entityKey <$> xs xLen = length xs yLen = length ys msg1 = mconcat [ s, "\nexpected: ", show yLen , "\n but got: ", show xLen , "\n[xs: ", show xs , ", ys: ", show ys, "]" ] msg2 y = mconcat [ s, ": " , "key \"", show y , "\" not in result:\n ", show ks ] specs :: Spec specs = describe "postgresql's JSON operators behave" $ do it "migrate, clean table, insert values and check queries" $ asIO $ runConn $ do runMigration jsonTestMigrate cleanDB liftIO $ putStrLn "\n- - - - - Inserting JSON values - - - - -\n" nullK <- insert' Null boolTK <- insert' $ Bool True boolFK <- insert' $ toJSON False num0K <- insert' $ Number 0 num1K <- insert' $ Number 1 numBigK <- insert' $ toJSON (1234567890 :: Int) numFloatK <- insert' $ Number 0.0 numSmallK <- insert' $ Number 0.0000000000000000123 numFloat2K <- insert' $ Number 1.5 -- numBigFloatK will turn into 9876543210.123457 because JSON numBigFloatK <- insert' $ toJSON (9876543210.123456789 :: Double) strNullK <- insert' $ String "" strObjK <- insert' $ String "{}" strArrK <- insert' $ String "[]" strAK <- insert' $ String "a" strTestK <- insert' $ toJSON ("testing" :: Text) str2K <- insert' $ String "2" strFloatK <- insert' $ String "0.45876" arrNullK <- insert' $ Array $ V.fromList [] arrListK <- insert' $ toJSON ([emptyArr,emptyArr,toJSON [emptyArr,emptyArr]]) arrList2K <- insert' $ toJSON [emptyArr,toJSON [Number 3,Bool False],toJSON [emptyArr,toJSON [Object mempty]]] arrFilledK <- insert' $ toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"]] objNullK <- insert' $ Object mempty objTestK <- insert' $ object ["test" .= Null, "test1" .= String "no"] objDeepK <- insert' $ object ["c" .= Number 24.986, "foo" .= object ["deep1" .= Bool True]] ---------------------------------------------------------------------------------------- liftIO $ putStrLn "\n- - - - - Starting @> tests - - - - -\n" -- An empty Object matches any object selectList [TestValueJson @>. Object mempty] [] >>= matchKeys "1" [objNullK,objTestK,objDeepK] -- {"test":null,"test1":"no"} @> {"test":null} == True selectList [TestValueJson @>. object ["test" .= Null]] [] >>= matchKeys "2" [objTestK] -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{}} == True selectList [TestValueJson @>. object ["foo" .= object []]] [] >>= matchKeys "3" [objDeepK] -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":"nope"} == False selectList [TestValueJson @>. object ["foo" .= String "nope"]] [] >>= matchKeys "4" [] -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{"deep1":true}} == True selectList [TestValueJson @>. (object ["foo" .= object ["deep1" .= True]])] [] >>= matchKeys "5" [objDeepK] -- {"c":24.986,"foo":{"deep1":true"}} @> {"deep1":true} == False selectList [TestValueJson @>. object ["deep1" .= True]] [] >>= matchKeys "6" [] -- An empty Array matches any array selectList [TestValueJson @>. emptyArr] [] >>= matchKeys "7" [arrNullK,arrListK,arrList2K,arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [4] == True selectList [TestValueJson @>. toJSON [4 :: Int]] [] >>= matchKeys "8" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"b"] == True selectList [TestValueJson @>. toJSON [Null, String "b"]] [] >>= matchKeys "9" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"d"] == False selectList [TestValueJson @>. toJSON [emptyArr, String "d"]] [] >>= matchKeys "10" [] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[],"b",{"test":[null],"test2":"yes"},4,null,{}] == True selectList [TestValueJson @>. toJSON [emptyArr, String "b", object [ "test" .= [Null], "test2" .= String "yes"], Number 4, Null, Object mempty]] [] >>= matchKeys "11" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == False selectList [TestValueJson @>. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] [] >>= matchKeys "12" [] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{}] == True selectList [TestValueJson @>. toJSON [Object mempty]] [] >>= matchKeys "13" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test":[]}] == True selectList [TestValueJson @>. toJSON [object ["test" .= emptyArr]]] [] >>= matchKeys "14" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test1":[null]}] == False selectList [TestValueJson @>. toJSON [object ["test1" .= [Null]]]] [] >>= matchKeys "15" [] -- [[],[],[[],[]]] @> [[]] == True -- [[],[3,false],[[],[{}]]] @> [[]] == True -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[]] == True selectList [TestValueJson @>. toJSON [emptyArr]] [] >>= matchKeys "16" [arrListK,arrList2K,arrFilledK] -- [[],[3,false],[[],[{}]]] @> [[3]] == True selectList [TestValueJson @>. toJSON [[3 :: Int]]] [] >>= matchKeys "17" [arrList2K] -- [[],[3,false],[[],[{}]]] @> [[true,3]] == False selectList [TestValueJson @>. toJSON [[Bool True, Number 3]]] [] >>= matchKeys "18" [] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True selectList [TestValueJson @>. Number 4] [] >>= matchKeys "19" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True selectList [TestValueJson @>. Number 99] [] >>= matchKeys "20" [] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "b" == True selectList [TestValueJson @>. String "b"] [] >>= matchKeys "21" [arrFilledK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "{}" == False selectList [TestValueJson @>. String "{}"] [] >>= matchKeys "22" [strObjK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> {"test":[null],"test2":"yes"} == False selectList [TestValueJson @>. object [ "test" .= [Null], "test2" .= String "yes"]] [] >>= matchKeys "23" [] -- "testing" @> "testing" == True selectList [TestValueJson @>. String "testing"] [] >>= matchKeys "24" [strTestK] -- "testing" @> "Testing" == False selectList [TestValueJson @>. String "Testing"] [] >>= matchKeys "25" [] -- "testing" @> "test" == False selectList [TestValueJson @>. String "test"] [] >>= matchKeys "26" [] -- "testing" @> {"testing":1} == False selectList [TestValueJson @>. object ["testing" .= Number 1]] [] >>= matchKeys "27" [] -- 1 @> 1 == True selectList [TestValueJson @>. toJSON (1 :: Int)] [] >>= matchKeys "28" [num1K] -- 0 @> 0.0 == True -- 0.0 @> 0.0 == True selectList [TestValueJson @>. toJSON (0.0 :: Double)] [] >>= matchKeys "29" [num0K,numFloatK] -- 1234567890 @> 123456789 == False selectList [TestValueJson @>. toJSON (123456789 :: Int)] [] >>= matchKeys "30" [] -- 1234567890 @> 234567890 == False selectList [TestValueJson @>. toJSON (234567890 :: Int)] [] >>= matchKeys "31" [] -- 1 @> "1" == False selectList [TestValueJson @>. String "1"] [] >>= matchKeys "32" [] -- 1234567890 @> [1,2,3,4,5,6,7,8,9,0] == False selectList [TestValueJson @>. toJSON ([1,2,3,4,5,6,7,8,9,0] :: [Int])] [] >>= matchKeys "33" [] -- true @> true == True -- false @> true == False selectList [TestValueJson @>. toJSON True] [] >>= matchKeys "34" [boolTK] -- false @> false == True -- true @> false == False selectList [TestValueJson @>. Bool False] [] >>= matchKeys "35" [boolFK] -- true @> "true" == False selectList [TestValueJson @>. String "true"] [] >>= matchKeys "36" [] -- null @> null == True selectList [TestValueJson @>. Null] [] >>= matchKeys "37" [nullK,arrFilledK] -- null @> "null" == False selectList [TestValueJson @>. String "null"] [] >>= matchKeys "38" [] ---------------------------------------------------------------------------------------- liftIO $ putStrLn "\n- - - - - Starting <@ tests - - - - -\n" -- {} <@ {"test":null,"test1":"no","blabla":[]} == True -- {"test":null,"test1":"no"} <@ {"test":null,"test1":"no","blabla":[]} == True selectList [TestValueJson <@. object ["test" .= Null, "test1" .= String "no", "blabla" .= emptyArr]] [] >>= matchKeys "39" [objNullK,objTestK] -- [] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True -- null <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True -- false <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True selectList [TestValueJson <@. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] [] >>= matchKeys "40" [arrNullK,arrFilledK,boolFK,nullK] -- "a" <@ "a" == True selectList [TestValueJson <@. String "a"] [] >>= matchKeys "41" [strAK] -- 9876543210.123457 <@ 9876543210.123457 == False selectList [TestValueJson <@. Number 9876543210.123457] [] >>= matchKeys "42" [numBigFloatK] -- 9876543210.123457 <@ 9876543210.123456789 == False selectList [TestValueJson <@. Number 9876543210.123456789] [] >>= matchKeys "43" [] -- null <@ null == True selectList [TestValueJson <@. Null] [] >>= matchKeys "44" [nullK] ---------------------------------------------------------------------------------------- liftIO $ putStrLn "\n- - - - - Starting ? tests - - - - -\n" arrList3K <- insert' $ toJSON [toJSON [String "a"], Number 1] arrList4K <- insert' $ toJSON [String "a", String "b", String "c", String "d"] objEmptyK <- insert' $ object ["" .= Number 9001] objFullK <- insert' $ object ["a" .= Number 1, "b" .= Number 2, "c" .= Number 3, "d" .= Number 4] -- {"test":null,"test1":"no"} ? "test" == True -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "test" == False selectList [TestValueJson ?. "test"] [] >>= matchKeys "45" [objTestK] -- {"c":24.986,"foo":{"deep1":true"}} ? "deep1" == False selectList [TestValueJson ?. "deep1"] [] >>= matchKeys "46" [] -- "{}" ? "{}" == True -- {} ? "{}" == False selectList [TestValueJson ?. "{}"] [] >>= matchKeys "47" [strObjK] -- {} ? "" == False -- "" ? "" == True -- {"":9001} ? "" == True selectList [TestValueJson ?. ""] [] >>= matchKeys "48" [strNullK,objEmptyK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "b" == True selectList [TestValueJson ?. "b"] [] >>= matchKeys "49" [arrFilledK,arrList4K,objFullK] -- [["a"]] ? "a" == False -- "a" ? "a" == True -- ["a","b","c","d"] ? "a" == True -- {"a":1,"b":2,"c":3,"d":4} ? "a" == True selectList [TestValueJson ?. "a"] [] >>= matchKeys "50" [strAK,arrList4K,objFullK] -- "[]" ? "[]" == True -- [] ? "[]" == False selectList [TestValueJson ?. "[]"] [] >>= matchKeys "51" [strArrK] -- null ? "null" == False selectList [TestValueJson ?. "null"] [] >>= matchKeys "52" [] -- true ? "true" == False selectList [TestValueJson ?. "true"] [] >>= matchKeys "53" [] ---------------------------------------------------------------------------------------- liftIO $ putStrLn "\n- - - - - Starting ?| tests - - - - -\n" -- "a" ?| ["a","b","c"] == True -- [["a"],1] ?| ["a","b","c"] == False -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["a","b","c"] == True -- ["a","b","c","d"] ?| ["a","b","c"] == True -- {"a":1,"b":2,"c":3,"d":4} ?| ["a","b","c"] == True selectList [TestValueJson ?|. ["a","b","c"]] [] >>= matchKeys "54" [strAK,arrFilledK,objDeepK,arrList4K,objFullK] -- "{}" ?| ["{}"] == True -- {} ?| ["{}"] == False selectList [TestValueJson ?|. ["{}"]] [] >>= matchKeys "55" [strObjK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["test"] == False -- "testing" ?| ["test"] == False -- {"test":null,"test1":"no"} ?| ["test"] == True selectList [TestValueJson ?|. ["test"]] [] >>= matchKeys "56" [objTestK] -- {"c":24.986,"foo":{"deep1":true"}} ?| ["deep1"] == False selectList [TestValueJson ?|. ["deep1"]] [] >>= matchKeys "57" [] -- ANYTHING ?| [] == False selectList [TestValueJson ?|. []] [] >>= matchKeys "58" [] -- true ?| ["true","null","1"] == False -- null ?| ["true","null","1"] == False -- 1 ?| ["true","null","1"] == False selectList [TestValueJson ?|. ["true","null","1"]] [] >>= matchKeys "59" [] -- [] ?| ["[]"] == False -- "[]" ?| ["[]"] == True selectList [TestValueJson ?|. ["[]"]] [] >>= matchKeys "60" [strArrK] ---------------------------------------------------------------------------------------- liftIO $ putStrLn "\n- - - - - Starting ?& tests - - - - -\n" -- ANYTHING ?& [] == True selectList [TestValueJson ?&. []] [] >>= matchKeys "61" [ nullK , boolTK, boolFK , num0K, num1K, numBigK, numFloatK, numSmallK, numFloat2K, numBigFloatK , strNullK, strObjK, strArrK, strAK, strTestK, str2K, strFloatK , arrNullK, arrListK, arrList2K, arrFilledK , objNullK, objTestK, objDeepK , arrList3K, arrList4K , objEmptyK, objFullK ] -- "a" ?& ["a"] == True -- [["a"],1] ?& ["a"] == False -- ["a","b","c","d"] ?& ["a"] == True -- {"a":1,"b":2,"c":3,"d":4} ?& ["a"] == True selectList [TestValueJson ?&. ["a"]] [] >>= matchKeys "62" [strAK,arrList4K,objFullK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["b","c"] == False -- {"c":24.986,"foo":{"deep1":true"}} ?& ["b","c"] == False -- ["a","b","c","d"] ?& ["b","c"] == True -- {"a":1,"b":2,"c":3,"d":4} ?& ["b","c"] == True selectList [TestValueJson ?&. ["b","c"]] [] >>= matchKeys "63" [arrList4K,objFullK] -- {} ?& ["{}"] == False -- "{}" ?& ["{}"] == True selectList [TestValueJson ?&. ["{}"]] [] >>= matchKeys "64" [strObjK] -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["test"] == False -- "testing" ?& ["test"] == False -- {"test":null,"test1":"no"} ?& ["test"] == True selectList [TestValueJson ?&. ["test"]] [] >>= matchKeys "65" [objTestK] -- {"c":24.986,"foo":{"deep1":true"}} ?& ["deep1"] == False selectList [TestValueJson ?&. ["deep1"]] [] >>= matchKeys "66" [] -- "a" ?& ["a","e"] == False -- ["a","b","c","d"] ?& ["a","e"] == False -- {"a":1,"b":2,"c":3,"d":4} ?& ["a","e"] == False selectList [TestValueJson ?&. ["a","e"]] [] >>= matchKeys "67" [] -- [] ?& ["[]"] == False -- "[]" ?& ["[]"] == True selectList [TestValueJson ?&. ["[]"]] [] >>= matchKeys "68" [strArrK] -- THIS WILL FAIL IF THE IMPLEMENTATION USES -- @ '{null}' @ -- INSTEAD OF -- @ ARRAY['null'] @ -- null ?& ["null"] == False selectList [TestValueJson ?&. ["null"]] [] >>= matchKeys "69" [] -- [["a"],1] ?& ["1"] == False -- "1" ?& ["1"] == True selectList [TestValueJson ?&. ["1"]] [] >>= matchKeys "70" [] -- {} ?& [""] == False -- [] ?& [""] == False -- "" ?& [""] == True -- {"":9001} ?& [""] == True selectList [TestValueJson ?&. [""]] [] >>= matchKeys "71" [strNullK,objEmptyK] persistent-postgresql-2.10.1.2/test/CustomConstraintTest.hs0000644000000000000000000000606713606232107022225 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} module CustomConstraintTest where import PgInit import qualified Data.Text as T share [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] [persistLowerCase| CustomConstraint1 some_field Text deriving Show CustomConstraint2 cc_id CustomConstraint1Id constraint=custom_constraint deriving Show CustomConstraint3 -- | This will lead to a constraint with the name custom_constraint3_cc_id1_fkey cc_id1 CustomConstraint1Id cc_id2 CustomConstraint1Id deriving Show |] specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specs runDb = do describe "custom constraint used in migration" $ do it "custom constraint is actually created" $ runDb $ do runMigration customConstraintMigrate runMigration customConstraintMigrate -- run a second time to ensure the constraint isn't dropped let query = T.concat ["SELECT DISTINCT COUNT(*) " ,"FROM information_schema.constraint_column_usage ccu, " ,"information_schema.key_column_usage kcu, " ,"information_schema.table_constraints tc " ,"WHERE tc.constraint_type='FOREIGN KEY' " ,"AND kcu.constraint_name=tc.constraint_name " ,"AND ccu.constraint_name=kcu.constraint_name " ,"AND kcu.ordinal_position=1 " ,"AND ccu.table_name=? " ,"AND ccu.column_name=? " ,"AND kcu.table_name=? " ,"AND kcu.column_name=? " ,"AND tc.constraint_name=?"] [Single exists] <- rawSql query [PersistText "custom_constraint1" ,PersistText "id" ,PersistText "custom_constraint2" ,PersistText "cc_id" ,PersistText "custom_constraint"] liftIO $ 1 @?= (exists :: Int) it "allows multiple constraints on a single column" $ runDb $ do runMigration customConstraintMigrate -- | Here we add another foreign key on the same column where the default one already exists. In practice, this could be a compound key with another field. rawExecute "ALTER TABLE \"custom_constraint3\" ADD CONSTRAINT \"extra_constraint\" FOREIGN KEY(\"cc_id1\") REFERENCES \"custom_constraint1\"(\"id\")" [] -- | This is where the error is thrown in `getColumn` _ <- getMigration customConstraintMigrate pure () persistent-postgresql-2.10.1.2/LICENSE0000644000000000000000000000207513167222713015537 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. persistent-postgresql-2.10.1.2/Setup.lhs0000755000000000000000000000016213167222713016340 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain persistent-postgresql-2.10.1.2/persistent-postgresql.cabal0000644000000000000000000000547113606232107022116 0ustar0000000000000000name: persistent-postgresql version: 2.10.1.2 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman maintainer: Michael Snoyman synopsis: Backend for the persistent library using postgresql. description: Based on the postgresql-simple package category: Database, Yesod stability: Stable cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 , persistent >= 2.10 && < 3 , aeson >= 1.0 , blaze-builder , bytestring >= 0.10 , conduit >= 1.2.12 , containers >= 0.5 , monad-logger >= 0.3.25 , postgresql-simple >= 0.6.1 && < 0.7 , postgresql-libpq >= 0.9.4.2 && < 0.10 , resourcet >= 1.1.9 , resource-pool , text >= 1.2 , time >= 1.6 , transformers >= 0.5 , unliftio-core exposed-modules: Database.Persist.Postgresql , Database.Persist.Postgresql.JSON ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: git://github.com/yesodweb/persistent.git test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test other-modules: PgInit ArrayAggTest EquivalentTypeTestPostgres JSONTest CustomConstraintTest ghc-options: -Wall build-depends: base >= 4.9 && < 5 , persistent , persistent-postgresql , persistent-qq , persistent-template , persistent-test , aeson , bytestring , containers , fast-logger , HUnit , hspec >= 2.4 , hspec-expectations , monad-logger , QuickCheck , quickcheck-instances , resourcet , text , time , transformers , unliftio-core , unordered-containers , vector default-language: Haskell2010 persistent-postgresql-2.10.1.2/ChangeLog.md0000644000000000000000000000776213606232107016707 0ustar0000000000000000# Changelog for persistent-postgresql ## 2.10.1.2 * Fix issue with multiple foreign keys on single column. [#1010](https://github.com/yesodweb/persistent/pull/1010) ## 2.10.1.1 * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) ## 2.10.1 * Added support for the `constraint=` attribute to the Postgresql backend. [#979](https://github.com/yesodweb/persistent/pull/979) ## 2.10.0 * Added question mark operators (`(?.), (?|.), (?&.)`) to `Database.Persist.Postgresql.JSON` [#863](https://github.com/yesodweb/persistent/pull/863) * Changes to certain types: * `PersistValue`: added `PersistArray` data constructor * `Filter`: Changed the `filterValue :: Either a [a]` to `filterValue :: FilterValue` ## 2.9.1 * Add `openSimpleConnWithVersion` function. [#883](https://github.com/yesodweb/persistent/pull/883) ## 2.9.0 * Added support for SQL isolation levels to via SqlBackend. [#812] * Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic. ## 2.8.2 Added module `Database.Persist.Postgresql.JSON` [#793](https://github.com/yesodweb/persistent/pull/793) * `PersistField` and `PersistFieldSql` instances for `Data.Aeson.Value` * Filter operators `(@>.)` and `(<@.)` to filter on JSON values ## 2.8.1.1 * Added a more detailed error message when a `numeric` column's scale and precision can't be parsed. [#781](https://github.com/yesodweb/persistent/pull/781) ## 2.8.1 * Implemented `connPutManySql` to utilize batched `putMany`. [#770](https://github.com/yesodweb/persistent/pull/770) ## 2.8.0 * Switch from `MonadBaseControl` to `MonadUnliftIO` ## 2.6.3 * Added new function `migrateEnableExtension`, to enable Postgres extensions in migrations. ## 2.6.2.2 * Because `text` and `varchar` are synonyms in Postgresql, don't attempt to migrate between them. [#762](https://github.com/yesodweb/persistent/pull/762) ## 2.6.2.1 * Fix bug where, if a custom column width was set, the field would be migrated every time [#742](https://github.com/yesodweb/persistent/pull/742) ## 2.6.2 * Expose new functions: `withPostgresqlPoolWithVersion`, `withPostgresqlConnWithVersion` and `createPostgresqlPoolModifiedWithVersion`. ## 2.6.1 * Match changes in persistent * Clean up warnings ## 2.6 * Atomic upsert support for postgreSQL backend ## 2.5 * changes for read/write typeclass split ## 2.2.2 * Postgresql primary key is Int4, not Int8 [#519](https://github.com/yesodweb/persistent/issues/519) ## 2.2.1.2 * Allow postgresql-simple 0.5 ## 2.2.1.1 Query pg_catalog instead of information_schema for metadata. This helps with permission issues as reported in issue #501 ## 2.2.1 * Fix treatment of `NULL`s inside arrays. For example, now you can use `array_agg` on a nullable column. * New derived instances for `PostgresConf`: `Read`, `Data` and `Typeable`. * New `mockMigration` function. Works like `printMigration` but doesn't need a database connection. * Fix typo on error message of the `FromJSON` instance of `PostgresConf`. ## 2.2 * Optimize the `insertMany` function to insert all rows and retrieve their keys in one SQL query. [#407](https://github.com/yesodweb/persistent/pull/407) ## 2.1.6 * Postgresql exceptions [#353](https://github.com/yesodweb/persistent/issues/353) ## 2.1.5.3 Migrations for custom primary keys ## 2.1.5.2 Support foreign key references to composite primary keys #389 ## 2.1.5 * Allow timestamp value in database to be serialized (presumes UTC timezone) [Yesod #391](https://github.com/yesodweb/persistent/issues/391) ## 2.1.4 * Treat unknown extension types as PersistDbSpecific values [#385](https://github.com/yesodweb/persistent/pull/385) ## 2.1.3 * Added a `Show` instance for `PostgresConf`. * `createPostgresqlPoolModified` added, see [relevant mailing list discussion](https://groups.google.com/d/msg/yesodweb/qUXrEN_swEo/O0pFwqwQIdcJ) ## 2.1.2.1 Documentation typo fix ## 2.1.1 Added `FromJSON` instance for `PostgresConf`.