vervis/src/Vervis/Migration.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Migration
    ( migrateDB
    )
where

import Prelude

import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.ByteString (ByteString)
--import Text.Email.QuasiQuotation (email)
import Text.Email.Validate (unsafeEmailAddress)
import Data.Foldable (traverse_, for_)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Proxy
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..))
import Database.Persist
import Database.Persist.BackendDataType (backendDataType)
import Database.Persist.Migration
import Database.Persist.Schema (SchemaT, Migration)
import Database.Persist.Schema.Types
import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey)
import Web.PathPieces (toPathPiece)

import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault)

import Vervis.Migration.Model
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Workflow

type Apply m = SchemaT SqlBackend m ()
type Mig m   = Migration SqlBackend m

defaultTime :: UTCTime
defaultTime = UTCTime (ModifiedJulianDay 0) 0

withPrepare :: Monad m => Mig m -> Apply m -> Mig m
withPrepare (validate, apply) prepare = (validate, prepare >> apply)

changes :: MonadIO m => [Mig m]
changes =
    [ -- 1
      unchecked $ traverse_ U.addEntity model_2016_08_04
      -- 2
    , unchecked $ U.unsetFieldDefault "Sharer" "created"
      -- 3
    , unchecked $ U.unsetFieldDefault "Project" "nextTicket"
      -- 4
    , unchecked $ U.unsetFieldDefault "Repo" "vcs"
      -- 5
    , unchecked $ U.unsetFieldDefault "Repo" "mainBranch"
      -- 6
    , removeField "Ticket" "done"
      -- 7
    , addFieldPrimRequired "Ticket" ("TSNew" :: Text) "status"
      -- 8
    , unchecked $ traverse_ U.addEntity model_2016_09_01_just_workflow
      -- 9
    , unchecked $ traverse_ U.addEntity model_2016_09_01_rest
      -- 10
    , let key = fromBackendKey defaultBackendKey :: Key Workflow2016
      in  withPrepare
            (addFieldRefRequired "Project"
                (toBackendKey key)
                "workflow"
                "Workflow"
            ) $ do
                noProjects <- lift $
                    null <$> selectKeysList [] [LimitTo 1 :: SelectOpt Project]
                unless noProjects $ lift $ do
                    msid <-
                        listToMaybe <$>
                        selectKeysList [] [Asc SharerId, LimitTo 1]
                    for_ msid $ \ sid -> do
                        let ident = text2wfl "dummy"
                            w = Workflow2016 sid ident Nothing Nothing WSPublic
                        insertKey key w
      -- 11
    , addFieldPrimRequired "Workflow" ("WSSharer" :: Text) "scope"
      -- 12
    , changeFieldType "Person" "hash" $
        backendDataType (Proxy :: Proxy ByteString)
      -- 13
    --, unsetFieldPrimMaybe "Person" "email" [email|noreply@no.such.email|]
    , unsetFieldPrimMaybe "Person" "email" $
        unsafeEmailAddress "noreply" "no.such.email"
      -- 14
    , addFieldPrimRequired "Person" True "verified"
      -- 15
    , addFieldPrimRequired "Person" ("" :: Text) "verifiedKey"
      -- 16
    , addFieldPrimRequired "Person" ("" :: Text) "resetPassphraseKey"
      -- 17
    , renameField "Person" "hash" "passphraseHash"
      -- 18
    , renameField "Person" "resetPassphraseKey" "resetPassKey"
      -- 19
    , addFieldPrimRequired "Person" defaultTime "verifiedKeyCreated"
      -- 20
    , addFieldPrimRequired "Person" defaultTime "resetPassKeyCreated"
    ]

migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB =
    let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
    in  f changes