{- 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 DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Vervis.Data.Collab
    ( GrantRecipBy (..)

    , parseInvite
    , parseJoin
    , parseGrant
    , parseAccept

    , grantResourceActorID
    )
where

import Control.Monad
import Control.Monad.Trans.Except
import Data.Barbie
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Identity
import Data.Text (Text)
import Database.Persist.Types
import GHC.Generics

import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite (asksSite)

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local

import Vervis.Access
import Vervis.Actor
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model

parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource _         = Nothing

data GrantRecipBy f = GrantRecipPerson (f Person)
    deriving (Generic, FunctorB, TraversableB, ConstraintsB)

deriving instance AllBF Eq f GrantRecipBy => Eq (GrantRecipBy f)

parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
parseGrantRecip _           = Nothing

unhashGrantRecipPure ctx = f
    where
    f (GrantRecipPerson p) =
        GrantRecipPerson <$> decodeKeyHashidPure ctx p

unhashGrantRecipOld resource = do
    ctx <- asksSite siteHashidsContext
    return $ unhashGrantRecipPure ctx resource

unhashGrantRecip resource = do
    ctx <- asksEnv stageHashidsContext
    return $ unhashGrantRecipPure ctx resource

unhashGrantRecipEOld resource e =
    ExceptT $ maybe (Left e) Right <$> unhashGrantRecipOld resource

unhashGrantRecipE resource e =
    ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource

verifyRole (Left AP.RoleAdmin) = pure ()
verifyRole (Right _) =
    throwE "ForgeFed Admin is the only role allowed currently"

parseTopic u = do
    routeOrRemote <- parseFedURIOld u
    bitraverse
        (\ route -> do
            resourceHash <-
                fromMaybeE
                    (parseGrantResource route)
                    "Not a shared resource route"
            unhashGrantResourceE
                resourceHash
                "Contains invalid hashid"
        )
        pure
        routeOrRemote

parseInvite
    :: Either PersonId FedURI
    -> AP.Invite URIMode
    -> ExceptT Text Handler
        ( Either (GrantResourceBy Key) FedURI
        , Either (GrantRecipBy Key) FedURI
        )
parseInvite sender (AP.Invite instrument object target) = do
    verifyRole instrument
    (,) <$> nameExceptT "Invite target" (parseTopic target)
        <*> nameExceptT "Invite object" (parseRecipient object)
    where
    parseRecipient u = do
        routeOrRemote <- parseFedURIOld u
        bitraverse
            (\ route -> do
                recipHash <-
                    fromMaybeE
                        (parseGrantRecip route)
                        "Not a grant recipient route"
                recipKey <-
                    unhashGrantRecipEOld
                        recipHash
                        "Contains invalid hashid"
                case recipKey of
                    GrantRecipPerson p | Left p == sender ->
                        throwE "Invite local sender and recipient are the same Person"
                    _ -> return recipKey
            )
            (\ u -> do
                when (Right u == sender) $
                    throwE "Invite remote sender and recipient are the same actor"
                return u
            )
            routeOrRemote

parseJoin
    :: AP.Join URIMode
    -> ExceptT Text Handler (Either (GrantResourceBy Key) FedURI)
parseJoin (AP.Join instrument object) = do
    verifyRole instrument
    nameExceptT "Join object" (parseTopic object)

parseGrant
    :: AP.Grant URIMode
    -> ActE
        ( Either (GrantResourceBy Key) FedURI
        , Either (GrantRecipBy Key) FedURI
        )
parseGrant (AP.Grant object context target) = do
    verifyRole object
    (,) <$> parseContext context
        <*> parseTarget target
    where
    verifyRole (Left AP.RoleAdmin) = pure ()
    verifyRole (Right _) =
        throwE "ForgeFed Admin is the only role allowed currently"
    parseContext u@(ObjURI h lu) = do
        hl <- hostIsLocal h
        if hl
            then Left <$> do
                route <-
                    fromMaybeE
                        (decodeRouteLocal lu)
                        "Grant context isn't a valid route"
                resourceHash <-
                    fromMaybeE
                        (parseGrantResource route)
                        "Grant context isn't a shared resource route"
                unhashGrantResourceE'
                    resourceHash
                    "Grant resource contains invalid hashid"
            else pure $ Right u
        where
        parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
        parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
        parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
        parseGrantResource _         = Nothing
    parseTarget u@(ObjURI h lu) = do
        hl <- hostIsLocal h
        if hl
            then Left <$> do
                route <-
                    fromMaybeE
                        (decodeRouteLocal lu)
                        "Grant target isn't a valid route"
                recipHash <-
                    fromMaybeE
                        (parseGrantRecip route)
                        "Grant target isn't a grant recipient route"
                unhashGrantRecipE
                    recipHash
                    "Grant target contains invalid hashid"
            else pure $ Right u

parseAccept (AP.Accept object mresult) = do
    verifyNothingE mresult "Accept must not contain 'result'"
    first (\ (actor, _, item) -> (actor, item)) <$>
        nameExceptT "Accept object" (parseActivityURI object)

grantResourceActorID :: GrantResourceBy Identity -> ActorId
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l