From 264ad01d8f26e698aec5e03ef908ca24650d88c1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 Aug 2018 14:13:38 +0200 Subject: [PATCH] Introduce database versioning Fixes #120 --- package.yaml | 2 +- src/Application.hs | 2 +- src/Import/NoFoundation.hs | 1 + src/Model.hs | 9 +--- src/Model/Migration.hs | 82 ++++++++++++++++++++++++++++++ src/Model/Migration/Version.hs | 92 ++++++++++++++++++++++++++++++++++ stack.yaml | 2 + 7 files changed, 180 insertions(+), 10 deletions(-) create mode 100644 src/Model/Migration.hs create mode 100644 src/Model/Migration/Version.hs diff --git a/package.yaml b/package.yaml index 60cff14a5..5cecac14d 100644 --- a/package.yaml +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index aa4685549..93bd35d76 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 5f0353d8b..c4eb77f32 100644 --- a/src/Import/NoFoundation.hs +++ b/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 diff --git a/src/Model.hs b/src/Model.hs index 9bff65c56..10fc4733e 100644 --- a/src/Model.hs +++ b/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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs new file mode 100644 index 000000000..f1468b647 --- /dev/null +++ b/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 (>>) + [ + ] diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs new file mode 100644 index 000000000..37bbd8f3f --- /dev/null +++ b/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" diff --git a/stack.yaml b/stack.yaml index 82f2e0c30..8f93444f8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,4 +34,6 @@ extra-deps: - system-locale-0.3.0.0 + - persistent-2.7.3.1 + resolver: lts-10.5