C2S: addBundleC for adding a new patch bundle version to a Ticket
This commit is contained in:
fr33domlover
parent
1b304994d0
commit
bf2e172f6e
2 changed files with 208 additions and 1 deletions
|
|
@ -14,7 +14,8 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.API
|
module Vervis.API
|
||||||
( noteC
|
( addBundleC
|
||||||
|
, noteC
|
||||||
, createNoteC
|
, createNoteC
|
||||||
, createTicketC
|
, createTicketC
|
||||||
, followC
|
, followC
|
||||||
|
|
@ -119,6 +120,207 @@ import Vervis.Patch
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
import Vervis.WorkItem
|
import Vervis.WorkItem
|
||||||
|
|
||||||
|
addBundleC
|
||||||
|
:: Entity Person
|
||||||
|
-> Sharer
|
||||||
|
-> Maybe TextHtml
|
||||||
|
-> Audience URIMode
|
||||||
|
-> NonEmpty (AP.Patch URIMode)
|
||||||
|
-> FedURI
|
||||||
|
-> ExceptT Text Handler OutboxItemId
|
||||||
|
addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarget = do
|
||||||
|
let shrUser = sharerIdent sharerUser
|
||||||
|
ticket <- do
|
||||||
|
t <- parseWorkItem "Target" uTarget
|
||||||
|
bitraverse
|
||||||
|
(\ wi ->
|
||||||
|
case wi of
|
||||||
|
WorkItemSharerTicket shr talid patch -> do
|
||||||
|
unless patch $ throwE "Target is a non-MR sharer-ticket"
|
||||||
|
return $ Left (shr, talid)
|
||||||
|
WorkItemProjectTicket _ _ _ ->
|
||||||
|
throwE "Target is a project-ticket"
|
||||||
|
WorkItemRepoProposal shr rp ltid ->
|
||||||
|
return $ Right (shr, rp, ltid)
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
(typ, diffs) <- do
|
||||||
|
((typ, diff) :| rest) <-
|
||||||
|
for patches $ \ (AP.Patch mlocal attrib mpub typ content) -> do
|
||||||
|
verifyNothingE mlocal "Patch with 'id'"
|
||||||
|
shrAttrib <- do
|
||||||
|
route <- fromMaybeE (decodeRouteLocal attrib) "Patch attrib not a valid route"
|
||||||
|
case route of
|
||||||
|
SharerR shr -> return shr
|
||||||
|
_ -> throwE "Patch attrib not a sharer route"
|
||||||
|
unless (shrAttrib == shrUser) $
|
||||||
|
throwE "Add and Patch attrib mismatch"
|
||||||
|
verifyNothingE mpub "Patch has 'published'"
|
||||||
|
return (typ, content)
|
||||||
|
let (typs, diffs) = unzip rest
|
||||||
|
unless (all (== typ) typs) $ throwE "Patches of different media types"
|
||||||
|
return (typ, diff :| diffs)
|
||||||
|
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||||
|
mrecips <- parseAudience audience
|
||||||
|
fromMaybeE mrecips "Add Bundle with no recipients"
|
||||||
|
federation <- asksSite $ appFederation . appSettings
|
||||||
|
unless (federation || null remoteRecips) $
|
||||||
|
throwE "Federation disabled, but remote recipients specified"
|
||||||
|
let ticketWI = first toWorkItem ticket
|
||||||
|
verifyHosterRecip localRecips "Ticket" ticketWI
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
ticketDetail <- runWorkerExcept $ getWorkItemDetail "Ticket" ticketWI
|
||||||
|
(obiidAdd, docAdd, remotesHttpAdd, maybeAccept) <- runDBExcept $ do
|
||||||
|
(obiid, doc, luAdd) <- lift $ insertAddToOutbox shrUser now (personOutbox personUser) blinded
|
||||||
|
remotesHttpAdd <- do
|
||||||
|
wiFollowers <- askWorkItemFollowers
|
||||||
|
let sieve =
|
||||||
|
let (ticketA, ticketC) =
|
||||||
|
workItemRecipSieve wiFollowers ticketDetail
|
||||||
|
in makeRecipientSet
|
||||||
|
ticketA
|
||||||
|
(LocalPersonCollectionSharerFollowers shrUser :
|
||||||
|
ticketC
|
||||||
|
)
|
||||||
|
moreRemoteRecips <-
|
||||||
|
lift $
|
||||||
|
deliverLocal'
|
||||||
|
True
|
||||||
|
(LocalActorSharer shrUser)
|
||||||
|
(personInbox personUser)
|
||||||
|
obiid
|
||||||
|
(localRecipSieve sieve False localRecips)
|
||||||
|
unless (federation || null moreRemoteRecips) $
|
||||||
|
throwE "Federation disabled, but recipient collection remote members found"
|
||||||
|
lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips
|
||||||
|
maccept <-
|
||||||
|
case widIdent ticketDetail of
|
||||||
|
Right _ -> return Nothing
|
||||||
|
Left (wi, ltid) -> Just <$> do
|
||||||
|
let local =
|
||||||
|
case ticket of
|
||||||
|
Left l -> l
|
||||||
|
Right _ -> error "Impossible wi"
|
||||||
|
mhoster <-
|
||||||
|
case local of
|
||||||
|
Left (shr, _) -> lift $ runMaybeT $ do
|
||||||
|
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||||
|
p <- MaybeT (getValBy $ UniquePersonIdent sid)
|
||||||
|
return (personOutbox p, personInbox p)
|
||||||
|
Right (shr, rp, _) -> runMaybeT $ do
|
||||||
|
sid <- MaybeT $ lift $ getKeyBy $ UniqueSharer shr
|
||||||
|
r <- MaybeT (lift $ getValBy $ UniqueRepo rp sid)
|
||||||
|
unless (repoVcs r == patchMediaTypeVCS typ) $
|
||||||
|
lift $ throwE "Patch type and repo VCS mismatch"
|
||||||
|
return (repoOutbox r, repoInbox r)
|
||||||
|
(obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB"
|
||||||
|
obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now
|
||||||
|
tid <- lift $ localTicketTicket <$> getJust ltid
|
||||||
|
bnid <- lift $ insert $ Bundle tid
|
||||||
|
lift $ insertMany_ $ NE.toList $ NE.map (Patch bnid now typ) diffs
|
||||||
|
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
|
lift $ insertAccept shrUser local ticketDetail obiid obiidAccept bnid
|
||||||
|
knownRemoteRecipsAccept <-
|
||||||
|
lift $
|
||||||
|
deliverLocal'
|
||||||
|
False
|
||||||
|
(workItemActor wi)
|
||||||
|
ibidHoster
|
||||||
|
obiidAccept
|
||||||
|
localRecipsAccept
|
||||||
|
lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||||
|
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
|
return (obiid, doc, remotesHttpAdd, maccept)
|
||||||
|
lift $ do
|
||||||
|
forkWorker "addBundleC: async HTTP Offer delivery" $
|
||||||
|
deliverRemoteHttp' fwdHosts obiidAdd docAdd remotesHttpAdd
|
||||||
|
for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
|
||||||
|
forkWorker "addBundleC: async HTTP Accept delivery" $
|
||||||
|
deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
|
||||||
|
return obiidAdd
|
||||||
|
where
|
||||||
|
toWorkItem (Left (shr, talid)) = WorkItemSharerTicket shr talid True
|
||||||
|
toWorkItem (Right (shr, rp, ltid)) = WorkItemRepoProposal shr rp ltid
|
||||||
|
|
||||||
|
insertAddToOutbox shrUser now obid blinded = do
|
||||||
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
obiid <- insertEmptyOutboxItem obid now
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
obikhid <- encodeKeyHashid obiid
|
||||||
|
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||||
|
doc = Doc hLocal Activity
|
||||||
|
{ activityId = Just luAct
|
||||||
|
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||||
|
, activitySummary = summary
|
||||||
|
, activityAudience = blinded
|
||||||
|
, activitySpecific =
|
||||||
|
AddActivity $ AP.Add (Right $ AddBundle patches) uTarget
|
||||||
|
}
|
||||||
|
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
|
return (obiid, doc, luAct)
|
||||||
|
|
||||||
|
workItemActor (WorkItemSharerTicket shr _ _) = LocalActorSharer shr
|
||||||
|
workItemActor (WorkItemProjectTicket shr prj _) = LocalActorProject shr prj
|
||||||
|
workItemActor (WorkItemRepoProposal shr rp _) = LocalActorRepo shr rp
|
||||||
|
|
||||||
|
insertAccept shrUser local (WorkItemDetail _ ctx ticketAuthor) obiidAdd obiidAccept bnid = do
|
||||||
|
let wi = toWorkItem local
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
wiFollowers <- askWorkItemFollowers
|
||||||
|
wiBundleRoute <- getWiBundleRoute
|
||||||
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
|
||||||
|
obikhidAdd <- encodeKeyHashid obiidAdd
|
||||||
|
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||||
|
bnkhid <- encodeKeyHashid bnid
|
||||||
|
|
||||||
|
let audAuthor =
|
||||||
|
AudLocal
|
||||||
|
[LocalActorSharer shrUser]
|
||||||
|
[LocalPersonCollectionSharerFollowers shrUser]
|
||||||
|
audTicketContext = contextAudience ctx
|
||||||
|
audTicketAuthor = authorAudience ticketAuthor
|
||||||
|
audTicketFollowers = AudLocal [] [wiFollowers wi]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience $
|
||||||
|
audAuthor :
|
||||||
|
audTicketAuthor :
|
||||||
|
audTicketFollowers :
|
||||||
|
audTicketContext
|
||||||
|
|
||||||
|
actor = workItemActor wi
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
doc = Doc hLocal Activity
|
||||||
|
{ activityId =
|
||||||
|
Just $ encodeRouteLocal $
|
||||||
|
actorOutboxItem actor obikhidAccept
|
||||||
|
, activityActor = encodeRouteLocal $ renderLocalActor actor
|
||||||
|
, activitySummary = Nothing
|
||||||
|
, activityAudience = Audience recips [] [] [] [] []
|
||||||
|
, activitySpecific = AcceptActivity Accept
|
||||||
|
{ acceptObject =
|
||||||
|
encodeRouteHome $ SharerOutboxItemR shrUser obikhidAdd
|
||||||
|
, acceptResult =
|
||||||
|
Just $ encodeRouteLocal $ wiBundleRoute local bnkhid
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||||
|
where
|
||||||
|
getWiBundleRoute = do
|
||||||
|
hashLTID <- getEncodeKeyHashid
|
||||||
|
hashTALID <- getEncodeKeyHashid
|
||||||
|
return $ \ wi ->
|
||||||
|
case wi of
|
||||||
|
Left (shr, talid) ->
|
||||||
|
SharerProposalBundleR shr $ hashTALID talid
|
||||||
|
Right (shr, rp, ltid) ->
|
||||||
|
RepoProposalBundleR shr rp $ hashLTID ltid
|
||||||
|
|
||||||
parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
|
parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
|
||||||
parseComment luParent = do
|
parseComment luParent = do
|
||||||
route <- case decodeRouteLocal luParent of
|
route <- case decodeRouteLocal luParent of
|
||||||
|
|
|
||||||
|
|
@ -375,6 +375,11 @@ postSharerOutboxR shr = do
|
||||||
Just (SharerR shr') | shr' == shr -> return ()
|
Just (SharerR shr') | shr' == shr -> return ()
|
||||||
_ -> throwE "Can't post activity sttributed to someone else"
|
_ -> throwE "Can't post activity sttributed to someone else"
|
||||||
case specific of
|
case specific of
|
||||||
|
AddActivity (AP.Add obj target) ->
|
||||||
|
case obj of
|
||||||
|
Right (AddBundle patches) ->
|
||||||
|
addBundleC eperson sharer summary audience patches target
|
||||||
|
_ -> throwE "Unsupported Add 'object' type"
|
||||||
CreateActivity (Create obj mtarget) ->
|
CreateActivity (Create obj mtarget) ->
|
||||||
case obj of
|
case obj of
|
||||||
CreateNote note ->
|
CreateNote note ->
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue