Add support for no downtime migrations

.travis.yml

@@ -29,9 +29,9 @@ before_cache:
 
 matrix:
   include:
-    - compiler: "ghc-8.6.2"
+    - compiler: "ghc-8.6.3"
     # env: TEST=--disable-tests BENCH=--disable-benchmarks
-      addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.2], sources: [hvr-ghc]}}
+      addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}}
     - compiler: "ghc-8.4.4"
     # env: TEST=--disable-tests BENCH=--disable-benchmarks
       addons: {"postgresql" : "10", apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
@@ -66,6 +66,7 @@ install:
   - rm -fv cabal.project cabal.project.local
   - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
   - "printf 'packages: \".\"\\n' > cabal.project"
+  - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
   - touch cabal.project.local
   - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- hpqtypes-extras | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
   - cat cabal.project || true
@@ -88,6 +89,7 @@ script:
   - cd ${DISTDIR} || false
   - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
   - "printf 'packages: hpqtypes-extras-*/*.cabal\\n' > cabal.project"
+  - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"
   - touch cabal.project.local
   - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- hpqtypes-extras | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
   - cat cabal.project || true

CHANGELOG.md

@@ -1,4 +1,24 @@
-# hpqtypes-extras-1.6.3.0 (2018-07-11)
+# hpqtypes-extras-1.7.0.0 (2018-12-20)
+* Added support for no-downtime migrations
+  ([#17](https://github.com/scrive/hpqtypes-extras/pull/17)):
+    - `sqlCreateIndex` is deprecated. Use either
+      `sqlCreateIndexSequentially` or `sqlCreateIndexConcurrently`
+      (no-downtime migration variant) instead.
+    - `sqlAddFK` is deprecated. Use either `sqlAddValidFK` or
+      `sqlAddNotValidFK` (no-downtime migration variant) instead.
+    - API addition: `sqlValidateFK`, for validating a foreign key
+      previously added with `sqlAddNotValidFK`.
+    - `sqlAddCheck` is deprecated. Use either `sqlAddValidCheck` or
+      `sqlAddNotValidCheck` (no-downtime migration variant) instead.
+    - API addition: `sqlValidateCheck`, for validating a check
+      previously added with `sqlAddNotValidCheck`.
+    - API addition: `sqlAddPKUsing`, converts a unique index to a
+      primary key.
+    - New `Table` field: `tblAcceptedDbVersions`.
+* `ValidationResult` is now an abstract type.
+* `ValidationResult` now supports info-level messages in addition to errors.
+
+# hpqtypes-extras-1.6.3.0 (2018-11-19)
 * API addition: `sqlWhereAnyE`
   ([#16](https://github.com/scrive/hpqtypes-extras/pull/16)).
 

hpqtypes-extras.cabal

@@ -1,6 +1,6 @@
 cabal-version:       1.18
 name:                hpqtypes-extras
-version:             1.6.3.0
+version:             1.7.0.0
 synopsis:            Extra utilities for hpqtypes library
 description:         The following extras for hpqtypes library:
                      .
@@ -20,7 +20,7 @@ maintainer:          Andrzej Rybczak <andrzej@rybczak.net>,
 copyright:           Scrive AB
 category:            Database
 build-type:          Simple
-tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2
+tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3
 
 Source-repository head
   Type:     git

src/Database/PostgreSQL/PQTypes/Checks/Util.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE CPP #-}
 module Database.PostgreSQL.PQTypes.Checks.Util (
-  ValidationResult(..),
+  ValidationResult,
+  validationError,
+  validationInfo,
+  mapValidationResult,
+  validationErrorsToInfos,
   resultCheck,
   topMessage,
   tblNameText,
@@ -28,31 +32,59 @@ import qualified Data.Semigroup as SG
 import Database.PostgreSQL.PQTypes.Model
 import Database.PostgreSQL.PQTypes
 
--- | A (potentially empty) list of error messages.
-newtype ValidationResult = ValidationResult [Text]
+-- | A (potentially empty) list of info/error messages.
+data ValidationResult = ValidationResult
+  { vrInfos  :: [Text]
+  , vrErrors :: [Text]
+  }
+
+validationError :: Text -> ValidationResult
+validationError err = mempty { vrErrors = [err] }
+
+validationInfo :: Text -> ValidationResult
+validationInfo msg  = mempty { vrInfos = [msg] }
+
+-- | Downgrade all error messages in a ValidationResult to info messages.
+validationErrorsToInfos :: ValidationResult -> ValidationResult
+validationErrorsToInfos ValidationResult{..} =
+  mempty { vrInfos = vrInfos <> vrErrors }
+
+mapValidationResult ::
+  ([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
+mapValidationResult mapInfos mapErrs ValidationResult{..} =
+  mempty { vrInfos = mapInfos vrInfos, vrErrors = mapErrs vrErrors }
 
 instance SG.Semigroup ValidationResult where
-  (ValidationResult a) <> (ValidationResult b) = ValidationResult (a ++ b)
+  (ValidationResult infos0 errs0) <> (ValidationResult infos1 errs1)
+    = ValidationResult (infos0 <> infos1) (errs0 <> errs1)
 
 instance Monoid ValidationResult where
-  mempty  = ValidationResult []
+  mempty  = ValidationResult [] []
   mappend = (SG.<>)
 
 topMessage :: Text -> Text -> ValidationResult -> ValidationResult
-topMessage objtype objname = \case
-  ValidationResult [] -> ValidationResult []
-  ValidationResult es -> ValidationResult
-    ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es)
-
+topMessage objtype objname vr@ValidationResult{..} =
+  case vrErrors of
+    [] -> vr
+    es -> ValidationResult vrInfos
+          ("There are problems with the" <+>
+            objtype <+> "'" <> objname <> "'" : es)
+
+-- | Log all messages in a 'ValidationResult', and fail if any of them
+-- were errors.
 resultCheck
   :: (MonadLog m, MonadThrow m)
   => ValidationResult
   -> m ()
-resultCheck = \case
-  ValidationResult [] -> return ()
-  ValidationResult msgs -> do
-    mapM_ logAttention_ msgs
-    error "resultCheck: validation failed"
+resultCheck ValidationResult{..} = do
+  mapM_ logInfo_ vrInfos
+  case vrErrors of
+    []   -> return ()
+    msgs -> do
+      mapM_ logAttention_ msgs
+      error "resultCheck: validation failed"
+
+----------------------------------------
 
 tblNameText :: Table -> Text
 tblNameText = unRawSQL . tblName
@@ -63,7 +95,7 @@ tblNameString = T.unpack . tblNameText
 checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
 checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of
   ([], []) -> mempty
-  (def_diff, db_diff) -> ValidationResult [mconcat [
+  (def_diff, db_diff) -> validationError . mconcat $ [
       "Table and its definition have diverged and have "
     , showt $ length db_diff
     , " and "
@@ -75,23 +107,23 @@ checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of
     , ", definition: "
     , T.pack $ show def_diff
     , ")."
-    ]]
+    ]
 
 checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
 checkNames prop_name = mconcat . map check
   where
     check (prop, name) = case prop_name prop of
       pname
         | pname == name -> mempty
-        | otherwise -> ValidationResult [mconcat [
+        | otherwise     -> validationError . mconcat $ [
             "Property "
           , T.pack $ show prop
           , " has invalid name (expected: "
           , unRawSQL pname
           , ", given: "
           , unRawSQL name
           , ")."
-          ]]
+          ]
 
 -- | Check presence of primary key on the named table. We cover all the cases so
 -- this could be used standalone, but note that the those where the table source
@@ -115,10 +147,10 @@ checkPKPresence tableName mdef mpk =
     noSrc = "no source definition"
     noTbl = "no table definition"
     valRes msgs =
-        ValidationResult [
-          mconcat [ "Table ", unRawSQL tableName
-                  , " has no primary key defined "
-                  , " (" <> (mintercalate ", " msgs) <> ")"]]
+        validationError . mconcat $
+        [ "Table ", unRawSQL tableName
+        , " has no primary key defined "
+        , " (" <> (mintercalate ", " msgs) <> ")"]
 
 
 tableHasLess :: Show t => Text -> t -> Text

src/Database/PostgreSQL/PQTypes/Migrate.hs

@@ -17,15 +17,15 @@ createDomain dom@Domain{..} = do
   -- create the domain
   runQuery_ $ sqlCreateDomain dom
   -- add constraint checks to the domain
-  F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck
+  F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheck
 
 createTable :: MonadDB m => Bool -> Table -> m ()
 createTable withConstraints table@Table{..} = do
   -- Create empty table and add the columns.
   runQuery_ $ sqlCreateTable tblName
   runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns
   -- Add indexes.
-  forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName
+  forM_ tblIndexes $ runQuery_ . sqlCreateIndexSequentially tblName
   -- Add all the other constraints if applicable.
   when withConstraints $ createTableConstraints table
   -- Register the table along with its version.
@@ -39,6 +39,6 @@ createTableConstraints Table{..} = when (not $ null addConstraints) $ do
   where
     addConstraints = concat [
         [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey]
-      , map sqlAddCheck tblChecks
-      , map (sqlAddFK tblName) tblForeignKeys
+      , map sqlAddValidCheck tblChecks
+      , map (sqlAddValidFK tblName) tblForeignKeys
       ]

src/Database/PostgreSQL/PQTypes/Model/Check.hs

@@ -1,6 +1,10 @@
 module Database.PostgreSQL.PQTypes.Model.Check (
     Check(..)
+  , tblCheck
   , sqlAddCheck
+  , sqlAddValidCheck
+  , sqlAddNotValidCheck
+  , sqlValidateCheck
   , sqlDropCheck
   ) where
 
@@ -11,16 +15,48 @@ import Prelude
 data Check = Check {
   chkName      :: RawSQL ()
 , chkCondition :: RawSQL ()
+, chkValidated :: Bool -- ^ Set to 'True' if check is created as NOT VALID and
+                       -- not validated afterwards.
 } deriving (Eq, Ord, Show)
 
+tblCheck :: Check
+tblCheck = Check
+  { chkName      = ""
+  , chkCondition = ""
+  , chkValidated = True
+  }
+
+{-# DEPRECATED sqlAddCheck "Use sqlAddValidCheck instead" #-}
+-- | Deprecated version of 'sqlAddValidCheck'.
 sqlAddCheck :: Check -> RawSQL ()
-sqlAddCheck Check{..} = smconcat [
+sqlAddCheck = sqlAddCheck_ True
+
+-- | Add valid check constraint. Warning: PostgreSQL acquires SHARE ROW
+-- EXCLUSIVE lock (that prevents updates) on modified table for the duration of
+-- the creation. If this is not acceptable, use 'sqlAddNotValidCheck' and
+-- 'sqlValidateCheck'.
+sqlAddValidCheck :: Check -> RawSQL ()
+sqlAddValidCheck = sqlAddCheck_ True
+
+-- | Add check marked as NOT VALID. This avoids potentially long validation
+-- blocking updates to modified table for its duration. However, checks created
+-- as such need to be validated later using 'sqlValidateCheck'.
+sqlAddNotValidCheck :: Check -> RawSQL ()
+sqlAddNotValidCheck = sqlAddCheck_ False
+
+-- | Validate check previously created as NOT VALID.
+sqlValidateCheck :: Check -> RawSQL ()
+sqlValidateCheck Check{..} = "VALIDATE" <+> chkName
+
+sqlAddCheck_ :: Bool -> Check -> RawSQL ()
+sqlAddCheck_ valid Check{..} = smconcat [
     "ADD CONSTRAINT"
   , chkName
   , "CHECK ("
   , chkCondition
   , ")"
+  , if valid then "" else " NOT VALID"
   ]
 
-sqlDropCheck :: Check -> RawSQL ()
-sqlDropCheck Check{..} = "DROP CONSTRAINT" <+> chkName
+sqlDropCheck :: RawSQL () -> RawSQL ()
+sqlDropCheck name = "DROP CONSTRAINT" <+> name

src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs

@@ -5,6 +5,9 @@ module Database.PostgreSQL.PQTypes.Model.ForeignKey (
   , fkOnColumns
   , fkName
   , sqlAddFK
+  , sqlAddValidFK
+  , sqlAddNotValidFK
+  , sqlValidateFK
   , sqlDropFK
   ) where
 
@@ -22,6 +25,8 @@ data ForeignKey = ForeignKey {
 , fkOnDelete   :: ForeignKeyAction
 , fkDeferrable :: Bool
 , fkDeferred   :: Bool
+, fkValidated  :: Bool -- ^ Set to 'True' if foreign key is created as NOT VALID
+                       -- and not validated afterwards.
 } deriving (Eq, Ord, Show)
 
 data ForeignKeyAction
@@ -45,6 +50,7 @@ fkOnColumns columns reftable refcolumns = ForeignKey {
 , fkOnDelete   = ForeignKeyNoAction
 , fkDeferrable = True
 , fkDeferred   = False
+, fkValidated  = True
 }
 
 fkName :: RawSQL () -> ForeignKey -> RawSQL ()
@@ -60,8 +66,31 @@ fkName tname ForeignKey{..} = shorten $ mconcat [
     -- PostgreSQL's limit for identifier is 63 characters
     shorten = flip rawSQL () . T.take 63 . unRawSQL
 
+{-# DEPRECATED sqlAddFK "Use sqlAddValidFK instead" #-}
+-- | Deprecated version of sqlAddValidFK.
 sqlAddFK :: RawSQL () -> ForeignKey -> RawSQL ()
-sqlAddFK tname fk@ForeignKey{..} = mconcat [
+sqlAddFK = sqlAddFK_ True
+
+-- | Add valid foreign key. Warning: PostgreSQL acquires SHARE ROW EXCLUSIVE
+-- lock (that prevents data updates) on both modified and referenced table for
+-- the duration of the creation. If this is not acceptable, use
+-- 'sqlAddNotValidFK' and 'sqlValidateFK'.
+sqlAddValidFK :: RawSQL () -> ForeignKey -> RawSQL ()
+sqlAddValidFK = sqlAddFK_ True
+
+-- | Add foreign key marked as NOT VALID. This avoids potentially long
+-- validation blocking updates to both modified and referenced table for its
+-- duration. However, keys created as such need to be validated later using
+-- 'sqlValidateFK'.
+sqlAddNotValidFK :: RawSQL () -> ForeignKey -> RawSQL ()
+sqlAddNotValidFK = sqlAddFK_ False
+
+-- | Validate foreign key previously created as NOT VALID.
+sqlValidateFK :: RawSQL () -> ForeignKey -> RawSQL ()
+sqlValidateFK tname fk = "VALIDATE" <+> fkName tname fk
+
+sqlAddFK_ :: Bool -> RawSQL () -> ForeignKey -> RawSQL ()
+sqlAddFK_ valid tname fk@ForeignKey{..} = mconcat [
     "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY ("
   , mintercalate ", " fkColumns
   , ") REFERENCES" <+> fkRefTable <+> "("
@@ -70,6 +99,7 @@ sqlAddFK tname fk@ForeignKey{..} = mconcat [
   , "  ON DELETE" <+> foreignKeyActionToSQL fkOnDelete
   , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE"
   , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE"
+  , if valid then "" else " NOT VALID"
   ]
   where
     foreignKeyActionToSQL ForeignKeyNoAction   = "NO ACTION"