1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 01:54:50 +09:00

S2S: Implement projectOfferDepF and repoOfferDepF

This commit is contained in:
fr33domlover 2020-06-22 11:29:30 +00:00
parent 5cf105fafb
commit a0325da028
2 changed files with 525 additions and 171 deletions

View file

@ -297,7 +297,7 @@ handleProjectInbox
-> ActivityAuthentication -> ActivityAuthentication
-> ActivityBody -> ActivityBody
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do handleProjectInbox shrRecip prjRecip now auth body = do
remoteAuthor <- remoteAuthor <-
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@ -306,20 +306,22 @@ handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
CreateTicket ticket -> CreateTicket ticket ->
projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget
_ -> error "Unsupported create object type for projects" _ -> error "Unsupported create object type for projects"
FollowActivity follow -> FollowActivity follow ->
projectFollowF shrRecip prjRecip now remoteAuthor body follow (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body follow
OfferActivity (Offer obj target) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferTicket ticket -> OfferTicket ticket ->
projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
_ -> return "Unsupported offer object type for projects" OfferDep dep ->
projectOfferDepF now shrRecip prjRecip remoteAuthor body dep target
_ -> return ("Unsupported offer object type for projects", Nothing)
UndoActivity undo -> UndoActivity undo ->
projectUndoF shrRecip prjRecip now remoteAuthor body undo (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body undo
_ -> return "Unsupported activity type for projects" _ -> return ("Unsupported activity type for projects", Nothing)
where where
errorLocalForwarded (ActivityAuthLocalPerson pid) = errorLocalForwarded (ActivityAuthLocalPerson pid) =
"Project inbox got local forwarded activity by pid#" <> "Project inbox got local forwarded activity by pid#" <>
@ -338,7 +340,7 @@ handleRepoInbox
-> ActivityAuthentication -> ActivityAuthentication
-> ActivityBody -> ActivityBody
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do handleRepoInbox shrRecip rpRecip now auth body = do
remoteAuthor <- remoteAuthor <-
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@ -347,13 +349,18 @@ handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
repoCreateNoteF now shrRecip rpRecip remoteAuthor body note (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
_ -> error "Unsupported create object type for repos" _ -> error "Unsupported create object type for repos"
FollowActivity follow -> FollowActivity follow ->
repoFollowF shrRecip rpRecip now remoteAuthor body follow (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body follow
OfferActivity (Offer obj target) ->
case obj of
OfferDep dep ->
repoOfferDepF now shrRecip rpRecip remoteAuthor body dep target
_ -> return ("Unsupported offer object type for repos", Nothing)
UndoActivity undo-> UndoActivity undo->
repoUndoF shrRecip rpRecip now remoteAuthor body undo (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body undo
_ -> return "Unsupported activity type for repos" _ -> return ("Unsupported activity type for repos", Nothing)
where where
errorLocalForwarded (ActivityAuthLocalPerson pid) = errorLocalForwarded (ActivityAuthLocalPerson pid) =
"Repo inbox got local forwarded activity by pid#" <> "Repo inbox got local forwarded activity by pid#" <>

View file

@ -21,6 +21,8 @@ module Vervis.Federation.Ticket
, projectCreateTicketF , projectCreateTicketF
, sharerOfferDepF , sharerOfferDepF
, projectOfferDepF
, repoOfferDepF
) )
where where
@ -30,6 +32,7 @@ import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Aeson import Data.Aeson
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
@ -43,6 +46,7 @@ import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
import Database.Persist.Sql
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html.Renderer.Text
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
@ -815,35 +819,8 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
throwE "Project 'id' differs from the URI we fetched" throwE "Project 'id' differs from the URI we fetched"
return return
(uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj) (uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj)
(childId, childCtx, childAuthor) <- childDetail <- getWorkItemDetail "Child" child
case child of return (talid, patch, parentLtid, parentCtx', childDetail)
Left wi -> runSiteDBExcept $ do
(ltid, ctx, author) <- getWorkItem "Child" wi
return (Left (wi, ltid), second mkuri ctx, second mkuri author)
Right u -> do
Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
(hTicket, tl) <- fromMaybeE (AP.ticketLocal t) "Child ticket no 'id'"
unless (ObjURI hAuthor (AP.ticketId tl) == u) $
throwE "Ticket 'id' differs from the URI we fetched"
uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
ctx <- parseTicketContext uCtx
author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
return (Right (u, AP.ticketParticipants tl), ctx, author)
childCtx' <- bifor childCtx pure $ \ u -> do
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
unless (objId obj == u) $
throwE "Project 'id' differs from the URI we fetched"
u' <-
case (objContext obj, objInbox obj) of
(Just c, Nothing) -> do
hl <- hostIsLocal $ objUriAuthority c
when hl $ throwE "Child remote context has a local context"
pure c
(Nothing, Just _) -> pure u
_ -> throwE "Umm context-inbox thing"
return
(u', objUriAuthority u, objFollowers obj, objTeam obj)
return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor)
mhttp <- runSiteDBExcept $ do mhttp <- runSiteDBExcept $ do
mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True
for mractid $ \ (ractid, ibiid) -> do for mractid $ \ (ractid, ibiid) -> do
@ -861,9 +838,9 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
localRecipSieve' localRecipSieve'
sieve False False localRecips sieve False False localRecips
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips (sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
mremotesHttpAccept <- lift $ for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do mremotesHttpAccept <- lift $ for relevantParent $ \ ticketData@(_, _, parentLtid, _, childDetail) -> do
obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
tdid <- insertDep ractid parentLtid childId obiidAccept tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid ticketData insertAccept luOffer obiidAccept tdid ticketData
knownRemoteRecipsAccept <- knownRemoteRecipsAccept <-
@ -894,19 +871,153 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
ticketRelevance shr (Left (WorkItemSharerTicket shr' talid patch)) ticketRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
| shr == shr' = Just (talid, patch) | shr == shr' = Just (talid, patch)
ticketRelevance _ _ = Nothing ticketRelevance _ _ = Nothing
{- insertDepOffer _ (Left _) _ = return ()
getWorkItem 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 <$> ticketRelevance shr wi
where
followers hashTALID (talid, patch) =
let coll =
if patch
then LocalPersonCollectionSharerPatchFollowers
else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid)
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, WorkItemDetail childId childCtx childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
workItemFollowers <- askWorkItemFollowers
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
tdkhid <- encodeKeyHashid tdid
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audParentContext = contextAudience parentCtx
audChildContext = contextAudience childCtx
audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
audChildAuthor =
case childAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (ObjURI h lu) -> AudRemote h [lu] []
audChildFollowers =
case childId of
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience $
audAuthor :
audParent :
audChildAuthor :
audChildFollowers :
audParentContext ++ audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
, activityActor = encodeRouteLocal $ SharerR shrRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ TicketDepR tdkhid
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
askFollowers = do
hashTALID <- getEncodeKeyHashid
return $ \ talid patch ->
let coll =
if patch
then LocalPersonCollectionSharerPatchFollowers
else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid)
data WorkItemDetail = WorkItemDetail
{ widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
, widContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (FedURI, Host, Maybe LocalURI, Maybe LocalURI)
, widAuthor :: Either ShrIdent FedURI
}
getAuthor
:: MonadIO m :: MonadIO m
=> Text => Either
-> WorkItem (Entity TicketAuthorLocal, Entity TicketUnderProject)
-> ExceptT Text (ReaderT SqlBaclend m) (Entity TicketAuthorRemote)
( LocalTicketId -> ReaderT SqlBackend m (Either ShrIdent (Instance, RemoteObject))
, Either getAuthor =
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) bitraverse
(Instance, RemoteObject) (\ (Entity _ tal, _) -> do
, Either ShrIdent (Instance, RemoteObject) p <- getJust $ ticketAuthorLocalAuthor tal
sharerIdent <$> getJust (personIdent p)
) )
-} (\ (Entity _ tar) -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
getWorkItemDetail
:: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail
getWorkItemDetail name v = do
manager <- asksSite appHttpManager
(childId, childCtx, childAuthor) <-
case v of
Left wi -> runSiteDBExcept $ do
(ltid, ctx, author) <- getWorkItem name wi
return (Left (wi, ltid), second mkuri ctx, second mkuri author)
Right u -> do
Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
(hTicket, tl) <- fromMaybeE (AP.ticketLocal t) $ name <> ": no 'id'"
unless (ObjURI hAuthor (AP.ticketId tl) == u) $
throwE "Ticket 'id' differs from the URI we fetched"
uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
ctx <- parseTicketContext uCtx
author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
return (Right (u, AP.ticketParticipants tl), ctx, author)
childCtx' <- bifor childCtx pure $ \ u -> do
obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
unless (objId obj == u) $
throwE "Project 'id' differs from the URI we fetched"
u' <-
case (objContext obj, objInbox obj) of
(Just c, Nothing) -> do
hl <- hostIsLocal $ objUriAuthority c
when hl $ throwE $ name <> ": remote context has a local context"
pure c
(Nothing, Just _) -> pure u
_ -> throwE "Umm context-inbox thing"
return
(u', objUriAuthority u, objFollowers obj, objTeam obj)
return $ WorkItemDetail childId childCtx' childAuthor
where
getWorkItem name (WorkItemSharerTicket shr talid False) = do getWorkItem name (WorkItemSharerTicket shr talid False) = do
(_, Entity ltid _, _, context) <- do (_, Entity ltid _, _, context) <- do
mticket <- lift $ getSharerTicket shr talid mticket <- lift $ getSharerTicket shr talid
@ -961,41 +1072,14 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
mticket <- lift $ getProjectTicket shr prj ltid mticket <- lift $ getProjectTicket shr prj ltid
(Entity _ s, Entity _ j, _, _, _, _, author) <- (Entity _ s, Entity _ j, _, _, _, _, author) <-
fromMaybeE mticket $ name <> ": No such project-ticket" fromMaybeE mticket $ name <> ": No such project-ticket"
author' <- author' <- lift $ getAuthor author
lift $
bitraverse
(\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal
sharerIdent <$> getJust (personIdent p)
)
(\ (Entity _ tar) -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
author
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author') return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do getWorkItem name (WorkItemRepoPatch shr rp ltid) = do
mticket <- lift $ getRepoPatch shr rp ltid mticket <- lift $ getRepoPatch shr rp ltid
(Entity _ s, Entity _ r, _, _, _, _, author, _) <- (Entity _ s, Entity _ r, _, _, _, _, author, _) <-
fromMaybeE mticket $ name <> ": No such repo-patch" fromMaybeE mticket $ name <> ": No such repo-patch"
author' <- author' <- lift $ getAuthor author
lift $
bitraverse
(\ (Entity _ tal, _) -> do
p <- getJust $ ticketAuthorLocalAuthor tal
sharerIdent <$> getJust (personIdent p)
)
(\ (Entity _ tar) -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro)
)
author
return (ltid, Left $ Right (sharerIdent s, repoIdent r), author') return (ltid, Left $ Right (sharerIdent s, repoIdent r), author')
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
parseTicketContext u@(ObjURI h lu) = do parseTicketContext u@(ObjURI h lu) = do
hl <- hostIsLocal h hl <- hostIsLocal h
if hl if hl
@ -1015,36 +1099,19 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
SharerR shr -> return shr SharerR shr -> return shr
_ -> throwE "Not a ticket author route" _ -> throwE "Not a ticket author route"
else return $ Right u else return $ Right u
insertDepOffer _ (Left _) _ = return ()
insertDepOffer ibiidOffer (Right _) child = mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
for_ (ticketRelevance shrRecip child) $ \ (talid, patch) -> do
ltid <- insertDep
if patch :: MonadIO m
then do => UTCTime
(_, Entity ltid _, _, _, _) <- do -> RemoteAuthor
mticket <- lift $ getSharerPatch shrRecip talid -> RemoteActivityId
fromMaybeE mticket $ "Child" <> ": No such sharer-patch" -> LocalTicketId
return ltid -> Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
else do -> OutboxItemId
(_, Entity ltid _, _, _) <- do -> ReaderT SqlBackend m LocalTicketDependencyId
mticket <- lift $ getSharerTicket shrRecip talid insertDep now author ractidOffer ltidParent child obiidAccept = do
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 <$> ticketRelevance shr wi
where
followers hashTALID (talid, patch) =
let coll =
if patch
then LocalPersonCollectionSharerPatchFollowers
else LocalPersonCollectionSharerTicketFollowers
in coll shrRecip (hashTALID talid)
insertDep ractidOffer ltidParent child obiidAccept = do
tdid <- insert LocalTicketDependency tdid <- insert LocalTicketDependency
{ localTicketDependencyParent = ltidParent { localTicketDependencyParent = ltidParent
, localTicketDependencyCreated = now , localTicketDependencyCreated = now
@ -1068,57 +1135,25 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
, ticketDependencyAuthorRemoteOpen = ractidOffer , ticketDependencyAuthorRemoteOpen = ractidOffer
} }
return tdid return tdid
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
workItemFollowers <- askWorkItemFollowers
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
tdkhid <- encodeKeyHashid tdid
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor = askWorkItemFollowers
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) :: (MonadSite m, YesodHashids (SiteEnv m))
audParentContext = contextAudience parentCtx => m (WorkItem -> LocalPersonCollection)
audChildContext = contextAudience childCtx askWorkItemFollowers = do
audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch] hashTALID <- getEncodeKeyHashid
audChildAuthor = hashLTID <- getEncodeKeyHashid
case childAuthor of let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
Left shr -> AudLocal [LocalActorSharer shr] [] workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
Right (ObjURI h lu) -> AudRemote h [lu] [] workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
audChildFollowers = workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
case childId of return workItemFollowers
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = contextAudience
collectAudience $ :: Either
audAuthor : (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
audParent : (FedURI, Host, Maybe LocalURI, Maybe LocalURI)
audChildAuthor : -> [Aud URIMode]
audChildFollowers : contextAudience ctx =
audParentContext ++ audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
, activityActor = encodeRouteLocal $ SharerR shrRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ TicketDepR tdkhid
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
contextAudience ctx =
case ctx of case ctx of
Left (Left (shr, prj)) -> Left (Left (shr, prj)) ->
pure $ AudLocal pure $ AudLocal
@ -1136,19 +1171,331 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
[ AudRemote hTracker [luTracker] [] [ AudRemote hTracker [luTracker] []
, AudRemote hProject [] (catMaybes [luFollowers, luTeam]) , AudRemote hProject [] (catMaybes [luFollowers, luTeam])
] ]
askFollowers = do
hashTALID <- getEncodeKeyHashid projectOfferDepF
return $ \ talid patch -> :: UTCTime
let coll = -> ShrIdent
if patch -> PrjIdent
then LocalPersonCollectionSharerPatchFollowers -> RemoteAuthor
else LocalPersonCollectionSharerTicketFollowers -> ActivityBody
in coll shrRecip (hashTALID talid) -> AP.TicketDependency URIMode
askWorkItemFollowers = do -> FedURI
hashTALID <- getEncodeKeyHashid -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
projectOfferDepF now shrRecip prjRecip author body dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorProject shrRecip prjRecip
Entity jidRecip projectRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
relevantParent <-
for (ticketRelevance shrRecip prjRecip parent) $ \ parentLtid -> do
parentAuthor <- runSiteDBExcept $ do
(_, _, _, _, _, _, author) <- do
mticket <- lift $ getProjectTicket shrRecip prjRecip parentLtid
fromMaybeE mticket $ "Parent" <> ": No such project-ticket"
lift $ getAuthor author
childDetail <- getWorkItemDetail "Child" child
return (parentLtid, parentAuthor, childDetail)
mhttp <- runSiteDBExcept $ do
mractid <- lift $ insertToInbox' now author body (projectInbox projectRecip) luOffer False
for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for msig $ \ sig -> do
relevantFollowers <- askRelevantFollowers
let rf = relevantFollowers shrRecip prjRecip
sieve =
makeRecipientSet [] $ catMaybes
[ rf parent
, rf child
]
remoteRecips <-
insertRemoteActivityToLocalInboxes
False ractid $
localRecipSieve'
sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do
obiidAccept <- insertEmptyOutboxItem (projectOutbox projectRecip) now
tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail
knownRemoteRecipsAccept <-
deliverLocal'
False
(LocalActorProject shrRecip prjRecip)
(projectInbox projectRecip)
obiidAccept
localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
return (mremotesHttpFwd, mremotesHttpAccept)
case mhttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just (mremotesHttpFwd, mremotesHttpAccept) -> do
for_ mremotesHttpFwd $ \ (sig, remotes) ->
forkWorker "projectOfferDepF inbox-forwarding" $
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
forkWorker "projectOfferDepF Accept HTTP delivery" $
deliverRemoteHttp' fwdHosts obiid doc remotes
return $
case (mremotesHttpAccept, mremotesHttpFwd) of
(Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
(Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
(Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
(Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
where
ticketRelevance shr prj (Left (WorkItemProjectTicket shr' prj' ltid))
| shr == shr' && prj == prj' = Just ltid
ticketRelevance _ _ _ = Nothing
insertDepOffer _ (Left _) _ = return ()
insertDepOffer ibiidOffer (Right _) child =
for_ (ticketRelevance shrRecip prjRecip child) $ \ ltid -> do
_ <- do
mticket <- lift $ getProjectTicket shrRecip prjRecip ltid
fromMaybeE mticket $ "Child" <> ": No such project-ticket"
lift $ insert_ TicketDependencyOffer
{ ticketDependencyOfferOffer = ibiidOffer
, ticketDependencyOfferChild = ltid
}
askRelevantFollowers = do
hashLTID <- getEncodeKeyHashid hashLTID <- getEncodeKeyHashid
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid return $
workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid \ shr prj wi -> followers hashLTID <$> ticketRelevance shr prj wi
workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid where
workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid followers hashLTID ltid =
return workItemFollowers LocalPersonCollectionProjectTicketFollowers
shrRecip prjRecip (hashLTID ltid)
insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
workItemFollowers <- askWorkItemFollowers
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
tdkhid <- encodeKeyHashid tdid
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audParentContext =
AudLocal
[]
[ LocalPersonCollectionProjectTeam shrRecip prjRecip
, LocalPersonCollectionProjectFollowers shrRecip prjRecip
]
audChildContext = contextAudience childCtx
audParentFollowers = AudLocal [] [followers ltid]
audParentAuthor =
case parentAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (i, ro) ->
AudRemote (instanceHost i) [remoteObjectIdent ro] []
audChildAuthor =
case childAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (ObjURI h lu) -> AudRemote h [lu] []
audChildFollowers =
case childId of
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience $
audAuthor :
audParentAuthor : audParentFollowers :
audChildAuthor : audChildFollowers :
audParentContext : audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
, activityActor = encodeRouteLocal $ ProjectR shrRecip prjRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ TicketDepR tdkhid
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
askFollowers = do
hashLTID <- getEncodeKeyHashid
return $
\ ltid ->
LocalPersonCollectionProjectTicketFollowers
shrRecip prjRecip (hashLTID ltid)
repoOfferDepF
:: UTCTime
-> ShrIdent
-> RpIdent
-> RemoteAuthor
-> ActivityBody
-> AP.TicketDependency URIMode
-> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
repoOfferDepF now shrRecip rpRecip author body dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorRepo shrRecip rpRecip
Entity ridRecip repoRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueRepo rpRecip sid
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
relevantParent <-
for (ticketRelevance shrRecip rpRecip parent) $ \ parentLtid -> do
parentAuthor <- runSiteDBExcept $ do
(_, _, _, _, _, _, author, _) <- do
mticket <- lift $ getRepoPatch shrRecip rpRecip parentLtid
fromMaybeE mticket $ "Parent" <> ": No such repo-patch"
lift $ getAuthor author
childDetail <- getWorkItemDetail "Child" child
return (parentLtid, parentAuthor, childDetail)
mhttp <- runSiteDBExcept $ do
mractid <- lift $ insertToInbox' now author body (repoInbox repoRecip) luOffer False
for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for msig $ \ sig -> do
relevantFollowers <- askRelevantFollowers
let rf = relevantFollowers shrRecip rpRecip
sieve =
makeRecipientSet [] $ catMaybes
[ rf parent
, rf child
]
remoteRecips <-
insertRemoteActivityToLocalInboxes
False ractid $
localRecipSieve'
sieve False False localRecips
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail
knownRemoteRecipsAccept <-
deliverLocal'
False
(LocalActorRepo shrRecip rpRecip)
(repoInbox repoRecip)
obiidAccept
localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
return (mremotesHttpFwd, mremotesHttpAccept)
case mhttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just (mremotesHttpFwd, mremotesHttpAccept) -> do
for_ mremotesHttpFwd $ \ (sig, remotes) ->
forkWorker "repoOfferDepF inbox-forwarding" $
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
forkWorker "repoOfferDepF Accept HTTP delivery" $
deliverRemoteHttp' fwdHosts obiid doc remotes
return $
case (mremotesHttpAccept, mremotesHttpFwd) of
(Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
(Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
(Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
(Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
where
ticketRelevance shr rp (Left (WorkItemRepoPatch shr' rp' ltid))
| shr == shr' && rp == rp' = Just ltid
ticketRelevance _ _ _ = Nothing
insertDepOffer _ (Left _) _ = return ()
insertDepOffer ibiidOffer (Right _) child =
for_ (ticketRelevance shrRecip rpRecip child) $ \ ltid -> do
_ <- do
mticket <- lift $ getRepoPatch shrRecip rpRecip ltid
fromMaybeE mticket $ "Child" <> ": No such repo-patch"
lift $ insert_ TicketDependencyOffer
{ ticketDependencyOfferOffer = ibiidOffer
, ticketDependencyOfferChild = ltid
}
askRelevantFollowers = do
hashLTID <- getEncodeKeyHashid
return $
\ shr rp wi -> followers hashLTID <$> ticketRelevance shr rp wi
where
followers hashLTID ltid =
LocalPersonCollectionRepoPatchFollowers
shrRecip rpRecip (hashLTID ltid)
insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
workItemFollowers <- askWorkItemFollowers
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
tdkhid <- encodeKeyHashid tdid
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audParentContext =
AudLocal
[]
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
]
audChildContext = contextAudience childCtx
audParentFollowers = AudLocal [] [followers ltid]
audParentAuthor =
case parentAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (i, ro) ->
AudRemote (instanceHost i) [remoteObjectIdent ro] []
audChildAuthor =
case childAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
Right (ObjURI h lu) -> AudRemote h [lu] []
audChildFollowers =
case childId of
Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience $
audAuthor :
audParentAuthor : audParentFollowers :
audChildAuthor : audChildFollowers :
audParentContext : audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ TicketDepR tdkhid
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
askFollowers = do
hashLTID <- getEncodeKeyHashid
return $
\ ltid ->
LocalPersonCollectionRepoPatchFollowers
shrRecip rpRecip (hashLTID ltid)