{- 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.Applicative
import Control.Exception
import Control.Monad (unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
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.Text as T
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 Database.Persist.Local

import Vervis.Model.Ident
import Vervis.Foundation (Route (..))
import Vervis.Migration.Model
import Vervis.Render

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 => Text -> HashidsContext -> [Mig m]
changes hLocal 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
                doc = 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 $ 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
                            -- Figure out:
                            --   * aud
                            --   * uContext
                            --   * muParent
                            m <- getJust $ localMessage201905Rest lm

                            let did = message201905Root m
                            mcontext <-
                                runMaybeT
                                    $   Left <$> MaybeT (getValBy $ UniqueTicketDiscussion201905 did)
                                    <|> Right <$> MaybeT (getValBy $ UniqueRemoteDiscussion201905 did)
                            let context =
                                    case mcontext of
                                        Nothing -> error "DiscussionId not used"
                                        Just c -> c
                            (uContext, recips) <-
                                case context of
                                    Left t -> do
                                        j <- getJust $ ticket201905Project t
                                        let tprj = project201905Ident j
                                        s <- getJust $ project201905Sharer j
                                        let tshr = sharer201905Ident s
                                            jPath = T.concat
                                                [ "/s/", shr2text tshr
                                                , "/p/", prj2text tprj
                                                ]
                                            tPath = T.concat
                                                [ jPath
                                                , "/t/", T.pack $ show $ ticket201905Number t
                                                ]
                                        return
                                            ( FedURI hLocal tPath ""
                                            , map (l2f hLocal . flip LocalURI "")
                                                [ jPath
                                                , tPath <> "/participants"
                                                , tPath <> "/team"
                                                ]
                                            )
                                    Right rd -> do
                                        i <- getJust $
                                            remoteDiscussion201905Instance rd
                                        return
                                            ( l2f
                                                (instance201905Host i)
                                                (remoteDiscussion201905Ident rd)
                                            , []
                                            )

                            -- parent
                            muParent <-
                                case Left <$> localMessage201905UnlinkedParent lm <|>
                                     Right <$> message201905Parent m of
                                    Nothing -> return Nothing
                                    Just (Left fu) -> return $ Just fu
                                    Just (Right midParent) -> Just <$> do
                                        mparent <-
                                            runMaybeT
                                                $   Left <$> MaybeT (getBy $ UniqueLocalMessage201905 midParent)
                                                <|> Right <$> MaybeT (getValBy $ UniqueRemoteMessage201905 midParent)
                                        case fromJust mparent of
                                            Left (Entity lmidP lmP) -> do
                                                p <- getJust $ localMessage201905Author lmP
                                                s <- getJust $ person201905Ident p
                                                let path = T.concat
                                                        [ "/s/", shr2text $ sharer201905Ident s
                                                        , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP
                                                        ]
                                                return $ FedURI hLocal path ""
                                            Right rmP -> do
                                                i <- getJust $
                                                    remoteMessage201905Instance rmP
                                                return $
                                                    l2f (instance201905Host i)
                                                        (remoteMessage201905Ident rmP)

                            let msg = T.filter (/= '\r') $ message201905Content m
                            contentHtml <-
                                case renderPandocMarkdown msg of
                                    Left e -> error $ T.unpack e
                                    Right t -> return t

                            let aud = Audience recips [] [] [] [] []

                                luAttrib = LocalURI ("/s/" <> shr2text shr) ""
                                activity luAct luNote = Doc hLocal Activity
                                    { activityId       = luAct
                                    , activityActor    = luAttrib
                                    , activityAudience = aud
                                    , activitySpecific = CreateActivity Create
                                        { createObject = Note
                                            { noteId        = Just luNote
                                            , noteAttrib    = luAttrib
                                            , noteAudience  = aud
                                            , noteReplyTo   = Just $ fromMaybe uContext muParent
                                            , noteContext   = Just uContext
                                            , notePublished = Just $ message201905Created m
                                            , noteSource    = msg
                                            , noteContent   = contentHtml
                                            }
                                        }
                                    }
                                tempUri = LocalURI "" ""
                            newObid <- insert OutboxItem201905
                                { outboxItem201905Person    = pid
                                , outboxItem201905Activity  = PersistJSON $ activity tempUri tempUri
                                , outboxItem201905Published = message201905Created m
                                }
                            let notePath = T.concat
                                    [ "/s/", shr2text shr
                                    , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmid
                                    ]
                                obPath = T.concat
                                    [ "/s/", shr2text shr
                                    , "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid
                                    ]
                                luAct = LocalURI obPath ""
                                luNote = LocalURI notePath ""
                                doc = activity luAct luNote
                            update newObid [OutboxItem201905Activity =. PersistJSON doc]
                            return newObid
                update lmid [LocalMessage201905Create =. obidNew]

            delete obid
            let pid = outboxItem201905Person ob
            p <- getJust pid
            delete pid
            delete $ person201905Ident p
        )
        "create"
        "OutboxItem"
      -- 78
    , addUnique "LocalMessage" $ Unique "UniqueLocalMessageCreate" ["create"]
      -- 79
    , renameEntity "ProjectRole" "Role"
      -- 80
    , renameUnique "Role" "UniqueProjectRole" "UniqueRole"
      -- 81
    , renameEntity "ProjectRoleInherit" "RoleInherit"
      -- 82
    , renameUnique "RoleInherit" "UniqueProjectRoleInherit" "UniqueRoleInherit"
      -- 83
    , renameEntity "ProjectAccess" "RoleAccess"
      -- 84
    , renameUnique "RoleAccess" "UniqueProjectAccess" "UniqueRoleAccess"
      -- 85
    , renameField "Message" "content" "source"
      -- 86
    , addFieldPrimRequired "Message" ("" :: Text) "content"
      -- 87
    , unchecked $ lift $ do
        msgs <- selectList ([] :: [Filter Message201906]) []
        for_ msgs $ \ (Entity mid m) ->
            let source = T.filter (/= '\r') $ message201906Source m
            in  case renderPandocMarkdown $ message201906Source m of
                    Left err -> liftIO $ throwIO $ userError $ T.unpack err
                    Right content ->
                        update mid
                            [ Message201906Source  =. source
                            , Message201906Content =. content
                            ]
    ]

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