106 lines
4.0 KiB
Haskell
106 lines
4.0 KiB
Haskell
{-# 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.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 (>>)
|
|
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
|
|
, do -- New theme format
|
|
haveUserTable <- [sqlQQ| SELECT to_regclass('user'); |]
|
|
|
|
case haveUserTable :: [Maybe (Single Text)] of
|
|
[Just _] -> do
|
|
userThemes <- [sqlQQ| SELECT 'id', 'theme' FROM 'user'; |]
|
|
forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
|
|
Just v
|
|
| Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
|
|
other -> error $ "Could not parse theme: " <> show other
|
|
_other -> return ()
|
|
)
|
|
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
|
, do -- Better JSON encoding
|
|
haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |]
|
|
|
|
case haveSheetTable :: [Maybe (Single Text)] of
|
|
[Just _] ->
|
|
[executeQQ|
|
|
ALTER TABLE 'sheet' ALTER COLUMN 'type' TYPE json USING 'type'::json;
|
|
ALTER TABLE 'sheet' ALTER COLUMN 'grouping' TYPE json USING 'grouping'::json;
|
|
|]
|
|
_other -> return ()
|
|
)
|
|
]
|