mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:24:51 +09:00
S2S: Implement projectOfferDepF and repoOfferDepF
This commit is contained in:
fr33domlover
parent
5cf105fafb
commit
a0325da028
2 changed files with 525 additions and 171 deletions
|
|
@ -297,7 +297,7 @@ handleProjectInbox
|
|||
-> ActivityAuthentication
|
||||
-> ActivityBody
|
||||
-> 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 <-
|
||||
case auth of
|
||||
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
|
||||
|
|
@ -306,20 +306,22 @@ handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
|
|||
CreateActivity (Create obj mtarget) ->
|
||||
case obj of
|
||||
CreateNote note ->
|
||||
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
|
||||
(,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
|
||||
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"
|
||||
FollowActivity follow ->
|
||||
projectFollowF shrRecip prjRecip now remoteAuthor body follow
|
||||
(,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body follow
|
||||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
OfferTicket ticket ->
|
||||
projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
|
||||
_ -> return "Unsupported offer object type for projects"
|
||||
(,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
|
||||
OfferDep dep ->
|
||||
projectOfferDepF now shrRecip prjRecip remoteAuthor body dep target
|
||||
_ -> return ("Unsupported offer object type for projects", Nothing)
|
||||
UndoActivity undo ->
|
||||
projectUndoF shrRecip prjRecip now remoteAuthor body undo
|
||||
_ -> return "Unsupported activity type for projects"
|
||||
(,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body undo
|
||||
_ -> return ("Unsupported activity type for projects", Nothing)
|
||||
where
|
||||
errorLocalForwarded (ActivityAuthLocalPerson pid) =
|
||||
"Project inbox got local forwarded activity by pid#" <>
|
||||
|
|
@ -338,7 +340,7 @@ handleRepoInbox
|
|||
-> ActivityAuthentication
|
||||
-> ActivityBody
|
||||
-> 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 <-
|
||||
case auth of
|
||||
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
|
||||
|
|
@ -347,13 +349,18 @@ handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
|
|||
CreateActivity (Create obj mtarget) ->
|
||||
case obj of
|
||||
CreateNote note ->
|
||||
repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
|
||||
(,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
|
||||
_ -> error "Unsupported create object type for repos"
|
||||
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->
|
||||
repoUndoF shrRecip rpRecip now remoteAuthor body undo
|
||||
_ -> return "Unsupported activity type for repos"
|
||||
(,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body undo
|
||||
_ -> return ("Unsupported activity type for repos", Nothing)
|
||||
where
|
||||
errorLocalForwarded (ActivityAuthLocalPerson pid) =
|
||||
"Repo inbox got local forwarded activity by pid#" <>
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ module Vervis.Federation.Ticket
|
|||
, projectCreateTicketF
|
||||
|
||||
, sharerOfferDepF
|
||||
, projectOfferDepF
|
||||
, repoOfferDepF
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -30,6 +32,7 @@ import Control.Monad.Logger.CallStack
|
|||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
|
|
@ -43,6 +46,7 @@ import Data.Time.Calendar
|
|||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
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"
|
||||
return
|
||||
(uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj)
|
||||
(childId, childCtx, childAuthor) <-
|
||||
case child of
|
||||
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)
|
||||
childDetail <- getWorkItemDetail "Child" child
|
||||
return (talid, patch, parentLtid, parentCtx', childDetail)
|
||||
mhttp <- runSiteDBExcept $ do
|
||||
mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True
|
||||
for mractid $ \ (ractid, ibiid) -> do
|
||||
|
|
@ -861,9 +838,9 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(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
|
||||
tdid <- insertDep ractid parentLtid childId obiidAccept
|
||||
tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAccept luOffer obiidAccept tdid ticketData
|
||||
knownRemoteRecipsAccept <-
|
||||
|
|
@ -894,19 +871,153 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
ticketRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
|
||||
| shr == shr' = Just (talid, patch)
|
||||
ticketRelevance _ _ = Nothing
|
||||
{-
|
||||
getWorkItem
|
||||
:: MonadIO m
|
||||
=> Text
|
||||
-> WorkItem
|
||||
-> ExceptT Text (ReaderT SqlBaclend m)
|
||||
( LocalTicketId
|
||||
, Either
|
||||
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
|
||||
(Instance, RemoteObject)
|
||||
, Either ShrIdent (Instance, RemoteObject)
|
||||
)
|
||||
-}
|
||||
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 <$> 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
|
||||
=> Either
|
||||
(Entity TicketAuthorLocal, Entity TicketUnderProject)
|
||||
(Entity TicketAuthorRemote)
|
||||
-> ReaderT SqlBackend m (Either ShrIdent (Instance, RemoteObject))
|
||||
getAuthor =
|
||||
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)
|
||||
)
|
||||
|
||||
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
|
||||
(_, Entity ltid _, _, context) <- do
|
||||
mticket <- lift $ getSharerTicket shr talid
|
||||
|
|
@ -961,41 +1072,14 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
mticket <- lift $ getProjectTicket shr prj ltid
|
||||
(Entity _ s, Entity _ j, _, _, _, _, author) <-
|
||||
fromMaybeE mticket $ name <> ": No such project-ticket"
|
||||
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
|
||||
author' <- lift $ getAuthor author
|
||||
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
|
||||
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do
|
||||
mticket <- lift $ getRepoPatch shr rp ltid
|
||||
(Entity _ s, Entity _ r, _, _, _, _, author, _) <-
|
||||
fromMaybeE mticket $ name <> ": No such repo-patch"
|
||||
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
|
||||
author' <- lift $ getAuthor author
|
||||
return (ltid, Left $ Right (sharerIdent s, repoIdent r), author')
|
||||
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
parseTicketContext u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
|
|
@ -1015,60 +1099,178 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
SharerR shr -> return shr
|
||||
_ -> throwE "Not a ticket author route"
|
||||
else return $ Right u
|
||||
|
||||
mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
|
||||
insertDep
|
||||
:: MonadIO m
|
||||
=> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> RemoteActivityId
|
||||
-> LocalTicketId
|
||||
-> Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
|
||||
-> OutboxItemId
|
||||
-> ReaderT SqlBackend m LocalTicketDependencyId
|
||||
insertDep now author ractidOffer ltidParent child obiidAccept = do
|
||||
tdid <- insert LocalTicketDependency
|
||||
{ localTicketDependencyParent = ltidParent
|
||||
, localTicketDependencyCreated = now
|
||||
, localTicketDependencyAccept = obiidAccept
|
||||
}
|
||||
case child of
|
||||
Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
|
||||
{ ticketDependencyChildLocalDep = tdid
|
||||
, ticketDependencyChildLocalChild = ltid
|
||||
}
|
||||
Right (ObjURI h lu, _luFollowers) -> do
|
||||
iid <- either entityKey id <$> insertBy' (Instance h)
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
insert_ TicketDependencyChildRemote
|
||||
{ ticketDependencyChildRemoteDep = tdid
|
||||
, ticketDependencyChildRemoteChild = roid
|
||||
}
|
||||
insert_ TicketDependencyAuthorRemote
|
||||
{ ticketDependencyAuthorRemoteDep = tdid
|
||||
, ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketDependencyAuthorRemoteOpen = ractidOffer
|
||||
}
|
||||
return tdid
|
||||
|
||||
askWorkItemFollowers
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> m (WorkItem -> LocalPersonCollection)
|
||||
askWorkItemFollowers = do
|
||||
hashTALID <- getEncodeKeyHashid
|
||||
hashLTID <- getEncodeKeyHashid
|
||||
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
|
||||
workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
|
||||
workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
|
||||
workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
|
||||
return workItemFollowers
|
||||
|
||||
contextAudience
|
||||
:: Either
|
||||
(Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
|
||||
(FedURI, Host, Maybe LocalURI, Maybe LocalURI)
|
||||
-> [Aud URIMode]
|
||||
contextAudience ctx =
|
||||
case ctx of
|
||||
Left (Left (shr, prj)) ->
|
||||
pure $ AudLocal
|
||||
[LocalActorProject shr prj]
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Left (Right (shr, rp)) ->
|
||||
pure $ AudLocal
|
||||
[LocalActorRepo shr rp]
|
||||
[ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
|
||||
[ AudRemote hTracker [luTracker] []
|
||||
, AudRemote hProject [] (catMaybes [luFollowers, luTeam])
|
||||
]
|
||||
|
||||
projectOfferDepF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> AP.TicketDependency URIMode
|
||||
-> FedURI
|
||||
-> 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 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
|
||||
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
|
||||
hashTALID <- getEncodeKeyHashid
|
||||
return $ \ shr wi -> followers hashTALID <$> ticketRelevance shr wi
|
||||
hashLTID <- getEncodeKeyHashid
|
||||
return $
|
||||
\ shr prj wi -> followers hashLTID <$> ticketRelevance shr prj 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
|
||||
{ localTicketDependencyParent = ltidParent
|
||||
, localTicketDependencyCreated = now
|
||||
, localTicketDependencyAccept = obiidAccept
|
||||
}
|
||||
case child of
|
||||
Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
|
||||
{ ticketDependencyChildLocalDep = tdid
|
||||
, ticketDependencyChildLocalChild = ltid
|
||||
}
|
||||
Right (ObjURI h lu, _luFollowers) -> do
|
||||
iid <- either entityKey id <$> insertBy' (Instance h)
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
insert_ TicketDependencyChildRemote
|
||||
{ ticketDependencyChildRemoteDep = tdid
|
||||
, ticketDependencyChildRemoteChild = roid
|
||||
}
|
||||
insert_ TicketDependencyAuthorRemote
|
||||
{ ticketDependencyAuthorRemoteDep = tdid
|
||||
, ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketDependencyAuthorRemoteOpen = ractidOffer
|
||||
}
|
||||
return tdid
|
||||
insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do
|
||||
followers hashLTID ltid =
|
||||
LocalPersonCollectionProjectTicketFollowers
|
||||
shrRecip prjRecip (hashLTID ltid)
|
||||
insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
followers <- askFollowers
|
||||
|
|
@ -1081,9 +1283,19 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audParentContext = contextAudience parentCtx
|
||||
audParentContext =
|
||||
AudLocal
|
||||
[]
|
||||
[ LocalPersonCollectionProjectTeam shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectFollowers shrRecip prjRecip
|
||||
]
|
||||
audChildContext = contextAudience childCtx
|
||||
audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
|
||||
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] []
|
||||
|
|
@ -1096,17 +1308,16 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience $
|
||||
audAuthor :
|
||||
audParent :
|
||||
audChildAuthor :
|
||||
audChildFollowers :
|
||||
audParentContext ++ audChildContext
|
||||
audParentAuthor : audParentFollowers :
|
||||
audChildAuthor : audChildFollowers :
|
||||
audParentContext : audChildContext
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
SharerOutboxItemR shrRecip obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ SharerR shrRecip
|
||||
, activityActor = encodeRouteLocal $ ProjectR shrRecip prjRecip
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
|
|
@ -1118,37 +1329,173 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
|
|||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
where
|
||||
contextAudience ctx =
|
||||
case ctx of
|
||||
Left (Left (shr, prj)) ->
|
||||
pure $ AudLocal
|
||||
[LocalActorProject shr prj]
|
||||
[ LocalPersonCollectionProjectTeam shr prj
|
||||
, LocalPersonCollectionProjectFollowers shr prj
|
||||
]
|
||||
Left (Right (shr, rp)) ->
|
||||
pure $ AudLocal
|
||||
[LocalActorRepo shr rp]
|
||||
[ LocalPersonCollectionRepoTeam shr rp
|
||||
, LocalPersonCollectionRepoFollowers shr rp
|
||||
]
|
||||
Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
|
||||
[ AudRemote hTracker [luTracker] []
|
||||
, AudRemote hProject [] (catMaybes [luFollowers, luTeam])
|
||||
]
|
||||
askFollowers = do
|
||||
hashTALID <- getEncodeKeyHashid
|
||||
return $ \ talid patch ->
|
||||
let coll =
|
||||
if patch
|
||||
then LocalPersonCollectionSharerPatchFollowers
|
||||
else LocalPersonCollectionSharerTicketFollowers
|
||||
in coll shrRecip (hashTALID talid)
|
||||
askWorkItemFollowers = do
|
||||
hashTALID <- getEncodeKeyHashid
|
||||
hashLTID <- getEncodeKeyHashid
|
||||
let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
|
||||
workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
|
||||
workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
|
||||
workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
|
||||
return workItemFollowers
|
||||
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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue