diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,15 @@ +## 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) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -19,6 +19,7 @@ , openSimpleConn , tableName , fieldName + , mockMigration ) where import Database.Persist.Sql @@ -39,6 +40,7 @@ import Control.Monad.Trans.Resource import Control.Exception (throw) import Control.Monad.IO.Class (MonadIO (..)) +import Data.Data import Data.Typeable import Data.IORef import qualified Data.Map as Map @@ -57,12 +59,15 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Text (Text) import Data.Aeson import Data.Aeson.Types (modifyFailure) import Control.Monad (forM) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Writer (runWriterT) import Data.Acquire (Acquire, mkAcquire, with) import System.Environment (getEnvironment) import Data.Int (Int64) @@ -262,7 +267,12 @@ else fmap Just $ forM (zip getters [0..]) $ \(getter, col) -> do mbs <- LibPQ.getvalue' ret row col case mbs of - Nothing -> return PersistNull + 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 @@ -299,7 +309,7 @@ instance PGFF.FromField Unknown where fromField f mdata = case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField Unknown" Just dat -> return (Unknown dat) instance PGTF.ToField Unknown where @@ -340,9 +350,8 @@ , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) , (k PS.unknown, convertPV (PersistByteString . unUnknown)) - - - -- array types: same order as above + -- Array types: same order as above. + -- The OIDs were taken from pg_type. , (1000, listOf PersistBool) , (1001, listOf (PersistByteString . unBinary)) , (1002, listOf PersistText) @@ -374,7 +383,13 @@ ] where k (PGFF.typoid -> i) = PG.oid2int i - listOf f = convertPV (PersistList . map f . PG.fromPGArray) + -- 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 @@ -432,18 +447,8 @@ -- for https://github.com/yesodweb/persistent/issues/152 createText newcols fdefs udspair = - addTable : uniques ++ references ++ foreignsAlt + (addTable newcols entity) : uniques ++ references ++ foreignsAlt where - addTable = AddTable $ T.concat - -- Lower case e: see Database.Persist.Sql.Migration - [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! - , escape name - , "(" - , idtxt - , if null newcols then "" else "," - , T.intercalate "," $ map showColumn newcols - , ")" - ] uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> @@ -453,7 +458,20 @@ let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields))) - idtxt = case entityPrimary entity of +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 @@ -465,7 +483,6 @@ , mayDefault defText ] - maySerial :: SqlType -> Maybe Text -> Text maySerial SqlInt64 Nothing = " SERIAL " maySerial sType _ = " " <> showSqlType sType @@ -908,10 +925,10 @@ -- ^ The connection string. , pgPoolSize :: Int -- ^ How many connections should be held on the connection pool. - } deriving Show + } deriving (Show, Read, Data, Typeable) instance FromJSON PostgresConf where - parseJSON v = modifyFailure ("Persistent: error loadomg PostgreSQL conf: " ++) $ + parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $ flip (withObject "PostgresConf") v $ \o -> do database <- o .: "database" host <- o .: "host" @@ -969,3 +986,70 @@ 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 actualy database isn't needed for it. +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, + connStmtMap = smap, + connClose = undefined, + connMigrateSql = mockMigrate, + connBegin = undefined, + connCommit = undefined, + connRollback = undefined, + connEscapeName = escape, + connNoLimit = undefined, + connRDBMS = undefined, + connLimitOffset = undefined, + connLogFunc = undefined} + result = runReaderT $ runWriterT $ runWriterT mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.2 +version: 2.2.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman