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'

{-
  Confusion about quotes, from the PostgreSQL Manual:
    Single quotes for string constants, double quotes for table/column names.

    QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
                  #{anything} (no escaping);
-}


customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>)
  [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
    , whenM (tableExists "user") $ do -- New theme format
        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
    )
  , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
    , whenM (tableExists "sheet") $ -- Better JSON encoding
        [executeQQ|
          ALTER TABLE 'sheet' ALTER COLUMN 'type' TYPE json USING 'type'::json;
          ALTER TABLE 'sheet' ALTER COLUMN 'grouping' TYPE json USING 'grouping'::json;
        |]
    )
  , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
    , whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
        -- Read old table into memory
        schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
        let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
        -- Convert columns containing SchoolId
        whenM (tableExists "user_admin") $ do
            [executeQQ|
              ALTER TABLE "user_admin"    DROP CONSTRAINT user_admin_school_fkey;
              ALTER TABLE "user_admin"    ALTER COLUMN school TYPE citext USING school::citext;
              |]
            forM_ schoolTable $ \(Single idnr, Single ssh) ->
              [executeQQ|
                UPDATE "user_admin"    SET school = #{ssh} WHERE school = #{tshow idnr};
              |]
            [executeQQ|
              ALTER TABLE "user_admin"    ADD CONSTRAINT "user_admin_school_fkey"
                FOREIGN KEY (school) REFERENCES school(shorthand);
              |]
        whenM (tableExists "user_lecturer") $ do
            [executeQQ|
              ALTER TABLE "user_lecturer" DROP CONSTRAINT user_lecturer_school_fkey;
              ALTER TABLE "user_lecturer" ALTER COLUMN school TYPE citext USING school::citext;
              |]
            forM_ schoolTable $ \(Single idnr, Single ssh) ->
              [executeQQ|
                UPDATE "user_lecturer" SET school = #{ssh} WHERE school = #{tshow idnr};
              |]
            [executeQQ|
              ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
                  FOREIGN KEY (school) REFERENCES school(shorthand);;
              |]
        whenM (tableExists "course") $ do
            [executeQQ|
              ALTER TABLE "course"        DROP CONSTRAINT course_school_fkey;
              ALTER TABLE "course"        ALTER COLUMN school TYPE citext USING school::citext;
              |]
            forM_ schoolTable $ \(Single idnr, Single ssh) ->
              [executeQQ|
                UPDATE "course"        SET school = #{ssh} WHERE school = #{tshow idnr};
              |]
            [executeQQ|
              ALTER TABLE "course"        ADD CONSTRAINT "course_school_fkey"
                  FOREIGN KEY (school) REFERENCES school(shorthand);
              |]
        [executeQQ|
            ALTER TABLE "school" DROP COLUMN "id";
            ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
          |]
    )
  ]



tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do
  haveSchoolTable <- [sqlQQ| SELECT to_regclass("#{table}"); |]
  case haveSchoolTable :: [Maybe (Single Text)] of
    [Just _] -> return True
    _other   -> return False