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)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson (Object)
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
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.Types.Header
import Network.HTTP.Types.URI
import Yesod.Core hiding (logError, logWarn, logInfo)
import Yesod.Persist.Core

import qualified Data.Text as T
import qualified Data.Vector as V
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 Data.Either.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
            | V.null bto && V.null cc && V.null bcc && V.null aud ->
                return fu
        _ -> throwE t
    where
    toSingleton v =
        case V.toList 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 -> do
            decodeHid <- getsYesod appHashidDecode
            case toSqlKey <$> decodeHid hid of
                Nothing -> throwE "Non-existent local message hashid"
                Just k  -> return (shr, k)
        _ -> 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
        encodeHid <- getsYesod appHashidEncode
        let activity luAct = Doc host Activity
                { activityId       = luAct
                , activityActor    = luAttrib
                , activityAudience = aud
                , activitySpecific = CreateActivity Create
                    { createObject = Note
                        { noteId        = Just $ route2local $ MessageR shrUser $ encodeHid $ fromSqlKey lmid
                        , 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
            }
        let luAct = route2local $ OutboxItemR shrUser $ encodeHid $ fromSqlKey obid
            doc = activity luAct
        update obid [OutboxItemActivity =. PersistJSON doc]
        return (lmid, doc)