{-# 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 ()
    )
  ]