persistent-postgresql 2.2 → 2.2.1
raw patch · 3 files changed
+118/−22 lines, 3 files
Files
- ChangeLog.md +12/−0
- Database/Persist/Postgresql.hs +105/−21
- persistent-postgresql.cabal +1/−1
ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -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
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 2.2+version: 2.2.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>