From 2cddadd6796e3c52bdff6c1f95084490ebfeffbe Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 21 Jun 2020 09:06:02 +0000
Subject: [PATCH] sharerOfferDepF: If parent is remote and child is mine,
record TicketDepOffer
---
src/Vervis/Federation/Ticket.hs | 38 +++++++++++++++++++++++++--------
src/Vervis/Federation/Util.hs | 17 +++++++++++++--
2 files changed, 44 insertions(+), 11 deletions(-)
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index 9bf5db0..40de57e 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/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 =
diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs
index 32880e3..7769511 100644
--- a/src/Vervis/Federation/Util.hs
+++ b/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)