fradrive-old/src/Model/Migration.hs

{-# 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 ()
import qualified Data.Set as Set

import Database.Persist.Sql
import Database.Persist.Postgresql

import Data.CaseInsensitive (CI)

-- 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 ()
    )
  , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
    , do -- SchoolId is the Shorthand CI Text now
        {-
          Confusion about quotes, from the SQL Manual:
            Single quotes for string constants, double quotes for table/column names.

            QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
                         #{anything} (no escaping);
        -}
        -- Read old table into memory
        -- schoolTable :: [(Single Int64, Single Text)]
        schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
        let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
        -- Convert columns containing SchoolId
        let convert0 = [executeQQ|
                ALTER TABLE "user_admin"    DROP CONSTRAINT user_admin_school_fkey;
                ALTER TABLE "user_lecturer" DROP CONSTRAINT user_lecturer_school_fkey;
                ALTER TABLE "course"        DROP CONSTRAINT course_school_fkey;
              |]
        let convert1 = [executeQQ|
                ALTER TABLE "user_admin"    ALTER COLUMN "school" TYPE citext USING to_char();
                ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING to_char();
                ALTER TABLE "course"        ALTER COLUMN "school" TYPE citext USING to_char();
              |]
        -- Convert Number-Strings to Shorthands
        let convert2 = forM_ schoolTable (\(Single idnr, Single ssh) ->
                [executeQQ|
                  UPDATE "user_admin"    SET "school" = #{ssh} WHERE "school" = #{idnr};
                  UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{idnr};
                  UPDATE "user_course"   SET "school" = #{ssh} WHERE "school" = #{idnr};
                |]
              )
        -- Recreate constraints
        let convert3 = [executeQQ|
                ALTER TABLE "user_admin"    ADD CONSTRAINT "user_admin_school_fkey"
                  FOREIGN KEY (school) REFERENCES school(shorthand);
                ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
                  FOREIGN KEY (school) REFERENCES school(shorthand);;
                ALTER TABLE "course"        ADD CONSTRAINT "course_school_fkey"
                  FOREIGN KEY (school) REFERENCES school(shorthand);
              |]
        let convert = convert0 >> convert1 >> convert2 >> convert3
        convert
    )
  ]