{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
 - 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.Actor.Person
    (
    )
where

import Control.Applicative
import Control.Exception.Base hiding (handle)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
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.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable
import Data.HList (HList (..))
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Optics.Core
import Yesod.Persist.Core

import qualified Data.Text as T

import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Database.Persist.Local

import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Actor.Common
import Vervis.Actor.Person.Client
import Vervis.Actor2
import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Data.Discussion
import Vervis.Data.Follow
import Vervis.Data.Ticket
import Vervis.FedURI

import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Persist.Follow
import Vervis.Persist.Ticket
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, renderLocalActor)
import Vervis.RemoteActorStore
import Vervis.Ticket

-- Meaning: Someone is offering a ticket or dependency to a tracker
-- Behavior:
--      * Insert to my inbox
personOffer
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Offer URIMode
    -> ActE (Text, Act (), Next)
personOffer now recipPersonID (Verse authorIdMsig body) (AP.Offer object uTarget) = do

    -- Check input
    ticket <-
        case object of
            AP.OfferTicket t -> pure t
            _ -> throwE "Unsupported Offer.object type"
    ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
    WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
    unless (bimap LocalActorPerson id wioAuthor == author) $
        throwE "Offering a Ticket attributed to someone else"

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeOfferDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeOfferDB $ \ (inboxItemID, _offerDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) ->
            doneDB inboxItemID "Inserted this Offer to my inbox"

-- Meaning: Someone has asked to resolve a ticket/MR
-- Behavior:
--      * Insert to my inbox
personResolve
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Resolve URIMode
    -> ActE (Text, Act (), Next)
personResolve now recipPersonID (Verse authorIdMsig body) (AP.Resolve uObject) = do

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeResolveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeResolveDB $ \ (inboxItemID, _resolveDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) ->
            doneDB inboxItemID "Inserted this Resolve to my inbox"

------------------------------------------------------------------------------
-- Following
------------------------------------------------------------------------------

-- Meaning: Someone is following someone
-- Behavior:
--      * Verify I'm the target
--      * Record the follow in DB
--      * Publish and send an Accept to the sender and its followers
personFollow
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Follow URIMode
    -> ActE (Text, Act (), Next)
personFollow now recipPersonID verse follow = do
    recipPersonHash <- encodeKeyHashid recipPersonID
    actorFollow
        (\case
            PersonR p | p == recipPersonHash -> pure ()
            _ -> throwE "Asking to follow someone else"
        )
        personActor
        True
        (\ recipPersonActor () ->
            pure $ actorFollowers recipPersonActor
        )
        (\ () -> pure $ makeRecipientSet [] [])
        LocalActorPerson
        (\ () -> pure [])
        now recipPersonID verse follow

-- Meaning: Someone is undoing some previous action
-- Behavior:
--      * Insert to my inbox
--      * If they're undoing their Following of me:
--          * Record it in my DB
--          * Publish and send an Accept only to the sender
personUndo
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Undo URIMode
    -> ActE (Text, Act (), Next)
personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do

    -- Check input
    undone <-
        first (\ (actor, _, item) -> (actor, item)) <$>
            parseActivityURI' uObject

    maybeUndo <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        -- Insert the Undo to person's inbox
        maybeUndoDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
        for maybeUndoDB $ \ (inboxItemID, undoDB) -> (inboxItemID,) <$> do

            maybeUndo <- runMaybeT $ do

                -- Find the undone activity in our DB
                undoneDB <- MaybeT $ getActivity undone

                let followers = actorFollowers actorRecip
                tryUnfollow followers undoneDB undoDB

            for maybeUndo $ \ () -> do

                -- Prepare an Accept activity and insert to person's outbox
                acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
                accept@(actionAccept, _, _, _) <- lift $ lift prepareAccept
                _luAccept <- lift $ updateOutboxItem' (LocalActorPerson recipPersonID) acceptID actionAccept

                return (personActor personRecip, acceptID, accept)

    case maybeUndo of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Unrelated to me, just inserted to inbox"
                Just (actorID, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
                    lift $ sendActivity
                        (LocalActorPerson recipPersonID) actorID localRecipsAccept
                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
                    doneDB inboxItemID "Undid the Follow and published Accept"

    where

    tryUnfollow personFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
        Entity remoteFollowID remoteFollow <-
            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
        let followerID = remoteFollowActor remoteFollow
            followerSetID = remoteFollowTarget remoteFollow
        guard $ followerSetID == personFollowersID
        unless (followerID == remoteAuthorId author) $
            lift $ throwE "You're trying to Undo someone else's Follow"
        lift $ lift $ delete remoteFollowID
    tryUnfollow personFollowersID (Left (_, _, outboxItemID)) (Left (_, actorID, _)) = do
        Entity followID follow <-
            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
        let followerID = followActor follow
            followerSetID = followTarget follow
        guard $ followerSetID == personFollowersID
        unless (followerID == actorID) $
            lift $ throwE "You're trying to Undo someone else's Follow"
        lift $ lift $ delete followID
    tryUnfollow _ _ _ = mzero

    prepareAccept = do
        encodeRouteHome <- getEncodeRouteHome

        audSender <- makeAudSenderOnly authorIdMsig
        uUndo <- getActivityURI authorIdMsig
        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audSender]

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Nothing
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = []
                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
                    { AP.acceptObject   = uUndo
                    , AP.acceptResult   = Nothing
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

-- Meaning: An actor accepted something
-- Behavior:
--      * Insert to my inbox
--
--      * If it's on a Follow I sent to them:
--          * Add to my following list in DB
--
--      * If it's on an Invite-for-me to collaborate on a resource:
--          * Verify I haven't yet seen the resource's accept
--          * Verify the Accept author is the resource
--          * Store it in the Permit record in DB
--          * Forward to my followers
--
--      * If it's on a Create-actor-via-factory I'd sent
--          * Insert PermitTopic*
--          * Send a Follow on the newly created actor
personAccept
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Accept URIMode
    -> ActE (Text, Act (), Next)
personAccept now recipPersonID (Verse authorIdMsig body) accept = do

    -- Check input
    acceptee <- parseAccept accept

    -- Discover Accept.result, before DB access since we might use HTTP
    maybeRightResult <-
        for (AP.acceptResult accept) $ \ luResult -> lift $ runExceptT $ do
            ObjURI h _ <- lift $ getActorURI authorIdMsig
            let uResult = ObjURI h luResult
            routeOrRemote <- parseFedURI uResult
            bitraverse
                (\ route -> do
                    lr <- parseLocalResourceE' route
                    resourceID <- withDBExcept $ do
                        lre <- getLocalResourceEntityE lr "Local Accept.result actor not found in DB"
                        lift $ grabLocalResourceID lre
                    return (lr, resourceID)
                )
                (\ u@(ObjURI h lu) -> do
                    instanceID <-
                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                    result <-
                        ExceptT $ first (T.pack . displayException) <$>
                            fetchRemoteActor' instanceID h lu
                    case result of
                        Left Nothing -> throwE "Result @id mismatch"
                        Left (Just err) -> throwE $ T.pack $ displayException err
                        Right Nothing -> throwE "Result isn't an actor"
                        Right (Just actor) -> return (u, actor)
                )
                routeOrRemote

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> fmap (inboxItemID,) $ runMaybeT $ do

            -- Find the accepted activity in our DB
            accepteeDB <- MaybeT $ getActivity acceptee

            let recipActorID = personActor personRecip
            Left . Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
                Left . Right <$> tryInvite recipActorID accepteeDB acceptDB <|>
                Right <$> tryCreate maybeRightResult recipActorID accepteeDB acceptDB

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Not my Follow/Invite; Just inserted to my inbox"
                Just (Left (Left ())) ->
                    doneDB inboxItemID "Recorded this Accept on the Follow request I sent"
                Just (Left (Right (actorID, sieve))) -> do
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "Recorded this Accept on the Invite I've had & \
                        \forwarded to my followers"
                Just (Right Nothing) ->
                    doneDB inboxItemID "Inserted PermitTopic*, Follow/Request already exists"
                Just (Right (Just (actorMeID, followID, follow))) -> do
                    let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
                    lift $ sendActivity
                        (LocalActorPerson recipPersonID) actorMeID localRecipsFollow
                        remoteRecipsFollow fwdHostsFollow followID actionFollow
                    doneDB inboxItemID "Inserted PermitTopic* & sent Follow"

    where

    tryCreate maybeRightResult actorMeID (Left (_, _, outboxItemID)) _ = do

        -- Verify Accept specifies a result
        result <- do
            r <- hoistMaybe maybeRightResult
            case r of
                Left e -> lift $ throwE e
                Right actor -> pure actor

        -- Find an admin-Permit-Fulfills-Create I have
        PermitPersonGesture permitID _ <-
            MaybeT $ lift $ getValBy $ UniquePermitPersonGestureActivity outboxItemID
        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
        Permit p role <- lift $ lift $ getJust permitID
        guard $ p == recipPersonID
        guard $ role == AP.RoleAdmin

        -- Grab the Create's origin, verify it's identical to Accept sender
        AP.Doc _ act <- lift $ lift $ getActivityBody $ Left outboxItemID
        uOrigin <-
            case AP.activitySpecific act of
                AP.CreateActivity (AP.Create _ (Just u)) -> pure u
                _ -> lift $ throwE "Expected acceptee to be a Create with origin"
        uAcceptSender <- lift $ lift $ lift $ getActorURI authorIdMsig
        unless (uAcceptSender == uOrigin) $
            lift $ throwE "Accept sender isn't the Create.origin"

        -- Verify permit topic is missing
        mptl <- lift $ lift $ getBy $ UniquePermitTopicLocal permitID
        mptr <- lift $ lift $ getBy $ UniquePermitTopicRemote permitID
        unless (isNothing mptl && isNothing mptr) $
            lift $ throwE "PermitTopic* already exists in DB"

        -- Insert permit topic, the new actor
        lift $ lift $
            case result of
                Left (_, resourceID) ->
                    insert_ $ PermitTopicLocal permitID resourceID
                Right (_, Entity actorID _) ->
                    insert_ $ PermitTopicRemote permitID actorID

        lift $ lift $ do
            -- Look for an existing follow/request record in DB
            existing <-
                case result of
                    Left (_, resourceID) -> do
                        Resource actorNewID <- getJust resourceID
                        fsID <- actorFollowers <$> getJust actorNewID
                        mf <- getBy $ UniqueFollow actorMeID fsID
                        mfr <- getBy $ UniqueFollowRequest actorMeID fsID
                        return $ isJust mf || isJust mfr
                    Right (uNewActor, _) -> do
                        mf <- getBy $ UniqueFollowRemote actorMeID uNewActor
                        mfr <- getBy $ UniqueFollowRemoteRequest recipPersonID uNewActor
                        return $ isJust mf || isJust mfr

            -- If none, insert request and prepare Follow activity
            if existing
                then pure Nothing
                else Just <$> do
                    actorMe <- getJust actorMeID
                    followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now

                    case result of
                        Left (_, resourceID) -> do
                            Resource actorNewID <- getJust resourceID
                            fsID <- actorFollowers <$> getJust actorNewID
                            insert_ $ FollowRequest actorMeID fsID True followID
                        Right (uNewActor, _) ->
                            insert_ $ FollowRemoteRequest recipPersonID uNewActor Nothing True followID

                    follow@(actionFollow, _, _, _) <- lift $ prepareFollow result
                    luFollow <- updateOutboxItem' (LocalActorPerson recipPersonID) followID actionFollow

                    return (actorMeID, followID, follow)

    tryCreate _ _ (Right _) _ = mzero

    tryFollow actorID (Left (_, _, outboxItemID)) (Right (author, _, acceptID)) = do
        Entity key val <-
            MaybeT $ lift $
                getBy $ UniqueFollowRemoteRequestActivity outboxItemID
        guard $ followRemoteRequestPerson val == recipPersonID
        let uRecip =
                fromMaybe
                    (followRemoteRequestTarget val)
                    (followRemoteRequestRecip val)
        unless (remoteAuthorURI author == uRecip) $
            lift $ throwE "You're Accepting a Follow I sent to someone else"
        lift $ lift $ delete key
        lift $ lift $ insert_ FollowRemote
            { followRemoteActor  = actorID
            , followRemoteRecip  = remoteAuthorId author
            , followRemoteTarget = followRemoteRequestTarget val
            , followRemotePublic = followRemoteRequestPublic val
            , followRemoteFollow = outboxItemID
            , followRemoteAccept = acceptID
            }
    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, acceptID)) = do
        Entity key val <-
            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
        guard $ followRequestActor val == actorID
        targetByKey <-
            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
        unless (authorByKey == targetByKey) $
            lift $ throwE "You're Accepting a Follow I sent to someone else"
        lift $ lift $ delete key
        -- The followee already inserted a Follow, so we just make sure it
        -- already exists
        followKey <- do
            mf <- lift $ lift $ getKeyBy $ UniqueFollowAccept acceptID
            lift $ fromMaybeE mf "Can't find a Follow record in DB"
        mf1 <-
            lift $ lift $ getKeyBy $ UniqueFollow actorID (followRequestTarget val)
        mf2 <-
            lift $ lift $ getKeyBy $ UniqueFollowFollow outboxItemID
        unless (mf1 == Just followKey && mf2 == Just followKey) $
            lift $ throwE "Weird inconsistency with Follow uniques"
        {-
        lift $ lift $ insert_ Follow
            { followActor  = actorID
            , followTarget = followRequestTarget val
            , followPublic = followRequestPublic val
            , followFollow = outboxItemID
            , followAccept = acceptID
            }
        -}
    tryFollow _ (Right _) _ = mzero

    tryInvite recipActorID accepteeDB acceptDB = do

        -- Find a PermitFulfillsInvite
        (permitID, fulfillsID) <-
            case accepteeDB of
                Left (actorByKey, _actorEntity, itemID) -> do
                    PermitTopicGestureLocal fulfillsID _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
                    return (permitID, fulfillsID)
                Right remoteActivityID -> do
                    PermitTopicGestureRemote fulfillsID _ _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
                    return (permitID, fulfillsID)

        -- Find the local person and verify it's me
        Permit p _role <- lift . lift $ getJust permitID
        guard $ p == recipPersonID

        lift $ do
            -- Find the topic
            topic <- lift $ getPermitTopic permitID

            -- Verify I haven't seen the topic's accept yet
            maybeTopicAccept <-
                lift $ case bimap fst fst topic of
                    Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID)
                    Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID)
            unless (isNothing maybeTopicAccept) $
                throwE "I've already seen the topic's Accept"

            -- Verify topic is the Accept sender
            case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of
                (Left la, Left la') | resourceToActor la == la' -> pure ()
                (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                _ -> throwE "Accept sender isn't the Invite topic"

            -- Update the Permit record
            lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB)  of
                (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID
                (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID
                _ -> error "personAccept impossible"

            -- Prepare forwarding Accept to my followers
            recipPersonHash <- encodeKeyHashid recipPersonID
            let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

            return (recipActorID, sieve)

    prepareFollow result = do
        encodeRouteHome <- getEncodeRouteHome

        (uNewActor, audNewActor) <-
            case result of
                Left (lr, _) -> do
                    la <- resourceToActor <$> hashLocalResource lr
                    return
                        ( encodeRouteHome $ renderLocalActor la
                        , AudLocal [la] []
                        )
                Right (u@(ObjURI h lu), _) ->
                    return (u, AudRemote h [lu] [])
        uAccept <- getActivityURI authorIdMsig
        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audNewActor]

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Nothing
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = [uAccept]
                , AP.actionSpecific   = AP.FollowActivity AP.Follow
                    { AP.followObject  = uNewActor
                    , AP.followContext = Nothing
                    , AP.followHide    = False
                    }
                }
        return (action, recipientSet, remoteActors, fwdHosts)

-- Meaning: An actor rejected something
-- Behavior:
--      * Insert to my inbox
--      * If it's a Follow I sent to them, remove record from my DB
personReject
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Reject URIMode
    -> ActE (Text, Act (), Next)
personReject now recipPersonID (Verse authorIdMsig body) reject = do

    -- Check input
    rejectee <- parseReject reject

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeRejectDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeRejectDB $ \ (inboxItemID, _rejectDB) -> fmap (inboxItemID,) $ runMaybeT $ do

            -- Find the rejected activity in our DB
            rejecteeDB <- MaybeT $ getActivity rejectee

            tryFollow (personActor personRecip) rejecteeDB authorIdMsig

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, Nothing) -> doneDB inboxItemID "Not my Follow; Just inserted to my inbox"
        Just (inboxItemID, Just ()) ->
            doneDB inboxItemID "Recorded this Reject on the Follow request I sent"

    where

    tryFollow _actorID (Left (_, _, outboxItemID)) (Right (author, _, _)) = do
        Entity key val <-
            MaybeT $ lift $
                getBy $ UniqueFollowRemoteRequestActivity outboxItemID
        guard $ followRemoteRequestPerson val == recipPersonID
        let uRecip =
                fromMaybe
                    (followRemoteRequestTarget val)
                    (followRemoteRequestRecip val)
        unless (remoteAuthorURI author == uRecip) $
            lift $ throwE "You're Rejecting a Follow I sent to someone else"
        lift $ lift $ delete key
    tryFollow actorID (Left (_, _, outboxItemID)) (Left (authorByKey, _, _)) = do
        Entity key val <-
            MaybeT $ lift $ getBy $ UniqueFollowRequestFollow outboxItemID
        guard $ followRequestActor val == actorID
        targetByKey <-
            lift $ lift $ followeeActor <$> getFollowee' (followRequestTarget val)
        unless (authorByKey == targetByKey) $
            lift $ throwE "You're Rejecting a Follow I sent to someone else"
        lift $ lift $ delete key
    tryFollow _ (Right _) _ = mzero

------------------------------------------------------------------------------
-- Commenting
------------------------------------------------------------------------------

-- Meaning: Someone commented on an issue/PR
-- Behavior: Insert to inbox
personCreateNote
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Note URIMode
    -> ActE (Text, Act (), Next)
personCreateNote now recipPersonID (Verse authorIdMsig body) note = do

    -- Check input
    (luNote, published, Comment maybeParent topic source content) <- do
        (luId, luAuthor, published, comment) <- parseRemoteComment note
        uCreateAuthor <- lift $ getActorURI authorIdMsig
        unless (luAuthor == objUriLocal uCreateAuthor) $
            throwE "Create author != note author"
        return (luId, published, comment)

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

        case topic of

            Right uContext -> do
                checkContextParent uContext maybeParent
                lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) 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 authorIdMsig body (actorInbox recipActor) 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 authorIdMsig body (actorInbox recipActor) True

    case mractid of
        Nothing -> done "I already have this activity in my inbox, doing nothing"
        Just (inboxItemID, _) -> doneDB inboxItemID "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"

------------------------------------------------------------------------------
-- Access
------------------------------------------------------------------------------

-- Meaning: Someone is adding something to something
-- Behavior:
--      * Insert to my inbox
personAdd
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Add URIMode
    -> ActE (Text, Act (), Next)
personAdd now recipPersonID (Verse authorIdMsig body) add = do

    -- Check input
    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
    _ <- parseAdd author add

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeAddDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeAddDB $ \ (inboxItemID, _addDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (_actorID, inboxItemID) -> doneDB inboxItemID "Inserted this Add to my inbox"

-- Meaning: Someone invited someone to a resource
-- Behavior:
--      * Insert to my inbox
--      * If I'm being invited to the resource's collaborators/members
--        collection:
--          * For each Permit record I have for this resource:
--              * Verify it's not enabled yet, i.e. I'm not already a
--                collaborator, haven't received a direct-Grant
--              * Verify it's not in Invite-Accept state, already got the
--                resource's Accept and waiting for my approval or for the
--                topic's Grant
--              * Verify it's not a Join
--          * Create a Permit record in DB
--          * Forward the Invite to my followers
personInvite
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Invite URIMode
    -> ActE (Text, Act (), Next)
personInvite now recipPersonID (Verse authorIdMsig body) invite = do

    -- Check input
    maybeRoleAndResourceDB <- do
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        (role, resource, recip) <- parseInvite author invite
        let recipIsMe =
                case recip of
                    Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True
                    _ -> False
        if not recipIsMe
            then pure Nothing
            else
                -- If resource collabs URI is remote, HTTP GET it and its resource and its
                -- managing actor, and insert to our DB. If resource is local, find it in
                -- our DB.
                case resource of
                    Left r ->
                        case r of
                            Left lr -> withDBExcept $ Just . (role,) . Left <$> getLocalResourceEntityE lr "Invite resource not found in DB"
                            Right _j -> pure Nothing
                    Right u@(ObjURI h luColl) -> do
                        manager <- asksEnv envHttpManager
                        coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                        lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                        if mluCollabs == Just luColl || mluMembers == Just luColl
                            then Just . (role,) . Right <$> do
                                instanceID <-
                                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                                result <-
                                    ExceptT $ first (T.pack . show) <$>
                                        fetchRemoteResource instanceID h lu
                                case result of
                                    Left (Entity actorID actor) ->
                                        return (remoteActorIdent actor, actorID, u)
                                    Right (objectID, luManager, (Entity actorID _)) ->
                                        return (objectID, actorID, ObjURI h luManager)
                            else pure Nothing

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do

            maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do

                -- Find existing Permit records I have for this topic
                -- Make sure none are enabled / in Join mode / in Invite-Accept
                -- mode
                checkExistingPermits
                    recipPersonID
                    (bimap localResourceID (view _2) resourceDB)

                -- Prepare forwarding Invite to my followers
                recipPersonHash <- encodeKeyHashid recipPersonID
                let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

                -- Insert Permit record to DB
                insertPermit resourceDB inviteDB role

                return sieve

            return (personActor personRecip, maybePermit, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (actorID, maybePermit, inboxItemID) ->
            case maybePermit of
                Nothing -> doneDB inboxItemID "I'm not the target; Inserted to inbox"
                Just sieve -> do
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "I'm the target; Inserted to inbox; Inserted Permit; \
                        \Forwarded to followers if addressed"

    where

    insertPermit resourceDB inviteDB role = do
        permitID <- lift $ insert $ Permit recipPersonID role
        case resourceDB of
            Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
            Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
        lift $ do
            fulfillsID <- insert $ PermitFulfillsInvite permitID
            case inviteDB of
                Left (_, _, inviteID) ->
                    insert_ $ PermitTopicGestureLocal fulfillsID inviteID
                Right (author, _, inviteID) ->
                    insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID

-- Meaning: Someone removed someone from a resource
-- Behavior:
--      * Insert to my inbox
--      * If I'm the object, forward the Remove to my followers
personRemove
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Remove URIMode
    -> ActE (Text, Act (), Next)
personRemove now recipPersonID (Verse authorIdMsig body) remove = do

    -- Check input
    memberOrComp <- do
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        (_resource, member) <- parseRemove author remove
        return member

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for maybeRemoveDB $ \ (inboxItemID, _removeDB) ->
            return (personActor personRecip, inboxItemID)

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (actorID, inboxItemID) -> do
            let memberIsMe =
                    case memberOrComp of
                        Left (LocalActorPerson p) -> p == recipPersonID
                        _ -> False
            if not memberIsMe
                then doneDB inboxItemID "I'm not the member; Inserted to inbox"
                else do
                    recipHash <- encodeKeyHashid recipPersonID
                    let sieve =
                            makeRecipientSet
                                []
                                [LocalStagePersonFollowers recipHash]
                    forwardActivity
                        authorIdMsig body (LocalActorPerson recipPersonID)
                        actorID sieve
                    doneDB inboxItemID
                        "I'm the member; Inserted to inbox; \
                        \Forwarded to followers if addressed"

-- Meaning: Someone asked to join a resource
-- Behavior: Insert to my inbox
personJoin
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Join URIMode
    -> ActE (Text, Act (), Next)
personJoin now recipPersonID (Verse authorIdMsig body) join = do

    -- Check input
    (_role, _resource) <- parseJoin join

    maybeJoinID <- lift $ withDB $ do

        -- Grab me from DB
        (_personRecip, actorRecip) <- do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        insertToInbox now authorIdMsig body (actorInbox actorRecip) True

    case maybeJoinID of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, _joinID) -> doneDB inboxItemID "Inserted to my inbox"

-- Meaning: An actor published a Grant
-- Behavior:
--      * Insert to my inbox
--
--      * If it's a developer direct-Grant from a local Factory, and there's no
--        Permit record:
--          * Insert a Permit record, storing the direct-Grant
--          * Forward the direct-Grant to my followers
--
--      * If it's a direct-Grant that fulfills a Permit I have:
--          * Verify the Permit isn't already enabled
--          * Verify the sender is the Permit topic
--          * Verify the role is identical to what was requested
--          * Update the Permit record, storing the direct-Grant
--          * Forward the direct-Grant to my followers
--          * If topic is a Project or a Team:
--              * Send a delegator-Grant to the topic
--              * Update the Permit record, storing the delegator-Grant
--
--      * If it's a extension-Grant whose capability is a delegator-Grant from
--        a Permit I have:
--          * Verify the sender is the Permit topic
--          * Update the Permit record, storing the extension-Grant
personGrant
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Grant URIMode
    -> ActE (Text, Act (), Next)
personGrant now recipPersonID (Verse authorIdMsig body) grant = do

    -- Check input
    maybeMine <- do
        -- Verify the capability URI, if provided, is one of:
        --   * Outbox item URI of a local actor, i.e. a local activity
        --   * A remote URI
        maybeCapability <-
            for (AP.activityCapability $ actbActivity body) $ \ uCap ->
                nameExceptT "Grant.capability" $
                    first (\ (actor, _, item) -> (actor, item)) <$>
                        parseActivityURI' uCap

        -- Basic sanity checks
        (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
            parseGrant' grant
        case (recip, authorIdMsig) of
            (Left (LocalActorPerson p), Left (LocalActorPerson p', _, _))
                | p == p' ->
                    throwE "Grant sender and target are the same local Person"
            (Right uRecip, Right (author, _, _))
                | uRecip == remoteAuthorURI author ->
                    throwE "Grant sender and target are the same remote actor"
            _ -> pure ()
        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
        case mdeleg of
            Nothing ->
                unless (author == resource) $
                    throwE "Not an extension but resource and actor differ"
            Just _ ->
                when (author == resource) $
                    throwE "Extension but resource and actor are identical"

        -- For a direct-Grant, use 'fulfills' to identify the Permit
        -- For an extension-Grant, use 'capability' for that
        runMaybeT $ do
            guard $ usage == AP.Invoke
            guard $ recip == Left (LocalActorPerson recipPersonID)
            lift $ do
                for_ mstart $ \ start ->
                    unless (start <= now) $
                        throwE "Got a Grant that hasn't started"
                for_ mend $ \ _ -> throwE "Got a Grant with expiration"
            if isNothing mdeleg
                then do
                    uFulfills <-
                        case AP.activityFulfills $ actbActivity body of
                            [] -> mzero
                            [u] -> pure u
                            _ -> lift $ throwE "Multiple fulfills"
                    fulfills <-
                        lift $
                        first (\ (actor, _, item) -> (actor, item)) <$>
                            parseActivityURI' uFulfills
                    return $ Left (role, fulfills)
                else do
                    cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability"
                    delegatorID <-
                        case cap of
                            Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
                            _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
                    return $ Right (resource, role, delegatorID)

    -- For extension-Grant, get the resource by DB/HTTP, and check role
    maybeMine' <-
        for maybeMine $ traverseOf _Right $ \ (resource, roleExt, delegatorID) -> do
            role <-
                case roleExt of
                    AP.RXRole r -> pure r
                    AP.RXDelegator -> throwE "I've been delegated a Grant with role being delegate"
            resourceDB <- bitraverse
                (\ la -> do
                    lr <- fromMaybeE (actorToResource la) "Got an extension-Grant with resource being a local Person"
                    withDBExcept $ localResourceID <$>
                        getLocalResourceEntityE lr "Extension-Grant resource not found in DB"
                )
                (\ (ObjURI h lu) -> do
                    manager <- asksEnv envHttpManager
                    instanceID <-
                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
                    result <-
                        ExceptT $ first (T.pack . displayException) <$>
                            fetchRemoteActor' instanceID h lu
                    case result of
                        Left Nothing -> throwE "Resource @id mismatch"
                        Left (Just err) -> throwE $ T.pack $ displayException err
                        Right Nothing -> throwE "Resource isn't an actor"
                        Right (Just actor) -> return $ entityKey actor
                )
                resource
            return (resourceDB, role, delegatorID)

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)
        selfCreateID <- lift $ do
            mc <- getValBy $ UniqueActorCreateLocalActor $ personActor personRecip
            case mc of
                Nothing -> error "I don't have an ActorCreateLocal record"
                Just c -> pure $ actorCreateLocalCreate c

        maybePermit <-
            for maybeMine' $
                bitraverse
                    (\ (role, fulfills) -> do

                        -- Find my Permit record, verify the roles match
                        fulfillsDB <- do
                            a <- getActivity fulfills
                            fromMaybeE a "Can't find fulfills in DB"
                        mp <- runMaybeT $ do
                            x@(pt, mg) <-
                                tryInvite fulfillsDB <|>
                                tryJoin fulfillsDB <|>
                                tryCreate fulfillsDB
                            Permit p role' <- lift . lift $ getJust pt
                            guard $ p == recipPersonID
                            lift $ unless (role == AP.RXRole role') $
                                throwE "Requested and granted roles differ"
                            return x
                        case mp of
                            Just (permitID, maybeGestureID) -> do

                                -- If Permit fulfills an Invite, verify I've approved
                                -- it
                                gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"

                                -- Verify the Permit isn't already enabled
                                topic <- lift $ getPermitTopic permitID
                                maybeTopicEnable <-
                                    lift $ case bimap fst fst topic of
                                        Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
                                        Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
                                unless (isNothing maybeTopicEnable) $
                                    throwE "I've already received the direct-Grant"

                                -- Verify the Grant sender is the Permit topic
                                case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                                    (Left la, Left la') | resourceToActor la == la' -> pure ()
                                    (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                                    _ -> throwE "Grant sender isn't the Permit topic"

                                return $ Left (gestureID, bimap fst fst topic)

                            Nothing -> do
                                case (authorIdMsig, role) of
                                    (Left (LocalActorFactory factoryID, actorID, grantID), AP.RXRole AP.RoleWrite) ->
                                        return $ Right (factoryID, actorID, grantID)
                                    _ -> throwE "No Permit found & sender-and-role not local-Factory-and-write"
                    )
                    (\ (resourceDB, role, delegatorID) -> do
                        Entity sendID (PermitPersonSendDelegator gestureID _) <- do
                            mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
                            fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
                        PermitPersonGesture permitID _ <- lift $ getJust gestureID

                        -- Verify the Grant sender is the Permit topic
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Grant sender isn't the Permit topic"

                        return (resourceDB, role, sendID, bimap fst fst topic)
                    )

        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        for mractid $ \ (inboxItemID, grantDB) ->

            fmap (inboxItemID,) $
            for maybePermit $
                bitraverse
                    (\ mode -> lift $ do

                        -- In factory-mode, we need to create a Permit record
                        (gestureID, topic) <-
                            case mode of
                                Left permit -> pure permit
                                Right (factoryID, _actorID, _grantID) -> do
                                    resourceID <- factoryResource <$> getJust factoryID
                                    permitID <- insert $ Permit recipPersonID AP.RoleWrite
                                    topicID <- insert $ PermitTopicLocal permitID resourceID
                                    insert_ $ PermitFulfillsResidentFactory permitID
                                    gestureID <- insert $ PermitPersonGesture permitID selfCreateID
                                    return (gestureID, Left topicID)

                        -- Update the Permit record, storing the direct-Grant
                        case (topic, grantDB) of
                            (Left localID, Left (_, _, grantID)) ->
                                insert_ $ PermitTopicEnableLocal gestureID localID grantID
                            (Right remoteID, Right (_, _, grantID)) ->
                                insert_ $ PermitTopicEnableRemote gestureID remoteID grantID
                            _ -> error "personGrant impossible"

                        -- Prepare forwarding direct-Grant to my followers
                        recipPersonHash <- encodeKeyHashid recipPersonID
                        let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]

                         -- Prepapre delegator-Grant and update Permit
                        needDeleg <-
                            case grantDB of
                                Left (la, _, _) ->
                                    pure $ case la of
                                        LocalActorProject _ -> True
                                        LocalActorGroup _ -> True
                                        _ -> False
                                Right (author, _, _) -> do
                                    ra <- getJust $ remoteAuthorId author
                                    pure $ case remoteActorType ra of
                                        AP.ActorTypeProject -> True
                                        AP.ActorTypeTeam -> True
                                        _ -> False
                        maybeDeleg <-
                            if needDeleg
                                then Just <$> do
                                    delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
                                    deleg@(actionDeleg, _, _, _) <- prepareDelegGrant
                                    let recipByKey = LocalActorPerson recipPersonID
                                    _luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg

                                    insert_ $ PermitPersonSendDelegator gestureID delegID

                                    return (delegID, deleg)
                                else
                                    pure Nothing

                        return (personActor personRecip, sieve, maybeDeleg)
                    )
                    (\ (resourceDB, role, sendID, topic) -> do
                        extendID <- case (topic, grantDB) of
                            (Left localID, Left (_, _, extID)) -> lift $ do
                                enableID <- do
                                    me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
                                    case me of
                                        Just e -> pure e
                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
                                extendID <- insert $ PermitTopicExtend sendID role
                                insert_ $ PermitTopicExtendLocal extendID enableID extID
                                return extendID
                            (Right remoteID, Right (_, _, extID)) -> lift $ do
                                enableID <- do
                                    me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
                                    case me of
                                        Just e -> pure e
                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
                                extendID <- insert $ PermitTopicExtend sendID role
                                insert_ $ PermitTopicExtendRemote extendID enableID extID
                                return extendID
                            _ -> error "personGrant impossible 2"
                        lift $ case resourceDB of
                            Left resourceID -> insert_ $ PermitTopicExtendResourceLocal extendID resourceID
                            Right actorID -> insert_ $ PermitTopicExtendResourceRemote extendID actorID
                    )

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, result) ->
            case result of
                Nothing -> doneDB inboxItemID "Inserted Grant to my inbox"
                Just (Left (recipActorID, sieve, maybeDeleg)) -> do
                    let recipByID = LocalActorPerson recipPersonID
                    forwardActivity authorIdMsig body recipByID recipActorID sieve
                    lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) ->
                        sendActivity
                            recipByID recipActorID localRecipsDeleg
                            remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
                    doneDB inboxItemID "Forwarded the direct-Grant, created/updated Permit, maybe published delegator-Grant"
                Just (Right ()) ->
                    doneDB inboxItemID "Got an extension-Grant, updated Permit"

    where

    tryInvite fulfillsDB = do
        fulfillsID <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) -> do
                    PermitTopicGestureLocal fulfillsID _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
                    return fulfillsID
                Right remoteActivityID -> do
                    PermitTopicGestureRemote fulfillsID _ _ <-
                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
                    return fulfillsID
        PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
        maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID
        return (permitID, maybeGestureID)

    tryJoin fulfillsDB = do
        Entity gestureID (PermitPersonGesture permitID _) <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) ->
                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
                Right _remoteActivityID -> mzero
        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID
        return (permitID, Just gestureID)

    tryCreate fulfillsDB = do
        Entity gestureID (PermitPersonGesture permitID _) <-
            case fulfillsDB of
                Left (_actorByKey, _actorEntity, itemID) ->
                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
                Right _remoteActivityID -> mzero
        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
        return (permitID, Just gestureID)

    prepareDelegGrant = do
        encodeRouteHome <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal

        personHash <- encodeKeyHashid recipPersonID
        audTopic <- lift $ makeAudSenderOnly authorIdMsig
        uTopic <- lift $ getActorURI authorIdMsig
        uDirectGrant <- lift $ getActivityURI authorIdMsig

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

            recips = map encodeRouteHome audLocal ++ audRemote
            action = AP.Action
                { AP.actionCapability = Just uDirectGrant
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = [uDirectGrant]
                , AP.actionSpecific   = AP.GrantActivity AP.Grant
                    { AP.grantObject    = AP.RXDelegator
                    , AP.grantContext   = encodeRouteHome $ PersonR personHash
                    , AP.grantTarget    = uTopic
                    , AP.grantResult    = Nothing
                    , AP.grantStart     = Just now
                    , AP.grantEnd       = Nothing
                    , AP.grantAllows    = AP.Invoke
                    , AP.grantDelegates = Nothing
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

-- Meaning: An actor has revoked some previously published Grants
-- Behavior:
--  * Insert to my inbox
--  * For each revoked activity:
--      * If it's a direct-Grant given to me:
--          * Verify the sender is the Permit topic
--          * Delete the Permit record
--      * If it's an extension-Grant given to me:
--          * Verify the sender is the Permit topic
--          * Delete the PermitTopicExtend* record
personRevoke
    :: UTCTime
    -> PersonId
    -> Verse
    -> AP.Revoke URIMode
    -> ActE (Text, Act (), Next)
personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do

    -- Check input
    grants <- nameExceptT "Revoke.object" $ do
        ObjURI h _ <- lift $ getActorURI authorIdMsig
        hl <- hostIsLocal h
        if hl
            then
                for lus $ \ lu ->
                    (\ (actor, _, item) -> Left (actor, item)) <$>
                        parseLocalActivityURI' lu
            else
                pure $ Right . ObjURI h <$> lus

    maybeNew <- withDBExcept $ do

        -- Grab me from DB
        (personRecip, actorRecip) <- lift $ do
            p <- getJust recipPersonID
            (p,) <$> getJust (personActor p)

        -- Look for the revoked Grants in my Permit records
        grantsDB <- for grants $ \ grant -> runMaybeT $ do
            grantDB <- MaybeT $ getActivity grant
            found <-
                Left <$> tryDirect grantDB <|>
                Right <$> tryExtension grantDB
            bitraverse
                (\ (gestureID, topicAndEnable) -> do

                    -- Verify the Permit is mine
                    PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
                    Permit p _ <- lift . lift $ getJust permitID
                    guard $ p == recipPersonID

                    -- Verify the Revoke sender is the Permit topic
                    lift $ do
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Revoke sender isn't the Permit topic"

                    -- Return data for Permit deletion
                    return (permitID, gestureID, topicAndEnable)
                )
                (\ extend -> do

                    -- Verify the Permit is mine
                    extendID <-
                        lift . lift $ case extend of
                            Left k -> permitTopicExtendLocalPermit <$> getJust k
                            Right k -> permitTopicExtendRemotePermit <$> getJust k
                    PermitTopicExtend sendID _ <- lift . lift $ getJust extendID
                    PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID
                    PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
                    Permit p _ <- lift . lift $ getJust permitID
                    guard $ p == recipPersonID

                    -- Verify the Revoke sender is the Permit topic
                    lift $ do
                        topic <- lift $ getPermitTopic permitID
                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
                            (Left la, Left la') | resourceToActor la == la' -> pure ()
                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
                            _ -> throwE "Revoke sender isn't the Permit topic"

                    -- Return data for PermitTopicExtend* deletion
                    return (extendID, extend)
                )
                found

        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
        lift $ for mractid $ \ (inboxItemID, _revokeDB) -> fmap (inboxItemID,) $
            -- Delete revoked records from DB
            for grantsDB $ traverse_ $
                bitraverse_
                    (\ (permitID, gestureID, topicAndEnable) -> do
                        case topicAndEnable of
                            Left (_, enableID) -> do
                                extends <- selectList [PermitTopicExtendLocalTopic ==. enableID] []
                                let extendIDs = map (permitTopicExtendLocalPermit . entityVal) extends
                                    extendLocalIDs = map entityKey extends
                                deleteWhere [PermitTopicExtendLocalId <-. extendLocalIDs]
                                deleteWhere [PermitTopicExtendResourceLocalPermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendResourceRemotePermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendId <-. extendIDs]
                            Right (_, enableID) -> do
                                extends <- selectList [PermitTopicExtendRemoteTopic ==. enableID] []
                                let extendIDs = map (permitTopicExtendRemotePermit . entityVal) extends
                                    extendRemoteIDs = map entityKey extends
                                deleteWhere [PermitTopicExtendRemoteId <-. extendRemoteIDs]
                                deleteWhere [PermitTopicExtendResourceLocalPermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendResourceRemotePermit <-. extendIDs]
                                deleteWhere [PermitTopicExtendId <-. extendIDs]
                        deleteBy $ UniquePermitPersonSendDelegator gestureID
                        case topicAndEnable of
                            Left (topicID, enableID) -> do
                                delete enableID
                                deleteBy $ UniquePermitTopicAcceptLocalTopic topicID
                            Right (topicID, enableID) -> do
                                delete enableID
                                deleteBy $ UniquePermitTopicAcceptRemoteTopic topicID
                        maybeInvite <- getKeyBy $ UniquePermitFulfillsInvite permitID
                        for_ maybeInvite $ \ inviteID -> do
                            deleteBy $ UniquePermitTopicGestureLocal inviteID
                            deleteBy $ UniquePermitTopicGestureRemote inviteID
                        delete gestureID
                        deleteBy $ UniquePermitFulfillsTopicCreation permitID
                        deleteBy $ UniquePermitFulfillsInvite permitID
                        deleteBy $ UniquePermitFulfillsJoin permitID
                        case topicAndEnable of
                            Left (topicID, _) -> delete topicID
                            Right (topicID, _) -> delete topicID
                        delete permitID
                    )
                    (\ (extendID, extend) -> do
                        case extend of
                            Left k -> delete k
                            Right k -> delete k
                        deleteBy $ UniquePermitTopicExtendResourceLocal extendID
                        deleteBy $ UniquePermitTopicExtendResourceRemote extendID
                        delete extendID
                    )

    case maybeNew of
        Nothing -> done "I already have this activity in my inbox"
        Just (inboxItemID, _) -> doneDB inboxItemID "Deleted any relevant Permit/Extend records"

    where

    tryDirect objectDB =
        case objectDB of
            Left (_actorByKey, _actorEntity, itemID) -> do
                Entity enableID (PermitTopicEnableLocal gestureID topicID _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicEnableLocalGrant itemID
                return (gestureID, Left (topicID, enableID))
            Right remoteActivityID -> do
                Entity enableID (PermitTopicEnableRemote gestureID topicID _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicEnableRemoteGrant remoteActivityID
                return (gestureID, Right (topicID, enableID))

    tryExtension objectDB =
        case objectDB of
            Left (_actorByKey, _actorEntity, itemID) -> do
                Entity extendID (PermitTopicExtendLocal _ _ _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicExtendLocalGrant itemID
                return $ Left extendID
            Right remoteActivityID -> do
                Entity extendID (PermitTopicExtendRemote _ _ _) <-
                    MaybeT $ lift $ getBy $ UniquePermitTopicExtendRemoteGrant remoteActivityID
                return $ Right extendID

------------------------------------------------------------------------------
-- Main behavior function
------------------------------------------------------------------------------

-- Meaning: I've just been verified
-- Behavior: Publish a Create-self activity & record ActorCreateLocal in DB
personInit
    :: UTCTime
    -> PersonId
    -> ActE (Text, Act (), Next)
personInit now personMeID = do

    _ <- withDBExcept $ do

        -- Grab me from DB
        personMe <- lift $ getJust personMeID
        let actorMeID = personActor personMe
        actorMe <- lift $ getJust actorMeID

        -- Grab ActorCreate* record, make sure it doesn't exist
        ml <- lift $ getKeyBy $ UniqueActorCreateLocalActor actorMeID
        mr <- lift $ getKeyBy $ UniqueActorCreateRemoteActor actorMeID
        unless (isNothing ml && isNothing mr) $
            throwE "ActorCreate* already exists"

        -- Prepare a Create activity and insert to my outbox
        createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
        create@(actionCreate, _, _, _) <- lift $ lift $ prepareCreate personMe actorMe
        _luCreate <- lift $ updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate

        -- Insert ActorCreateLocal record
        lift $ insert_ $ ActorCreateLocal actorMeID createID

        return (actorMeID, createID, create)

    -- Not sending the activity anywhere
    done "Published a Create-self activity"

    where

    prepareCreate personMe actorMe = do
        hLocal <- asksEnv stageInstanceHost
        encodeRouteHome <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
        personMeHash <- encodeKeyHashid personMeID
        let audMe = AudLocal [] [LocalStagePersonFollowers personMeHash]
            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                collectAudience [audMe]

            recips = map encodeRouteHome audLocal ++ audRemote

            pdetail = AP.ActorDetail
                { AP.actorType     = AP.ActorTypePerson
                , AP.actorUsername = Just $ username2text $ personUsername personMe
                , AP.actorName     = Just $ actorName actorMe
                , AP.actorSummary  = Just $ actorDesc actorMe
                , AP.actorOrigin   = Nothing
                }
            plocal = AP.ActorLocal
                { AP.actorId         = encodeRouteLocal $ PersonR personMeHash
                , AP.actorInbox      = encodeRouteLocal $ PersonInboxR personMeHash
                , AP.actorOutbox     = Nothing
                , AP.actorFollowers  = Nothing
                , AP.actorFollowing  = Nothing
                , AP.actorPublicKeys = []
                , AP.actorSshKeys    = []
                }
            action = AP.Action
                { AP.actionCapability = Nothing
                , AP.actionSummary    = Nothing
                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                , AP.actionFulfills   = []
                , AP.actionSpecific   = AP.CreateActivity AP.Create
                    { AP.createObject = AP.CreatePerson pdetail (Just (hLocal, plocal))
                    , AP.createOrigin = Nothing
                    }
                }

        return (action, recipientSet, remoteActors, fwdHosts)

personVerse personID verse@(Verse _authorIdMsig body) = do
    now <- liftIO getCurrentTime
    case AP.activitySpecific $ actbActivity body of
        AP.AcceptActivity accept -> personAccept now personID verse accept
        AP.AddActivity add -> personAdd now personID verse add
        AP.CreateActivity (AP.Create obj mtarget) ->
            case obj of
                AP.CreateNote _ note ->
                    personCreateNote now personID verse note
                _ -> throwE "Unsupported create object type for people"
        AP.FollowActivity follow -> personFollow now personID verse follow
        AP.GrantActivity grant   -> personGrant now personID verse grant
        AP.InviteActivity invite -> personInvite now personID verse invite
        AP.JoinActivity join     -> personJoin now personID verse join
        AP.OfferActivity offer   -> personOffer now personID verse offer
        AP.RejectActivity reject -> personReject now personID verse reject
        AP.RemoveActivity remove -> personRemove now personID verse remove
        AP.ResolveActivity resolve -> personResolve now personID verse resolve
        AP.RevokeActivity revoke -> personRevoke now personID verse revoke
        AP.UndoActivity undo     -> personUndo now personID verse undo
        _ -> throwE "Unsupported activity type for Person"

instance ActorLaunch Person where
    actorBehavior _ =
        (handleMethod @"verse" := \ personID verse -> adaptHandlerResult $ do
            errboxID <- lift $ withDB $ do
                actorID <- personActor <$> getJust personID
                actorErrbox <$> getJust actorID
            adaptErrbox errboxID True (personVerse personID) verse
        )
        `HCons`
        (handleMethod @"client" := \ personID msg -> adaptHandlerResult $ do
            now <- liftIO getCurrentTime
            clientBehavior now personID msg
        )
        `HCons`
        (handleMethod @"init" := \ personID -> adaptHandlerResult $ do
            now <- liftIO getCurrentTime
            personInit now personID
        )
        `HCons`
        HNil