vervis/src/Vervis/Federation.hs

{- This file is part of Vervis.
 -
 - Written in 2019 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.Federation
    ( handleInboxActivity
    , handleOutboxNote
    )
where

import Prelude

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 Data.Aeson (Object)
import Data.Bifunctor
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy)
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 Data.Tuple
import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy)
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo)
import Yesod.Persist.Core

import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E

import Network.HTTP.Signature

import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids

import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Database.Persist.Local

import Vervis.ActorKey
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings

hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings

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

parseAudience :: Monad m => Audience -> Text -> ExceptT Text m FedURI
parseAudience (Audience to bto cc bcc aud) t =
    case toSingleton to of
        Just fu
            | null bto && null cc && null bcc && null aud ->
                return fu
        _ -> throwE t
    where
    toSingleton v =
        case v of
            [x] -> Just x
            _   -> Nothing

fromMaybeE :: Monad m => Maybe a -> Text -> ExceptT Text m a
fromMaybeE Nothing  t = throwE t
fromMaybeE (Just x) _ = return x

requireEitherM
    :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
requireEitherM mx my f t =
    case requireEither mx my of
        Left b    -> liftIO $ throwIO $ userError $ if b then t else f
        Right exy -> return exy

prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do
    r <- lift $ runExceptT a
    case r of
        Left e -> throwE $ t <> ": " <> e
        Right x -> return x

parseProject :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent)
parseProject luRecip = do
    route <- case decodeRouteLocal luRecip of
        Nothing -> throwE "Got Create Note with recipient that isn't a valid route"
        Just r -> return r
    case route of
        ProjectR shr prj -> return (shr, prj)
        _ -> throwE "Got Create Note with non-project recipient"

parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m Int
parseTicket project luContext = do
    route <- case decodeRouteLocal luContext of
        Nothing -> throwE "Local context isn't a valid route"
        Just r -> return r
    case route of
        TicketR shr prj num ->
            if (shr, prj) == project
                then return num
                else throwE "Local context ticket doesn't belong to the recipient project"
        _ -> throwE "Local context isn't a ticket route"

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"

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

-- | Handle an activity that came to our inbox. Return a description of what we
-- did, and whether we stored the activity or not (so that we can decide
-- whether to log it for debugging).
handleInboxActivity :: Object -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
    case specific of
        CreateActivity (Create note) -> do
            result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note
            case result of
                Left e -> logWarn e >> return ("Create Note: " <> e, False)
                Right (uNew, luTicket) ->
                    return
                        ( T.concat
                            [ "Inserted remote comment <"
                            , renderFedURI uNew
                            , "> into discussion of local ticket <"
                            , luriPath luTicket
                            , ">."
                            ]
                        , True
                        )
        _ -> return ("Unsupported activity type", False)
    where
    verifyLocal fu t = do
        let (h, lu) = f2l fu
        local <- hostIsLocal h
        if local
            then return lu
            else throwE t
    parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
    parseParent luContext uParent = do
        let (hParent, luParent) = f2l uParent
        local <- hostIsLocal hParent
        if local
            then if luParent == luContext
                then return Nothing
                else prependError "Local parent" $ Just . Left <$> parseComment luParent
            else return $ Just $ Right (hParent, luParent)
    selectOrphans uNote did op =
        E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
            E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
            E.where_ $
                rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
                m E.^. MessageRoot `op` E.val did
            return (rm E.^. RemoteMessageId, m E.^. MessageId)
    handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do
        luNote <- fromMaybeE mluNote "Got Create Note without note id"
        (shr, prj) <- do
            (hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience"
            verifyHostLocal hRecip "Non-local recipient"
            parseProject luRecip
        luContext <- do
            uContext <- fromMaybeE muContext "Got a Create Note without context"
            verifyLocal uContext "Got a Create Note with non-local context"
        num <- parseTicket (shr, prj) luContext
        mparent <- do
            uParent <- fromMaybeE muParent "Got a Create Note without inReplyTo"
            parseParent luContext uParent
        published <- fromMaybeE mpublished "Got Create Note without 'published' field"
        ExceptT $ runDB $ runExceptT $ do
            mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
            for_ mrmid $ \ rmid ->
                throwE $
                    "Got a Create Note with a note ID we already have, \
                    \RemoteMessageId " <> T.pack (show rmid)
            mdid <- lift $ runMaybeT $ do
                sid <- MaybeT $ getKeyBy $ UniqueSharer shr
                jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
                t <- MaybeT $ getValBy $ UniqueTicket jid num
                return $ ticketDiscuss t
            did <- fromMaybeE mdid "Got Create Note on non-existent ticket"
            meparent <- for mparent $ \ parent ->
                case parent of
                    Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid
                    Right (hParent, luParent) -> do
                        mrm <- lift $ runMaybeT $ do
                            iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                            MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                        case mrm of
                            Nothing -> do
                                logWarn "Got Create Note replying to a remote message we don't have"
                                return $ Right $ l2f hParent luParent
                            Just rm -> do
                                let mid = remoteMessageRest rm
                                m <- lift $ getJust mid
                                unless (messageRoot m == did) $
                                    throwE "Got Create Note replying to remote message which belongs to a different discussion"
                                return $ Left mid
            now <- liftIO getCurrentTime
            rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now
            mid <- lift $ insert Message
                { messageCreated = published
                , messageContent = content
                , messageParent  =
                    case meparent of
                        Just (Left midParent) -> Just midParent
                        _                     -> Nothing
                , messageRoot    = did
                }
            lift $ insert_ RemoteMessage
                { remoteMessageAuthor     = rsidActor
                , remoteMessageInstance   = iidActor
                , remoteMessageIdent      = luNote
                , remoteMessageRest       = mid
                , remoteMessageRaw        = rroid
                , remoteMessageLostParent =
                    case meparent of
                        Just (Right uParent) -> Just uParent
                        _                    -> Nothing
                }
            -- Now we need to check orphans. These are RemoteMessages whose
            -- associated Message doesn't have a parent, but the original Note
            -- does have an inReplyTo which isn't the same as the context. It's
            -- possible that this new activity we just got, this new Note, is
            -- exactly that lost parent.
            let uNote = l2f hActor luNote
            related <- lift $ selectOrphans uNote did (E.==.)
            lift $ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
                logWarn $ T.concat
                    [ "Found parent for related orphan RemoteMessage #"
                    , T.pack (show rmidOrphan)
                    , ", setting its parent now to Message #"
                    , T.pack (show mid)
                    ]
                update rmidOrphan [RemoteMessageLostParent =. Nothing]
                update midOrphan [MessageParent =. Just mid]
            unrelated <- lift $ selectOrphans uNote did (E.!=.)
            for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
                logWarn $ T.concat
                    [ "Found parent for unrelated orphan RemoteMessage #"
                    , T.pack (show rmidOrphan)
                    , ", NOT settings its parent to Message #"
                    , T.pack (show mid)
                    , " because they have different DiscussionId!"
                    ]
            return (uNote, luContext)

{-
-- | 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'.
handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
    verifyHostLocal host "Attributed to non-local actor"
    verifyNothing mluNote "Note specifies an id"
    verifyNothing mpublished "Note specifies published"
    uContext <- fromMaybeE muContext "Note without context"
    uRecip <- parseAudience aud "Note has not-just-single-to audience"
    recipContextParent <- parseRecipContextParent uRecip uContext muParent

    (lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
        (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
        case recipContextParent of
            (mparent, Left (shr, prj, num)) -> do
                mdid <- lift $ runMaybeT $ do
                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
                    jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
                    t <- MaybeT $ getValBy $ UniqueTicket jid num
                    return $ ticketDiscuss t
                did <- fromMaybeE mdid "Context: No such local ticket"
                mmidParent <- for mparent $ \ parent ->
                    case parent of
                        Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
                        Right (hParent, luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                            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
                let meparent = Left <$> mmidParent
                (lmid, _doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
                return (lmid, Nothing)
            (mparent, Right (hRecip, luRecip, luContext)) -> do
                (did, rdid, rdnew, mluInbox) <- do
                    miid <- lift $ getKeyBy $ UniqueInstance hRecip
                    erd <-
                        case miid of
                            Just iid -> findExistingRemoteDiscussion iid hRecip luRecip luContext
                            Nothing -> return Nothing
                    case erd of
                        Just (d, rd, minb) -> return (d, rd, False, minb)
                        Nothing -> ExceptT $ withHostLock hRecip $ runExceptT $ storeRemoteDiscussion miid hRecip luRecip luContext
                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 (hParent, luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                            case mrm of
                                Nothing -> return $ Right $ l2f hParent luParent
                                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
                (lmid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
                return (lmid, Just (doc, hRecip, maybe (Right (luRecip, rdid)) Left mluInbox))
    let handleDeliverError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
    lift $ for_ mdeliver $ \ (doc, hRecip, einb) -> forkHandler handleDeliverError $ do
        uInbox <-
            case einb of
                Left luInbox -> return $ l2f hRecip luInbox
                Right (luRecip, rdid) -> do
                    mluInbox <- runDB $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
                        rs <- MaybeT $ getValBy $ UniqueRemoteSharer iid luRecip
                        return $ remoteSharerInbox rs
                    case mluInbox of
                        Just luInbox -> return $ l2f hRecip luInbox
                        Nothing -> do
                            manager <- getsYesod appHttpManager
                            eactor <- fetchAPID manager actorId hRecip luRecip
                            case eactor of
                                Left s -> fail $ "Fetched recipient actor: " ++ s
                                Right actor -> withHostLock hRecip $ runDB $ do
                                    iid <- either entityKey id <$> insertBy (Instance hRecip)
                                    let luInbox = actorInbox actor
                                    rsid <- either entityKey id <$> insertBy (RemoteSharer luRecip iid luInbox)
                                    update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing]
                                    return $ l2f hRecip luInbox
        -- TODO based on the httpPostAP usage in postOutboxR
        manager <- getsYesod appHttpManager
        (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
        renderUrl <- getUrlRender
        let (keyID, akey) =
                if new1
                    then (renderUrl ActorKey1R, akey1)
                    else (renderUrl ActorKey2R, akey2)
            sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
            actorID = renderFedURI $ l2f host luAttrib
        eres <- httpPostAP manager uInbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID doc
        case eres of
            Left e -> logError $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
            Right _ -> logInfo $ T.concat
                [ "Successful delivery of <"
                , renderFedURI $ l2f (docHost doc) (activityId $ docValue doc)
                , " to <"
                , renderFedURI uRecip
                , ">"
                ]
    return lmid
    where
    verifyNothing :: Monad m => Maybe a -> Text -> ExceptT Text m ()
    verifyNothing Nothing  _ = return ()
    verifyNothing (Just _) t = throwE t

    verifySameHost
        :: Monad m => Text -> FedURI -> Text -> ExceptT Text m LocalURI
    verifySameHost h fu t = do
        let (h', lu) = f2l fu
        if h == h'
            then return lu
            else throwE t

    parseRecipContextParent
        :: FedURI
        -> FedURI
        -> Maybe FedURI
        -> ExceptT
            Text
            Handler
            ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
            , Either
                (ShrIdent, PrjIdent, Int)
                (Text, LocalURI, LocalURI)
            )
    parseRecipContextParent uRecip uContext muParent = do
        let r@(hRecip, luRecip) = f2l uRecip
        luContext <- verifySameHost hRecip uContext "Recipient and context on different hosts"
        meparent <-
            case muParent of
                Nothing -> return Nothing
                Just uParent ->
                    if uParent == uContext
                        then return Nothing
                        else Just <$> do
                            let (hParent, luParent) = f2l uParent
                            parentLocal <- hostIsLocal hParent
                            if parentLocal
                                then Left <$> parseComment luParent
                                else return $ Right (hParent, luParent)
        local <- hostIsLocal hRecip
        if local
            then do
                (shr, prj) <- parseProject luRecip
                num <- parseTicket (shr, prj) luContext
                return (meparent, Left (shr, prj, num))
            else do
                when (luRecip == luContext) $
                    throwE "Identical recipient and context"
                {-
                mrs <- lift $ runDB $ runMaybeT $ do
                    iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
                    MaybeT $ getBy $ UniqueRemoteSharer iid luRecip
                erecip <-
                    case mrs of
                        Just ers -> return $ Left ers
                        Nothing -> do
                            manager <- getsYesod appHttpManager
                            eactor <- fetchAPID manager actorId hRecip luRecip
                            case eactor of
                                Left s -> throwE $ "Fetched recipient actor: " <> T.pack s
                                Right actor -> return $ Right actor
                -}
                return (meparent, Right (hRecip, luRecip, luContext))

    verifyIsLoggedInUser
        :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, 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, shr)
            else throwE t

    findExistingRemoteDiscussion
        :: InstanceId
        -> Text
        -> LocalURI
        -> LocalURI
        -> ExceptT Text AppDB
            (Maybe (DiscussionId, RemoteDiscussionId, Maybe LocalURI))
    findExistingRemoteDiscussion iid hRecip luRecip luContext = do
        merd <- lift $ getBy $ UniqueRemoteDiscussionIdent iid luContext
        for merd $ \ (Entity rdid rd) -> do
            eactor <-
                requireEitherM
                    (remoteDiscussionActor rd)
                    (remoteDiscussionUnlinkedActor rd)
                    "RemoteDiscussion actor and unlinkedActor both unset"
                    "RemoteDiscussion actor and unlinkedActor both set"
            minb <- case eactor of
                Left rsid -> do
                    rs <- lift $ getJust rsid
                    unless (remoteSharerInstance rs == iid && remoteSharerIdent rs == luRecip) $
                        throwE "Known remote context, but its actor doesn't match the new Note's recipient"
                    return $ Just $ remoteSharerInbox rs
                Right uActor -> do
                    unless (uActor == l2f hRecip luRecip) $
                        throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient"
                    return Nothing
            return (remoteDiscussionDiscuss rd, rdid, minb)

    insertRemoteDiscussion
        :: InstanceId
        -> Bool
        -> Text
        -> LocalURI
        -> LocalURI
        -> AppDB (DiscussionId, RemoteDiscussionId, Maybe LocalURI)
    insertRemoteDiscussion iid inew hRecip luRecip luContext = do
        mrs <-
            if inew
                then return Nothing
                else getBy $ UniqueRemoteSharer iid luRecip
        did <- insert Discussion
        rdid <- insert RemoteDiscussion
            { remoteDiscussionActor         = entityKey <$> mrs
            , remoteDiscussionInstance      = iid
            , remoteDiscussionIdent         = luContext
            , remoteDiscussionDiscuss       = did
            , remoteDiscussionUnlinkedActor =
                case mrs of
                    Nothing -> Just $ l2f hRecip luRecip
                    Just _ -> Nothing
            }
        return (did, rdid, remoteSharerInbox . entityVal <$> mrs)

    storeRemoteDiscussion
        :: Maybe InstanceId
        -> Text
        -> LocalURI
        -> LocalURI
        -> ExceptT Text AppDB
            (DiscussionId, RemoteDiscussionId, Bool, Maybe LocalURI)
    storeRemoteDiscussion miid hRecip luRecip luContext = do
        (iid, inew) <-
            case miid of
                Just i -> return (i, False)
                Nothing -> lift $ idAndNew <$> insertBy (Instance hRecip)
        if inew
            then do
                (did, rdid, minb) <- lift $ insertRemoteDiscussion iid True hRecip luRecip luContext
                return (did, rdid, True, minb)
            else do
                erd <- findExistingRemoteDiscussion iid hRecip luRecip luContext
                case erd of
                    Just (did, rdid, minb) -> return (did, rdid, False, minb)
                    Nothing -> do
                        (did, rdid, minb) <- lift $ insertRemoteDiscussion iid False hRecip luRecip luContext
                        return (did, rdid, True, minb)

    insertMessage
        :: LocalURI
        -> ShrIdent
        -> PersonId
        -> FedURI
        -> DiscussionId
        -> Maybe FedURI
        -> Maybe (Either MessageId FedURI)
        -> Text
        -> AppDB (LocalMessageId, Doc Activity)
    insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
        now <- liftIO getCurrentTime
        mid <- insert Message
            { messageCreated = now
            , messageContent = content
            , messageParent  =
                case meparent of
                    Just (Left midParent) -> Just midParent
                    _                     -> Nothing
            , messageRoot    = did
            }
        lmid <- insert LocalMessage
            { localMessageAuthor         = pid
            , localMessageRest           = mid
            , localMessageUnlinkedParent =
                case meparent of
                    Just (Right uParent) -> Just uParent
                    _                    -> Nothing
            }
        route2local <- getEncodeRouteLocal
        lmhid <- encodeKeyHashid lmid
        let activity luAct = Doc host Activity
                { activityId       = luAct
                , activityActor    = luAttrib
                , activityAudience = aud
                , activitySpecific = CreateActivity Create
                    { createObject = Note
                        { noteId        = Just $ route2local $ MessageR shrUser lmhid
                        , noteAttrib    = luAttrib
                        , noteAudience  = aud
                        , noteReplyTo   = Just $ fromMaybe uContext muParent
                        , noteContext   = Just uContext
                        , notePublished = Just now
                        , noteContent   = content
                        }
                    }
                }
        obid <- insert OutboxItem
            { outboxItemPerson    = pid
            , outboxItemActivity  = PersistJSON $ activity $ LocalURI "" ""
            , outboxItemPublished = now
            }
        obhid <- encodeKeyHashid obid
        let luAct = route2local $ OutboxItemR shrUser obhid
            doc = activity luAct
        update obid [OutboxItemActivity =. PersistJSON doc]
        return (lmid, doc)
-}

data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
    deriving (Eq, Ord)

data LocalProjectRecipient
    = LocalProject
    | LocalTicketRelated Int LocalTicketRecipient
    deriving (Eq, Ord)

data LocalSharerRecipient
    = LocalSharer
    | LocalProjectRelated PrjIdent LocalProjectRecipient
    deriving (Eq, Ord)

data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
    deriving (Eq, Ord)

data LocalTicketRelatedSet
    = OnlyTicketParticipants
    | OnlyTicketTeam
    | BothTicketParticipantsAndTeam

data LocalProjectRelatedSet = LocalProjectRelatedSet
    { localRecipProject       :: Bool
    , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
    }

data LocalSharerRelatedSet = LocalSharerRelatedSet
    { localRecipSharer         :: Bool
    , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
    }

type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]

newtype FedError = FedError Text deriving Show

instance Exception FedError

-- | 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'.
handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
    verifyHostLocal host "Attributed to non-local actor"
    verifyNothing mluNote "Note specifies an id"
    verifyNothing mpublished "Note specifies published"
    uContext <- fromMaybeE muContext "Note without context"
    recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
    (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
    result <- lift $ try $ runDB $ (either abort return =<<) . runExceptT $ do
        (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
        (did, meparent, mcollections) <- case mticket of
            Just (shr, prj, num) -> do
                mt <- lift $ runMaybeT $ do
                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
                    jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
                    t <- MaybeT $ getValBy $ UniqueTicket jid num
                    return (sid, t)
                (sid, t) <- fromMaybeE mt "Context: No such local ticket"
                let did = ticketDiscuss t
                mmidParent <- for mparent $ \ parent ->
                    case parent of
                        Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
                        Right (hParent, luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                            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 (did, Left <$> mmidParent, Just (sid, ticketFollowers t))
            Nothing -> do
                (rd, rdnew) <- do
                    let (hContext, luContext) = f2l uContext
                    miid <- lift $ getKeyBy $ UniqueInstance hContext
                    mrd <-
                        case miid of
                            Just iid -> lift $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
                            Nothing -> return Nothing
                    case mrd of
                        Just rd -> return (rd, False)
                        Nothing -> lift $ withHostLock hContext $ do
                            (iid, inew) <-
                                case miid of
                                    Just i -> return (i, False)
                                    Nothing -> idAndNew <$> insertBy (Instance hContext)
                            if inew
                                then do
                                    did <- insert Discussion
                                    rd <- insertRecord $ RemoteDiscussion iid luContext did
                                    return (rd, True)
                                else do
                                    mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
                                    case mrd of
                                        Just rd -> return (rd, False)
                                        Nothing -> do
                                            did <- insert Discussion
                                            rd <- insertRecord $ RemoteDiscussion iid luContext did
                                            return (rd, True)
                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 (hParent, luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                            case mrm of
                                Nothing -> return $ Right $ l2f hParent luParent
                                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 (did, meparent, Nothing)
        (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
        moreRemotes <- deliverLocal obid localRecips mcollections
        return (lmid, doc, moreRemotes)
    (lmid, doc, moreRemotes) <- case result of
        Left (FedError t) -> throwE t
        Right r -> return r
    -- TODO deliver *async* to remote sharers: remoteRecips and moreRemotes
    --
    -- doc          :: Doc Activity
    -- remoteRecips :: [FedURI]
    -- moreRemotes  :: [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
    return lmid
    where
    verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
    verifyNothing Nothing  _ = return ()
    verifyNothing (Just _) e = throwE e

    concatRecipients :: Audience -> [FedURI]
    concatRecipients (Audience to bto cc bcc gen) = concat [to, bto, cc, bcc, gen]

    nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
    nonEmptyE l e =
        case nonEmpty l of
            Nothing -> throwE e
            Just ne -> return ne

    parseRecipsContextParent
        :: NonEmpty FedURI
        -> FedURI
        -> Maybe FedURI
        -> ExceptT Text Handler
            ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
            , [ShrIdent]
            , Maybe (ShrIdent, PrjIdent, Int)
            , [FedURI]
            )
    parseRecipsContextParent recips uContext muParent = do
        (locals, remotes) <- lift $ splitRecipients recips
        let (localsParsed, localsRest) = parseLocalRecipients locals
        unless (null localsRest) $
            throwE "Note has invalid local recipients"
        let localsSet = groupLocalRecipients localsParsed
            (hContext, luContext) = f2l uContext
        parent <- parseParent uContext muParent
        local <- hostIsLocal hContext
        if local
            then do
                ticket <- parseContextTicket luContext
                shrs <- verifyTicketRecipients ticket localsSet
                return (parent, shrs, Just ticket, remotes)
            else do
                shrs <- verifyOnlySharers localsSet
                return (parent, shrs, Nothing, remotes)
        where
        -- First step: Split into remote and local:
        splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI])
        splitRecipients recips = do
            home <- getsYesod $ appInstanceHost . appSettings
            let (local, remote) = NE.partition ((== home) . furiHost) recips
            return (map (snd . f2l) local, remote)

        -- Parse the local recipients
        parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)])
        parseLocalRecipients = swap . partitionEithers . map decide
            where
            parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
            parseLocalRecipient (ProjectR shr prj) =
                Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
            parseLocalRecipient (TicketParticipantsR shr prj num) =
                Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
            parseLocalRecipient (TicketTeamR shr prj num) =
                Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam
            parseLocalRecipient _ = Nothing
            decide lu =
                case decodeRouteLocal lu of
                    Nothing -> Left $ Left lu
                    Just route ->
                        case parseLocalRecipient route of
                            Nothing -> Left $ Right route
                            Just lr -> Right lr

        -- Group local recipients
        groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet
        groupLocalRecipients
            = map
                ( second
                    $ uncurry LocalSharerRelatedSet
                    . bimap
                        (not . null)
                        ( map
                            ( second
                                $ uncurry LocalProjectRelatedSet
                                . bimap
                                    (not . null)
                                    ( map (second ltrs2ltrs)
                                    . groupWithExtract fst snd
                                    )
                                . partitionEithers
                                . NE.toList
                            )
                        . groupWithExtract fst (lpr2e . snd)
                        )
                    . partitionEithers
                    . NE.toList
                )
            . groupWithExtract
                (\ (LocalSharerRelated shr _) -> shr)
                (\ (LocalSharerRelated _ lsr) -> lsr2e lsr)
            . sort
            where
            lsr2e LocalSharer                   = Left ()
            lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
            lpr2e LocalProject                 = Left ()
            lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
            ltrs2ltrs (LocalTicketParticipants :| l) =
                if LocalTicketTeam `elem` l
                    then BothTicketParticipantsAndTeam
                    else OnlyTicketParticipants
            ltrs2ltrs (LocalTicketTeam :| l) =
                if LocalTicketParticipants `elem` l
                    then BothTicketParticipantsAndTeam
                    else OnlyTicketTeam

        parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
        parseParent _        Nothing        = return Nothing
        parseParent uContext (Just uParent) =
            if uParent == uContext
                then return Nothing
                else Just <$> do
                    let (hParent, luParent) = f2l uParent
                    parentLocal <- hostIsLocal hParent
                    if parentLocal
                        then Left <$> parseComment luParent
                        else return $ Right (hParent, luParent)

        parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
        parseContextTicket luContext = do
            route <- case decodeRouteLocal luContext of
                Nothing -> throwE "Local context isn't a valid route"
                Just r -> return r
            case route of
                TicketR shr prj num -> return (shr, prj, num)
                _ -> throwE "Local context isn't a ticket route"

        atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
        atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing
        atMostSharer e (_  , LocalSharerRelatedSet _ _ ) = throwE e

        verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
        verifyTicketRecipients (shr, prj, num) recips = do
            lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
            (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
            unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
            unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
            (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
            unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
            case ltrSet of
                OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
                OnlyTicketTeam -> throwE "Note ticket team not addressed"
                BothTicketParticipantsAndTeam -> return ()
            let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
                orig = if localRecipSharer lsrSet then Just shr else Nothing
            catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
                where
                verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
                verifySingleton []  t = throwE $ t <> ": expected 1, got 0"
                verifySingleton [x] _ = return x
                verifySingleton l   t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)

        verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
        verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs

    abort :: Text -> AppDB a
    abort = liftIO . throwIO . FedError

    verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, 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, shr)
            else throwE t

    insertMessage
        :: LocalURI
        -> ShrIdent
        -> PersonId
        -> FedURI
        -> DiscussionId
        -> Maybe FedURI
        -> Maybe (Either MessageId FedURI)
        -> Text
        -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
    insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
        now <- liftIO getCurrentTime
        mid <- insert Message
            { messageCreated = now
            , messageContent = content
            , messageParent  =
                case meparent of
                    Just (Left midParent) -> Just midParent
                    _                     -> Nothing
            , messageRoot    = did
            }
        lmid <- insert LocalMessage
            { localMessageAuthor         = pid
            , localMessageRest           = mid
            , localMessageUnlinkedParent =
                case meparent of
                    Just (Right uParent) -> Just uParent
                    _                    -> Nothing
            }
        route2local <- getEncodeRouteLocal
        lmhid <- encodeKeyHashid lmid
        let activity luAct = Doc host Activity
                { activityId       = luAct
                , activityActor    = luAttrib
                , activityAudience = aud
                , activitySpecific = CreateActivity Create
                    { createObject = Note
                        { noteId        = Just $ route2local $ MessageR shrUser lmhid
                        , noteAttrib    = luAttrib
                        , noteAudience  = aud
                        , noteReplyTo   = Just $ fromMaybe uContext muParent
                        , noteContext   = Just uContext
                        , notePublished = Just now
                        , noteContent   = content
                        }
                    }
                }
        obid <- insert OutboxItem
            { outboxItemPerson    = pid
            , outboxItemActivity  = PersistJSON $ activity $ LocalURI "" ""
            , outboxItemPublished = now
            }
        obhid <- encodeKeyHashid obid
        let luAct = route2local $ OutboxItemR shrUser obhid
            doc = activity luAct
        update obid [OutboxItemActivity =. PersistJSON doc]
        return (lmid, obid, doc)

    -- | Merge 2 lists ordered on fst, concatenating snd values when
    -- multiple identical fsts occur. The resulting list is ordered on fst,
    -- and each fst value appears only once.
    --
    -- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
    -- [('a',6), ('b',5), ('c',4)]
    mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
    mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys

    -- Deliver to local recipients. For local users, find in DB and deliver.
    -- For local collections, expand them, deliver to local users, and return a
    -- list of remote actors found in them.
    deliverLocal
        :: OutboxItemId
        -> [ShrIdent]
        -> Maybe (SharerId, FollowerSetId)
        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
    deliverLocal obid recips mticket = do
        recipPids <- traverse getPersonId $ nub recips
        (morePids, remotes) <-
            lift $ case mticket of
                Nothing -> return ([], [])
                Just (sid, fsid) -> do
                    (teamPids, teamRemotes) <- getTicketTeam sid
                    (fsPids, fsRemotes) <- getFollowers fsid
                    return
                        ( union teamPids fsPids
                          -- TODO this is inefficient! The way this combines
                          -- same-host sharer lists is:
                          --
                          --   (1) concatenate them
                          --   (2) nubBy fst to remove duplicates
                          --
                          -- But we have knowledge that:
                          --
                          --   (1) in each of the 2 lists we're combining, each
                          --       instance occurs only once
                          --   (2) in each actor list, each actor occurs only
                          --       once
                          --
                          -- So we can improve this code by:
                          --
                          --   (1) Not assume arbitrary number of consecutive
                          --       repetition of the same instance, we may only
                          --       have repetition if the same instance occurs
                          --       in both lists
                          --   (2) Don't <> the lists, instead apply unionBy or
                          --       something better (unionBy assumes one list
                          --       may have repetition, but removes repetition
                          --       from the other; we know both lists have no
                          --       repetition, can we use that to do this
                          --       faster than unionBy?)
                          --
                          -- Also, if we ask the DB to sort by actor, then in
                          -- the (2) point above, instead of unionBy we can use
                          -- the knowledge the lists are sorted, and apply
                          -- LO.unionBy instead. Or even better, because
                          -- LO.unionBy doesn't assume no repetitions (possibly
                          -- though it still does it the fastest way).
                          --
                          -- So, in mergeConcat, don't start with merging,
                          -- because we lose the knowledge that each list's
                          -- instances aren't repeated. Use a custom merge
                          -- where we can unionBy or LO.unionBy whenever both
                          -- lists have the same instance.
                        , map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat teamRemotes fsRemotes
                        )
        lift $ for_ (union recipPids morePids) $ \ pid -> insert_ $ InboxItemLocal pid obid
        return remotes
        where
        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"
        getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
        getPersonId shr = do
            msid <- lift $ getKeyBy $ UniqueSharer shr
            sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
            id_ <- lift $ getPersonOrGroupId sid
            case id_ of
                Left pid -> return pid
                Right _gid -> throwE "Local Note addresses a local group"
        groupRemotes :: [(InstanceId, Text, RemoteSharerId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]
        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs
            where
            toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu))
        getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
        getTicketTeam sid = do
            id_ <- getPersonOrGroupId sid
            (,[]) <$> case id_ of
                Left pid -> return [pid]
                Right gid ->
                    map (groupMemberPerson . entityVal) <$>
                        selectList [GroupMemberGroup ==. gid] []
        getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))])
        getFollowers fsid = do
            local <- selectList [FollowTarget ==. fsid] []
            remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
                E.on $ rs E.^. RemoteSharerInstance E.==. i E.^. InstanceId
                E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteSharerId
                E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
                E.orderBy [E.asc $ i E.^. InstanceId]
                return
                    ( i E.^. InstanceId
                    , i E.^. InstanceHost
                    , rs E.^. RemoteSharerId
                    , rs E.^. RemoteSharerInbox
                    )
            return
                ( map (followPerson . entityVal) local
                , groupRemotes $
                    map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luInbox) ->
                            (iid, h, rsid, luInbox)
                        )
                        remote
                )

    -- Deliver to a local sharer, if they exist as a user account
    deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
    deliverToLocalSharer obid shr = do
        msid <- lift $ getKeyBy $ UniqueSharer shr
        sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
        mpid <- lift $ getKeyBy $ UniquePersonIdent sid
        mgid <- lift $ getKeyBy $ UniqueGroup sid
        id_ <-
            requireEitherM mpid mgid
                "Found sharer that is neither person nor group"
                "Found sharer that is both person and group"
        case id_ of
            Left pid -> lift $ insert_ $ InboxItemLocal pid obid
            Right _gid -> throwE "Local Note addresses a local group"

    -- TODO NEXT: So far, we have 2 groups of remote actors to handle,
    -- 'allKnown' and 'stillUnknown'. We could be done with DB and proceed to
    -- launch HTTP requests, but we haven't considered something: Some actors
    -- are known to be unreachable:
    --
    --   (1) There are actors we've never reached, for whom there are pending
    --       deliveries
    --   (2) There are actors we already fetched, but for whom there are
    --       pending deliveries because lately their inboxes are unreachable
    --
    -- And this brings us to 2 potential things to do:
    --
    --   (1) Skip the request for some actors, and instead insert a delivery to
    --       the DB
    --   (2) Insert/update reachability records for actors we try to reach but
    --       fail
    --   (3) Insert/update reachability records for actors we suddenly succeed
    --       to reach
    --
    -- So, for each RemoteSharer, we're going to add a field 'errorSince'.
    -- Its type will be Maybe UTCTime, and the meaning is:
    --
    --   - Nothing: We haven't observed the inbox being down
    --   - Just t: The time t denotes a time we couldn't reach the inbox, and
    --             since that time all our following attempts failed too
    --
    -- In this context, inbox error means any result that isn't a 2xx status.
    deliverRemote :: Doc Activity -> [FedURI] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] -> Handler ()
    deliverRemote doc recips known = runDB $ do
        recips' <- for (groupByHost recips) $ \ (h, lus) -> do
            let lus' = NE.nub lus
            (iid, inew) <- idAndNew <$> insertBy' (Instance h)
            if inew
                then return ((iid, h), (Nothing, Just lus'))
                else do
                    es <- for lus' $ \ lu -> do
                        mers <- getBy $ UniqueRemoteSharer iid lu
                        return $
                            case mers of
                                Just (Entity rsid rs) -> Left (rsid, remoteSharerInbox rs)
                                Nothing -> Right lu
                    let (newKnown, unknown) = partitionEithers $ NE.toList es
                    return ((iid, h), (nonEmpty newKnown, nonEmpty unknown))
        let moreKnown = mapMaybe (\ (i, (k, _)) -> (i,) <$> k) recips'
            stillUnknown = mapMaybe (\ (i, (_, u)) -> (i,) <$> u) recips'
            -- ^ [ ( (iid, h) , NonEmpty luActor ) ]
            -- TODO see the earlier TODO about merge, it applies here too
            allKnown = map (second $ NE.nubBy ((==) `on` fst)) $ mergeConcat known moreKnown
            -- ^ [ ( (iid, h) , NonEmpty (rsid, inb) ) ]
        error "TODO CONTINUE"
        where
        groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
        groupByHost = groupAllExtract furiHost (snd . f2l)