vervis/src/Vervis/ActivityPub.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.ActivityPub
    ( hostIsLocal
    , verifyHostLocal
    , parseContext
    , parseParent
    , runDBExcept
    , getLocalParentMessageId
    , getPersonOrGroupId
    , getTicketTeam
    , getProjectTeam
    , getRepoTeam
    , getFollowers
    , unionRemotes
    , insertMany'
    , isInstanceErrorP
    , isInstanceErrorG
    , deliverHttp
    , deliverHttpBL
    , deliverRemoteDB
    , deliverRemoteHTTP
    , checkForward
    , parseTarget
    --, checkDep
    , getProjectAndDeps
    , deliverRemoteDB'
    , deliverRemoteHttp
    , serveCommit
    , deliverLocal
    , RemoteRecipient (..)
    , deliverLocal'
    )
where

import Control.Applicative
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
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.Bifunctor
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Client
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.Core.Handler
import Yesod.Persist.Core

import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List.NonEmpty as NE
import qualified Data.List as L
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 Yesod.HttpSignature

import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Author (..), Ticket)
import Yesod.ActivityPub
import Yesod.MonadSite
import Yesod.FedURI
import Yesod.Hashids

import qualified Web.ActivityPub as AP

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

import Vervis.ActivityPub.Recipient
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Patch
import Vervis.RemoteActorStore
import Vervis.Settings
import Vervis.Time
import Vervis.Widget.Repo
import Vervis.Widget.Sharer

hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings

verifyHostLocal
    :: (MonadSite m, SiteEnv m ~ App)
    => Host -> Text -> ExceptT Text m ()
verifyHostLocal h t = do
    local <- hostIsLocal h
    unless local $ throwE t

parseContext
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
    -> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI)
parseContext uContext = do
    let ObjURI hContext luContext = uContext
    local <- hostIsLocal hContext
    if local
        then Left <$> do
            route <- case decodeRouteLocal luContext of
                Nothing -> throwE "Local context isn't a valid route"
                Just r -> return r
            case route of
                ProjectTicketR shr prj num -> return (shr, prj, num)
                _ -> throwE "Local context isn't a ticket route"
        else return $ Right uContext

parseParent
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
    -> ExceptT Text m (Either (ShrIdent, LocalMessageId) FedURI)
parseParent uParent = do
    let ObjURI hParent luParent = uParent
    local <- hostIsLocal hParent
    if local
        then Left <$> do
            route <- case decodeRouteLocal luParent of
                Nothing -> throwE "Local parent isn't a valid route"
                Just r -> return r
            case route of
                MessageR shr lmkhid ->
                    (shr,) <$>
                        decodeKeyHashidE lmkhid
                            "Local parent has non-existent message \
                            \hashid"
                _ -> throwE "Local parent isn't a message route"
        else return $ Right uParent

newtype FedError = FedError Text deriving Show

instance Exception FedError

runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a
runDBExcept action = do
    result <-
        lift $ try $ runSiteDB $ either abort return =<< runExceptT action
    case result of
        Left (FedError t) -> throwE t
        Right r -> return r
    where
    abort = liftIO . throwIO . FedError

getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do
    mlm <- lift $ get lmid
    lm <- fromMaybeE mlm "Local parent: no such lmid"
    p <- lift $ getJust $ localMessageAuthor lm
    s <- lift $ getJust $ personIdent p
    unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
    let mid = localMessageRest lm
    m <- lift $ getJust mid
    unless (messageRoot m == did) $
        throwE "Local parent belongs to a different discussion"
    return mid

getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
getPersonOrGroupId sid = do
    mpid <- getKeyBy $ UniquePersonIdent sid
    mgid <- getKeyBy $ UniqueGroup sid
    requireEitherM mpid mgid
        "Found sharer that is neither person nor group"
        "Found sharer that is both person and group"

getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
getTicketTeam sid = do
    id_ <- getPersonOrGroupId sid
    (,[]) <$> case id_ of
        Left pid -> return [pid]
        Right gid ->
            map (groupMemberPerson . entityVal) <$>
                selectList [GroupMemberGroup ==. gid] [Asc GroupMemberPerson]

getProjectTeam = getTicketTeam

getRepoTeam = getTicketTeam

getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
getFollowers fsid = do
    local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
    remote <- 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.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
        return
            ( i E.^. InstanceId
            , i E.^. InstanceHost
            , ra E.^. RemoteActorId
            , ro E.^. RemoteObjectIdent
            , ra E.^. RemoteActorInbox
            , ra E.^. RemoteActorErrorSince
            )
    return
        ( map (followPerson . entityVal) local
        , groupRemotes $
            map (\ (E.Value iid, E.Value h, E.Value raid, E.Value luActor, E.Value luInbox, E.Value msince) ->
                    (iid, h, raid, luActor, luInbox, msince)
                )
                remote
        )
    where
    groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
        where
        toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), RemoteRecipient raid luA luI ms)

unionRemotes
    :: [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
unionRemotes = unionGroupsOrdWith fst remoteRecipientActor

insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
    where
    zip' x y =
        case nonEmpty y of
            Just y' | length x == length y' -> NE.zip x y'
            _ -> error "insertMany' returned different length!"

isInstanceErrorHttp (InvalidUrlException _ _)    = False
isInstanceErrorHttp (HttpExceptionRequest _ hec) =
    case hec of
        ResponseTimeout -> True
        ConnectionTimeout -> True
        InternalException se ->
            case fromException se of
                Just (HandshakeFailed _) -> True
                _ -> False
        _ -> False

isInstanceErrorP (APPostErrorSig _)   = False
isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he

isInstanceErrorG Nothing  = False
isInstanceErrorG (Just e) =
    case e of
        APGetErrorHTTP he -> isInstanceErrorHttp he
        APGetErrorJSON _ -> False
        APGetErrorContentType _ -> False

deliverHttp
    :: (MonadSite m, SiteEnv m ~ App)
    => Doc Activity URIMode
    -> Maybe LocalURI
    -> Host
    -> LocalURI
    -> m (Either APPostError (Response ()))
deliverHttp doc mfwd h luInbox =
    deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc

deliverHttpBL
    :: (MonadSite m, SiteEnv m ~ App)
    => BL.ByteString
    -> Maybe LocalURI
    -> Host
    -> LocalURI
    -> m (Either APPostError (Response ()))
deliverHttpBL body mfwd h luInbox =
    deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body

deliverRemoteDB
    :: BL.ByteString
    -> RemoteActivityId
    -> ProjectId
    -> ByteString
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> AppDB
        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body ractid jid sig recips = do
    let body' = BL.toStrict body
        deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
    fetchedDeliv <- for recips $ \ (i, rs) ->
        (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
    return $ takeNoError4 fetchedDeliv
    where
    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
    takeNoError4 = takeNoError noError
        where
        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing

deliverRemoteHTTP
    :: UTCTime
    -> ShrIdent
    -> PrjIdent
    -> BL.ByteString
    -> ByteString
    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
    -> Handler ()
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
    let deliver h inbox =
            let sender = ProjectR shrRecip prjRecip
            in  forwardActivity (ObjURI h inbox) sig sender body
    traverse_ (fork . deliverFetched deliver now) fetched
    where
    fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
        let (raid, _luActor, luInbox, fwid) = r
        e <- deliver h luInbox
        let e' = case e of
                    Left err ->
                        if isInstanceErrorP err
                            then Nothing
                            else Just False
                    Right _resp -> Just True
        case e' of
            Nothing -> runDB $ do
                let recips' = NE.toList recips
                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
            Just success -> do
                runDB $
                    if success
                        then delete fwid
                        else do
                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                            update fwid [ForwardingRunning =. False]
                for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
                    fork $ do
                        e <- deliver h luInbox
                        runDB $
                            case e of
                                Left _err -> do
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update fwid [ForwardingRunning =. False]
                                Right _resp -> delete fwid

checkForward shrRecip prjRecip = join <$> do
    let hSig = hForwardingSignature
    msig <- maybeHeader hSig
    for msig $ \ sig -> do
        _proof <- withExceptT (T.pack . displayException) $ ExceptT $
            let requires = [hDigest, hActivityPubForwarder]
            in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
        forwarder <- requireHeader hActivityPubForwarder
        renderUrl <- getUrlRender
        let project = renderUrl $ ProjectR shrRecip prjRecip
        return $
            if forwarder == encodeUtf8 project
                then Just sig
                else Nothing
    where
    maybeHeader n = do
        let n' = decodeUtf8 $ CI.original n
        hs <- lookupHeaders n
        case hs of
            [] -> return Nothing
            [h] -> return $ Just h
            _ -> throwE $ n' <> " multiple headers found"
    requireHeader n = do
        let n' = decodeUtf8 $ CI.original n
        mh <- maybeHeader n
        case mh of
            Nothing -> throwE $ n' <> " header not found"
            Just h -> return h

parseTarget u = do
    let ObjURI h lu = u
    (shr, prj) <- parseProject lu
    return (h, shr, prj)
    where
    parseProject lu = do
        route <- case decodeRouteLocal lu of
            Nothing -> throwE "Expected project route, got invalid route"
            Just r -> return r
        case route of
            ProjectR shr prj -> return (shr, prj)
            _ -> throwE "Expected project route, got non-project route"

{-
checkDep hProject shrProject prjProject u = do
    let (h, lu) = f2l u
    unless (h == hProject) $
        throwE "Dep belongs to different host"
    (shrTicket, prjTicket, num) <- parseTicket lu
    unless (shrTicket == shrProject) $
        throwE "Dep belongs to different sharer under same host"
    unless (prjTicket == prjProject) $
        throwE "Dep belongs to different project under same sharer"
    return num
    where
    parseTicket lu = do
        route <- case decodeRouteLocal lu of
            Nothing -> throwE "Expected ticket route, got invalid route"
            Just r -> return r
        case route of
            TicketR shr prj num -> return (shr, prj, num)
            _ -> throwE "Expected ticket route, got non-ticket route"
-}

getProjectAndDeps shr prj {-deps-} = do
    msid <- lift $ getKeyBy $ UniqueSharer shr
    sid <- fromMaybeE msid "Offer target: no such local sharer"
    mej <- lift $ getBy $ UniqueProject prj sid
    Entity jid j <- fromMaybeE mej "Offer target: no such local project"
    {-
    tids <- for deps $ \ dep -> do
        mtid <- lift $ getKeyBy $ UniqueTicket jid dep
        fromMaybeE mtid "Local dep: No such ticket number in DB"
    -}
    return (sid, jid, projectInbox j, projectFollowers j{-, tids-})

data Recip
    = RecipRA (Entity RemoteActor)
    | RecipURA (Entity UnfetchedRemoteActor)
    | RecipRC (Entity RemoteCollection)

deliverRemoteDB'
    :: Host
    -> OutboxItemId
    -> [(Host, NonEmpty LocalURI)]
    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
    -> AppDB
        ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        )
deliverRemoteDB' hContext obid recips known = do
    recips' <- for recips $ \ (h, lus) -> do
        let lus' = NE.nub lus
        (iid, inew) <- idAndNew <$> insertBy' (Instance h)
        if inew
            then return ((iid, h), (Nothing, Nothing, Just lus'))
            else do
                es <- for lus' $ \ lu -> do
                    ma <- runMaybeT $ do
                        Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu
                        recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid)
                             <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid)
                             <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid)
                        return (ro, recip)
                    return $
                        case ma of
                            Nothing -> Just $ Left lu
                            Just (ro, r) ->
                                case r of
                                    RecipRA (Entity raid ra) -> Just $ Right $ Left $ RemoteRecipient raid (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra)
                                    RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
                                    RecipRC _ -> Nothing
                let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
                    (fetched, unfetched) = partitionEithers newKnown
                return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown))
    let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips'
        unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips'
        stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
        allFetched = unionRemotes known moreKnown
    fetchedDeliv <- for allFetched $ \ (i, rs) ->
        let fwd = snd i == hContext
        in  (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> Delivery raid obid fwd $ isNothing msince) rs
    unfetchedDeliv <- for unfetched $ \ (i, rs) ->
        let fwd = snd i == hContext
        in  (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
    unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
        -- TODO maybe for URA insertion we should do insertUnique?
        ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus
        rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros
        let fwd = snd i == hContext
        (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
    return
        ( takeNoError4 fetchedDeliv
        , takeNoError3 unfetchedDeliv
        , map
            (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk))
            unknownDeliv
        )
    where
    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
    takeNoError3 = takeNoError noError
        where
        noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
        noError ((_ , _ , Just _ ), _  ) = Nothing
    takeNoError4 = takeNoError noError
        where
        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing

deliverRemoteHttp
    :: Host
    -> OutboxItemId
    -> Doc Activity URIMode
    -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        )
    -> Worker ()
deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
    logDebug' "Starting"
    let deliver fwd h inbox = do
            let fwd' = if h == hContext then Just fwd else Nothing
            (isJust fwd',) <$> deliverHttp doc fwd' h inbox
    now <- liftIO getCurrentTime
    logDebug' $
        "Launching fetched " <> showHosts fetched
    traverse_ (fork . deliverFetched deliver now) fetched
    logDebug' $
        "Launching unfetched " <> showHosts unfetched
    traverse_ (fork . deliverUnfetched deliver now) unfetched
    logDebug' $
        "Launching unknown " <> showHosts unknown
    traverse_ (fork . deliverUnfetched deliver now) unknown
    logDebug' "Done (async delivery may still be running)"
    where
    showHosts = T.pack . show . map (renderAuthority . snd . fst)
    logDebug' t = logDebug $ prefix <> t
        where
        prefix =
            T.concat
                [ "Outbox POST handler: deliverRemoteHttp obid#"
                , T.pack $ show $ fromSqlKey obid
                , ": "
                ]
    fork = forkWorker "Outbox POST handler: HTTP delivery"
    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
        logDebug'' "Starting"
        let (raid, luActor, luInbox, dlid) = r
        (_, e) <- deliver luActor h luInbox
        e' <- case e of
                Left err -> do
                    logError $ T.concat
                        [ "Outbox DL delivery #", T.pack $ show dlid
                        , " error for <", renderObjURI $ ObjURI h luActor
                        , ">: ",  T.pack $ displayException err
                        ]
                    return $
                        if isInstanceErrorP err
                            then Nothing
                            else Just False
                Right _resp -> return $ Just True
        case e' of
            Nothing -> runSiteDB $ do
                let recips' = NE.toList recips
                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
            Just success -> do
                runSiteDB $
                    if success
                        then delete dlid
                        else do
                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                            update dlid [DeliveryRunning =. False]
                for_ rs $ \ (raid, luActor, luInbox, dlid) ->
                    fork $ do
                        (_, e) <- deliver luActor h luInbox
                        runSiteDB $
                            case e of
                                Left err -> do
                                    logError $ T.concat
                                        [ "Outbox DL delivery #", T.pack $ show dlid
                                        , " error for <", renderObjURI $ ObjURI h luActor
                                        , ">: ",  T.pack $ displayException err
                                        ]
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update dlid [DeliveryRunning =. False]
                                Right _resp -> delete dlid
        where
        logDebug'' t = logDebug' $ T.concat ["deliverFetched ", renderAuthority h, t]
    deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
        logDebug'' "Starting"
        let (uraid, luActor, udlid) = r
        e <- fetchRemoteActor iid h luActor
        let e' = case e of
                    Left err -> Just Nothing
                    Right (Left err) ->
                        if isInstanceErrorG err
                            then Nothing
                            else Just Nothing
                    Right (Right mera) -> Just $ Just mera
        case e' of
            Nothing -> runSiteDB $ do
                let recips' = NE.toList recips
                updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
            Just mmera -> do
                for_ rs $ \ (uraid, luActor, udlid) ->
                    fork $ do
                        e <- fetchRemoteActor iid h luActor
                        case e of
                            Right (Right mera) ->
                                case mera of
                                    Nothing -> runSiteDB $ delete udlid
                                    Just (Entity raid ra) -> do
                                        (fwd, e') <- deliver luActor h $ remoteActorInbox ra
                                        runSiteDB $
                                            case e' of
                                                Left _ -> do
                                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                                    delete udlid
                                                    insert_ $ Delivery raid obid fwd False
                                                Right _ -> delete udlid
                            _ -> runSiteDB $ do
                                updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                                update udlid [UnlinkedDeliveryRunning =. False]
                case mmera of
                    Nothing -> runSiteDB $ do
                        updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                        update udlid [UnlinkedDeliveryRunning =. False]
                    Just mera ->
                        case mera of
                            Nothing -> runSiteDB $ delete udlid
                            Just (Entity raid ra) -> do
                                (fwd, e'') <- deliver luActor h $ remoteActorInbox ra
                                runSiteDB $
                                    case e'' of
                                        Left _ -> do
                                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                            delete udlid
                                            insert_ $ Delivery raid obid fwd False
                                        Right _ -> delete udlid
        where
        logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t]

serveCommit
    :: ShrIdent
    -> RpIdent
    -> Text
    -> Patch
    -> [Text]
    -> Handler TypedContent
serveCommit shr rp ref patch parents = do
    (msharerWritten, msharerCommitted) <- runDB $ (,)
        <$> getSharer (patchWritten patch)
        <*> maybe (pure Nothing) getSharer (patchCommitted patch)
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let (author, written) = patchWritten patch
        mcommitter = patchCommitted patch
        patchAP = AP.Commit
            { commitId          =
                encodeRouteLocal $ RepoPatchR shr rp ref
            , commitRepository  = encodeRouteLocal $ RepoR shr rp
            , commitAuthor      =
                makeAuthor encodeRouteHome msharerWritten author
            , commitCommitter   =
                makeAuthor encodeRouteHome msharerCommitted . fst <$>
                    mcommitter
            , commitTitle       = patchTitle patch
            , commitHash        = Hash $ encodeUtf8 ref
            , commitDescription =
                let desc = patchDescription patch
                in  if T.null desc
                        then Nothing
                        else Just desc
            , commitWritten     = written
            , commitCommitted   = snd <$> patchCommitted patch
            }
    provideHtmlAndAP patchAP $
        let number = zip ([1..] :: [Int])
        in  $(widgetFile "repo/patch")
    where
    getSharer (author, _time) = do
        mp <- getBy $ UniquePersonEmail $ authorEmail author
        for mp $ \ (Entity _ person) -> getJust $ personIdent person
    makeAuthor _ Nothing author = Left AP.Author
        { AP.authorName  = authorName author
        , AP.authorEmail = authorEmail author
        }
    makeAuthor encodeRouteHome (Just sharer) _ =
        Right $ encodeRouteHome $ SharerR $ sharerIdent sharer

-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If the author's follower collection is listed, insert activity to the
--   local members and return the remote members
-- * Ignore other collections
deliverLocal
    :: ShrIdent
    -> InboxId
    -> FollowerSetId
    -> OutboxItemId
    -> LocalRecipientSet
    -> AppDB
        [ ( (InstanceId, Host)
          , NonEmpty RemoteRecipient
          )
        ]
deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True
    where
    sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [] [])]

data RemoteRecipient = RemoteRecipient
    { remoteRecipientActor      :: RemoteActorId
    , remoteRecipientId         :: LocalURI
    , remoteRecipientInbox      :: LocalURI
    , remoteRecipientErrorSince :: Maybe UTCTime
    }

-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return
--   the remote members
deliverLocal'
    :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
    -> LocalActor
    -> InboxId
    -> OutboxItemId
    -> LocalRecipientSet
    -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid recips = do
    ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
    ibidsOther <- concat <$> traverse getOtherInboxes recips

    (ibidsFollowers, remotesFollowers) <- do
        fsidsSharer <- getSharerFollowerSets recips
        fsidsOther <- concat <$> traverse getOtherFollowerSets recips
        let fsids = fsidsSharer ++ fsidsOther
        (,) <$> getLocalFollowers fsids <*> getRemoteFollowers fsids

    ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips

    let ibids = L.delete ibidAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther
    ibiids <- insertMany $ replicate (length ibids) $ InboxItem True
    insertMany_ $
        map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid)
            (zip ibids ibiids)
    return remotesFollowers
    where
    getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId]
    getSharerInboxes sharers = do
        let shrs =
                [shr | (shr, s) <- sharers
                     , localRecipSharer $ localRecipSharerDirect s
                ]
        sids <- selectKeysList [SharerIdent <-. shrs] []
        map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox]

    getOtherInboxes :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId]
    getOtherInboxes (shr, LocalSharerRelatedSet _ _ projects repos) = do
        msid <- getKeyBy $ UniqueSharer shr
        case msid of
            Nothing -> return []
            Just sid ->
                (++)
                    <$> getProjectInboxes sid projects
                    <*> getRepoInboxes sid repos
        where
        getProjectInboxes sid projects =
            let prjs =
                    [prj | (prj, j) <- projects
                         , localRecipProject $ localRecipProjectDirect j
                    ]
            in  map (projectInbox . entityVal) <$>
                    selectList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
        getRepoInboxes sid repos =
            let rps =
                    [rp | (rp, r) <- repos
                        , localRecipRepo $ localRecipRepoDirect r
                    ]
            in  map (repoInbox . entityVal) <$>
                    selectList [RepoSharer ==. sid, RepoIdent <-. rps] []

    getSharerFollowerSets :: LocalRecipientSet -> AppDB [FollowerSetId]
    getSharerFollowerSets sharers = do
        let shrs =
                [shr | (shr, s) <- sharers
                     , let d = localRecipSharerDirect s
                       in  localRecipSharerFollowers d &&
                           (localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
                ]
        sids <- selectKeysList [SharerIdent <-. shrs] []
        map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []

    getOtherFollowerSets :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [FollowerSetId]
    getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets projects repos) = do
        msid <- getKeyBy $ UniqueSharer shr
        case msid of
            Nothing -> return []
            Just sid -> do
                mpid <- getKeyBy $ UniquePersonIdent sid
                (\ t j r -> map E.unValue t ++ j ++ r)
                    <$> case mpid of
                            Nothing -> pure []
                            Just pid -> getSharerTicketFollowerSets pid tickets
                    <*> getProjectFollowerSets sid projects
                    <*> getRepoFollowerSets sid repos
        where
        getSharerTicketFollowerSets pid tickets = do
            let talkhids =
                    [talkhid | (talkhid, t) <- tickets
                             , localRecipTicketFollowers t
                    ]
            talids <- catMaybes <$> traverse decodeKeyHashid talkhids
            E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do
                E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
                E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId
                E.where_ $
                    tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
                    E.isNothing (tup E.?. TicketUnderProjectId)
                return $ lt E.^. LocalTicketFollowers
        getProjectFollowerSets sid projects = do
            let prjsJ =
                    [prj | (prj, j) <- projects
                         , let d = localRecipProjectDirect j
                           in  localRecipProjectFollowers d &&
                               (localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
                    ]
            fsidsJ <-
                map (projectFollowers . entityVal) <$>
                    selectList [ProjectSharer ==. sid, ProjectIdent <-. prjsJ] []
            let prjsT =
                    if requireOwner
                        then
                            [ (prj, localRecipProjectTicketRelated j)
                                | (prj, j) <- projects
                                , localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
                            ]
                        else
                            map (second localRecipProjectTicketRelated) projects
            fsidssT <- for prjsT $ \ (prj, tickets) -> do
                mjid <- getKeyBy $ UniqueProject prj sid
                case mjid of
                    Nothing -> return []
                    Just jid -> getTicketFollowerSets jid tickets
            return $ fsidsJ ++ map E.unValue (concat fsidssT)
            where
            getTicketFollowerSets jid tickets = do
                let ltkhids =
                        [ltkhid | (ltkhid, t) <- tickets
                                , localRecipTicketFollowers t
                        ]
                ltids <- catMaybes <$> traverse decodeKeyHashid ltkhids
                E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tpl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do
                    E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tar E.?. TicketAuthorRemoteTicket
                    E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tup E.?. TicketUnderProjectProject
                    E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
                    E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId
                    E.where_ $
                        tpl E.^. TicketProjectLocalProject E.==. E.val jid E.&&.
                        E.not_
                            ( E.isNothing (tup E.?. TicketUnderProjectId) E.&&.
                              E.isNothing (tar E.?. TicketAuthorRemoteId)
                            )
                    return $ lt E.^. LocalTicketFollowers
        getRepoFollowerSets sid repos =
            let rps =
                    [rp | (rp, r) <- repos
                        , let d = localRecipRepoDirect r
                          in  localRecipRepoFollowers d &&
                              (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
                    ]
            in  map (repoFollowers . entityVal) <$>
                    selectList [RepoSharer ==. sid, RepoIdent <-. rps] []

    getLocalFollowers :: [FollowerSetId] -> AppDB [InboxId]
    getLocalFollowers fsids = do
        pids <-
            map (followPerson . entityVal) <$>
                selectList [FollowTarget <-. fsids] []
        map (personInbox . entityVal) <$>
            selectList [PersonId <-. pids] [Asc PersonInbox]

    getRemoteFollowers :: [FollowerSetId] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
    getRemoteFollowers fsids =
        fmap groupRemotes $
            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.in_` E.valList fsids
                E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
                return
                    ( i E.^. InstanceId
                    , i E.^. InstanceHost
                    , ra E.^. RemoteActorId
                    , ro E.^. RemoteObjectIdent
                    , ra E.^. RemoteActorInbox
                    , ra E.^. RemoteActorErrorSince
                    )
        where
        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
            where
            toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)

    getTeams :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId]
    getTeams (shr, LocalSharerRelatedSet _ tickets projects repos) = do
        msid <- getKeyBy $ UniqueSharer shr
        case msid of
            Nothing -> return []
            Just sid -> do
                mpid <- getKeyBy $ UniquePersonIdent sid
                (\ t j r -> t `LO.union` j `LO.union` r)
                    <$> case mpid of
                            Nothing -> pure []
                            Just pid -> getSharerTicketTeams pid tickets
                    <*> getProjectTeams sid projects
                    <*> getRepoTeams sid repos
        where
        getSharerTicketTeams _pid _tickets = pure []
        getProjectTeams sid projects = do
            let prjs =
                    [prj | (prj, LocalProjectRelatedSet d ts) <- projects
                         , (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
                           (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
                    ]
            jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
            pids <- map (projectCollabPerson . entityVal) <$> selectList [ProjectCollabProject <-. jids] []
            map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]
        getRepoTeams sid repos = do
            let rps =
                    [rp | (rp, r) <- repos
                        , let d = localRecipRepoDirect r
                          in  localRecipRepoTeam d &&
                              (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
                    ]
            rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
            pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []
            map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]