{- This file is part of Vervis.
 -
 - Written in 2016, 2019, 2020, 2022 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.Web.Discussion
    ( serveDiscussion
    , getTopReply
    , getReply
    , postReply
    , serveMessage
    )
where

import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Time.Clock (getCurrentTime)
import Database.Persist
import Database.Persist.Sql
import Data.Traversable
import Text.Blaze.Html (Html)
import Data.Text (Text)
import Yesod.Auth
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)

import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Data.Aeson.Encode.Pretty.ToEncoding
import Database.Persist.JSON
import Network.FedURI
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import qualified Web.ActivityPub as AP

import Data.Either.Local
import Database.Persist.Local
import Yesod.Form.Local
import Yesod.Persist.Local

import Vervis.API
import Vervis.Data.Discussion
import Vervis.Data.Ticket
import Vervis.FedURI
import Vervis.Form.Discussion
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Actor
import Vervis.Persist.Discussion
import Vervis.Persist.Ticket
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket
import Vervis.Widget.Discussion

import qualified Vervis.Client as C

getRepliesCollection
    :: Route App -> AppDB DiscussionId -> Handler (AP.Collection FedURI URIMode)
getRepliesCollection here getDiscussionId404 = do
    (locals, remotes) <- runDB $ do
        did <- getDiscussionId404
        (,) <$> selectLocals did <*> selectRemotes did
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    hashMsg <- getEncodeKeyHashid
    hashActor <- getHashLocalActor
    let localUri (authorByKey, localMsgID) =
            encodeRouteHome $
                messageRoute (hashActor authorByKey) (hashMsg localMsgID)
    return AP.Collection
        { AP.collectionId         = encodeRouteLocal here
        , AP.collectionType       = AP.CollectionTypeUnordered
        , AP.collectionTotalItems = Just $ length locals + length remotes
        , AP.collectionCurrent    = Nothing
        , AP.collectionFirst      = Nothing
        , AP.collectionLast       = Nothing
        , AP.collectionItems      =
            map localUri locals ++ map remoteUri remotes
        }
    where
    selectLocals did = do
        locals <- E.select $ E.from $ \ (m `E.InnerJoin` lm) -> do
            E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest
            E.where_ $
                m E.^. MessageRoot E.==. E.val did E.&&.
                E.isNothing (m E.^. MessageParent) E.&&.
                E.isNothing (lm E.^. LocalMessageUnlinkedParent)
            return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId)
        for locals $ \ (E.Value actorID, E.Value localMsgID) -> do
            actorByKey <- getLocalActor actorID
            return (actorByKey, localMsgID)
    selectRemotes did =
        E.select $ E.from $
            \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do
                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
                E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId
                E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest
                E.where_ $
                    m E.^. MessageRoot E.==. E.val did E.&&.
                    E.isNothing (m E.^. MessageParent) E.&&.
                    E.isNothing (rm E.^. RemoteMessageLostParent)
                return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
    remoteUri (E.Value h, E.Value lu) = ObjURI h lu

serveDiscussion
    :: Route App
    -> (MessageId -> Route App)
    -> Route App
    -> AppDB DiscussionId
    -> Handler TypedContent
serveDiscussion here reply topic getdid = do
    replies <- getRepliesCollection here getdid
    provideHtmlAndAP replies (discussionW getdid topic reply)

{-
getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode
getNodeL getdid lmid = do
    did <- getdid
    lm <- get404 lmid
    let mid = localMessageRest lm
    m <- getJust mid
    unless (messageRoot m == did) notFound
    p <- getJust $ localMessageAuthor lm
    s <- getJust $ personIdent p
    return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
-}

getTopReply :: Route App -> Handler Html
getTopReply replyP = do
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/top-reply")

getReply'
    :: (MessageId -> Route App)
    -> (MessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
getReply' replyG replyP getdid midParent = do
    mtn <- runDB $ getMessageFromID getdid midParent
    now <- liftIO getCurrentTime
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/reply")

getReply
    :: (MessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
getReply replyR = getReply' replyR replyR

postReply
    :: Route App
    -> [LocalActorBy KeyHashid]
    -> [LocalStageBy KeyHashid]
    -> Route App
    -> Maybe (AppDB DiscussionId, MessageId)
    -> Handler Html
postReply formR actors stages topicR maybeParent = do
    source <- runFormPostRedirect formR newMessageForm
    person@(Entity senderID sender) <- requireAuth
    senderHash <- encodeKeyHashid senderID
    errorOrCreate <- runExceptT $ do
        muParent <- for maybeParent $ \ (getdid, midParent) -> do
            MessageTreeNode _ _ author <-
                lift $ runDB $ getMessageFromID getdid midParent
            case author of
                MessageTreeNodeLocal localMsgID authorByKey _ _ -> do
                    encodeRouteHome <- getEncodeRouteHome
                    localMsgHash <- encodeKeyHashid localMsgID
                    authorByHash <- hashLocalActor authorByKey
                    return $ encodeRouteHome $
                        messageRoute authorByHash localMsgHash
                MessageTreeNodeRemote h _ luAuthor _ ->
                    return $ ObjURI h luAuthor
        (maybeSummary, audience, note) <-
            C.comment senderHash source actors stages topicR muParent
        hLocal <- asksSite siteInstanceHost
        let specific =
                AP.CreateActivity $
                    AP.Create (AP.CreateNote hLocal note) Nothing
        (localRecips, remoteRecips, fwdHosts, action) <-
            lift $ C.makeServerInput Nothing maybeSummary audience specific
        actor <- lift $ runDB $ getJust $ personActor sender
        createNoteC
            person actor Nothing localRecips remoteRecips fwdHosts
            action note Nothing
    case errorOrCreate of
        Left e -> do
            setMessage $ toHtml e
            redirect formR
        Right createID -> do
            setMessage "Message submitted."
            redirect topicR

serveMessage authorHash localMessageHash = do
    authorID <- decodeKeyHashid404 authorHash
    localMessageID <- decodeKeyHashid404 localMessageHash

    encodeRouteHome <- getEncodeRouteHome
    noteAP <- runDB $ do
        author <- get404 authorID
        localMessage <- get404 localMessageID
        unless (localMessageAuthor localMessage == personActor author) notFound
        message <- getJust $ localMessageRest localMessage

        uContext <- do
            let discussionID = messageRoot message
            topic <-
                requireEitherAlt
                    (getKeyBy $ UniqueTicketDiscuss discussionID)
                    (getValBy $ UniqueRemoteDiscussion discussionID)
                    "Neither T nor RD found"
                    "Both T and RD found"
            case topic of
                Left ticketID -> do
                    wiByKey <- getWorkItem ticketID
                    wiByHash <- hashWorkItem wiByKey
                    return $ encodeRouteHome $ workItemRoute wiByHash
                Right rd -> do
                    ro <- getJust $ remoteDiscussionIdent rd
                    i <- getJust $ remoteObjectInstance ro
                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)

        muParent <- for (messageParent message) $ \ parentID -> do
            parent <-
                requireEitherAlt
                    (getBy $ UniqueLocalMessage parentID)
                    (getValBy $ UniqueRemoteMessage parentID)
                    "Message with no author"
                    "Message used as both local and remote"
            case parent of
                Left (Entity localParentID localParent) -> do
                    authorByKey <-
                        getLocalActor $ localMessageAuthor localParent
                    authorByHash <- hashLocalActor authorByKey
                    localParentHash <- encodeKeyHashid localParentID
                    return $
                        encodeRouteHome $
                            messageRoute authorByHash localParentHash
                Right remoteParent -> do
                    rs <- getJust $ remoteMessageAuthor remoteParent
                    ro <- getJust $ remoteActorIdent rs
                    i <- getJust $ remoteObjectInstance ro
                    return $ ObjURI (instanceHost i) (remoteObjectIdent ro)

        encodeRouteLocal <- getEncodeRouteLocal
        return AP.Note
            { AP.noteId        = Just $ encodeRouteLocal here
            , AP.noteAttrib    = encodeRouteLocal $ PersonR authorHash
            , AP.noteAudience  = AP.Audience [] [] [] [] [] []
            , AP.noteReplyTo   = Just $ fromMaybe uContext muParent
            , AP.noteContext   = Just uContext
            , AP.notePublished = Just $ messageCreated message
            , AP.noteSource    = messageSource message
            , AP.noteContent   = messageContent message
            }
    provideHtmlAndAP noteAP $ redirectToPrettyJSON here
    where
    here = PersonMessageR authorHash localMessageHash