Create Note outbox handler, not in use yet

I wrote a function handleOutboxNote that's supposed to do the whole outbox POST
handler process. There's an outbox item table in the DB now, I adapted things
in various source files. Ticket comment federation work is still in progress.

config/models

@@ -43,6 +43,11 @@ Person
     UniquePersonLogin login
     UniquePersonEmail email
 
+OutboxItem
+    person    PersonId
+    activity  PersistActivity
+    published UTCTime
+
 VerifKey
     ident    LocalURI
     instance InstanceId
@@ -225,10 +230,11 @@ TicketClaimRequest
 Discussion
 
 RemoteDiscussion
-    sharer   RemoteSharerId
+    actor         RemoteSharerId Maybe
-    instance InstanceId
+    instance      InstanceId
-    ident    LocalURI
+    ident         LocalURI
-    discuss  DiscussionId
+    discuss       DiscussionId
+    unlinkedActor FedURI         Maybe
 
     UniqueRemoteDiscussionIdent instance ident
     UniqueRemoteDiscussion discuss
@@ -240,8 +246,9 @@ Message
     root    DiscussionId
 
 LocalMessage
-    author  PersonId
+    author         PersonId
-    rest    MessageId
+    rest           MessageId
+    unlinkedParent FedURI    Maybe
 
     UniqueLocalMessage rest
 

config/routes

@@ -26,7 +26,6 @@
 
 /publish                                     PublishR          GET
 /inbox                                       InboxR            GET POST
-/outbox                                      OutboxR           GET POST
 /akey1                                       ActorKey1R        GET
 /akey2                                       ActorKey2R        GET
 
@@ -51,6 +50,8 @@
 
 /s                                           SharersR             GET
 /s/#ShrIdent                                 SharerR              GET
+/s/#ShrIdent/outbox                          OutboxR              GET POST
+/s/#ShrIdent/outbox/#Text                    OutboxItemR          GET
 
 /p                                           PeopleR              GET
 

migrations/2019_03_19.model

@@ -1,19 +1,26 @@
 RemoteRawObject
-    content  PersistJSONObject
+    content  PersistJSONValue
     received UTCTime
 
+OutboxItem
+    person    PersonId
+    activity  PersistJSONValue
+    published UTCTime
+
 RemoteDiscussion
-    sharer   RemoteSharerId
+    actor         RemoteSharerId Maybe
-    instance InstanceId
+    instance      InstanceId
-    ident    Text
+    ident         Text
-    discuss  DiscussionId
+    discuss       DiscussionId
+    unlinkedActor Text           Maybe
 
     UniqueRemoteDiscussionIdent instance ident
     UniqueRemoteDiscussion discuss
 
 LocalMessage
-    author  PersonId
+    author         PersonId
-    rest    MessageId
+    rest           MessageId
+    unlinkedParent Text      Maybe
 
     UniqueLocalMessage rest
 

src/Data/Either/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,6 +16,7 @@
 module Data.Either.Local
     ( maybeRight
     , maybeLeft
+    , requireEither
     )
 where
 
@@ -28,3 +29,9 @@ maybeRight (Right b) = Just b
 maybeLeft :: Either a b -> Maybe a
 maybeLeft (Left a)  = Just a
 maybeLeft (Right _) = Nothing
+
+requireEither :: Maybe a -> Maybe b -> Either Bool (Either a b)
+requireEither Nothing  Nothing   = Left False
+requireEither (Just _) (Just _)  = Left True
+requireEither (Just x) Nothing   = Right $ Left x
+requireEither Nothing  (Just y)  = Right $ Right y

src/Vervis/Federation.hs

@@ -15,40 +15,143 @@
 
 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 (logWarn)
+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).
@@ -57,10 +160,10 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
     case specific of
         CreateActivity (Create note) -> do
             result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note
-            return $
+            case result of
-                case result of
+                Left e -> logWarn e >> return ("Create Note: " <> e, False)
-                    Left e -> (e, False)
+                Right (uNew, luTicket) ->
-                    Right (uNew, luTicket) ->
+                    return
                         ( T.concat
                             [ "Inserted remote comment <"
                             , renderFedURI uNew
@@ -72,73 +175,20 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
                         )
         _ -> return ("Unsupported activity type", False)
     where
-    toSingleton v =
-        case V.toList v of
-            [x] -> Just x
-            _   -> Nothing
-    --result t = logWarn t >> return (t, False)
-    done t = logWarn t >> throwE t
-    fromMaybeE Nothing  t = done t
-    fromMaybeE (Just x) _ = return x
-    --hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
-    hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
     verifyLocal fu t = do
         let (h, lu) = f2l fu
         local <- hostIsLocal h
         if local
             then return lu
-            else done t
+            else throwE t
-    parseAudience (Audience to bto cc bcc aud) =
+    parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
-        case toSingleton to of
+    parseParent luContext uParent = do
-            Just fu
-                | V.null bto && V.null cc && V.null bcc && V.null aud ->
-                    return fu
-            _ -> done "Got a Create Note with a not-just-single-to audience"
-    local2route = parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
-        where
-        noFrag lu =
-            if T.null $ luriFragment lu
-                then Just lu
-                else Nothing
-    parseProject uRecip = do
-        let (hRecip, luRecip) = f2l uRecip
-        local <- hostIsLocal hRecip
-        unless local $ done "Got Create Note with non-local recipient"
-        route <- case local2route luRecip of
-            Nothing -> done "Got Create Note with recipient that isn't a valid route"
-            Just r -> return r
-        case route of
-            ProjectR shr prj -> return (shr, prj)
-            _ -> done "Got Create Note with non-project recipient"
-    parseTicket project luContext = do
-        route <- case local2route luContext of
-            Nothing -> done "Got Create Note with context that isn't a valid route"
-            Just r -> return r
-        case route of
-            TicketR shr prj num ->
-                if (shr, prj) == project
-                    then return num
-                    else done "Got Create Note under ticket that doesn't belong to the recipient project"
-            _ -> done "Got Create Note with non-ticket context"
-    parseParent luContext ticket uParent = do
         let (hParent, luParent) = f2l uParent
         local <- hostIsLocal hParent
         if local
             then if luParent == luContext
                 then return Nothing
-                else do
+                else prependError "Local parent" $ Just . Left <$> parseComment luParent
-                    route <- case local2route luParent of
-                        Nothing -> done "Got Create Note with local non-route parent"
-                        Just r -> return r
-                    case route of
-                        TicketMessageR shr prj num hid -> do
-                            unless (ticket == (shr, prj, num)) $
-                                done "Got Create Note with local parent not under the same ticket as the context"
-                            decodeHid <- getsYesod appHashidDecode
-                            case toSqlKey <$> decodeHid hid of
-                                Nothing -> done "Got Create Note non-existent ticket message parent hashid"
-                                Just k  -> return $ Just $ Left k
-                        _ -> done "Got Create Note with local non-ticket-message parent"
             else return $ Just $ Right (hParent, luParent)
     selectOrphans uNote did op =
         E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
@@ -150,20 +200,21 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
     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
-            uRecip <- parseAudience audience
+            (hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience"
-            parseProject uRecip
+            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 (shr, prj, num) uParent
+            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 ->
-                done $
+                throwE $
                     "Got a Create Note with a note ID we already have, \
                     \RemoteMessageId " <> T.pack (show rmid)
             mdid <- lift $ runMaybeT $ do
@@ -172,33 +223,23 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
                 t <- MaybeT $ getValBy $ UniqueTicket jid num
                 return $ ticketDiscuss t
             did <- fromMaybeE mdid "Got Create Note on non-existent ticket"
-            meparent <-
+            meparent <- for mparent $ \ parent ->
-                case mparent of
+                case parent of
-                    Nothing -> return Nothing
+                    Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid
-                    Just parent ->
+                    Right (hParent, luParent) -> do
-                        case parent of
+                        mrm <- lift $ runMaybeT $ do
-                            Left lmid -> do
+                            iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
-                                mlm <- lift $ get lmid
+                            MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
-                                lm <- fromMaybeE mlm "Got Create Note replying to non-existent local message, no such lmid"
+                        case mrm of
-                                let mid = localMessageRest lm
+                            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) $
-                                    done "Got Create Note replying to non-existent local message, lmid not under the context ticket"
+                                    throwE "Got Create Note replying to remote message which belongs to a different discussion"
-                                return $ Just $ Left mid
+                                return $ Left mid
-                            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 $ Just $ Right $ l2f hParent luParent
-                                    Just rm -> do
-                                        let mid = remoteMessageRest rm
-                                        m <- lift $ getJust mid
-                                        unless (messageRoot m == did) $
-                                            done "Got Create Note replying to remote message which belongs to a different discussion"
-                                        return $ Just $ Left mid
             now <- liftIO getCurrentTime
             rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now
             mid <- lift $ insert Message
@@ -247,3 +288,323 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
                     , " 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)

src/Vervis/Foundation.hs

@@ -210,7 +210,7 @@ instance Yesod App where
             | a == resendVerifyR           -> personFromResendForm
         (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
 
-        (OutboxR                   , True) -> personAny
+        (OutboxR shr               , True) -> person shr
 
         (GroupsR                   , True) -> personAny
         (GroupNewR                 , _   ) -> personAny
@@ -767,7 +767,8 @@ instance YesodBreadcrumbs App where
 
         PublishR                         -> ("Publish", Just HomeR)
         InboxR                           -> ("Inbox", Just HomeR)
-        OutboxR                          -> ("Outbox", Just HomeR)
+        OutboxR shr                      -> ("Outbox", Just $ SharerR shr)
+        OutboxItemR shr hid              -> ("#" <> hid, Just $ OutboxR shr)
         ActorKey1R                       -> ("Actor Key 1", Nothing)
         ActorKey2R                       -> ("Actor Key 2", Nothing)
 

src/Vervis/Handler/Discussion.hs

@@ -125,12 +125,24 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
             (Nothing, Just rd) -> do
                 let iid = remoteDiscussionInstance rd
                 i <- getJust iid
-                rs <- getJust $ remoteDiscussionSharer rd
+                let hInstance = instanceHost i
-                unless (iid == remoteSharerInstance rs) $
+                mrs <- traverse getJust $ remoteDiscussionActor rd
-                    fail "RemoteDiscussion and its sharer on different hosts"
+                let muActor = f2l <$> remoteDiscussionUnlinkedActor rd
+                luActor <-
+                    case (mrs, muActor) of
+                        (Nothing, Nothing) -> fail "RemoteDiscussion actor and unlinkedActor both unset"
+                        (Just _, Just _) -> fail "RemoteDiscussion actor and unlinkedActor both set"
+                        (Just rs, Nothing) -> do
+                            unless (iid == remoteSharerInstance rs) $
+                                fail "RemoteDiscussion and its actor on different hosts"
+                            return $ remoteSharerIdent rs
+                        (Nothing, Just (h, lu)) -> do
+                            unless (hInstance == h) $
+                                fail "RemoteDiscussion and its unlinked actor on different hosts"
+                            return lu
                 return
-                    ( l2f (instanceHost i) (remoteSharerIdent rs)
+                    ( l2f hInstance luActor
-                    , l2f (instanceHost i) (remoteDiscussionIdent rd)
+                    , l2f hInstance (remoteDiscussionIdent rd)
                     )
     muParent <- for (messageParent m) $ \ midParent -> do
         mlocal <- getBy $ UniqueLocalMessage midParent
@@ -186,8 +198,9 @@ postTopReply replyP after getdid = do
                     , messageRoot    = did
                     }
                 lmid <- insert LocalMessage
-                    { localMessageAuthor = author
+                    { localMessageAuthor         = author
-                    , localMessageRest   = mid
+                    , localMessageRest           = mid
+                    , localMessageUnlinkedParent = Nothing
                     }
                 return lmid
             setMessage "Message submitted."
@@ -237,8 +250,9 @@ postReply replyG replyP after getdid mid = do
                     , messageRoot    = did
                     }
                 lmid <- insert LocalMessage
-                    { localMessageAuthor = author
+                    { localMessageAuthor         = author
-                    , localMessageRest   = mid
+                    , localMessageRest           = mid
+                    , localMessageUnlinkedParent = Nothing
                     }
                 return lmid
             setMessage "Message submitted."

src/Vervis/Handler/Inbox.hs

@@ -18,6 +18,7 @@ module Vervis.Handler.Inbox
     , postInboxR
     , getPublishR
     , getOutboxR
+    , getOutboxItemR
     , postOutboxR
     , getActorKey1R
     , getActorKey2R
@@ -212,40 +213,45 @@ activityForm = renderDivs $ (,,,)
     defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
     defmsg = "Hi! I'm testing federation. Can you see my message? :)"
 
-activityWidget :: Widget -> Enctype -> Widget
+activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
-activityWidget widget enctype =
+activityWidget shr widget enctype =
     [whamlet|
         <p>
           This is a federation test page. Provide a recepient actor URI and
           message text, and a Create activity creating a new Note will be sent
           to the destination server.
-        <form method=POST action=@{OutboxR} enctype=#{enctype}>
+        <form method=POST action=@{OutboxR shr} enctype=#{enctype}>
           ^{widget}
           <input type=submit>
     |]
 
+getUserShrIdent :: Handler ShrIdent
+getUserShrIdent = do
+    Entity _ p <- requireVerifiedAuth
+    s <- runDB $ get404 $ personIdent p
+    return $ sharerIdent s
+
 getPublishR :: Handler Html
 getPublishR = do
+    shr <- getUserShrIdent
     ((_result, widget), enctype) <- runFormPost activityForm
-    defaultLayout $ activityWidget widget enctype
+    defaultLayout $ activityWidget shr widget enctype
 
-getOutboxR :: Handler TypedContent
+getOutboxR :: ShrIdent -> Handler TypedContent
 getOutboxR = error "Not implemented yet"
 
-postOutboxR :: Handler Html
+getOutboxItemR :: ShrIdent -> Text -> Handler TypedContent
-postOutboxR = do
+getOutboxItemR = error "Not implemented yet"
+
+postOutboxR :: ShrIdent -> Handler Html
+postOutboxR shr = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
     ((result, widget), enctype) <- runFormPost activityForm
-    defaultLayout $ activityWidget widget enctype
     case result of
         FormMissing -> setMessage "Field(s) missing"
         FormFailure _l -> setMessage "Invalid input, see below"
         FormSuccess (to, mparent, mcontext, msg) -> do
-            shr <- do
-                Entity _pid person <- requireVerifiedAuth
-                sharer <- runDB $ get404 $ personIdent person
-                return $ sharerIdent sharer
             renderUrl <- getUrlRender
             route2uri <- getEncodeRouteFed
             now <- liftIO getCurrentTime
@@ -282,7 +288,7 @@ postOutboxR = do
                 case eres' of
                     Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
                     Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
-    defaultLayout $ activityWidget widget enctype
+    defaultLayout $ activityWidget shr widget enctype
     where
     fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI)
     fetchInboxURI manager h lto = do

src/Vervis/Migration/Model.hs

@@ -40,7 +40,7 @@ import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Database.Persist.Class (EntityField)
-import Database.Persist.JSON (PersistJSONObject)
+import Database.Persist.JSON (PersistJSONValue)
 import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Sql (SqlBackend)

src/Vervis/Model.hs

@@ -30,6 +30,7 @@ import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
 import Database.Persist.JSON
 import Network.FedURI (FedURI, LocalURI)
+import Web.ActivityPub (Doc, Activity)
 
 import Vervis.Model.Group
 import Vervis.Model.Ident
@@ -39,6 +40,8 @@ import Vervis.Model.Ticket
 import Vervis.Model.TH
 import Vervis.Model.Workflow
 
+type PersistActivity = PersistJSON (Doc Activity)
+
 makeEntities $(modelFile "config/models")
 
 instance PersistUserCredentials Person where

src/Vervis/RemoteActorStore.hs

@@ -83,10 +83,14 @@ stateTVar var f = do
     return a
 
 withHostLock
-    :: YesodRemoteActorStore site
+    :: ( MonadHandler m
+       , MonadUnliftIO m
+       , HandlerSite m ~ site
+       , YesodRemoteActorStore site
+       )
     => Text
-    -> HandlerFor site a
+    -> m a
-    -> HandlerFor site a
+    -> m a
 withHostLock host action = do
     InstanceMutex tvar <- getsYesod siteInstanceMutex
     mvar <- liftIO $ do

src/Yesod/FedURI.hs

@@ -16,14 +16,20 @@
 module Yesod.FedURI
     ( getEncodeRouteFed
     , getEncodeRouteLocal
+    , decodeRouteLocal
     )
 where
 
 import Prelude
 
+import Control.Monad
+import Data.Text.Encoding
+import Network.HTTP.Types.URI
 import Yesod.Core
 import Yesod.Core.Handler
 
+import qualified Data.Text as T
+
 import Network.FedURI
 
 getEncodeRouteFed :: MonadHandler m => m (Route (HandlerSite m) -> FedURI)
@@ -36,3 +42,12 @@ getEncodeRouteFed = toFed <$> getUrlRender
 
 getEncodeRouteLocal :: MonadHandler m => m (Route (HandlerSite m) -> LocalURI)
 getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteFed
+
+decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
+decodeRouteLocal =
+    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
+    where
+    noFrag lu =
+        if T.null $ luriFragment lu
+            then Just lu
+            else Nothing