vervis/src/Vervis/Migration.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019 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 Data.Default.Class
import Data.Default.Instances.ByteString ()
import Data.Foldable (traverse_, for_)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..))
import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.Migration
import Database.Persist.Schema (SchemaT, Migration)
import Database.Persist.Schema.Types hiding (Entity)
import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey)
--import Text.Email.QuasiQuotation (email
import Text.Email.Validate (unsafeEmailAddress)
import Web.PathPieces (toPathPiece)

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

import Vervis.Migration.Model

instance PersistDefault ByteString where
    pdef = def

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)

--withPrePost :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
--withPrePost pre (validate, apply) post = (validate, pre >> apply >> post)

changes :: MonadIO m => [Mig m]
changes =
    [ -- 1
      addEntities 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
    , addEntities model_2016_09_01_just_workflow
      -- 9
    , addEntities 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 Project2016]
                unless noProjects $ lift $ do
                    msid <-
                        listToMaybe <$>
                        selectKeysList [] [Asc Sharer2016Id, LimitTo 1]
                    for_ msid $ \ sid ->
                        insertKey key $
                            Workflow2016 sid "dummy" Nothing Nothing
      -- 11
    , addFieldPrimRequired "Workflow" ("WSSharer" :: Text) "scope"
      -- 12
    , unsetFieldPrimMaybe "Person" "hash" ("" :: Text)
      -- 13
    , changeFieldTypePrimRequiredFreeHs "Person" "hash" encodeUtf8
      -- 14
    --, unsetFieldPrimMaybe "Person" "email" [email|noreply@no.such.email|]
    , unsetFieldPrimMaybe "Person" "email" $
        unsafeEmailAddress "noreply" "no.such.email"
      -- 15
    , addFieldPrimRequired "Person" True "verified"
      -- 16
    , addFieldPrimRequired "Person" ("" :: Text) "verifiedKey"
      -- 17
    , addFieldPrimRequired "Person" ("" :: Text) "resetPassphraseKey"
      -- 18
    , renameField "Person" "hash" "passphraseHash"
      -- 19
    , renameField "Person" "resetPassphraseKey" "resetPassKey"
      -- 20
    , addFieldPrimRequired "Person" defaultTime "verifiedKeyCreated"
      -- 21
    , addFieldPrimRequired "Person" defaultTime "resetPassKeyCreated"
      -- 22
    , addUnique "Person" $ Unique "UniquePersonEmail" ["email"]
      -- 23
    , renameField "ProjectCollabAnon" "repo" "project"
      -- 24
    , renameField "ProjectCollabUser" "repo" "project"
      -- 25
    , addFieldPrimRequired "Person" ("" :: Text) "about"
      -- 26
    , setFieldMaybe "ProjectCollab" "role"
      -- 27
    , removeField "RepoCollab" "role"
      -- 28
    , addFieldRefOptional "RepoCollab" Nothing "role" "ProjectRole"
      -- 29
    , removeEntity "RepoCollabAnon"
      -- 30
    , removeEntity "RepoCollabUser"
      -- 31
    , addFieldRefOptional "Repo" Nothing "collabUser" "ProjectRole"
      -- 32
    , addFieldRefOptional "Repo" Nothing "collabAnon" "ProjectRole"
      -- 33
    , addFieldRefOptional "Project" Nothing "collabUser" "ProjectRole"
      -- 34
    , addFieldRefOptional "Project" Nothing "collabAnon" "ProjectRole"
      -- 35
    , unchecked $ lift $ do
        l <- E.select $ E.from $ \ (j `E.LeftOuterJoin`
                                   jcu `E.LeftOuterJoin`
                                   jca) -> do
            E.on $
                E.just (j E.^. Project2018Id) E.==.
                jca E.?. ProjectCollabAnon2018Project
            E.on $
                E.just (j E.^. Project2018Id) E.==.
                jcu E.?. ProjectCollabUser2018Project
            E.where_ $ E.not_ $
                E.isNothing (jcu E.?. ProjectCollabUser2018Project) E.&&.
                E.isNothing (jca E.?. ProjectCollabAnon2018Project)
            return
                ( j E.^. Project2018Id
                , jca E.?. ProjectCollabAnon2018Role
                , jcu E.?. ProjectCollabUser2018Role
                )
        for_ l $ \ (E.Value jid, E.Value malid, E.Value mulid) ->
            update jid
                [ Project2018CollabAnon =. malid
                , Project2018CollabUser =. mulid
                ]
      -- 36
    , removeEntity "ProjectCollabAnon"
      -- 37
    , removeEntity "ProjectCollabUser"
      -- 38
    , removeEntity "RepoAccess"
      -- 39
    , removeEntity "RepoRoleInherit"
      -- 40
    , removeEntity "RepoRole"
      -- 41
    , addEntities model_2019_02_03_verifkey
      -- 42
    , unchecked $ lift $ do
        deleteWhere ([] :: [Filter VerifKeySharedUsage2019])
        deleteWhere ([] :: [Filter VerifKey2019])
      -- 43
    , removeUnique "Message" "UniqueMessage"
      -- 44
    , removeField "Message" "number"
      -- 45
    , removeField "Discussion" "nextMessage"
      -- 46
    , addEntities model_2019_03_19
      -- 47
    , unchecked $ lift $ do
        msgs <- selectList ([] :: [Filter Message2019]) []
        let mklocal (Entity mid m) = LocalMessage2019 (message2019Author m) mid
        insertMany_ $ map mklocal msgs
      -- 48
    , removeField "Message" "author"
      -- 49
    , addUnique "Ticket" $ Unique "UniqueTicketDiscussion" ["discuss"]
      -- 50
    , addEntities model_2019_03_30
      -- 51
    , addFieldRefRequired'
        "Ticket"
        FollowerSet2019
        (Just $ do
            tids <- selectKeysList ([] :: [Filter Ticket2019]) []
            for_ tids $ \ tid -> do
                fsid <- insert FollowerSet2019
                update tid [Ticket2019Followers =. fsid]
        )
        "followers"
        "FollowerSet"
      -- 52
    , addUnique "Ticket" $ Unique "UniqueTicketFollowers" ["followers"]
      -- 53
    , removeField "RemoteDiscussion" "sharer"
      -- 54
    , addFieldPrimOptional
        "LocalMessage"
        (Nothing :: Maybe Text)
        "unlinkedParent"
      -- 55
    , addEntities model_2019_04_11
      -- 56
    , renameEntity "RemoteSharer" "RemoteActor"
      -- 57
    , renameUnique "RemoteActor" "UniqueRemoteSharer" "UniqueRemoteActor"
      -- 58
    , addFieldPrimOptional
        "RemoteActor"
        (Nothing :: Maybe UTCTime)
        "errorSince"
      -- 59
    , addEntities model_2019_04_12
      -- 60
    , addEntities model_2019_04_22
      -- 61
    , addFieldRefRequiredEmpty "RemoteMessage" "create" "RemoteActivity"
      -- 62
    , removeField "RemoteMessage" "raw"
      -- 63
    , removeEntity "RemoteRawObject"
    ]

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