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
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
import Data.Proxy
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock
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.Hashids
import Web.PathPieces (toPathPiece)

import qualified Data.Aeson as A
import qualified Database.Esqueleto as E

import qualified Database.Persist.Schema as S
import qualified Database.Persist.Schema.Types as ST

import Network.FedURI
import Database.Persist.JSON
import Web.ActivityPub
import Yesod.FedURI
import Yesod.Hashids

import Vervis.Model.Ident
import Vervis.Foundation (Route (..))
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 => HashidsContext -> [Mig m]
changes ctx =
    [ -- 1
      addEntities model_2016_08_04
      -- 2
    , unchecked $ S.unsetFieldDefault "Sharer" "created"
      -- 3
    , unchecked $ S.unsetFieldDefault "Project" "nextTicket"
      -- 4
    , unchecked $ S.unsetFieldDefault "Repo" "vcs"
      -- 5
    , unchecked $ S.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"
      -- 64
    , addFieldPrimRequired "UnlinkedDelivery" True "forwarding"
      -- 65
    , addFieldPrimRequired "Delivery" True "forwarding"
      -- 66
    , addEntities model_2019_05_03
      -- 67
    , addFieldPrimRequired "Follow" False "manual"
      -- 68
    , addFieldPrimRequired "RemoteFollow" False "manual"
      -- 69
    , addEntity $ ST.Entity "InboxItem" [] []
      -- 70
    , addFieldRefRequiredEmpty "InboxItemLocal" "item" "InboxItem"
      -- 71
    , addFieldRefRequiredEmpty "InboxItemRemote" "item" "InboxItem"
      -- 72
    , addUnique "InboxItemLocal" $ Unique "UniqueInboxItemLocalItem" ["item"]
      -- 73
    , addUnique "InboxItemRemote" $ Unique "UniqueInboxItemRemoteItem" ["item"]
      -- 74
    , addEntities model_2019_05_17
      -- 75
    , addFieldPrimOptional "RemoteActor" (Nothing :: Maybe Text) "name"
      -- 76
    , addFieldPrimRequired "InboxItem" False "unread"
      -- 77
    , addFieldRefRequired''
        "LocalMessage"
        (do let user = "$$temp$$"
            sid <-
                insert $ Sharer201905 (text2shr user) Nothing defaultTime
            pid <-
                insert $
                    Person201905
                        sid user "" "e@ma.il" False "" defaultTime ""
                        defaultTime ""
            let localUri = LocalURI "/x/y" ""
                fedUri = l2f "x.y" localUri
                d2v = fromJust . A.decode . A.encode
                doc = d2v $ Doc "x.y" Activity
                    { activityId       = localUri
                    , activityActor    = localUri
                    , activityAudience = Audience [] [] [] [] [] []
                    , activitySpecific = AcceptActivity $ Accept fedUri
                    }
            insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
        )
        (Just $ \ (Entity obid ob) -> do
            let actNoteId (Activity _ _ _ (CreateActivity (Create note))) = noteId note
                actNoteId _                                               = Nothing
                obNoteId (Entity i o) =
                    if i == obid
                        then Nothing
                        else (,i) <$> actNoteId (docValue $ fromJust $ A.decode $ A.encode $ persistJSONValue $ outboxItem201905Activity o)
            obs <-
                mapMaybe obNoteId <$>
                    selectList ([] :: [Filter OutboxItem201905]) []
            lms <- selectList ([] :: [Filter LocalMessage201905]) []
            for_ lms $ \ (Entity lmid lm) -> do
                let pid = localMessage201905Author lm
                p <- getJust pid
                s <- getJust $ person201905Ident p
                let shr = sharer201905Ident s
                    route = MessageR shr (encodeKeyHashidPure ctx $ E.toSqlKey $ E.fromSqlKey lmid)
                    match (luNote, obid') =
                        case decodeRouteLocal luNote of
                            Just r@(MessageR _ _) ->
                                if r == route
                                    then Just obid'
                                    else Nothing
                            _ -> error "Invalid local luNote"
                    mobid =
                        case mapMaybe match obs of
                            [] -> Nothing
                            [k] -> Just k
                            _ -> error "Multiple outbox IDs!"
                obidNew <-
                    case mobid of
                        Just k -> return k
                        Nothing -> do
                            now <- liftIO getCurrentTime
                            let localUri = LocalURI "/x/y" ""
                                fedUri = l2f "lo.cal" localUri
                                d2v = fromJust . A.decode . A.encode
                                doc = PersistJSON $ d2v $ Doc "lo.cal" Activity
                                    { activityId       = localUri
                                    , activityActor    = localUri
                                    , activityAudience = Audience [] [] [] [] [] []
                                    , activitySpecific = AcceptActivity $ Accept fedUri
                                    }
                            insert $ OutboxItem201905 pid doc now
                update lmid [LocalMessage201905Create =. obidNew]

            delete obid
            let pid = outboxItem201905Person ob
            p <- getJust pid
            delete pid
            delete $ person201905Ident p
        )
        "create"
        "OutboxItem"
    ]

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