sharerOfferDepF: If parent is remote and child is mine, record TicketDepOffer

src/Vervis/Federation/Ticket.hs

@@ -767,7 +767,7 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
     return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
         manager <- asksSite appHttpManager
         relevantParent <-
-            for (parentRelevance shrRecip parent) $ \ (talid, patch) -> do
+            for (ticketRelevance shrRecip parent) $ \ (talid, patch) -> do
                 (parentLtid, parentCtx) <- runSiteDBExcept $ do
                     let getTcr tcr = do
                             let getRoid roid = do
@@ -844,10 +844,11 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
                     return
                         (u', objUriAuthority u, objFollowers obj, objTeam obj)
                 return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor)
-        mhttp <- lift $ runSiteDB $ do
-            mractid <- insertToInbox now author body (personInbox personRecip) luOffer True
-            for mractid $ \ ractid -> do
-                mremotesHttpFwd <- for msig $ \ sig -> do
+        mhttp <- runSiteDBExcept $ do
+            mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True
+            for mractid $ \ (ractid, ibiid) -> do
+                insertDepOffer ibiid parent child
+                mremotesHttpFwd <- lift $ for msig $ \ sig -> do
                     relevantFollowers <- askRelevantFollowers
                     let sieve =
                             makeRecipientSet [] $ catMaybes
@@ -860,7 +861,7 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
                                 localRecipSieve'
                                     sieve False False localRecips
                     (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
-                mremotesHttpAccept <- for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do
+                mremotesHttpAccept <- lift $ for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do
                     obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
                     tdid <- insertDep ractid parentLtid childId obiidAccept
                     (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
@@ -947,9 +948,9 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
         checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
         checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
         checkParentAndTarget (Right _) (Right _) = return ()
-    parentRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
+    ticketRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
         | shr == shr' = Just (talid, patch)
-    parentRelevance _ _ = Nothing
+    ticketRelevance _ _ = Nothing
     {-
     getWorkItem
         :: MonadIO m
@@ -1071,9 +1072,28 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
                         SharerR shr -> return shr
                         _ -> throwE "Not a ticket author route"
             else return $ Right u
+    insertDepOffer _          (Left _)  _     = return ()
+    insertDepOffer ibiidOffer (Right _) child =
+        for_ (ticketRelevance shrRecip child) $ \ (talid, patch) -> do
+            ltid <-
+                if patch
+                    then do
+                        (_, Entity ltid _, _, _, _) <- do
+                            mticket <- lift $ getSharerPatch shrRecip talid
+                            fromMaybeE mticket $ "Child" <> ": No such sharer-patch"
+                        return ltid
+                    else do
+                        (_, Entity ltid _, _, _) <- do
+                            mticket <- lift $ getSharerTicket shrRecip talid
+                            fromMaybeE mticket $ "Child" <> ": No such sharer-ticket"
+                        return ltid
+            lift $ insert_ TicketDependencyOffer
+                { ticketDependencyOfferOffer = ibiidOffer
+                , ticketDependencyOfferChild = ltid
+                }
     askRelevantFollowers = do
         hashTALID <- getEncodeKeyHashid
-        return $ \ shr wi -> followers hashTALID <$> parentRelevance shr wi
+        return $ \ shr wi -> followers hashTALID <$> ticketRelevance shr wi
         where
         followers hashTALID (talid, patch) =
             let coll =

src/Vervis/Federation/Util.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Federation.Util
     ( insertToInbox
+    , insertToInbox'
     )
 where
 
@@ -45,7 +46,19 @@ insertToInbox
     -> LocalURI
     -> Bool
     -> ReaderT SqlBackend m (Maybe RemoteActivityId)
-insertToInbox now author body ibid luAct unread = do
+insertToInbox now author body ibid luAct unread =
+    fmap fst <$> insertToInbox' now author body ibid luAct unread
+
+insertToInbox'
+    :: MonadIO m
+    => UTCTime
+    -> RemoteAuthor
+    -> ActivityBody
+    -> InboxId
+    -> LocalURI
+    -> Bool
+    -> ReaderT SqlBackend m (Maybe (RemoteActivityId, InboxItemId))
+insertToInbox' now author body ibid luAct unread = do
     let iidAuthor = remoteAuthorInstance author
     roid <-
         either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct)
@@ -60,4 +73,4 @@ insertToInbox now author body ibid luAct unread = do
         Nothing -> do
             delete ibiid
             return Nothing
-        Just _ -> return $ Just ractid
+        Just _ -> return $ Just (ractid, ibiid)