S2S: sharerCreateNoteF caches note and does inbox fwd if sharer is ticket owner

config/models

@@ -115,12 +115,23 @@ Forwarding
     recipient   RemoteActorId
     activity    RemoteActivityId
     activityRaw ByteString
-    sender      ProjectId
     signature   ByteString
     running     Bool
 
     UniqueForwarding recipient activity
 
+ForwarderSharer
+    task   ForwardingId
+    sender SharerId
+
+    UniqueForwarderSharer task
+
+ForwarderProject
+    task   ForwardingId
+    sender ProjectId
+
+    UniqueForwarderProject task
+
 VerifKey
     ident    LocalRefURI
     instance InstanceId

migrations/2020_05_12_fwd_sender.model

@@ -0,0 +1,11 @@
+ForwarderSharer
+    task   ForwardingId
+    sender SharerId
+
+    UniqueForwarderSharer task
+
+ForwarderProject
+    task   ForwardingId
+    sender ProjectId
+
+    UniqueForwarderProject task

migrations/2020_05_12_fwd_sender_mig.model

@@ -0,0 +1,21 @@
+RemoteActor
+
+RemoteActivity
+
+Project
+
+Forwarding
+    recipient   RemoteActorId
+    activity    RemoteActivityId
+    activityRaw ByteString
+    sender      ProjectId
+    signature   ByteString
+    running     Bool
+
+    UniqueForwarding recipient activity
+
+ForwarderProject
+    task   ForwardingId
+    sender ProjectId
+
+    UniqueForwarderProject task

src/Data/Tuple/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,8 +16,10 @@
 module Data.Tuple.Local
     ( fst3
     , fst4
+    , fst5
     , thd3
     , fourth4
+    , fourth5
     )
 where
 
@@ -27,8 +29,14 @@ fst3 (x, _, _) = x
 fst4 :: (a, b, c, d) -> a
 fst4 (x, _, _, _) = x
 
+fst5 :: (a, b, c, d, e) -> a
+fst5 (x, _, _, _, _) = x
+
 thd3 :: (a, b, c) -> c
 thd3 (_, _, z) = z
 
 fourth4 :: (a, b, c, d) -> d
 fourth4 (_, _, _, w) = w
+
+fourth5 :: (a, b, c, d, e) -> d
+fourth5 (_, _, _, w, _) = w

src/Vervis/ActivityPub.hs

@@ -32,8 +32,10 @@ module Vervis.ActivityPub
     , isInstanceErrorG
     , deliverHttp
     , deliverHttpBL
-    , deliverRemoteDB
+    , deliverRemoteDB_J
-    , deliverRemoteHTTP
+    , deliverRemoteDB_S
+    , deliverRemoteHTTP_J
+    , deliverRemoteHTTP_S
     , checkForward
     , parseTarget
     --, checkDep
@@ -59,6 +61,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Either
 import Data.Foldable
@@ -312,45 +315,67 @@ deliverHttpBL
 deliverHttpBL body mfwd h luInbox =
     deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
 
-deliverRemoteDB
+deliverRemoteDB_
+    :: PersistRecordBackend fwder SqlBackend
+    => (ForwardingId -> Key sender -> fwder)
+    -> BL.ByteString
+    -> RemoteActivityId
+    -> Key sender
+    -> ByteString
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
+    -> AppDB
+        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
+deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
+    let body' = BL.toStrict body
+        makeFwd (RemoteRecipient raid _ _ msince) =
+            Forwarding raid ractid body' sig (isNothing msince)
+    fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do
+        fwds <- insertMany' makeFwd rs
+        insertMany' (flip makeFwder senderKey . snd) fwds
+    return $ takeNoError5 fetchedDeliv
+    where
+    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+    takeNoError5 = takeNoError noError
+        where
+        noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid)
+        noError ((RemoteRecipient _  _   _   (Just _), _   ), _    ) = Nothing
+
+deliverRemoteDB_J
     :: BL.ByteString
     -> RemoteActivityId
     -> ProjectId
     -> ByteString
     -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
     -> AppDB
-        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
-deliverRemoteDB body ractid jid sig recips = do
+deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject
-    let body' = BL.toStrict body
-        deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
-    fetchedDeliv <- for recips $ \ (i, rs) ->
-        (i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
-    return $ takeNoError4 fetchedDeliv
-    where
-    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
-    takeNoError4 = takeNoError noError
-        where
-        noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
-        noError (RemoteRecipient _  _   _   (Just _), _  ) = Nothing
 
-deliverRemoteHTTP
+deliverRemoteDB_S
-    :: (MonadSite m, SiteEnv m ~ App)
+    :: BL.ByteString
+    -> RemoteActivityId
+    -> SharerId
+    -> ByteString
+    -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
+    -> AppDB
+        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
+deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer
+
+deliverRemoteHTTP'
+    :: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend)
     => UTCTime
-    -> ShrIdent
+    -> LocalActor
-    -> PrjIdent
     -> BL.ByteString
     -> ByteString
-    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
     -> m ()
-deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
+deliverRemoteHTTP' now sender body sig fetched = do
     let deliver h inbox =
-            let sender = ProjectR shrRecip prjRecip
+            forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body
-            in  forwardActivity (ObjURI h inbox) sig sender body
     traverse_ (fork . deliverFetched deliver now) fetched
     where
     fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed"
     deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
-        let (raid, _luActor, luInbox, fwid) = r
+        let (raid, _luActor, luInbox, fwid, forwarderKey) = r
         e <- deliver h luInbox
         let e' = case e of
                     Left err ->
@@ -361,16 +386,18 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
         case e' of
             Nothing -> runSiteDB $ do
                 let recips' = NE.toList recips
-                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
-                updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
+                updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False]
             Just success -> do
                 runSiteDB $
                     if success
-                        then delete fwid
+                        then do
+                            delete forwarderKey
+                            delete fwid
                         else do
                             updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                             update fwid [ForwardingRunning =. False]
-                for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
+                for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) ->
                     fork $ do
                         e <- deliver h luInbox
                         runSiteDB $
@@ -378,9 +405,33 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
                                 Left _err -> do
                                     updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                     update fwid [ForwardingRunning =. False]
-                                Right _resp -> delete fwid
+                                Right _resp -> do
+                                    delete forwarderKey
+                                    delete fwid
 
-checkForward shrRecip prjRecip = join <$> do
+deliverRemoteHTTP_J
+    :: (MonadSite m, SiteEnv m ~ App)
+    => UTCTime
+    -> ShrIdent
+    -> PrjIdent
+    -> BL.ByteString
+    -> ByteString
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
+    -> m ()
+deliverRemoteHTTP_J now shr prj =
+    deliverRemoteHTTP' now $ LocalActorProject shr prj
+
+deliverRemoteHTTP_S
+    :: (MonadSite m, SiteEnv m ~ App)
+    => UTCTime
+    -> ShrIdent
+    -> BL.ByteString
+    -> ByteString
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
+    -> m ()
+deliverRemoteHTTP_S now shr = deliverRemoteHTTP' now $ LocalActorSharer shr
+
+checkForward recip = join <$> do
     let hSig = hForwardingSignature
     msig <- maybeHeader hSig
     for msig $ \ sig -> do
@@ -389,9 +440,8 @@ checkForward shrRecip prjRecip = join <$> do
             in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
         forwarder <- requireHeader hActivityPubForwarder
         renderUrl <- getUrlRender
-        let project = renderUrl $ ProjectR shrRecip prjRecip
         return $
-            if forwarder == encodeUtf8 project
+            if forwarder == encodeUtf8 (renderUrl $ renderLocalActor recip)
                 then Just sig
                 else Nothing
     where

src/Vervis/Federation.hs

@@ -373,6 +373,14 @@ fixRunningDeliveries = do
         , " forwarding deliveries"
         ]
 
+data Fwder = FwderProject ForwarderProjectId | FwderSharer ForwarderSharerId
+
+partitionFwders :: [Fwder] -> ([ForwarderProjectId], [ForwarderSharerId])
+partitionFwders = foldl' f ([], [])
+    where
+    f (js, ss) (FwderProject j) = (j : js, ss)
+    f (js, ss) (FwderSharer s)  = (js    , s : ss)
+
 retryOutboxDelivery :: Worker ()
 retryOutboxDelivery = do
     logInfo "Periodic delivery starting"
@@ -440,9 +448,14 @@ retryOutboxDelivery = do
         let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked
         deleteWhere [DeliveryId <-. linkedOld]
         -- Same for forwarding deliveries, which are always linked
-        forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` j `E.InnerJoin` s) -> do
+        forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` (fwj `E.InnerJoin` j `E.InnerJoin` s) `E.LeftOuterJoin` (fws `E.InnerJoin` s2)) -> do
-            E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
+            E.on $ fws E.?. ForwarderSharerSender E.==. s2 E.?. SharerId
-            E.on $ fw E.^. ForwardingSender E.==. j E.^. ProjectId
+            E.on $ E.just (fw E.^. ForwardingId) E.==. fws E.?. ForwarderSharerTask
+
+            E.on $ j E.?. ProjectSharer E.==. s E.?. SharerId
+            E.on $ fwj E.?. ForwarderProjectSender E.==. j E.?. ProjectId
+            E.on $ E.just (fw E.^. ForwardingId) E.==. fwj E.?. ForwarderProjectTask
+
             E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
             E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
             E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId
@@ -456,12 +469,22 @@ retryOutboxDelivery = do
                 , ra E.^. RemoteActorErrorSince
                 , fw E.^. ForwardingId
                 , fw E.^. ForwardingActivityRaw
-                , j E.^. ProjectIdent
+
-                , s E.^. SharerIdent
+                , fwj E.?. ForwarderProjectId
+                , s E.?. SharerIdent
+                , j E.?. ProjectIdent
+
+                , fws E.?. ForwarderSharerId
+                , s2 E.?. SharerIdent
+
                 , fw E.^. ForwardingSignature
                 )
         let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding
-        deleteWhere [ForwardingId <-. forwardingOld]
+            (fwidsOld, fwdersOld) = unzip forwardingOld
+            (fwjidsOld, fwsidsOld) = partitionFwders fwdersOld
+        deleteWhere [ForwarderProjectId <-. fwjidsOld]
+        deleteWhere [ForwarderSharerId <-. fwsidsOld]
+        deleteWhere [ForwardingId <-. fwidsOld]
         return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew)
     let deliver = deliverHttpBL
     logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
@@ -548,19 +571,44 @@ retryOutboxDelivery = do
         = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
         . groupWithExtractBy ((==) `on` fst) fst snd
     adaptForwarding
-        (E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since, E.Value fwid, E.Value body, E.Value prj, E.Value shr, E.Value sig) =
+        ( E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since
+        , E.Value fwid, E.Value body
+        , E.Value mfwjid, E.Value mprj, E.Value mshr
+        , E.Value mfwsid, E.Value mshr2
+        , E.Value sig
+        ) =
             ( ( (iid, h)
-              , ((raid, inbox), (fwid, BL.fromStrict body, ProjectR shr prj, sig))
+              , ( (raid, inbox)
+                , ( fwid
+                  , BL.fromStrict body
+                  , let project = together3 mfwjid mprj mshr
+                        sharer = together2 mfwsid mshr2
+                    in  case (project, sharer) of
+                            (Just (fwjid, shr, prj), Nothing) ->
+                                (FwderProject fwjid, ProjectR shr prj)
+                            (Nothing, Just (fwsid, shr)) ->
+                                (FwderSharer fwsid, SharerR shr)
+                            _ -> error $ "Non-single fwder for fw#" ++ show fwid
+                  , sig
+                  )
+                )
               )
             , since
             )
-    decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _))), msince) =
+        where
+        together2 (Just x) (Just y) = Just (x, y)
+        together2 Nothing Nothing = Nothing
+        together2 _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
+        together3 (Just x) (Just y) (Just z) = Just (x, y, z)
+        together3 Nothing Nothing Nothing = Nothing
+        together3 _ _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
+    decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, (fwder, _), _))), msince) =
         case msince of
             Nothing -> Right fw
             Just since ->
                 if relevant dropAfter now since
                     then Right fw
-                    else Left fwid
+                    else Left (fwid, fwder)
     groupForwarding
         = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
         . groupWithExtractBy ((==) `on` fst) fst snd
@@ -648,12 +696,16 @@ retryOutboxDelivery = do
             logDebug $
                 "Periodic deliver starting forwarding for inbox " <>
                 renderObjURI (ObjURI h inbox)
-            waitsD <- for delivs $ \ (fwid, body, sender, sig) -> fork $ do
+            waitsD <- for delivs $ \ (fwid, body, (fwder, sender), sig) -> fork $ do
                 e <- forwardActivity (ObjURI h inbox) sig sender body
                 case e of
                     Left _err -> return False
                     Right _resp -> do
-                        runSiteDB $ delete fwid
+                        runSiteDB $ do
+                            case fwder of
+                                FwderProject k -> delete k
+                                FwderSharer k -> delete k
+                            delete fwid
                         return True
             results <- sequence waitsD
             runSiteDB $

src/Vervis/Federation/Discussion.hs

@@ -73,19 +73,21 @@ import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Ticket
 
-sharerCreateNoteF
+-- | Check the note in the remote Create Note activity delivered to us.
-    :: UTCTime
+checkNote
-    -> ShrIdent
+    :: Note URIMode
-    -> RemoteAuthor
+    -> ExceptT Text Handler
-    -> ActivityBody
+        ( LocalURI
-    -> Note URIMode
+        , UTCTime
-    -> ExceptT Text Handler Text
+        , Either NoteContext FedURI
-sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do
+        , Maybe (Either (ShrIdent, LocalMessageId) FedURI)
-    luCreate <-
+        , Text
-        fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
+        , Text
-    _luNote <- fromMaybeE mluNote "Note without note id"
+        )
-    _published <- fromMaybeE mpublished "Note without 'published' field"
+checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do
-    uContext <- fromMaybeE muContext "Note without context"
+    luNote <- fromMaybeE mluNote "Note without note id"
+    published <- fromMaybeE mpub "Note without 'published' field"
+    uContext <- fromMaybeE muCtx "Note without context"
     context <- parseContext uContext
     mparent <-
         case muParent of
@@ -94,44 +96,224 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
                 if uParent == uContext
                     then return Nothing
                     else Just <$> parseParent uParent
-    ExceptT $ runDB $ do
+    return (luNote, published, context, mparent, source, content)
-        personRecip <- do
+
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
+-- | Insert a remote activity delivered to us into our inbox. Return its
-            getValBy404 $ UniquePersonIdent sid
+-- database ID if the activity wasn't already in our inbox.
-        valid <- checkContextParent context mparent
+insertToInbox
-        case valid of
+    :: UTCTime
-            Left e -> return $ Left e
+    -> RemoteAuthor
-            Right _ ->
+    -> ActivityBody
-                Right <$> insertToInbox luCreate (personInbox personRecip)
+    -> InboxId
+    -> LocalURI
+    -> Bool
+    -> AppDB (Maybe RemoteActivityId)
+insertToInbox now author body ibid luCreate unread = do
+    let iidAuthor = remoteAuthorInstance author
+    roid <-
+        either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
+    ractid <- either entityKey id <$> insertBy' RemoteActivity
+        { remoteActivityIdent    = roid
+        , remoteActivityContent  = persistJSONFromBL $ actbBL body
+        , remoteActivityReceived = now
+        }
+    ibiid <- insert $ InboxItem unread
+    new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
+    return $
+        if new
+            then Just ractid
+            else Nothing
+
+-- | Given the parent specified by the Note we received, check if we already
+-- know and have this parent note in the DB, and whether the child and parent
+-- belong to the same discussion root.
+getParent
+    :: DiscussionId
+    -> Either (ShrIdent, LocalMessageId) FedURI
+    -> ExceptT Text AppDB (Either MessageId FedURI)
+getParent did (Left (shr, lmid)) = Left <$> getLocalParentMessageId did shr lmid
+getParent did (Right p@(ObjURI hParent luParent)) = do
+    mrm <- lift $ runMaybeT $ do
+        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
+        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
+    case mrm of
+        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
+        Nothing -> return $ Right p
+
+-- | Insert the new remote comment into the discussion tree. If we didn't have
+-- this comment before, return the database ID of the newly created cached
+-- comment.
+insertToDiscussion
+    :: RemoteAuthor
+    -> LocalURI
+    -> UTCTime
+    -> Text
+    -> Text
+    -> DiscussionId
+    -> Maybe (Either MessageId FedURI)
+    -> RemoteActivityId
+    -> AppDB (Maybe MessageId)
+insertToDiscussion author luNote published source content did meparent ractid = do
+    let iidAuthor = remoteAuthorInstance author
+        raidAuthor = remoteAuthorId author
+    mid <- insert Message
+        { messageCreated = published
+        , messageSource  = source
+        , messageContent = content
+        , messageParent  =
+            case meparent of
+                Just (Left midParent) -> Just midParent
+                _                     -> Nothing
+        , messageRoot    = did
+        }
+    roidNote <-
+        either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
+    mrmid <- insertUnique RemoteMessage
+        { remoteMessageAuthor     = raidAuthor
+        , remoteMessageIdent      = roidNote
+        , remoteMessageRest       = mid
+        , remoteMessageCreate     = ractid
+        , remoteMessageLostParent =
+            case meparent of
+                Just (Right uParent) -> Just uParent
+                _                    -> Nothing
+        }
+    case mrmid of
+        Nothing -> do
+            delete mid
+            return Nothing
+        Just _ -> return $ Just mid
+
+-- | Look for known remote comments in the database, whose parent was unknown
+-- but turns out to be the new comment we just received. Fix that in the
+-- database and log warnings about it.
+updateOrphans
+    :: RemoteAuthor
+    -> LocalURI
+    -> DiscussionId
+    -> MessageId
+    -> AppDB ()
+updateOrphans author luNote did mid = do
+    let hAuthor = objUriAuthority $ remoteAuthorURI author
+        uNote = ObjURI hAuthor luNote
+    related <- selectOrphans uNote (E.==.)
+    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 <- selectOrphans uNote (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!"
+            ]
     where
-    checkContextParent (Left context) mparent = runExceptT $ do
+    selectOrphans uNote op =
-        did <-
+        E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
-            case context of
+            E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
-                NoteContextSharerTicket shr talid -> do
+            E.where_ $
-                    (_, Entity _ lt, _, project) <- do
+                rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
-                        mticket <- lift $ getSharerTicket shr talid
+                m E.^. MessageRoot `op` E.val did
-                        fromMaybeE mticket "Note context no such local sharer-hosted ticket"
+            return (rm E.^. RemoteMessageId, m E.^. MessageId)
-                    return $ localTicketDiscuss lt
+
-                NoteContextProjectTicket shr prj ltid -> do
+sharerCreateNoteF
-                    (_, _, _, Entity _ lt, _, _) <- do
+    :: UTCTime
-                        mticket <- lift $ getProjectTicket shr prj ltid
+    -> ShrIdent
-                        fromMaybeE mticket "Note context no such local project-hosted ticket"
+    -> RemoteAuthor
-                    return $ localTicketDiscuss lt
+    -> ActivityBody
-        for_ mparent $ \ parent ->
+    -> Note URIMode
-            case parent of
+    -> ExceptT Text Handler Text
-                Left (shrP, lmidP) ->
+sharerCreateNoteF now shrRecip author body note = do
-                    void $ getLocalParentMessageId did shrP lmidP
+    luCreate <-
-                Right (ObjURI hParent luParent) -> do
+        fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
-                    mrm <- lift $ runMaybeT $ do
+    (luNote, published, context, mparent, source, content) <- checkNote note
-                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+    (localRecips, _remoteRecips) <- do
-                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
+        mrecips <- parseAudience $ activityAudience $ actbActivity body
-                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
+        fromMaybeE mrecips "Create Note with no recipients"
-                    for_ mrm $ \ rm -> do
+    msig <- checkForward $ LocalActorSharer shrRecip
-                        let mid = remoteMessageRest rm
+    case context of
-                        m <- lift $ getJust mid
+        Right uContext -> runDBExcept $ do
-                        unless (messageRoot m == did) $
+            personRecip <- lift $ do
-                            throwE "Remote parent belongs to a different discussion"
+                sid <- getKeyBy404 $ UniqueSharer shrRecip
-    checkContextParent (Right (ObjURI hContext luContext)) mparent = runExceptT $ do
+                getValBy404 $ UniquePersonIdent sid
+            checkContextParent uContext mparent
+            mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
+            return $
+                case mractid of
+                    Nothing -> "I already have this activity in my inbox, doing nothing"
+                    Just _ -> "Context is remote, so just inserting to my inbox"
+        Left (NoteContextSharerTicket shr talid) -> do
+            mremotesHttp <- runDBExcept $ do
+                (sid, pid, ibid) <- lift getRecip404
+                (Entity _ tal, Entity _ lt, _, _) <- do
+                    mticket <- lift $ getSharerTicket shr talid
+                    fromMaybeE mticket "Context: No such sharer-ticket"
+                if ticketAuthorLocalAuthor tal == pid
+                    then do
+                        mractid <- lift $ insertToInbox now author body ibid luCreate True
+                        case mractid of
+                            Nothing -> return $ Left "Activity already in my inbox"
+                            Just ractid -> do
+                                let did = localTicketDiscuss lt
+                                meparent <- traverse (getParent did) mparent
+                                mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
+                                case mmid of
+                                    Nothing -> return $ Left "I already have this comment, just storing in inbox"
+                                    Just mid -> lift $ do
+                                        updateOrphans author luNote did mid
+                                        case msig of
+                                            Nothing ->
+                                                return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
+                                            Just sig -> Right <$> do
+                                                talkhid <- encodeKeyHashid talid
+                                                let sieve =
+                                                        makeRecipientSet
+                                                            []
+                                                            [ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
+                                                            , LocalPersonCollectionSharerTicketTeam shrRecip talkhid
+                                                            ]
+                                                remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+                                                (sig,) <$> deliverRemoteDB_S (actbBL body) ractid sid sig remoteRecips
+                    else return $ Left "Context is a sharer-ticket of another sharer"
+            case mremotesHttp of
+                Left msg -> return msg
+                Right (sig, remotesHttp) -> do
+                    forkWorker "sharerCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotesHttp
+                    return "Stored to inbox, cached comment, and did inbox forwarding"
+        Left (NoteContextProjectTicket shr prj ltid) -> runDBExcept $ do
+            personRecip <- lift $ do
+                sid <- getKeyBy404 $ UniqueSharer shrRecip
+                getValBy404 $ UniquePersonIdent sid
+            (_, _, _, Entity _ lt, _, _) <- do
+                mticket <- lift $ getProjectTicket shr prj ltid
+                fromMaybeE mticket "Context: No such project-ticket"
+            let did = localTicketDiscuss lt
+            _ <- traverse (getParent did) mparent
+            mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
+            return $
+                case mractid of
+                    Nothing -> "I already have this activity in my inbox, doing nothing"
+                    Just _ -> "Context is a project-ticket, so just inserting to my inbox"
+    where
+    getRecip404 = do
+        sid <- getKeyBy404 $ UniqueSharer shrRecip
+        Entity pid p <- getBy404 $ UniquePersonIdent sid
+        return (sid, pid, personInbox p)
+    checkContextParent (ObjURI hContext luContext) mparent = do
         mdid <- lift $ runMaybeT $ do
             iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
             roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
@@ -153,21 +335,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
                         did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
                         unless (messageRoot m == did) $
                             throwE "Remote parent belongs to a different discussion"
-    insertToInbox luCreate ibidRecip = do
-        let iidAuthor = remoteAuthorInstance author
-        roid <-
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
-        let jsonObj = persistJSONFromBL $ actbBL body
-            ract = RemoteActivity roid jsonObj now
-        ractid <- either entityKey id <$> insertBy' ract
-        ibiid <- insert $ InboxItem True
-        mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
-        let recip = shr2text shrRecip
-        case mibrid of
-            Nothing -> do
-                delete ibiid
-                return $ "Activity already exists in inbox of /s/" <> recip
-            Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
 
 projectCreateNoteF
     :: UTCTime
@@ -177,24 +344,14 @@ projectCreateNoteF
     -> ActivityBody
     -> Note URIMode
     -> ExceptT Text Handler Text
-projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
+projectCreateNoteF now shrRecip prjRecip author body note = do
     luCreate <-
         fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
-    luNote <- fromMaybeE mluNote "Note without note id"
+    (luNote, published, context, mparent, source, content) <- checkNote note
-    published <- fromMaybeE mpub "Note without 'published' field"
-    uContext <- fromMaybeE muCtx "Note without context"
-    context <- parseContext uContext
-    mparent <-
-        case muParent of
-            Nothing -> return Nothing
-            Just uParent ->
-                if uParent == uContext
-                    then return Nothing
-                    else Just <$> parseParent uParent
     (localRecips, _remoteRecips) <- do
         mrecips <- parseAudience $ activityAudience $ actbActivity body
         fromMaybeE mrecips "Create Note with no recipients"
-    msig <- checkForward shrRecip prjRecip
+    msig <- checkForward $ LocalActorProject shrRecip prjRecip
     case context of
         Right _ -> return "Not using; context isn't local"
         Left (NoteContextSharerTicket shr talid) -> do
@@ -206,7 +363,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                 case project of
                     Left (Entity _ tpl)
                         | ticketProjectLocalProject tpl == jid -> do
-                            mractid <- lift $ insertToProjectInbox ibid luCreate
+                            mractid <- lift $ insertToInbox now author body ibid luCreate False
                             case mractid of
                                 Nothing -> return $ Left "Activity already in my inbox"
                                 Just ractid ->
@@ -225,12 +382,12 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                                                         , LocalPersonCollectionProjectTeam shrRecip prjRecip
                                                         ]
                                             remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
-                                            (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
+                                            (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
                     _ -> return $ Left "Context is a sharer-ticket of another project"
             case mremotesHttp of
                 Left msg -> return msg
                 Right (sig, remotesHttp) -> do
-                    forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                    forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
                     return "Stored to inbox and did inbox forwarding"
         Left (NoteContextProjectTicket shr prj ltid) -> do
             mremotesHttp <- runDBExcept $ do
@@ -240,17 +397,17 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                     fromMaybeE mticket "Context: No such project-ticket"
                 if ticketProjectLocalProject tpl == jid
                     then do
-                        mractid <- lift $ insertToProjectInbox ibid luCreate
+                        mractid <- lift $ insertToInbox now author body ibid luCreate False
                         case mractid of
                             Nothing -> return $ Left "Activity already in my inbox"
                             Just ractid -> do
                                 let did = localTicketDiscuss lt
                                 meparent <- traverse (getParent did) mparent
-                                mmid <- lift $ insertToDiscussion luNote published did meparent ractid
+                                mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
                                 case mmid of
                                     Nothing -> return $ Left "I already have this comment, just storing in inbox"
                                     Just mid -> lift $ do
-                                        updateOrphans luNote did mid
+                                        updateOrphans author luNote did mid
                                         case msig of
                                             Nothing ->
                                                 return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
@@ -265,104 +422,15 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                                                             , LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
                                                             ]
                                                 remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
-                                                (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
+                                                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
                     else return $ Left "Context is a project-ticket of another project"
             case mremotesHttp of
                 Left msg -> return msg
                 Right (sig, remotesHttp) -> do
-                    forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                    forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
                     return "Stored to inbox, cached comment, and did inbox forwarding"
     where
     getProjectRecip404 = do
         sid <- getKeyBy404 $ UniqueSharer shrRecip
         Entity jid j <- getBy404 $ UniqueProject prjRecip sid
         return (jid, projectInbox j)
-    insertToProjectInbox ibid luCreate = do
-        let iidAuthor = remoteAuthorInstance author
-        roid <-
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
-        ractid <- either entityKey id <$> insertBy' RemoteActivity
-            { remoteActivityIdent    = roid
-            , remoteActivityContent  = persistJSONFromBL $ actbBL body
-            , remoteActivityReceived = now
-            }
-        ibiid <- insert $ InboxItem False
-        new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
-        return $
-            if new
-                then Just ractid
-                else Nothing
-    getParent did (Left (shrParent, lmidParent)) = Left <$> getLocalParentMessageId did shrParent lmidParent
-    getParent did (Right p@(ObjURI hParent luParent)) = do
-        mrm <- lift $ runMaybeT $ do
-            iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
-            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
-            MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
-        case mrm of
-            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
-            Nothing -> return $ Right p
-    insertToDiscussion luNote published did meparent ractid = do
-        let iidAuthor = remoteAuthorInstance author
-            raidAuthor = remoteAuthorId author
-        mid <- insert Message
-            { messageCreated = published
-            , messageSource  = src
-            , messageContent = content
-            , messageParent  =
-                case meparent of
-                    Just (Left midParent) -> Just midParent
-                    _                     -> Nothing
-            , messageRoot    = did
-            }
-        roidNote <-
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
-        mrmid <- insertUnique RemoteMessage
-            { remoteMessageAuthor     = raidAuthor
-            , remoteMessageIdent      = roidNote
-            , remoteMessageRest       = mid
-            , remoteMessageCreate     = ractid
-            , remoteMessageLostParent =
-                case meparent of
-                    Just (Right uParent) -> Just uParent
-                    _                    -> Nothing
-            }
-        case mrmid of
-            Nothing -> do
-                delete mid
-                return Nothing
-            Just _ -> return $ Just mid
-    updateOrphans luNote did mid = do
-        let hAuthor = objUriAuthority $ remoteAuthorURI author
-            uNote = ObjURI hAuthor luNote
-        related <- selectOrphans uNote (E.==.)
-        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 <- selectOrphans uNote (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!"
-                ]
-        where
-        selectOrphans uNote 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)

src/Vervis/Federation/Ticket.hs

@@ -211,7 +211,7 @@ projectOfferTicketF
                 hLocal <- getsYesod siteInstanceHost
                 {-deps <- -}
                 checkOffer ticket hLocal shrRecip prjRecip
-                msig <- checkForward shrRecip prjRecip
+                msig <- checkForward $ LocalActorProject shrRecip prjRecip
                 let colls =
                         findRelevantCollections shrRecip prjRecip hLocal $
                             activityAudience $ actbActivity body
@@ -225,13 +225,13 @@ projectOfferTicketF
                         for mticket $ \ (ractid, obiidAccept, docAccept) -> do
                             msr <- for msig $ \ sig -> do
                                 remoteRecips <- deliverFwdLocal ractid colls sid fsid
-                                (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
+                                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
                             return (msr, obiidAccept, docAccept)
                 lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do
                     let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
                     for msr $ \ (sig, remotesHttp) -> do
                         forkHandler handler $
-                            deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                            deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
                     forkHandler handler $ publishAccept luOffer obiidAccept docAccept
                 return $ recip <> " inserted new ticket"
     where
@@ -541,7 +541,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
     case targetAndContext of
         Left (_, shrContext, prjContext)
             | shrRecip == shrContext && prjRecip == prjContext -> do
-                msig <- checkForward shrRecip prjRecip
+                msig <- checkForward $ LocalActorProject shrRecip prjRecip
                 msgOrRecips <- lift $ runDB $ do
                     (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
                     mractidCreate <- insertCreate luCreate ibidProject
@@ -562,7 +562,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
                                     let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
                                     mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do
                                         remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
-                                        (sig,) <$> deliverRemoteDB (actbBL body) ractidCreate jid sig remoteRecips
+                                        (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
                                     remoteRecipsHttpAccept <- do
                                         moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
                                         deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
@@ -570,7 +570,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
                 case msgOrRecips of
                     Left msg -> return msg
                     Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
-                        for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig recips
+                        for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
                         forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
                         return "Accepting and listing new remote author hosted ticket"
         _ -> return "Create/Ticket against different project, ignoring"

src/Vervis/Migration.hs

@@ -1552,6 +1552,16 @@ changes hLocal ctx =
         "RemoteDiscussion"
       -- 239
     , addUnique "RemoteTicket" $ Unique "UniqueRemoteTicketDiscuss" ["discuss"]
+      -- 240
+    , addEntities model_2020_05_12
+      -- 241
+    , unchecked $ lift $ do
+        fwds <- selectList ([] :: [Filter Forwarding241]) []
+        let makeSender (Entity fwdid fwd) =
+                ForwarderProject241 fwdid (forwarding241Sender fwd)
+        insertMany_ $ map makeSender fwds
+      -- 242
+    , removeField "Forwarding" "sender"
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -189,6 +189,10 @@ module Vervis.Migration.Model
     , RemoteObject238Generic (..)
     , Discussion238Generic (..)
     , RemoteDiscussion238Generic (..)
+    , model_2020_05_12
+    , Forwarding241
+    , Forwarding241Generic (..)
+    , ForwarderProject241Generic (..)
     )
 where
 
@@ -371,3 +375,9 @@ model_2020_04_09 :: [Entity SqlBackend]
 model_2020_04_09 = $(schema "2020_04_09_rt")
 
 makeEntitiesMigration "238" $(modelFile "migrations/2020_04_10_rt_rd.model")
+
+model_2020_05_12 :: [Entity SqlBackend]
+model_2020_05_12 = $(schema "2020_05_12_fwd_sender")
+
+makeEntitiesMigration "241"
+    $(modelFile "migrations/2020_05_12_fwd_sender_mig.model")