S2S: Handle remote dep in sharerAcceptF

If sharer receives Accept on an Offer/Dep where the sharer hosts the child
ticket, it records a RemoteTicketDependency and runs inbox forwarding to ticket
followers. But this relies on a TicketDependencyOffer record already existing.
I'll take care of that in the next patches.

sharerAcceptF and sharerRejectF now use the insertToInbox from
Vervis.Federation.Util instead of their own copies of it, which were identical
anyway. Perhaps gradually all the inbox insertion in all S2S handlers will
switch to using that function.

config/models

@@ -455,11 +455,19 @@ Patch
     created UTCTime
     content Text
 
+TicketDependencyOffer
+    offer InboxItemId
+    child LocalTicketId
+
+    UniqueTicketDependencyOffer offer
+
 RemoteTicketDependency
     ident  RemoteObjectId
     child  LocalTicketId
+    accept RemoteActivityId
 
     UniqueRemoteTicketDependency ident
+    UniqueRemoteTicketDependencyAccept accept
 
 LocalTicketDependency
     parent  LocalTicketId

migrations/2020_06_18_tdo.model

@@ -0,0 +1,5 @@
+TicketDependencyOffer
+    offer InboxItemId
+    child LocalTicketId
+
+    UniqueTicketDependencyOffer offer

src/Vervis/Federation/Offer.hs

@@ -37,6 +37,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Data.Aeson
 import Data.Bifunctor
+import Data.Bitraversable
 import Data.Foldable
 import Data.Function
 import Data.List (nub, union)
@@ -74,8 +75,10 @@ import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.ActivityPub.Recipient
 import Vervis.FedURI
 import Vervis.Federation.Auth
+import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -93,43 +96,38 @@ sharerAcceptF
 sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do
     luAccept <-
         fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
-    lift $ runDB $ do
+    (localRecips, _) <- do
+        mrecips <- parseAudience $ activityAudience $ actbActivity body
+        fromMaybeE mrecips "Accept with no recipients"
+    msig <- checkForward $ LocalActorSharer shr
+    mres <- lift $ runDB $ do
         Entity pidRecip recip <- do
             sid <- getKeyBy404 $ UniqueSharer shr
             getBy404 $ UniquePersonIdent sid
-        mractid <- insertToInbox luAccept $ personInbox recip
+        mractid <- insertToInbox now author body (personInbox recip) luAccept True
-        encodeRouteLocal <- getEncodeRouteLocal
+        for mractid $ \ ractid -> do
-        let me = localUriPath $ encodeRouteLocal $ SharerR shr
+            mv <- runMaybeT $ asum
-        case mractid of
+                [ insertFollow pidRecip (personOutbox recip) ractid
-            Nothing -> return $ "Activity already exists in inbox of " <> me
+                , updateTicket pidRecip (personOutbox recip) ractid
-            Just ractid -> do
+                , insertDep msig (personInbox recip) ractid
-                mv <-
+                ]
-                    runMaybeT
+            for mv $ bitraverse pure $ traverse $ \ (sig, collections) -> do
-                        $   Left  <$> insertFollow pidRecip (personOutbox recip) ractid
+                let sieve = makeRecipientSet [] collections
-                        <|> Right <$> updateTicket pidRecip (personOutbox recip) ractid
+                remoteRecips <-
-                case mv of
+                    insertRemoteActivityToLocalInboxes
-                    Nothing ->
+                        False ractid $
-                        return $ "Activity inserted to inbox of " <> me
+                            localRecipSieve'
-                    Just (Left ()) ->
+                                sieve False False localRecips
-                        return $ "Accept received for follow request by " <> me
+                (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent recip) sig remoteRecips
-                    Just (Right ()) ->
+    case mres of
-                        return $ "Accept received for ticket by " <> me
+        Nothing -> return "Activity already in my inbox"
+        Just Nothing -> return "Activity inserted to my inbox"
+        Just (Just (t, mfwd)) -> do
+            for_ mfwd $ \ (sig, remotes) -> do
+                forkWorker "sharerAcceptF inbox-forwarding" $
+                    deliverRemoteHTTP_S now shr (actbBL body) sig remotes
+            return t
     where
-    insertToInbox luAccept ibidRecip = do
-        let iidAuthor = remoteAuthorInstance author
-        roid <-
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luAccept)
-        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
-        encodeRouteLocal <- getEncodeRouteLocal
-        case mibrid of
-            Nothing -> do
-                delete ibiid
-                return Nothing
-            Just _ -> return $ Just ractid
     insertFollow pidRecip obidRecip ractidAccept = do
         guard =<< hostIsLocal hOffer
         route <- MaybeT . pure $ decodeRouteLocal luOffer
@@ -156,6 +154,7 @@ sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do
             , followRemoteFollow = followRemoteRequestActivity frr
             , followRemoteAccept = ractidAccept
             }
+        return ("Accept received for my follow request", Nothing)
     updateTicket pidRecip obidRecip ractidAccept = do
         guard =<< hostIsLocal hOffer
         route <- MaybeT . pure $ decodeRouteLocal luOffer
@@ -176,7 +175,64 @@ sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do
             , ticketProjectRemoteAcceptAccept   = True
             , ticketProjectRemoteAcceptResult   = mresult
             }
-        return ()
+        return ("Accept received for my ticket", Nothing)
+    insertDep msig ibidRecip ractidAccept = do
+        luResult <- MaybeT $ pure mresult
+        hl <- hostIsLocal hOffer
+        ibiidOffer <-
+            if hl
+                then do
+                    route <- MaybeT . pure $ decodeRouteLocal luOffer
+                    obiid <-
+                        case route of
+                            SharerOutboxItemR shr' obikhid -> do
+                                obiid <- decodeKeyHashidM obikhid
+                                obi <- MaybeT $ get obiid
+                                p <- do
+                                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr'
+                                    MaybeT $ getValBy $ UniquePersonIdent sid
+                                guard $ personOutbox p == outboxItemOutbox obi
+                                return obiid
+                            _ -> MaybeT $ pure Nothing
+                    inboxItemLocalItem <$>
+                        MaybeT (getValBy $ UniqueInboxItemLocal ibidRecip obiid)
+                else do
+                    iid <- MaybeT $ getKeyBy $ UniqueInstance hOffer
+                    roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luOffer
+                    ractid <- MaybeT $ getKeyBy $ UniqueRemoteActivity roid
+                    inboxItemRemoteItem <$>
+                        MaybeT (getValBy $ UniqueInboxItemRemote ibidRecip ractid)
+        Entity tdoid tdo <-
+            MaybeT $ getBy $ UniqueTicketDependencyOffer ibiidOffer
+        let ltidChild = ticketDependencyOfferChild tdo
+        child <- lift $ getWorkItem ltidChild
+        (talid, patch) <-
+            case child of
+                WorkItemSharerTicket shr' t p | shr == shr' -> return (t, p)
+                _ -> MaybeT $ pure Nothing
+        lift $ do
+            delete tdoid
+            roidResult <-
+                let iid = remoteAuthorInstance author
+                in  either entityKey id <$>
+                        insertBy' (RemoteObject iid luResult)
+            insert_ RemoteTicketDependency
+                { remoteTicketDependencyIdent  = roidResult
+                , remoteTicketDependencyChild  = ltidChild
+                , remoteTicketDependencyAccept = ractidAccept
+                }
+        talkhid <- encodeKeyHashid talid
+        let collections =
+                [ let coll =
+                        if patch
+                            then LocalPersonCollectionSharerPatchFollowers
+                            else LocalPersonCollectionSharerTicketFollowers
+                  in  coll shr talkhid
+                ]
+        return
+            ( "Inserted remote reverse ticket dep"
+            , (,collections) <$> msig
+            )
 
 sharerRejectF
     :: ShrIdent
@@ -192,7 +248,7 @@ sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
         Entity pidRecip recip <- do
             sid <- getKeyBy404 $ UniqueSharer shr
             getBy404 $ UniquePersonIdent sid
-        mractid <- insertToInbox luReject $ personInbox recip
+        mractid <- insertToInbox now author body (personInbox recip) luReject True
         encodeRouteLocal <- getEncodeRouteLocal
         let me = localUriPath $ encodeRouteLocal $ SharerR shr
         case mractid of
@@ -205,21 +261,6 @@ sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
                     Just () ->
                         return $ "Reject received for follow request by " <> me
     where
-    insertToInbox luReject ibidRecip = do
-        let iidAuthor = remoteAuthorInstance author
-        roid <-
-            either entityKey id <$> insertBy' (RemoteObject iidAuthor luReject)
-        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
-        encodeRouteLocal <- getEncodeRouteLocal
-        case mibrid of
-            Nothing -> do
-                delete ibiid
-                return Nothing
-            Just _ -> return $ Just ractid
     deleteFollow pidRecip obidRecip = runMaybeT $ do
         guard =<< hostIsLocal hOffer
         route <- MaybeT . pure $ decodeRouteLocal luOffer

src/Vervis/Federation/Util.hs

@@ -55,8 +55,9 @@ insertToInbox now author body ibid luAct unread = do
         , remoteActivityReceived = now
         }
     ibiid <- insert $ InboxItem unread
-    new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
+    mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
-    return $
+    case mibrid of
-        if new
+        Nothing -> do
-            then Just ractid
+            delete ibiid
-            else Nothing
+            return Nothing
+        Just _ -> return $ Just ractid

src/Vervis/Migration.hs

@@ -1704,6 +1704,14 @@ changes hLocal ctx =
         )
         "accept"
         "OutboxItem"
+      -- 267
+    , addEntities model_2020_06_18
+      -- 268
+    , addFieldRefRequiredEmpty
+        "RemoteTicketDependency" "accept" "RemoteActivity"
+      -- 269
+    , addUnique "RemoteTicketDependency" $
+        Unique "UniqueRemoteTicketDependencyAccept" ["accept"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -217,7 +217,6 @@ module Vervis.Migration.Model
     , LocalTicket263Generic (..)
     , LocalTicketDependency263
     , LocalTicketDependency263Generic (..)
-
     , Outbox266Generic (..)
     , OutboxItem266Generic (..)
     , LocalTicketDependency266
@@ -227,6 +226,7 @@ module Vervis.Migration.Model
     , TicketUnderProject266Generic (..)
     , TicketProjectLocal266Generic (..)
     , Project266Generic (..)
+    , model_2020_06_18
     )
 where
 
@@ -442,3 +442,6 @@ makeEntitiesMigration "263" $(modelFile "migrations/2020_06_02_tdp.model")
 
 makeEntitiesMigration "266"
     $(modelFile "migrations/2020_06_15_td_accept.model")
+
+model_2020_06_18 :: [Entity SqlBackend]
+model_2020_06_18 = $(schema "2020_06_18_tdo")