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
|
||||
( noteC
|
||||
( addBundleC
|
||||
, noteC
|
||||
, createNoteC
|
||||
, createTicketC
|
||||
, followC
|
||||
|
|
@ -119,6 +120,207 @@ import Vervis.Patch
|
|||
import Vervis.Ticket
|
||||
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 luParent = do
|
||||
route <- case decodeRouteLocal luParent of
|
||||
|
|
|
|||
|
|
@ -375,6 +375,11 @@ postSharerOutboxR shr = do
|
|||
Just (SharerR shr') | shr' == shr -> return ()
|
||||
_ -> throwE "Can't post activity sttributed to someone else"
|
||||
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) ->
|
||||
case obj of
|
||||
CreateNote note ->
|
||||
|
|
|
|||
Loading…
Reference in a new issue