Introduce database versioning

Fixes #120

package.yaml

@@ -20,7 +20,7 @@ dependencies:
 - classy-prelude-conduit >=0.10.2
 - bytestring >=0.9 && <0.11
 - text >=0.11 && <2.0
-- persistent >=2.0 && <2.8
+- persistent >=2.7.2 && <2.8
 - persistent-postgresql >=2.1.1 && <2.8
 - persistent-template >=2.0 && <2.8
 - template-haskell

src/Application.hs

@@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
         (pgPoolSize appDatabaseConf)
 
     -- Perform database migration using our application's logging settings.
-    runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc
+    runLoggingT (runSqlPool migrateAll pool) logFunc
 
     -- Return the foundation
     return $ mkFoundation pool

src/Import/NoFoundation.hs

@@ -5,6 +5,7 @@ module Import.NoFoundation
 
 import ClassyPrelude.Yesod    as Import hiding (formatTime)
 import Model                  as Import
+import Model.Migration        as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import

src/Model.hs

@@ -18,8 +18,6 @@ module Model
 
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
-import Database.Persist.Postgresql (migrateEnableExtension)
-import Database.Persist.Sql (Migration)
 -- import Data.Time
 -- import Data.ByteString
 import Model.Types
@@ -31,17 +29,12 @@ import Data.CaseInsensitive (CI)
 -- You can find more information on persistent and how to declare entities
 -- at:
 -- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
     $(persistFileWith lowerCaseSettings "models")
 
 -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
 deriving instance Eq (Unique Course)
 
-migrateAll :: Migration
-migrateAll = do
-  migrateEnableExtension "citext"
-  migrateAll'
-
 data PWEntry = PWEntry
   { pwUser :: User
   , pwHash :: Text

src/Model/Migration.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Model.Migration
+  ( migrateAll
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Model
+import Model.Migration.Version
+import Data.Version
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Database.Persist.Sql
+import Database.Persist.Postgresql
+
+
+-- Database versions must follow https://pvp.haskell.org:
+--   - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
+--   - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
+
+-- Note that only one automatic migration is done (after all manual migrations).
+-- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion)
+-- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system
+
+-- Database versions must be marked with git tags:
+--   The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x
+--   Tags should be annotated with a description of the changes affecting the database.
+--
+--   Example:
+--     $ git tag -a db0.0.0 -m "Simplified format of UserTheme"
+--
+--   Doing so creates sort of parallel commit history tracking changes to the database schema
+
+  
+share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
+  [persistLowerCase|
+    AppliedMigration json
+      from MigrationVersion
+      to Version
+      time UTCTime
+      UniqueAppliedMigration from
+      Primary from to
+      deriving Show Eq Ord
+  |]
+
+migrateAll :: MonadIO m => ReaderT SqlBackend m ()
+migrateAll = do
+  runMigration $ do
+    -- Manual migrations to go to InitialVersion below:
+    migrateEnableExtension "citext"
+
+    migrateDBVersioning
+
+  appliedMigrations <- map entityKey <$> selectList [] []
+  let
+    missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+    doCustomMigration acc desc migration = acc <* do
+      let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
+      appliedMigrationTime <- liftIO getCurrentTime
+      migration
+      insert AppliedMigration{..} 
+  -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
+  Map.foldlWithKey doCustomMigration (return ()) missingMigrations 
+  
+  runMigration migrateAll'
+
+
+customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
+customMigrations = Map.fromListWith (>>)
+  [
+  ]

src/Model/Migration/Version.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Migration.Version
+  ( MigrationVersion(..)
+  , version, migrationVersion
+  , module Data.Version
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Database.Persist.Sql
+import Text.ParserCombinators.ReadP
+import Data.Maybe (fromJust)
+
+import Data.Version
+
+import Data.Aeson.TH
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax (Lift)
+import qualified Language.Haskell.TH.Syntax as TH (lift)
+
+import Data.Data (Data)
+
+
+deriving instance Lift Version
+  
+
+data MigrationVersion = InitialVersion | MigrationVersion Version
+  deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = toLower . fromJust . stripSuffix "Version"
+  , sumEncoding = UntaggedValue
+  } ''MigrationVersion
+
+instance PersistField MigrationVersion where
+  toPersistValue  InitialVersion      = PersistText "initial"
+  toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v
+
+  fromPersistValue (PersistText t)
+    | t == "initial" = return InitialVersion
+    | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+        [x] -> Right $ MigrationVersion x
+        []  -> Left "No parse"
+        _   -> Left "Ambiguous parse"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql MigrationVersion where
+  sqlType _ = SqlString
+
+
+instance PersistField Version where
+  toPersistValue = PersistText . pack . showVersion
+
+  fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+    [x] -> Right x
+    []  -> Left "No parse"
+    _   -> Left "Ambiguous parse"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql Version where
+  sqlType _ = SqlString
+
+
+version, migrationVersion :: QuasiQuoter
+version = QuasiQuoter{..}
+  where
+    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+      [x] -> x
+      []  -> error "No parse"
+      _   -> error "Ambiguous parse"
+    quotePat = error "version cannot be used as pattern"
+    quoteType = error "version cannot be used as type"
+    quoteDec = error "version cannot be used as declaration"
+migrationVersion = QuasiQuoter{..}
+  where
+    quoteExp "initial" = TH.lift InitialVersion
+    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+      [x] -> MigrationVersion x
+      []  -> error "No parse"
+      _   -> error "Ambiguous parse"
+    quotePat = error "version cannot be used as pattern"
+    quoteType = error "version cannot be used as type"
+    quoteDec = error "version cannot be used as declaration"

stack.yaml

@@ -34,4 +34,6 @@ extra-deps:
 
   - system-locale-0.3.0.0
 
+  - persistent-2.7.3.1
+
 resolver: lts-10.5