{- This file is part of Vervis.
 -
 - Written in 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/>.
 -}

{-# LANGUAGE RankNTypes #-}

module Vervis.Federation.Collab
    ( --personInviteF
      topicInviteF

    , repoJoinF
    , deckJoinF
    , loomJoinF

    , repoAcceptF
    , deckAcceptF
    , loomAcceptF

    --, personGrantF
    )
where

import Control.Applicative
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Functor.Identity
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T

import Database.Persist.JSON
import Development.PatchMediaType
import Network.FedURI
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.Either.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Web.Delivery
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Recipient
import Vervis.RemoteActorStore

topicInviteF
    :: UTCTime
    -> GrantResourceBy KeyHashid
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Invite URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
topicInviteF now recipByHash author body mfwd luInvite invite = do

    -- Check input
    uCap <- do
        let muCap = AP.activityCapability $ actbActivity body
        fromMaybeE muCap "No capability provided"
    (resourceAndCap, recipient) <- do

        -- Check the invite-specific data
        (resource, recip) <-
            parseInvite (Right $ remoteAuthorURI author) invite

        -- Verify the capability URI is one of:
        --   * Outbox item URI of a local actor, i.e. a local activity
        --   * A remote URI
        capability <- nameExceptT "Invite capability" $ parseActivityURI uCap

        -- Verify that capability is either a local activity of a local
        -- resource, or both resource and capability are of the same remote
        -- instance
        (,recip) <$> case (resource, capability) of
            (Left r, Left (actor, _, item)) -> do
                unless (grantResourceLocalActor r == actor) $
                    throwE "Local capability belongs to actor that isn't the resource"
                return $ Left (r, item)
            (Left _, Right _) ->
                throwE "Remote capability obviously doesn't belong to local resource"
            (Right _, Left _) ->
                throwE "Local capability obviously doesn't belong to remote resource"
            (Right (ObjURI h r), Right (ObjURI h' c)) -> do
                unless (h == h') $
                    throwE "Capability and resource are on different remote instances"
                return $ Right (ObjURI h r, c)

    -- Find recipient topic in DB, returning 404 if doesn't exist because
    -- we're in the topic's inbox post handler
    recipByKey <- unhashGrantResource404 recipByHash
    (_recipByEntity, recipActorID, recipActor) <- lift $ runDB $ do
        recipE <- getGrantResource404 recipByKey
        let actorID = grantResourceActorID $ bmap (Identity . entityVal) recipE
        (recipE, actorID,) <$> getJust actorID

    -- Verify that Invite's topic is me, otherwise I don't need this Invite
    capability <-
        case resourceAndCap of
            Left (resource, item) | resource == recipByKey -> return item
            _ -> throwE "I'm not the Invite's topic, don't need this Invite"

    return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
        mhttp <- do
            mractid <- lift $ runSiteDB $ insertToInbox now author body (actorInbox recipActor) luInvite False
            for mractid $ \ inviteID -> do

                -- Verify the specified capability gives relevant access to the
                -- resource
                let recipLocalActorByKey = grantResourceLocalActor recipByKey
                runSiteDBExcept $
                    verifyCapability
                        (recipLocalActorByKey, capability)
                        (Right $ remoteAuthorId author)
                        recipByKey

                -- If recipient is remote, HTTP GET it, make sure it's an
                -- actor, and insert it to our DB. If recipient is local, find
                -- it in our DB.
                recipientDB <-
                    bitraverse
                        (runSiteDBExcept . flip getGrantRecip "Invitee not found in DB")
                        (\ u@(ObjURI h lu) -> do
                            instanceID <-
                                lift $ runSiteDB $ either entityKey id <$> insertBy' (Instance h)
                            result <-
                                ExceptT $ first (T.pack . displayException) <$>
                                    fetchRemoteActor instanceID h lu
                            case result of
                                Left Nothing -> throwE "Recipient @id mismatch"
                                Left (Just err) -> throwE $ T.pack $ displayException err
                                Right Nothing -> throwE "Recipient isn't an actor"
                                Right (Just actor) -> return $ entityKey actor
                        )
                        recipient

                lift $ runSiteDB $ do

                    -- Insert Collab record to DB
                    insertCollab recipByKey recipientDB inviteID

                    -- Forward the Invite activity to relevant local stages,
                    -- and schedule delivery for unavailable remote members of
                    -- them
                    for mfwd $ \ (localRecips, sig) -> do
                        let recipLocalActor =
                                grantResourceLocalActor recipByHash
                            sieve =
                                makeRecipientSet [] [localActorFollowers recipLocalActor]
                        forwardActivityDB
                            (actbBL body) localRecips sig recipActorID
                            recipLocalActor sieve inviteID

        -- Launch asynchronous HTTP forwarding of the Invite activity
        case mhttp of
            Nothing -> return "I already have this activity in my inbox, doing nothing"
            Just maybeForward -> do
                traverse_ (forkWorker "topicInviteF inbox-forwarding") maybeForward
                return $
                    case maybeForward of
                        Nothing -> "Inserted Collab to DB, no inbox-forwarding to do"
                        Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Invite"

    where

    insertCollab resource recipient inviteID = do
        collabID <- insert Collab
        fulfillsID <- insert $ CollabFulfillsInvite collabID
        case resource of
            GrantResourceRepo repoID ->
                insert_ $ CollabTopicRepo collabID repoID
            GrantResourceDeck deckID ->
                insert_ $ CollabTopicDeck collabID deckID
            GrantResourceLoom loomID ->
                insert_ $ CollabTopicLoom collabID loomID
        let authorID = remoteAuthorId author
        insert_ $ CollabInviterRemote fulfillsID authorID inviteID
        case recipient of
            Left (GrantRecipPerson (Entity personID _)) ->
                insert_ $ CollabRecipLocal collabID personID
            Right remoteActorID ->
                insert_ $ CollabRecipRemote collabID remoteActorID

topicJoinF
    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
    => (topic -> ActorId)
    -> (forall f. f topic -> GrantResourceBy f)
    -> UTCTime
    -> KeyHashid topic
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Join URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
topicJoinF topicActor topicResource now recipHash author body mfwd luJoin join = (,Nothing) <$> do

    -- Check input
    recipKey <- decodeKeyHashid404 recipHash
    verifyNothingE
        (AP.activityCapability $ actbActivity body)
        "Capability not needed"
    resource <- parseJoin join
    unless (resource == Left (topicResource recipKey)) $
        throwE "Join's object isn't me, don't need this Join"

    maybeHttp <- lift $ runDB $ do

        -- Find recipient topic in DB, returning 404 if doesn't exist because
        -- we're in the topic's inbox post handler
        (recipActorID, recipActor) <- do
            topic <- get404 recipKey
            let actorID = topicActor topic
            (actorID,) <$> getJust actorID

        -- Insert the Join to topic's inbox
        mractid <- insertToInbox now author body (actorInbox recipActor) luJoin False
        for mractid $ \ joinID -> do

            -- Insert Collab record to DB
            insertCollab (topicResource recipKey) joinID

            -- Forward the Join activity to relevant local stages,
            -- and schedule delivery for unavailable remote members of
            -- them
            for mfwd $ \ (localRecips, sig) -> do
                let recipByHash =
                        grantResourceLocalActor $ topicResource recipHash
                    sieve =
                        makeRecipientSet
                            []
                            [localActorFollowers recipByHash]
                forwardActivityDB
                    (actbBL body) localRecips sig recipActorID recipByHash
                    sieve joinID

    -- Launch asynchronous HTTP forwarding of the Join activity
    case maybeHttp of
        Nothing -> return "I already have this activity in my inbox, doing nothing"
        Just maybeForward -> do
            traverse_ (forkWorker "topicJoinF inbox-forwarding") maybeForward
            return $
                case maybeForward of
                    Nothing -> "Inserted Collab to DB, no inbox-forwarding to do"
                    Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Join"

    where

    insertCollab topic joinID = do
        collabID <- insert Collab
        fulfillsID <- insert $ CollabFulfillsJoin collabID
        case topic of
            GrantResourceRepo repoID ->
                insert_ $ CollabTopicRepo collabID repoID
            GrantResourceDeck deckID ->
                insert_ $ CollabTopicDeck collabID deckID
            GrantResourceLoom loomID ->
                insert_ $ CollabTopicLoom collabID loomID
        let authorID = remoteAuthorId author
        recipID <- insert $ CollabRecipRemote collabID authorID
        insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID

repoJoinF
    :: UTCTime
    -> KeyHashid Repo
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Join URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
repoJoinF = topicJoinF repoActor GrantResourceRepo

deckJoinF
    :: UTCTime
    -> KeyHashid Deck
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Join URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
deckJoinF = topicJoinF deckActor GrantResourceDeck

loomJoinF
    :: UTCTime
    -> KeyHashid Loom
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Join URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
loomJoinF = topicJoinF loomActor GrantResourceLoom

topicAcceptF
    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
    => (topic -> ActorId)
    -> (forall f. f topic -> GrantResourceBy f)
    -> UTCTime
    -> KeyHashid topic
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Accept URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
topicAcceptF topicActor topicResource now recipHash author body mfwd luAccept accept = (,Nothing) <$> do

    -- Check input
    acceptee <- parseAccept accept

    -- Verify the capability URI is one of:
    --   * Outbox item URI of a local actor, i.e. a local activity
    --   * A remote URI
    maybeCap <-
        traverse
            (nameExceptT "Accept capability" . parseActivityURI)
            (AP.activityCapability $ actbActivity body)

    -- Find recipient topic in DB, returning 404 if doesn't exist because
    -- we're in the topic's inbox post handler
    recipKey <- decodeKeyHashid404 recipHash
    mhttp <- runDBExcept $ do
        (recipActorID, recipActor) <- lift $ do
            recip <- get404 recipKey
            let actorID = topicActor recip
            (actorID,) <$> getJust actorID

        -- Find the accepted activity in our DB
        accepteeDB <- do
            a <- getActivity acceptee
            fromMaybeE a "Can't find acceptee in DB"

        -- See if the accepted activity is an Invite or Join to a local
        -- resource, grabbing the Collab record from our DB
        collab <- do
            maybeCollab <-
                lift $ runMaybeT $
                    Left <$> tryInvite accepteeDB <|>
                    Right <$> tryJoin accepteeDB
            fromMaybeE maybeCollab "Accepted activity isn't an Invite or Join I'm aware of"

        -- Find the local resource and verify it's me
        collabID <-
            lift $ case collab of
                Left (fulfillsID, _) ->
                    collabFulfillsInviteCollab <$> getJust fulfillsID
                Right (fulfillsID, _) ->
                    collabFulfillsJoinCollab <$> getJust fulfillsID
        topic <- lift $ getCollabTopic collabID
        unless (topicResource recipKey == topic) $
            throwE "Accept object is an Invite for some other resource"

        idsForAccept <-
            case collab of

                -- If accepting an Invite, find the Collab recipient and verify
                -- it's the sender of the Accept
                Left (fulfillsID, _) -> Left <$> do
                    recip <-
                        lift $
                        requireEitherAlt
                            (getBy $ UniqueCollabRecipLocal collabID)
                            (getBy $ UniqueCollabRecipRemote collabID)
                            "Found Collab with no recip"
                            "Found Collab with multiple recips"
                    case recip of
                        Right (Entity crrid crr)
                            | collabRecipRemoteActor crr == remoteAuthorId author -> return (fulfillsID, crrid)
                        _ -> throwE "Accepting an Invite whose recipient is someone else"

                -- If accepting a Join, verify accepter has permission
                Right (fulfillsID, _) -> Right <$> do
                    capID <- fromMaybeE maybeCap "No capability provided"
                    capability <-
                        case capID of
                            Left (capActor, _, capItem) -> return (capActor, capItem)
                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
                    verifyCapability
                        capability
                        (Right $ remoteAuthorId author)
                        (topicResource recipKey)
                    return fulfillsID

        -- Verify the Collab isn't already validated
        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
        verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"

        -- Record the Accept on the Collab
        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
        for mractid $ \ acceptID -> do

            case idsForAccept of
                Left (fulfillsID, recipID) -> do
                    maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
                    unless (isNothing maybeAccept) $ do
                        lift $ delete acceptID
                        throwE "This Invite already has an Accept by recip"
                Right fulfillsID -> do
                    maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
                    unless (isNothing maybeAccept) $ do
                        lift $ delete acceptID
                        throwE "This Join already has an Accept"

            -- Forward the Accept activity to relevant local stages, and
            -- schedule delivery for unavailable remote members of them
            let recipByHash = grantResourceLocalActor $ topicResource recipHash
            maybeHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do
                let sieve =
                        makeRecipientSet [] [localActorFollowers recipByHash]
                forwardActivityDB
                    (actbBL body) localRecips sig recipActorID recipByHash
                    sieve acceptID

            deliverHttpGrant <- do

                -- Enable the Collab in our DB
                grantID <- lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
                lift $ insert_ $ CollabEnable collabID grantID

                -- Prepare a Grant activity and insert to topic's outbox
                let inviterOrJoiner = either snd snd collab
                (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
                    lift $ prepareGrant inviterOrJoiner
                let recipByKey = grantResourceLocalActor $ topicResource recipKey
                _luGrant <- lift $ updateOutboxItem recipByKey grantID actionGrant

                -- Deliver the Grant to local recipients, and schedule delivery
                -- for unavailable remote recipients
                deliverActivityDB
                    recipByHash recipActorID localRecipsGrant remoteRecipsGrant
                    fwdHostsGrant grantID actionGrant

            return (maybeHttpFwdAccept, deliverHttpGrant)

    -- Launch asynchronous HTTP forwarding of the Accept activity
    case mhttp of
        Nothing -> return "I already have this activity in my inbox, doing nothing"
        Just (mhttpFwd, deliverHttpGrant) -> do
            forkWorker "topicAcceptF Grant HTTP delivery" deliverHttpGrant
            case mhttpFwd of
                Nothing -> return "Sent a Grant, no inbox-forwarding to do"
                Just forwardHttpAccept -> do
                    forkWorker "topicAcceptF inbox-forwarding" forwardHttpAccept
                    return "Sent a Grant and ran inbox-forwarding of the Accept"

    where

    tryInvite (Left (actorByKey, _actorEntity, itemID)) =
        (,Left actorByKey) . collabInviterLocalCollab <$>
            MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
    tryInvite (Right remoteActivityID) = do
        CollabInviterRemote collab actorID _ <-
            MaybeT $ getValBy $
                UniqueCollabInviterRemoteInvite remoteActivityID
        actor <- lift $ getJust actorID
        sender <-
            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
        return (collab, Right sender)

    tryJoin (Left (actorByKey, _actorEntity, itemID)) =
        (,Left actorByKey) . collabRecipLocalJoinFulfills <$>
            MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
    tryJoin (Right remoteActivityID) = do
        CollabRecipRemoteJoin recipID fulfillsID _ <-
            MaybeT $ getValBy $
                UniqueCollabRecipRemoteJoinJoin remoteActivityID
        remoteActorID <- lift $ collabRecipRemoteActor <$> getJust recipID
        actor <- lift $ getJust remoteActorID
        joiner <-
            lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
        return (fulfillsID, Right joiner)

    prepareGrant sender = do
        encodeRouteHome <- getEncodeRouteHome

        accepter <- getJust $ remoteAuthorId author
        let topicByHash = grantResourceLocalActor $ topicResource recipHash

        senderHash <- bitraverse hashLocalActor pure sender

        let audSender =
                case senderHash of
                    Left actor -> AudLocal [actor] [localActorFollowers actor]
                    Right (ObjURI h lu, followers) ->
                        AudRemote h [lu] (maybeToList followers)
            audRecip =
                let ObjURI h lu = remoteAuthorURI author
                in  AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
            audTopic = AudLocal [] [localActorFollowers topicByHash]

            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audSender, audRecip, audTopic]

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Nothing
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = [AP.acceptObject accept]
                , AP.actionSpecific   = AP.GrantActivity AP.Grant
                    { AP.grantObject    = Left AP.RoleAdmin
                    , AP.grantContext   = encodeRouteHome $ renderLocalActor topicByHash
                    , AP.grantTarget    = remoteAuthorURI author
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

repoAcceptF
    :: UTCTime
    -> KeyHashid Repo
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Accept URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
repoAcceptF = topicAcceptF repoActor GrantResourceRepo

deckAcceptF
    :: UTCTime
    -> KeyHashid Deck
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Accept URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
deckAcceptF = topicAcceptF deckActor GrantResourceDeck

loomAcceptF
    :: UTCTime
    -> KeyHashid Loom
    -> RemoteAuthor
    -> ActivityBody
    -> Maybe (RecipientRoutes, ByteString)
    -> LocalURI
    -> AP.Accept URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
loomAcceptF = topicAcceptF loomActor GrantResourceLoom