{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2022, 2023 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.Federation.Discussion
    ( personCreateNoteF
    , deckCreateNoteF
    , loomCreateNoteF
    )
where

import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Yesod.HttpSignature

import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.Text
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Cloth
import Vervis.Data.Discussion
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Discussion
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket
import Vervis.Web.Delivery

-- | Insert the new remote comment into the discussion tree. If we didn't have
-- this comment before, return the database ID of the newly created cached
-- comment.
insertToDiscussion
    :: RemoteAuthor
    -> LocalURI
    -> UTCTime
    -> PandocMarkdown
    -> HTML
    -> DiscussionId
    -> Maybe (Either MessageId FedURI)
    -> RemoteActivityId
    -> AppDB (Maybe MessageId)
insertToDiscussion author luNote published source content did meparent ractid = do
    let iidAuthor = remoteAuthorInstance author
        raidAuthor = remoteAuthorId author
    mid <- insert Message
        { messageCreated = published
        , messageSource  = source
        , messageContent = content
        , messageParent  =
            case meparent of
                Just (Left midParent) -> Just midParent
                _                     -> Nothing
        , messageRoot    = did
        }
    roidNote <-
        either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
    mrmid <- insertUnique RemoteMessage
        { remoteMessageAuthor     = raidAuthor
        , remoteMessageIdent      = roidNote
        , remoteMessageRest       = mid
        , remoteMessageCreate     = ractid
        , remoteMessageLostParent =
            case meparent of
                Just (Right uParent) -> Just uParent
                _                    -> Nothing
        }
    case mrmid of
        Nothing -> do
            delete mid
            return Nothing
        Just _ -> return $ Just mid

-- | Look for known remote comments in the database, whose parent was unknown
-- but turns out to be the new comment we just received. Fix that in the
-- database and log warnings about it.
updateOrphans
    :: RemoteAuthor
    -> LocalURI
    -> DiscussionId
    -> MessageId
    -> AppDB ()
updateOrphans author luNote did mid = do
    let hAuthor = objUriAuthority $ remoteAuthorURI author
        uNote = ObjURI hAuthor luNote
    related <- selectOrphans uNote (E.==.)
    for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
        logWarn $ T.concat
            [ "Found parent for related orphan RemoteMessage #"
            , T.pack (show rmidOrphan)
            , ", setting its parent now to Message #"
            , T.pack (show mid)
            ]
        update rmidOrphan [RemoteMessageLostParent =. Nothing]
        update midOrphan [MessageParent =. Just mid]
    unrelated <- selectOrphans uNote (E.!=.)
    for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
        logWarn $ T.concat
            [ "Found parent for unrelated orphan RemoteMessage #"
            , T.pack (show rmidOrphan)
            , ", NOT settings its parent to Message #"
            , T.pack (show mid)
            , " because they have different DiscussionId!"
            ]
    where
    selectOrphans uNote op =
        E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
            E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
            E.where_ $
                rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
                m E.^. MessageRoot `op` E.val did
            return (rm E.^. RemoteMessageId, m E.^. MessageId)

personCreateNoteF
    :: UTCTime
    -> KeyHashid Person
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Note URIMode
    -> ExceptT Text Handler Text
personCreateNoteF now recipPersonHash author body mfwd luCreate note = do

    -- Check input
    recipPersonID <- decodeKeyHashid404 recipPersonHash
    (luNote, published, Comment maybeParent topic source content) <- do
        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
            throwE "Create author != note author"
        return (luId, published, comment)

    mractid <- runDBExcept $ do
        Entity recipActorID recipActor <- lift $ do
            person <- get404 recipPersonID
            let actorID = personActor person
            Entity actorID <$> getJust actorID

        case topic of

            Right uContext -> do
                checkContextParent uContext maybeParent
                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True

            Left (CommentTopicTicket deckID taskID) -> do
                (_, _, Entity _ ticket, _, _) <- do
                    mticket <- lift $ getTicket deckID taskID
                    fromMaybeE mticket "Context: No such deck-ticket"
                let did = ticketDiscuss ticket
                _ <- traverse (getMessageParent did) maybeParent
                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True

            Left (CommentTopicCloth loomID clothID) -> do
                (_, _, Entity _ ticket, _, _, _) <- do
                    mticket <- lift $ getCloth loomID clothID
                    fromMaybeE mticket "Context: No such loom-cloth"
                let did = ticketDiscuss ticket
                _ <- traverse (getMessageParent did) maybeParent
                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True

    return $
        case mractid of
            Nothing -> "I already have this activity in my inbox, doing nothing"
            Just _ -> "Inserted Create{Note} to my inbox"
    where
    checkContextParent (ObjURI hContext luContext) mparent = do
        mdid <- lift $ runMaybeT $ do
            iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
            rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid
            return $ remoteDiscussionDiscuss rd
        for_ mparent $ \ parent ->
            case parent of
                Left msg -> do
                    did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
                    void $ getLocalParentMessageId did msg
                Right (ObjURI hParent luParent) -> do
                    mrm <- lift $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
                    for_ mrm $ \ rm -> do
                        let mid = remoteMessageRest rm
                        m <- lift $ getJust mid
                        did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
                        unless (messageRoot m == did) $
                            throwE "Remote parent belongs to a different discussion"

deckCreateNoteF
    :: UTCTime
    -> KeyHashid Deck
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Note URIMode
    -> ExceptT Text Handler Text
deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do

    recipDeckID <- decodeKeyHashid404 recipDeckHash
    (luNote, published, Comment maybeParent topic source content) <- do
        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
            throwE "Create author != note author"
        return (luId, published, comment)

    case topic of
        Right _ ->
            pure "Topic is remote, i.e. not mine, so ignoring activity"
        Left (CommentTopicCloth _ _) ->
            pure "Topic is a local cloth, i.e. not mine, so ignoring activity"
        Left (CommentTopicTicket deckID taskID)
            | deckID /= recipDeckID ->
                pure "Topic is some other deck's ticket, so ignoring activity"
            | otherwise -> do
                msgOrForward <- runDBExcept $ do

                    Entity recipActorID recipActor <- lift $ do
                        deck <- get404 recipDeckID
                        let actorID = deckActor deck
                        Entity actorID <$> getJust actorID

                    (_d, _td, Entity _ ticket, _a, _r) <- do
                        mticket <- lift $ getTicket recipDeckID taskID
                        fromMaybeE mticket "Topic: No such ticket in DB"

                    mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luCreate False
                    case mractid of
                        Nothing -> return $ Left "Activity already in my inbox"
                        Just createID -> do
                            let did = ticketDiscuss ticket
                            meparent <- traverse (getMessageParent did) maybeParent
                            mmid <- lift $ insertToDiscussion author luNote published source content did meparent createID
                            case mmid of
                                Nothing -> return $ Left "I already have this comment, just storing in inbox"
                                Just mid -> lift $ do
                                    updateOrphans author luNote did mid
                                    case mfwd of
                                        Nothing ->
                                            return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
                                        Just (localRecips, sig) -> Right <$> do
                                            taskHash <- encodeKeyHashid taskID
                                            let sieve =
                                                    makeRecipientSet
                                                        []
                                                        [ LocalStageDeckFollowers recipDeckHash
                                                        , LocalStageTicketFollowers recipDeckHash taskHash
                                                        ]
                                            forwardActivityDB
                                                (actbBL body) localRecips sig recipActorID
                                                (LocalActorDeck recipDeckHash) sieve createID
                case msgOrForward of
                    Left msg -> return msg
                    Right forwardHttp -> do
                        forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                        return "Stored to inbox, cached comment, and did inbox forwarding"

loomCreateNoteF
    :: UTCTime
    -> KeyHashid Loom
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Note URIMode
    -> ExceptT Text Handler Text
loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do

    recipLoomID <- decodeKeyHashid404 recipLoomHash
    (luNote, published, Comment maybeParent topic source content) <- do
        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
            throwE "Create author != note author"
        return (luId, published, comment)

    case topic of
        Right _ ->
            pure "Topic is remote, i.e. not mine, so ignoring activity"
        Left (CommentTopicTicket _ _) ->
            pure "Topic is a local issue, i.e. not mine, so ignoring activity"
        Left (CommentTopicCloth loomID clothID)
            | loomID /= recipLoomID ->
                pure "Topic is some other loom's MR, so ignoring activity"
            | otherwise -> do
                msgOrForward <- runDBExcept $ do

                    Entity recipActorID recipActor <- lift $ do
                        loom <- get404 recipLoomID
                        let actorID = loomActor loom
                        Entity actorID <$> getJust actorID

                    (_l, _tl, Entity _ ticket, _a, _r, _) <- do
                        mcloth <- lift $ getCloth recipLoomID clothID
                        fromMaybeE mcloth "Topic: No such cloth in DB"

                    mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luCreate False
                    case mractid of
                        Nothing -> return $ Left "Activity already in my inbox"
                        Just createID -> do
                            let did = ticketDiscuss ticket
                            meparent <- traverse (getMessageParent did) maybeParent
                            mmid <- lift $ insertToDiscussion author luNote published source content did meparent createID
                            case mmid of
                                Nothing -> return $ Left "I already have this comment, just storing in inbox"
                                Just mid -> lift $ do
                                    updateOrphans author luNote did mid
                                    case mfwd of
                                        Nothing ->
                                            return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
                                        Just (localRecips, sig) -> Right <$> do
                                            clothHash <- encodeKeyHashid clothID
                                            let sieve =
                                                    makeRecipientSet
                                                        []
                                                        [ LocalStageLoomFollowers recipLoomHash
                                                        , LocalStageClothFollowers recipLoomHash clothHash
                                                        ]
                                            forwardActivityDB
                                                (actbBL body) localRecips sig recipActorID
                                                (LocalActorLoom recipLoomHash) sieve createID
                case msgOrForward of
                    Left msg -> return msg
                    Right forwardHttp -> do
                        forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                        return "Stored to inbox, cached comment, and did inbox forwarding"