vervis/src/Vervis/API.hs

{- This file is part of Vervis.
 -
 - Written in 2019, 2020 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.API
    ( noteC
    , createNoteC
    , createTicketC
    , followC
    , offerTicketC
    , undoC
    , pushCommitsC
    , getFollowersCollection
    )
where

import Control.Applicative
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Crypto.Hash
import Data.Aeson
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Units
import Data.Traversable
import Data.Tuple
import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy)
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Network.TLS hiding (SHA256)
import Text.Blaze.Html (preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
import qualified Network.Wai as W

import Data.Time.Interval
import Network.HTTP.Signature hiding (requestHeaders)
import Yesod.HttpSignature

import Crypto.PublicVerifKey
import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient
import Vervis.ActorKey
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.RemoteActorStore
import Vervis.Settings
import Vervis.Ticket

verifyIsLoggedInUser
    :: LocalURI
    -> Text
    -> ExceptT Text AppDB (PersonId, OutboxId, ShrIdent)
verifyIsLoggedInUser lu t = do
    Entity pid p <- requireVerifiedAuth
    s <- lift $ getJust $ personIdent p
    route2local <- getEncodeRouteLocal
    let shr = sharerIdent s
    if route2local (SharerR shr) == lu
        then return (pid, personOutbox p, shr)
        else throwE t

verifyAuthor
    :: ShrIdent
    -> LocalURI
    -> Text
    -> ExceptT Text AppDB (PersonId, OutboxId)
verifyAuthor shr lu t = ExceptT $ do
    Entity sid s <- getBy404 $ UniqueSharer shr
    Entity pid p <- getBy404 $ UniquePersonIdent sid
    encodeRouteLocal <- getEncodeRouteLocal
    return $
        if encodeRouteLocal (SharerR shr) == lu
            then Right (pid, personOutbox p)
            else Left t

parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
parseComment luParent = do
    route <- case decodeRouteLocal luParent of
        Nothing -> throwE "Not a local route"
        Just r -> return r
    case route of
        MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
        _                -> throwE "Not a local message route"

noteC
    :: Entity Person
    -> Sharer
    -> Note URIMode
    -> Handler (Either Text LocalMessageId)
noteC person sharer note = do
    let shrUser = sharerIdent sharer
    summary <-
        TextHtml . TL.toStrict . renderHtml <$>
            withUrlRenderer
                [hamlet|
                    <p>
                      <a href=@{SharerR shrUser}>#{shr2text shrUser}
                      $maybe uContext <- noteContext note
                        \ commented under a #
                        <a href="#{renderObjURI uContext}">topic</a>.
                      $nothing
                        \ commented.
                |]
    createNoteC person sharer summary (noteAudience note) note

-- | Handle a Note submitted by a local user to their outbox. It can be either
-- a comment on a local ticket, or a comment on some remote context. Return an
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
createNoteC
    :: Entity Person
    -> Sharer
    -> TextHtml
    -> Audience URIMode
    -> Note URIMode
    -> Handler (Either Text LocalMessageId)
createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do
    let shrUser = sharerIdent sharerUser
    noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
    (localRecips, remoteRecips) <- do
        mrecips <- parseAudience audience
        fromMaybeE mrecips "Create Note with no recipients"
    checkFederation remoteRecips
    verifyContextRecip context localRecips remoteRecips
    now <- liftIO getCurrentTime
    (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
        (mproject, did, meparent) <- getTopicAndParent context mparent
        lmid <- lift $ insertMessage now content source obiidCreate did meparent
        docCreate <- lift $ insertCreateToOutbox now shrUser noteData obiidCreate lmid
        remoteRecipsHttpCreate <- do
            hashLT <- getEncodeKeyHashid
            hashTAL <- getEncodeKeyHashid
            let sieve =
                    let actors =
                            case mproject of
                                Nothing -> []
                                Just (shr, prj) -> [LocalActorProject shr prj]
                        collections =
                            let project =
                                    case mproject of
                                        Nothing -> []
                                        Just (shr, prj) ->
                                            [ LocalPersonCollectionProjectTeam shr prj
                                            , LocalPersonCollectionProjectFollowers shr prj
                                            ]
                                ticket =
                                    case context of
                                        Left nc ->
                                            case nc of
                                                NoteContextSharerTicket shr talid ->
                                                    let talkhid = hashTAL talid
                                                    in  [ -- LocalPersonCollectionSharerTicketTeam shr talkhid
                                                          LocalPersonCollectionSharerTicketFollowers shr talkhid
                                                        ]
                                                NoteContextProjectTicket shr prj ltid ->
                                                    let ltkhid = hashLT ltid
                                                    in  [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid
                                                          LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
                                                        ]
                                        Right _ -> []
                                commenter = [LocalPersonCollectionSharerFollowers shrUser]
                            in  project ++ ticket ++ commenter
                    in  makeRecipientSet actors collections
            moreRemoteRecips <-
                lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
                    localRecipSieve' sieve True False localRecips
            checkFederation moreRemoteRecips
            lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips
        return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate)
    lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
    return lmid
    where
    checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
        verifyNothingE mluNote "Note specifies an id"
        encodeRouteLocal <- getEncodeRouteLocal
        unless (encodeRouteLocal (SharerR shrUser) == luAttrib) $
            throwE "Note attributed to someone else"
        verifyNothingE mpublished "Note specifies published"
        uContext <- fromMaybeE muContext "Note without context"
        context <- parseNoteContext uContext
        mparent <- checkParent context =<< traverse parseParent muParent
        return (muParent, mparent, uContext, context, source, content)
        where
        parseTopic name route =
            case route of
                SharerTicketR shr talkhid ->
                    NoteContextSharerTicket shr <$>
                        decodeKeyHashidE
                            talkhid
                            (name <> " sharer ticket invalid talkhid")
                ProjectTicketR shr prj ltkhid ->
                    NoteContextProjectTicket shr prj <$>
                        decodeKeyHashidE
                            ltkhid
                            (name <> " project ticket invalid ltkhid")
                _ -> throwE $ name <> " isn't a discussion topic route"
        parseNoteContext u@(ObjURI h lu) = do
            hl <- hostIsLocal h
            if hl
                then Left <$> do
                    route <-
                        fromMaybeE
                            (decodeRouteLocal lu)
                            "Note context local but not a valid route"
                    parseTopic "Note context" route
                else return $ Right u
        parseParent u@(ObjURI h lu) = do
            hl <- hostIsLocal h
            if hl
                then Left <$> do
                    route <-
                        fromMaybeE
                            (decodeRouteLocal lu)
                            "Note parent local but not a valid route"
                    Left <$> parseTopic "Note parent" route <|>
                        Right <$> parseComment route
                else return $ Right u
            where
            parseComment (MessageR shr lmkhid) =
                (shr,) <$> decodeKeyHashidE lmkhid "Note parent invalid lmkhid"
            parseComment _ = throwE "Note parent not a comment route"
        checkParent _            Nothing                     = return Nothing
        checkParent (Left topic) (Just (Left (Left topic'))) =
            if topic == topic'
                then return Nothing
                else throwE "Note context and parent are different local topics"
        checkParent _            (Just (Left (Right msg)))   = return $ Just $ Left msg
        checkParent (Left _)     (Just (Right u))            = return $ Just $ Right u
        checkParent (Right u)    (Just (Right u'))           =
            return $
                if u == u'
                    then Nothing
                    else Just $ Right u'
    checkFederation remoteRecips = do
        federation <- asksSite $ appFederation . appSettings
        unless (federation || null remoteRecips) $
            throwE "Federation disabled, but remote recipients found"
    verifyContextRecip (Right (ObjURI h _)) _ remoteRecips =
        unless (any ((== h) . fst) remoteRecips) $
            throwE
                "Context is remote but no recipients of that host are listed"
    verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ =
        fromMaybeE
            verify
            "Local context ticket's hosting sharer isn't listed as a recipient"
        where
        verify = do
            sharerSet <- lookup shr localRecips
            guard $ localRecipSharer $ localRecipSharerDirect sharerSet
    verifyContextRecip (Left (NoteContextProjectTicket shr prj _)) localRecips _ =
        fromMaybeE
            verify
            "Local context ticket's hosting project isn't listed as a recipient"
        where
        verify = do
            sharerSet <- lookup shr localRecips
            projectSet <- lookup prj $ localRecipProjectRelated sharerSet
            guard $ localRecipProject $ localRecipProjectDirect projectSet
    insertEmptyOutboxItem obid now = do
        h <- asksSite siteInstanceHost
        insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  = persistJSONObjectFromDoc $ Doc h emptyActivity
            , outboxItemPublished = now
            }
    getProject tpl = do
        j <- getJust $ ticketProjectLocalProject tpl
        s <- getJust $ projectSharer j
        return (sharerIdent s, projectIdent j)
    getTopicAndParent (Left context) mparent = do
        (mproject, did) <-
            case context of
                NoteContextSharerTicket shr talid -> do
                    (_, Entity _ lt, _, project) <- do
                        mticket <- lift $ getSharerTicket shr talid
                        fromMaybeE mticket "Note context no such local sharer-hosted ticket"
                    mproj <-
                        case project of
                            Left (Entity _ tpl) -> lift $ Just <$> getProject tpl
                            Right _ -> return Nothing
                    return (mproj, localTicketDiscuss lt)
                NoteContextProjectTicket shr prj ltid -> do
                    (_, _, _, Entity _ lt, _, _) <- do
                        mticket <- lift $ getProjectTicket shr prj ltid
                        fromMaybeE mticket "Note context no such local project-hosted ticket"
                    return (Just (shr, prj), localTicketDiscuss lt)
        mmidParent <- for mparent $ \ parent ->
            case parent of
                Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
                Right (ObjURI hParent luParent) -> do
                    mrm <- lift $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
                    rm <- fromMaybeE mrm "Remote parent unknown locally"
                    let mid = remoteMessageRest rm
                    m <- lift $ getJust mid
                    unless (messageRoot m == did) $
                        throwE "Remote parent belongs to a different discussion"
                    return mid
        return (mproject, did, Left <$> mmidParent)
    getTopicAndParent (Right u@(ObjURI h lu)) mparent = do
        (mproject, rd, rdnew) <- lift $ do
            iid <- either entityKey id <$> insertBy' (Instance h)
            roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
            merd <- getBy $ UniqueRemoteDiscussionIdent roid
            case merd of
                Just (Entity rdid rd) -> do
                    mproj <- do
                        mrt <- getValBy $ UniqueRemoteTicketDiscuss rdid
                        for mrt $ \ rt -> do
                            tar <- getJust $ remoteTicketTicket rt
                            tpl <- getJust $ ticketAuthorRemoteTicket tar
                            getProject tpl
                    return (mproj, rd, False)
                Nothing -> do
                    did <- insert Discussion
                    (rd, rdnew) <- valAndNew <$> insertByEntity' (RemoteDiscussion roid did)
                    unless rdnew $ delete did
                    return (Nothing, rd, rdnew)
        let did = remoteDiscussionDiscuss rd
        meparent <- for mparent $ \ parent ->
            case parent of
                Left (shrParent, lmidParent) -> do
                    when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
                    Left <$> getLocalParentMessageId did shrParent lmidParent
                Right uParent@(ObjURI hParent luParent) -> do
                    mrm <- lift $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
                    case mrm of
                        Nothing -> return $ Right uParent
                        Just rm -> Left <$> do
                            let mid = remoteMessageRest rm
                            m <- lift $ getJust mid
                            unless (messageRoot m == did) $
                                throwE "Remote parent belongs to a different discussion"
                            return mid
        return (mproject, did, meparent)
    insertMessage now content source obiidCreate did meparent = do
        mid <- insert Message
            { messageCreated = now
            , messageSource  = source
            , messageContent = content
            , messageParent  =
                case meparent of
                    Just (Left midParent) -> Just midParent
                    _                     -> Nothing
            , messageRoot    = did
            }
        insert LocalMessage
            { localMessageAuthor         = pidUser
            , localMessageRest           = mid
            , localMessageCreate         = obiidCreate
            , localMessageUnlinkedParent =
                case meparent of
                    Just (Right uParent) -> Just uParent
                    _                    -> Nothing
            }
    insertCreateToOutbox now shrUser (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do
        encodeRouteLocal <- getEncodeRouteLocal
        hLocal <- asksSite siteInstanceHost
        obikhid <- encodeKeyHashid obiidCreate
        lmkhid <- encodeKeyHashid lmid
        let luAttrib = encodeRouteLocal $ SharerR shrUser
            create = Doc hLocal Activity
                { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
                , activityActor    = luAttrib
                , activitySummary  = Just summary
                , activityAudience = audience
                , activitySpecific = CreateActivity Create
                    { createObject = CreateNote Note
                        { noteId        = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
                        , noteAttrib    = luAttrib
                        , noteAudience  = emptyAudience
                        , noteReplyTo   = Just $ fromMaybe uContext muParent
                        , noteContext   = Just uContext
                        , notePublished = Just now
                        , noteSource    = source
                        , noteContent   = content
                        }
                    , createTarget = Nothing
                    }
                }
        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
        return create

-- | Handle a Ticket submitted by a local user to their outbox. The ticket's
-- context project may be local or remote. Return an error message if the
-- Ticket is rejected, otherwise the new 'TicketAuthorLocalId'.
createTicketC
    :: Entity Person
    -> Sharer
    -> TextHtml
    -> Audience URIMode
    -> AP.Ticket URIMode
    -> Maybe FedURI
    -> Handler (Either Text TicketAuthorLocalId)
createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do
    let shrUser = sharerIdent sharerUser
    ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
    context <- parseTicketContext uContext
    (localRecips, remoteRecips) <- do
        mrecips <- parseAudience audience
        fromMaybeE mrecips "Create Ticket with no recipients"
    checkFederation remoteRecips
    verifyProjectRecip context localRecips
    tracker <- fetchTracker context uTarget
    now <- liftIO getCurrentTime
    (talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
        obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
        project <- prepareProject now tracker
        talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
        docCreate <- lift $ insertCreateToOutbox shrUser ticketData now obiidCreate talid
        remoteRecipsHttpCreate <- do
            let sieve =
                    case tracker of
                        Left (shr, prj) ->
                            makeRecipientSet
                                [ LocalActorProject shr prj
                                ]
                                [ LocalPersonCollectionSharerFollowers shrUser
                                , LocalPersonCollectionProjectTeam shr prj
                                , LocalPersonCollectionProjectFollowers shr prj
                                ]
                        Right _ ->
                            makeRecipientSet
                                []
                                [LocalPersonCollectionSharerFollowers shrUser]
            moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
            checkFederation moreRemoteRecips
            lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips
        maccept <-
            case project of
                Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
                    let prj = projectIdent j
                        recipsA =
                            [ LocalActorSharer shrUser
                            ]
                        recipsC =
                            [ LocalPersonCollectionProjectTeam shr prj
                            , LocalPersonCollectionProjectFollowers shr prj
                            , LocalPersonCollectionSharerFollowers shrUser
                            ]
                    doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
                    recips <- lift $ deliverLocal' True (LocalActorProject shr prj)  (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
                    checkFederation recips
                    lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips
                Right _ -> return Nothing
        return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
    lift $ do
        forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate
        for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
            forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
    return talid
    where
    checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved) mtarget = do
        verifyNothingE mlocal "Ticket with 'id'"
        encodeRouteLocal <- getEncodeRouteLocal
        unless (encodeRouteLocal (SharerR shr) == luAttrib) $
            throwE "Ticket attributed to someone else"
        verifyNothingE mpublished "Ticket with 'published'"
        verifyNothingE mupdated "Ticket with 'updated'"
        context <- fromMaybeE mcontext "Ticket without 'context'"
        verifyNothingE massigned "Ticket with 'assignedTo'"
        when resolved $ throwE "Ticket resolved"
        target <- fromMaybeE mtarget "Create Ticket without 'target'"
        return (context, summary, content, source, target)

    parseTicketContext :: (MonadSite m, SiteEnv m ~ App) => FedURI -> ExceptT Text m (Either (ShrIdent, PrjIdent) FedURI)
    parseTicketContext u@(ObjURI h lu) = do
        hl <- hostIsLocal h
        if hl
            then Left <$> do
                route <- fromMaybeE (decodeRouteLocal lu) "Ticket context isn't a valid route"
                case route of
                    ProjectR shr prj -> return (shr, prj)
                    _ -> throwE "Ticket context isn't a project route"
            else return $ Right u

    checkFederation remoteRecips = do
        federation <- asksSite $ appFederation . appSettings
        unless (federation || null remoteRecips) $
            throwE "Federation disabled, but remote recipients found"

    verifyProjectRecip (Right _)         _           = return ()
    verifyProjectRecip (Left (shr, prj)) localRecips =
        fromMaybeE verify "Local context project isn't listed as a recipient"
        where
        verify = do
            sharerSet <- lookup shr localRecips
            projectSet <- lookup prj $ localRecipProjectRelated sharerSet
            guard $ localRecipProject $ localRecipProjectDirect projectSet

    fetchTracker c u@(ObjURI h lu) = do
        hl <- hostIsLocal h
        case (hl, c) of
            (True, Left (shr, prj)) -> Left <$> do
                encodeRouteLocal <- getEncodeRouteLocal
                unless (encodeRouteLocal (ProjectR shr prj) == lu) $
                    throwE "Local context and target mismatch"
                return (shr, prj)
            (True, Right _) -> throwE "context and target different host"
            (False, Left _) -> throwE "context and target different host"
            (False, Right (ObjURI h' lu')) -> Right <$> do
                unless (h == h') $ throwE "context and target different host"
                (iid, era) <- do
                    iid <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
                    result <- lift $ fetchRemoteActor iid h lu
                    case result of
                        Left e -> throwE $ T.pack $ displayException e
                        Right (Left e) -> throwE $ T.pack $ show e
                        Right (Right mera) -> do
                            era <- fromMaybeE mera "target found to be a collection, not an actor"
                            return (iid, era)
                return (iid, era, if lu == lu' then Nothing else Just lu')

    insertEmptyOutboxItem obid now = do
        h <- asksSite siteInstanceHost
        insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  = persistJSONObjectFromDoc $ Doc h emptyActivity
            , outboxItemPublished = now
            }

    prepareProject now (Left (shr, prj)) = Left <$> do
        mej <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            MaybeT $ getBy $ UniqueProject prj sid
        ej@(Entity _ j) <- fromMaybeE mej "Local context: no such project"
        obiidAccept <- lift $ insertEmptyOutboxItem (projectOutbox j) now
        return (shr, ej, obiidAccept)
    prepareProject _   (Right (iid, era, mlu)) = lift $ Right <$> do
        mroid <- for mlu $ \ lu -> either entityKey id <$> insertBy' (RemoteObject iid lu)
        return (era, mroid)

    insertTicket now pidUser title desc source obiidCreate project = do
        did <- insert Discussion
        fsid <- insert FollowerSet
        tid <- insert Ticket
            { ticketNumber      = Nothing
            , ticketCreated     = now
            , ticketTitle       = unTextHtml title
            , ticketSource      = unTextPandocMarkdown source
            , ticketDescription = unTextHtml desc
            , ticketAssignee    = Nothing
            , ticketStatus      = TSNew
            , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
            , ticketCloser      = Nothing
            }
        ltid <- insert LocalTicket
            { localTicketTicket    = tid
            , localTicketDiscuss   = did
            , localTicketFollowers = fsid
            }
        talid <- insert TicketAuthorLocal
            { ticketAuthorLocalTicket = ltid
            , ticketAuthorLocalAuthor = pidUser
            , ticketAuthorLocalOpen   = obiidCreate
            }
        case project of
            Left (_shr, Entity jid _j, obiidAccept) ->
                insert_ TicketProjectLocal
                    { ticketProjectLocalTicket  = tid
                    , ticketProjectLocalProject = jid
                    , ticketProjectLocalAccept  = obiidAccept
                    }
            Right (Entity raid _ra, mroid) ->
                insert_ TicketProjectRemote
                    { ticketProjectRemoteTicket  = talid
                    , ticketProjectRemoteTracker = raid
                    , ticketProjectRemoteProject = mroid
                    }
        return talid

    insertCreateToOutbox shrUser (uContext, title, desc, source, uTarget) now obiidCreate talid = do
        encodeRouteLocal <- getEncodeRouteLocal
        hLocal <- asksSite siteInstanceHost
        talkhid <- encodeKeyHashid talid
        obikhid <- encodeKeyHashid obiidCreate
        let luAttrib = encodeRouteLocal $ SharerR shrUser
            tlocal = TicketLocal
                { ticketId           = encodeRouteLocal $ SharerTicketR shrUser talkhid
                , ticketReplies      = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid
                , ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid
                , ticketTeam         = encodeRouteLocal $ SharerTicketTeamR shrUser talkhid
                , ticketEvents       = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid
                , ticketDeps         = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid
                , ticketReverseDeps  = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid
                }
            create = Doc hLocal Activity
                { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
                , activityActor    = luAttrib
                , activitySummary  = Just summary
                , activityAudience = audience
                , activitySpecific = CreateActivity Create
                    { createObject = CreateTicket AP.Ticket
                        { AP.ticketLocal        = Just (hLocal, tlocal)
                        , AP.ticketAttributedTo = luAttrib
                        , AP.ticketPublished    = Just now
                        , AP.ticketUpdated      = Nothing
                        , AP.ticketContext      = Just uContext
                        , AP.ticketSummary      = title
                        , AP.ticketContent      = desc
                        , AP.ticketSource       = source
                        , AP.ticketAssignedTo   = Nothing
                        , AP.ticketIsResolved   = False
                        }
                    , createTarget = Just uTarget
                    }
                }
        update obiidCreate [OutboxItemActivity =. persistJSONObjectFromDoc create]
        return create

    insertAcceptToOutbox (shrJ, Entity _ j, obiidAccept) shrU obiidCreate talid actors colls = do
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRouteHome <- getEncodeRouteHome
        hLocal <- asksSite siteInstanceHost
        obikhidAccept <- encodeKeyHashid obiidAccept
        obikhidCreate <- encodeKeyHashid obiidCreate
        talkhid <- encodeKeyHashid talid
        let prjJ = projectIdent j
        summary <-
            TextHtml . TL.toStrict . renderHtml <$>
                withUrlRenderer
                    [hamlet|
                        <p>
                          Project #
                          <a href=@{ProjectR shrJ prjJ}>
                            #{prj2text prjJ}
                          \ accepted #
                          <a href=@{SharerTicketR shrU talkhid}>
                            ticket
                          \ by #
                          <a href=@{SharerR shrU}>
                            #{shr2text shrU}
                    |]
        let recips = map encodeRouteHome $ map renderLocalActor actors ++ map renderLocalPersonCollection colls
            accept = Doc hLocal Activity
                { activityId       = Just $ encodeRouteLocal $ ProjectOutboxItemR shrJ prjJ obikhidAccept
                , activityActor    = encodeRouteLocal $ ProjectR shrJ prjJ
                , activitySummary  = Just summary
                , activityAudience = Audience recips [] [] [] [] []
                , activitySpecific = AcceptActivity Accept
                    { acceptObject = encodeRouteHome $ SharerOutboxItemR shrU obikhidCreate
                    , acceptResult = Nothing
                    }
                }
        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
        return accept

    dont = Authority "dont-do.any-forwarding" Nothing

data Followee
    = FolloweeSharer ShrIdent
    | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
    | FolloweeProject ShrIdent PrjIdent
    | FolloweeProjectTicket ShrIdent PrjIdent (KeyHashid LocalTicket)
    | FolloweeRepo ShrIdent RpIdent

followC
    :: ShrIdent
    -> TextHtml
    -> Audience URIMode
    -> AP.Follow URIMode
    -> Handler (Either Text OutboxItemId)
followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = runExceptT $ do
    (localRecips, remoteRecips) <- do
        mrecips <- parseAudience audience
        fromMaybeE mrecips "Follow with no recipients"
    federation <- asksSite $ appFederation . appSettings
    unless (federation || null remoteRecips) $
        throwE "Federation disabled, but remote recipients specified"
    mfollowee <- do
        let ObjURI h luObject = uObject
        local <- hostIsLocal h
        if local
            then Just <$> do
                    route <-
                        fromMaybeE
                            (decodeRouteLocal luObject)
                            "Follow object isn't a valid route"
                    followee <-
                        fromMaybeE
                            (parseFollowee route)
                            "Follow object isn't a followee route"
                    let actor = followeeActor followee
                    unless (actorRecips actor == localRecips) $
                        throwE "Follow object isn't the recipient"
                    case followee of
                        FolloweeSharer shr | shr == shrUser ->
                            throwE "User trying to follow themselves"
                        _ -> return ()
                    return (followee, actor)
            else do
                unless (null localRecips) $
                    throwE "Follow object is remote but local recips listed"
                return Nothing
    let dont = Authority "dont-do.any-forwarding" Nothing
    (obiidFollow, doc, remotesHttp) <- runDBExcept $ do
        Entity pidAuthor personAuthor <- lift $ getAuthor shrUser
        let ibidAuthor = personInbox personAuthor
            obidAuthor = personOutbox personAuthor
        (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
        case mfollowee of
            Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow
            Just (followee, actorRecip) -> do
                (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee
                obiidAccept <- lift $ insertAcceptToOutbox luFollow actorRecip obidRecip
                deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip
                lift $ deliverAcceptLocal obiidAccept ibidAuthor
        remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
        return (obiidFollow, doc, remotesHttp)
    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidFollow doc remotesHttp
    return obiidFollow
    where
    parseFollowee (SharerR shr)                = Just $ FolloweeSharer shr
    parseFollowee (SharerTicketR shr khid)     = Just $ FolloweeSharerTicket shr khid
    parseFollowee (ProjectR shr prj)           = Just $ FolloweeProject shr prj
    parseFollowee (ProjectTicketR shr prj num) = Just $ FolloweeProjectTicket shr prj num
    parseFollowee (RepoR shr rp)               = Just $ FolloweeRepo shr rp
    parseFollowee _                            = Nothing

    followeeActor (FolloweeSharer shr)              = LocalActorSharer shr
    followeeActor (FolloweeSharerTicket shr _)      = LocalActorSharer shr
    followeeActor (FolloweeProject shr prj)         = LocalActorProject shr prj
    followeeActor (FolloweeProjectTicket shr prj _) = LocalActorProject shr prj
    followeeActor (FolloweeRepo shr rp)             = LocalActorRepo shr rp

    getAuthor shr = do
        sid <- getKeyBy404 $ UniqueSharer shr
        getBy404 $ UniquePersonIdent sid

    getFollowee (FolloweeSharer shr) = do
        msid <- lift $ getKeyBy $ UniqueSharer shr
        sid <- fromMaybeE msid "Follow object: No such sharer in DB"
        mval <- runMaybeT
            $   Left  <$> MaybeT (lift $ getValBy $ UniquePersonIdent sid)
            <|> Right <$> MaybeT (lift $ getValBy $ UniqueGroup sid)
        val <-
            fromMaybeE mval $
                "Found non-person non-group sharer: " <> shr2text shr
        case val of
            Left person -> return (personFollowers person, personInbox person, True, personOutbox person)
            Right _group -> throwE "Follow object is a group"
    getFollowee (FolloweeSharerTicket shr talkhid) = do
        mfollowee <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            Entity pid p <- MaybeT $ getBy $ UniquePersonIdent sid
            talid <- decodeKeyHashidM talkhid
            tal <- MaybeT $ get talid
            guard $ ticketAuthorLocalAuthor tal == pid
            mtup <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid
            guard $ isNothing mtup
            lt <- lift $ getJust $ ticketAuthorLocalTicket tal
            return (lt, p)
        (lt, p) <- fromMaybeE mfollowee "Follow object: No such sharer ticket in DB"
        return (localTicketFollowers lt, personInbox p, True, personOutbox p)
    getFollowee (FolloweeProject shr prj) = do
        mproject <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            MaybeT $ getValBy $ UniqueProject prj sid
        project <- fromMaybeE mproject "Follow object: No such project in DB"
        return (projectFollowers project, projectInbox project, False, projectOutbox project)
    getFollowee (FolloweeProjectTicket shr prj ltkhid) = do
        mproject <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid
            ltid <- decodeKeyHashidM ltkhid
            lticket <- MaybeT $ get ltid
            tpl <-
                MaybeT $ getValBy $
                    UniqueTicketProjectLocal $ localTicketTicket lticket
            guard $ ticketProjectLocalProject tpl == jid
            return (lticket, project)
        (lticket, project) <- fromMaybeE mproject "Follow object: No such project ticket in DB"
        return (localTicketFollowers lticket, projectInbox project, False, projectOutbox project)
    getFollowee (FolloweeRepo shr rp) = do
        mrepo <- lift $ runMaybeT $ do
            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
            MaybeT $ getValBy $ UniqueRepo rp sid
        repo <- fromMaybeE mrepo "Follow object: No such repo in DB"
        return (repoFollowers repo, repoInbox repo, False, repoOutbox repo)

    insertFollowToOutbox obid = do
        hLocal <- asksSite siteInstanceHost
        encodeRouteLocal <- getEncodeRouteLocal
        let activity mluAct = Doc hLocal Activity
                { activityId       = mluAct
                , activityActor    = encodeRouteLocal $ SharerR shrUser
                , activitySummary  = Just summary
                , activityAudience = audience
                , activitySpecific = FollowActivity follow
                }
        now <- liftIO getCurrentTime
        obiid <- insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  =
                persistJSONObjectFromDoc $ activity Nothing
            , outboxItemPublished = now
            }
        obikhid <- encodeKeyHashid obiid
        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
            doc = activity $ Just luAct
        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
        return (obiid, doc, luAct)

    deliverFollowLocal pidAuthor fsid unread obiidF obiidA ibidRecip = do
        mfid <- lift $ insertUnique $ Follow pidAuthor fsid (not hide) obiidF obiidA
        _ <- fromMaybeE mfid "Already following this object"
        ibiid <- lift $ insert $ InboxItem unread
        lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid

    insertAcceptToOutbox luFollow actorRecip obidRecip = do
        now <- liftIO getCurrentTime
        summary <-
            TextHtml . TL.toStrict . renderHtml <$>
                withUrlRenderer
                    [hamlet|
                        <p>
                          <a href=@{SharerR shrUser}>
                            #{shr2text shrUser}
                          's follow request accepted by #
                          <a href=#{renderObjURI uObject}>
                            #{localUriPath $ objUriLocal uObject}
                    |]
        hLocal <- asksSite siteInstanceHost
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRouteHome <- getEncodeRouteHome
        let recips = [encodeRouteHome $ SharerR shrUser]
            accept mluAct = Doc hLocal Activity
                { activityId       = mluAct
                , activityActor    = objUriLocal uObject
                , activitySummary  = Just summary
                , activityAudience = Audience recips [] [] [] [] []
                , activitySpecific = AcceptActivity Accept
                    { acceptObject = ObjURI hLocal luFollow
                    , acceptResult = Nothing
                    }
                }
        obiid <- insert OutboxItem
            { outboxItemOutbox    = obidRecip
            , outboxItemActivity  =
                persistJSONObjectFromDoc $ accept Nothing
            , outboxItemPublished = now
            }
        obikhid <- encodeKeyHashid obiid
        let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid
            doc = accept $ Just luAct
        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
        return obiid
        where
        actorOutboxItem (LocalActorSharer shr)      = SharerOutboxItemR shr
        actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
        actorOutboxItem (LocalActorRepo shr rp)     = RepoOutboxItemR shr rp

    deliverAcceptLocal obiidAccept ibidAuthor = do
        ibiid <- insert $ InboxItem True
        insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid

offerTicketC
    :: ShrIdent
    -> TextHtml
    -> Audience URIMode
    -> Offer URIMode
    -> Handler (Either Text OutboxItemId)
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
    (hProject, shrProject, prjProject) <- parseTarget uTarget
    {-deps <- -}
    checkOffer hProject shrProject prjProject
    (localRecips, remoteRecips) <- do
        mrecips <- parseAudience audience
        fromMaybeE mrecips "Offer with no recipients"
    federation <- asksSite $ appFederation . appSettings
    unless (federation || null remoteRecips) $
        throwE "Federation disabled, but remote recipients specified"
    checkRecips hProject shrProject prjProject localRecips
    now <- liftIO getCurrentTime
    (obiid, doc, remotesHttp) <- runDBExcept $ do
        (pidAuthor, obidAuthor) <-
            verifyAuthor
                shrUser
                (AP.ticketAttributedTo ticket)
                "Ticket attributed to different actor"
        mprojAndDeps <- do
            targetIsLocal <- hostIsLocal hProject
            if targetIsLocal
                then Just <$> getProjectAndDeps shrProject prjProject {-deps-}
                else return Nothing
        (obiid, doc, luOffer) <- lift $ insertToOutbox now obidAuthor
        moreRemotes <-
            lift $ deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer localRecips
        unless (federation || null moreRemotes) $
            throwE "Federation disabled but remote collection members found"
        remotesHttp <- lift $ deliverRemoteDB' hProject obiid remoteRecips moreRemotes
        return (obiid, doc, remotesHttp)
    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp hProject obiid doc remotesHttp
    return obiid
    where
    checkOffer hProject shrProject prjProject = do
        verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
        verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
        verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
        -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
        verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
        when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
    checkRecips hProject shrProject prjProject localRecips = do
        local <- hostIsLocal hProject
        if local
            then traverse (verifyOfferRecips shrProject prjProject) localRecips
            else traverse (verifyOnlySharer . snd) localRecips
        where
        verifyOfferRecips shr prj (shr', lsrSet) =
            if shr == shr'
                then unless (lsrSet == offerRecips prj) $
                        throwE "Unexpected offer target recipient set"
                else verifyOnlySharer lsrSet
            where
            offerRecips prj = LocalSharerRelatedSet
                { localRecipSharerDirect        = LocalSharerDirectSet False False
                , localRecipSharerTicketRelated = []
                , localRecipProjectRelated      =
                    [ ( prj
                      , LocalProjectRelatedSet
                            { localRecipProjectDirect =
                                LocalProjectDirectSet True True True
                            , localRecipProjectTicketRelated = []
                            }
                      )
                    ]
                , localRecipRepoRelated         = []
                }
        verifyOnlySharer lsrSet = do
            unless (null $ localRecipProjectRelated lsrSet) $
                throwE "Unexpected recipients unrelated to offer target"
            unless (null $ localRecipRepoRelated lsrSet) $
                throwE "Unexpected recipients unrelated to offer target"
    insertToOutbox now obid = do
        hLocal <- asksSite siteInstanceHost
        let activity mluAct = Doc hLocal Activity
                { activityId       = mluAct
                , activityActor    = AP.ticketAttributedTo ticket
                , activitySummary  = Just summary
                , activityAudience = audience
                , activitySpecific = OfferActivity offer
                }
        obiid <- insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  =
                persistJSONObjectFromDoc $ activity Nothing
            , outboxItemPublished = now
            }
        encodeRouteLocal <- getEncodeRouteLocal
        obikhid <- encodeKeyHashid obiid
        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
            doc = activity $ Just luAct
        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
        return (obiid, doc, luAct)
    deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
        (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ projects _) -> do
            (pids, remotes) <-
                traverseCollect (uncurry $ deliverLocalProject shr) projects
            pids' <- do
                mpid <-
                    if localRecipSharer sharer
                        then runMaybeT $ do
                            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
                            MaybeT $ getKeyBy $ UniquePersonIdent sid
                        else return Nothing
                return $
                    case mpid of
                        Nothing -> pids
                        Just pid -> LO.insertSet pid pids
            return (pids', remotes)
        for_ (L.delete pidAuthor pids) $ \ pid -> do
            ibid <- personInbox <$> getJust pid
            ibiid <- insert $ InboxItem True
            insert_ $ InboxItemLocal ibid obiid ibiid
        return remotes
        where
        traverseCollect action values =
            bimap collectPids collectRemotes . unzip <$> traverse action values
            where
            collectPids = foldl' LO.union []
            collectRemotes = foldl' unionRemotes []
        forCollect = flip traverseCollect
        deliverLocalProject shr prj (LocalProjectRelatedSet project _) =
            case mprojAndDeps of
                Just (sid, jid, ibid, fsid{-, tids-})
                    | shr == shrProject &&
                      prj == prjProject &&
                      localRecipProject project -> do
                        insertToInbox ibid
                        {-
                        num <-
                            ((subtract 1) . projectNextTicket) <$>
                                updateGet jid [ProjectNextTicket +=. 1]
                        -}
                        obiidAccept <- do
                            obidProject <- projectOutbox <$> getJust jid
                            now <- liftIO getCurrentTime
                            hLocal <- asksSite siteInstanceHost
                            insert OutboxItem
                                { outboxItemOutbox    = obidProject
                                , outboxItemActivity  =
                                    persistJSONObjectFromDoc $ Doc hLocal emptyActivity
                                , outboxItemPublished = now
                                }
                        ltid <- insertTicket jid {-tids-} {-num-} obiidAccept
                        docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept ltid
                        publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept
                        (pidsTeam, remotesTeam) <-
                            if localRecipProjectTeam project
                                then getProjectTeam sid
                                else return ([], [])
                        (pidsFollowers, remotesFollowers) <-
                            if localRecipProjectFollowers project
                                then getFollowers fsid
                                else return ([], [])
                        return
                            ( LO.union pidsTeam pidsFollowers
                            , unionRemotes remotesTeam remotesFollowers
                            )
                _ -> return ([], [])
            where
            insertToInbox ibid = do
                ibiid <- insert $ InboxItem False
                insert_ $ InboxItemLocal ibid obiid ibiid
            insertAccept pidAuthor sid jid fsid luOffer obiid ltid = do
                ltkhid <- encodeKeyHashid ltid
                summary <-
                    TextHtml . TL.toStrict . renderHtml <$>
                        withUrlRenderer
                            [hamlet|
                                <p>
                                  <a href=@{SharerR shrUser}>
                                    #{shr2text shrUser}
                                  's ticket accepted by project #
                                  <a href=@{ProjectR shrProject prjProject}>
                                    ./s/#{shr2text shrProject}/p/#{prj2text prjProject}
                                  : #
                                  <a href=@{ProjectTicketR shrProject prjProject ltkhid}>
                                    #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
                            |]
                hLocal <- asksSite siteInstanceHost
                encodeRouteLocal <- getEncodeRouteLocal
                encodeRouteHome <- getEncodeRouteHome
                obikhid <- encodeKeyHashid obiid
                let recips =
                        map encodeRouteHome
                            [ SharerR shrUser
                            , ProjectTeamR shrProject prjProject
                            , ProjectFollowersR shrProject prjProject
                            ]
                    doc = Doc hLocal Activity
                        { activityId       =
                            Just $ encodeRouteLocal $
                                ProjectOutboxItemR shrProject prjProject obikhid
                        , activityActor    =
                            encodeRouteLocal $ ProjectR shrProject prjProject
                        , activitySummary  = Just summary
                        , activityAudience = Audience recips [] [] [] [] []
                        , activitySpecific = AcceptActivity Accept
                            { acceptObject = ObjURI hLocal luOffer
                            , acceptResult =
                                Just $ encodeRouteLocal $
                                    ProjectTicketR shrProject prjProject ltkhid
                            }
                        }
                update
                    obiid
                    [OutboxItemActivity =. persistJSONObjectFromDoc doc]
                return doc
            insertTicket jid {-tidsDeps-} {-next-} obiidAccept = do
                did <- insert Discussion
                fsid <- insert FollowerSet
                tid <- insert Ticket
                    { ticketNumber      = Nothing
                    , ticketCreated     = now
                    , ticketTitle       = unTextHtml $ AP.ticketSummary ticket
                    , ticketSource      =
                        unTextPandocMarkdown $ AP.ticketSource ticket
                    , ticketDescription = unTextHtml $ AP.ticketContent ticket
                    , ticketAssignee    = Nothing
                    , ticketStatus      = TSNew
                    , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
                    , ticketCloser      = Nothing
                    }
                ltid <- insert LocalTicket
                    { localTicketTicket    = tid
                    , localTicketDiscuss   = did
                    , localTicketFollowers = fsid
                    }
                tplid <- insert TicketProjectLocal
                    { ticketProjectLocalTicket  = tid
                    , ticketProjectLocalProject = jid
                    , ticketProjectLocalAccept  = obiidAccept
                    }
                talid <- insert TicketAuthorLocal
                    { ticketAuthorLocalTicket = ltid
                    , ticketAuthorLocalAuthor = pidAuthor
                    , ticketAuthorLocalOpen   = obiid
                    }
                insert_ TicketUnderProject
                    { ticketUnderProjectProject = tplid
                    , ticketUnderProjectAuthor  = talid
                    }
                --insertMany_ $ map (TicketDependency tid) tidsDeps
                -- insert_ $ Follow pidAuthor fsid False True
                return ltid
            publishAccept pidAuthor sid jid fsid luOffer {-num-} obiid doc = do
                now <- liftIO getCurrentTime
                let dont = Authority "dont-do.any-forwarding" Nothing
                remotesHttp <- do
                    moreRemotes <- deliverLocal now sid fsid obiid
                    deliverRemoteDB' dont obiid [] moreRemotes
                site <- askSite
                liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
                where
                deliverLocal now sid fsid obiid = do
                    (pidsTeam, remotesTeam) <- getProjectTeam sid
                    (pidsFollowers, remotesFollowers) <- getFollowers fsid
                    let pids = LO.insertSet pidAuthor $ LO.union pidsTeam pidsFollowers
                        remotes = unionRemotes remotesTeam remotesFollowers
                    for_ pids $ \ pid -> do
                        ibid <- personInbox <$> getJust pid
                        ibiid <- insert $ InboxItem True
                        insert_ $ InboxItemLocal ibid obiid ibiid
                    return remotes

undoC
    :: ShrIdent
    -> TextHtml
    -> Audience URIMode
    -> Undo URIMode
    -> Handler (Either Text OutboxItemId)
undoC shrUser summary audience undo@(Undo luObject) = runExceptT $ do
    (localRecips, remoteRecips) <- do
        mrecips <- parseAudience audience
        fromMaybeE mrecips "Follow with no recipients"
    federation <- asksSite $ appFederation . appSettings
    unless (federation || null remoteRecips) $
        throwE "Federation disabled, but remote recipients specified"
    route <-
        fromMaybeE
            (decodeRouteLocal luObject)
            "Undo object isn't a valid route"
    obiidOriginal <- case route of
        SharerOutboxItemR shr obikhid
            | shr == shrUser ->
                decodeKeyHashidE obikhid "Undo object invalid obikhid"
        _ -> throwE "Undo object isn't actor's outbox item route"
    let dont = Authority "dont-do.any-forwarding" Nothing
    (obiidUndo, doc, remotesHttp) <- runDBExcept $ do
        Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser
        obi <- do
            mobi <- lift $ get obiidOriginal
            fromMaybeE mobi "Undo object obiid doesn't exist in DB"
        unless (outboxItemOutbox obi == personOutbox personAuthor) $
            throwE "Undo object obiid belongs to different actor"
        lift $ do
            deleteFollow obiidOriginal
            deleteFollowRemote obiidOriginal
            deleteFollowRemoteRequest obiidOriginal
            let obidAuthor = personOutbox personAuthor
            (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor
            let ibidAuthor = personInbox personAuthor
                fsidAuthor = personFollowers personAuthor
            knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips
            remotesHttp <- deliverRemoteDB' dont obiidUndo remoteRecips knownRemotes
            return (obiidUndo, doc, remotesHttp)
    lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidUndo doc remotesHttp
    return obiidUndo
    where
    getAuthor shr = do
        sid <- getKeyBy404 $ UniqueSharer shr
        getBy404 $ UniquePersonIdent sid
    deleteFollow obiid = do
        mfid <- getKeyBy $ UniqueFollowFollow obiid
        traverse_ delete mfid
    deleteFollowRemote obiid = do
        mfrid <- getKeyBy $ UniqueFollowRemoteFollow obiid
        traverse_ delete mfrid
    deleteFollowRemoteRequest obiid = do
        mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid
        traverse_ delete mfrrid
    insertUndoToOutbox obid = do
        hLocal <- asksSite siteInstanceHost
        encodeRouteLocal <- getEncodeRouteLocal
        let activity mluAct = Doc hLocal Activity
                { activityId       = mluAct
                , activityActor    = encodeRouteLocal $ SharerR shrUser
                , activitySummary  = Just summary
                , activityAudience = audience
                , activitySpecific = UndoActivity undo
                }
        now <- liftIO getCurrentTime
        obiid <- insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  =
                persistJSONObjectFromDoc $ activity Nothing
            , outboxItemPublished = now
            }
        obikhid <- encodeKeyHashid obiid
        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
            doc = activity $ Just luAct
        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
        return (obiid, doc, luAct)

pushCommitsC
    :: (Entity Person, Sharer)
    -> Html
    -> Push URIMode
    -> ShrIdent
    -> RpIdent
    -> Handler (Either Text OutboxItemId)
pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
    let dont = Authority "dont-do.any-forwarding" Nothing
    (obiid, doc, remotesHttp) <- runDBExcept $ do
        (obiid, doc) <- lift $ insertToOutbox
        remoteRecips <- lift $ deliverLocal obiid
        federation <- getsYesod $ appFederation . appSettings
        unless (federation || null remoteRecips) $
            throwE "Federation disabled but remote collection members found"
        remotesHttp <- lift $ deliverRemoteDB' dont obiid [] remoteRecips
        return (obiid, doc, remotesHttp)
    lift $ forkWorker "pushCommitsC: async HTTP delivery" $ deliverRemoteHttp dont obiid doc remotesHttp
    return obiid
    where
    insertToOutbox :: AppDB (OutboxItemId, Doc Activity URIMode)
    insertToOutbox = do
        host <- getsYesod siteInstanceHost
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRouteHome <- getEncodeRouteHome
        let shrUser = sharerIdent sharer
            aud = map encodeRouteHome
                    [ SharerFollowersR shrUser
                    , RepoR shrRepo rpRepo
                    , RepoTeamR shrRepo rpRepo
                    , RepoFollowersR shrRepo rpRepo
                    ]
            activity mluAct = Doc host Activity
                { activityId       = mluAct
                , activityActor    = encodeRouteLocal $ SharerR shrUser
                , activitySummary  =
                    Just $ TextHtml $ TL.toStrict $ renderHtml summary
                , activityAudience = Audience aud [] [] [] [] []
                , activitySpecific = PushActivity push
                }
        now <- liftIO getCurrentTime
        obiid <- insert OutboxItem
            { outboxItemOutbox    = personOutbox $ entityVal eperson
            , outboxItemActivity  = persistJSONObjectFromDoc $ activity Nothing
            , outboxItemPublished = now
            }
        obikhid <- encodeKeyHashid obiid
        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
            doc = activity $ Just luAct
        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
        return (obiid, doc)

    deliverLocal
        :: OutboxItemId
        -> AppDB
            [ ( (InstanceId, Host)
              , NonEmpty RemoteRecipient
              )
            ]
    deliverLocal obiid = do
        let pidAuthor = entityKey eperson
        (sidRepo, repo) <- do
            sid <- getKeyBy404 $ UniqueSharer shrRepo
            r <- getValBy404 $ UniqueRepo rpRepo sid
            return (sid, r)
        (pids, remotes) <- do
            (repoPids, repoRemotes) <- getRepoTeam sidRepo
            (pfsPids, pfsRemotes) <-
                getFollowers $ personFollowers $ entityVal eperson
            (rfsPids, rfsRemotes) <- getFollowers $ repoFollowers repo
            return
                ( L.delete pidAuthor $ union repoPids $ union pfsPids rfsPids
                , repoRemotes `unionRemotes` pfsRemotes `unionRemotes` rfsRemotes
                )
        ibiid <- insert $ InboxItem False
        insert_ $ InboxItemLocal (repoInbox repo) obiid ibiid
        for_ pids $ \ pid -> do
            ibid <- personInbox <$> getJust pid
            ibiid <- insert $ InboxItem True
            insert_ $ InboxItemLocal ibid obiid ibiid
        return remotes

getFollowersCollection
    :: Route App -> AppDB FollowerSetId -> Handler TypedContent
getFollowersCollection here getFsid = do
    (locals, remotes, l, r) <- runDB $ do
        fsid <- getFsid
        (,,,) <$> do pids <-
                        map (followPerson . entityVal) <$>
                            selectList
                                [FollowTarget ==. fsid, FollowPublic ==. True]
                                []
                     sids <-
                        map (personIdent . entityVal) <$>
                            selectList [PersonId <-. pids] []
                     map (sharerIdent . entityVal) <$>
                        selectList [SharerId <-. sids] []
              <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
                        E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
                        E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
                        E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
                        E.where_
                            $     rf E.^. RemoteFollowTarget E.==. E.val fsid
                            E.&&. rf E.^. RemoteFollowPublic E.==. E.val True
                        return
                            ( i E.^. InstanceHost
                            , ro E.^. RemoteObjectIdent
                            )
              <*> count [FollowTarget ==. fsid]
              <*> count [RemoteFollowTarget ==. fsid]

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let followersAP = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ l + r
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . SharerR) locals ++
                map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
            }
    provideHtmlAndAP followersAP $ redirectToPrettyJSON here