UI: Use the actor system for opening a ticket, and remove offerTicketC
This commit is contained in:
Pere Lev
parent
be569ab26d
commit
cb693184f8
4 changed files with 14 additions and 356 deletions
|
|
@ -26,7 +26,6 @@ module Vervis.API
|
|||
, createPatchTrackerC
|
||||
, createRepositoryC
|
||||
, followC
|
||||
, offerTicketC
|
||||
--, offerDepC
|
||||
, resolveC
|
||||
, undoC
|
||||
|
|
@ -1652,352 +1651,6 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
|
|||
}
|
||||
}
|
||||
|
||||
offerTicketC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe
|
||||
(Either
|
||||
(LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
|
||||
FedURI
|
||||
)
|
||||
-> RecipientRoutes
|
||||
-> [(Host, NonEmpty LocalURI)]
|
||||
-> [Host]
|
||||
-> AP.Action URIMode
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action ticket uTarget = do
|
||||
|
||||
-- Check input
|
||||
verifyNothingE maybeCap "Capability not needed"
|
||||
(title, desc, source, tam) <- do
|
||||
hostLocal <- asksSite siteInstanceHost
|
||||
WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget
|
||||
unless (wioAuthor == Left senderPersonID) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
return (wioTitle, wioDesc, wioSource, wioRest)
|
||||
|
||||
-- Verify that the target tracker is addressed by the Offer
|
||||
case tam of
|
||||
TAM_Task deckID -> do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
unless (actorIsAddressed localRecips $ LocalActorDeck deckHash) $
|
||||
throwE "Local target deck not addressed by the Offer"
|
||||
TAM_Merge loomID _ -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
unless (actorIsAddressed localRecips $ LocalActorLoom loomHash) $
|
||||
throwE "Local target loom not addressed by the Offer"
|
||||
TAM_Remote uTracker _ -> verifyRemoteAddressed remoteRecips uTracker
|
||||
|
||||
senderHash <- encodeKeyHashid senderPersonID
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
-- If tracker is a local loom, and a remote origin repo is specified, fetch
|
||||
-- that repo's AP object via HTTP and remember in DB
|
||||
maybeLocalTracker <-
|
||||
case tam of
|
||||
TAM_Task deckID -> pure $ Just $ Left deckID
|
||||
TAM_Merge loomID (Merge maybeOriginTip maybeBundle targetTip) -> do
|
||||
maybeOrigin <- for maybeOriginTip $ \case
|
||||
TipLocalRepo repoID -> pure $ Left (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch)
|
||||
TipRemote uOrigin -> Right <$> do
|
||||
(vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
|
||||
return (vcs, raid, uClone, first Just <$> mb)
|
||||
TipRemoteBranch uRepo branch -> Right <$> do
|
||||
(vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
|
||||
return (vcs, raid, uClone, Just (Nothing, branch))
|
||||
originOrBundle <-
|
||||
fromMaybeE
|
||||
(align maybeOrigin maybeBundle)
|
||||
"MR provides neither origin nor patches"
|
||||
(targetRepoID, maybeTargetBranch) <-
|
||||
case targetTip of
|
||||
TipLocalRepo repoID -> pure (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure (repoID, Just branch)
|
||||
_ -> throwE "Offer target is a local loom but MR target is a remote repo (Looms serve only local repos)"
|
||||
return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch)
|
||||
TAM_Remote _ _ -> pure Nothing
|
||||
|
||||
(offerID, deliverHttpOffer, maybeAcceptMaybePull) <- runDBExcept $ do
|
||||
|
||||
-- If target tracker is local, find it in our DB
|
||||
-- If that tracker is a loom, find and check the MR too
|
||||
maybeLocalTrackerDB <- for maybeLocalTracker $ bitraverse
|
||||
(\ deckID -> do
|
||||
deck <- getE deckID "Offer local target no such deck in DB"
|
||||
return (deckID, deckActor deck)
|
||||
)
|
||||
(\ (loomID, originOrBundle, targetRepoID, maybeTargetBranch) -> do
|
||||
loom <- getE loomID "Offer local target no such loom in DB"
|
||||
|
||||
unless (targetRepoID == loomRepo loom) $
|
||||
throwE "MR target repo isn't the one served by the Offer target loom"
|
||||
targetRepo <- getE targetRepoID "MR target local repo not found in DB"
|
||||
unless (repoLoom targetRepo == Just loomID) $
|
||||
throwE "Offer target loom doesn't have repo's consent to serve it"
|
||||
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
unless (repoVcs targetRepo == patchMediaTypeVCS typ) $
|
||||
throwE "Patch type and local target repo VCS mismatch"
|
||||
case (typ, diffs) of
|
||||
(PatchMediaTypeDarcs, _ :| _ : _) ->
|
||||
throwE "More than one Darcs dpatch file provided"
|
||||
_ -> pure ()
|
||||
|
||||
originOrBundle' <-
|
||||
bitraverse
|
||||
(\ origin -> do
|
||||
(vcs, origin') <-
|
||||
case origin of
|
||||
Left (repoID, maybeBranch) -> do
|
||||
repo <- getE repoID "MR origin local repo not found in DB"
|
||||
return (repoVcs repo, Left (repoID, maybeBranch))
|
||||
Right (vcs, remoteActorID, uClone, maybeBranch) ->
|
||||
pure (vcs, Right (remoteActorID, uClone, maybeBranch))
|
||||
unless (vcs == repoVcs targetRepo) $
|
||||
throwE "Origin repo VCS differs from target repo VCS"
|
||||
return origin'
|
||||
)
|
||||
pure
|
||||
originOrBundle
|
||||
|
||||
-- Verify that the VCS of target repo, origin repo and patches
|
||||
-- all match, and that branches are specified for Git and
|
||||
-- aren't specified for Darcs
|
||||
tipInfo <- case repoVcs targetRepo of
|
||||
VCSGit -> do
|
||||
targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
|
||||
maybeOrigin <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
|
||||
return (Left originRepoID, originBranch)
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
(_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
|
||||
return (Right uClone, originBranch)
|
||||
return $ Left (targetBranch, maybeOrigin)
|
||||
VCSDarcs -> do
|
||||
verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
|
||||
maybeOriginRepo <- for (justHere originOrBundle') $ \case
|
||||
Left (originRepoID, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
|
||||
return $ Left originRepoID
|
||||
Right (_remoteActorID, uClone, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
|
||||
return $ Right uClone
|
||||
return $ Right $ maybeOriginRepo
|
||||
|
||||
return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch, tipInfo)
|
||||
)
|
||||
|
||||
-- Insert Offer to sender's outbox
|
||||
offerID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
luOffer <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) offerID action
|
||||
|
||||
-- Deliver the Offer activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpOffer <- do
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
let tipRepo tip =
|
||||
case tip of
|
||||
TipLocalRepo repoID -> Just $ hashRepo repoID
|
||||
TipLocalBranch repoID _ -> Just $ hashRepo repoID
|
||||
_ -> Nothing
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
let (tracker, target, origin) =
|
||||
case tam of
|
||||
TAM_Task deckID ->
|
||||
( Just $ Left $ hashDeck deckID
|
||||
, Nothing
|
||||
, Nothing
|
||||
)
|
||||
TAM_Merge loomID (Merge maybeOriginTip _ targetTip) ->
|
||||
( Just $ Right $ hashLoom loomID
|
||||
, tipRepo targetTip
|
||||
, tipRepo =<< maybeOriginTip
|
||||
)
|
||||
TAM_Remote _ maybeMerge ->
|
||||
( Nothing
|
||||
, tipRepo . mergeTarget =<< maybeMerge
|
||||
, tipRepo =<< mergeOrigin =<< maybeMerge
|
||||
)
|
||||
sieveActors = catMaybes
|
||||
[ tracker <&> \case
|
||||
Left deckHash -> LocalActorDeck deckHash
|
||||
Right loomHash -> LocalActorLoom loomHash
|
||||
, LocalActorRepo <$> target
|
||||
, LocalActorRepo <$> origin
|
||||
]
|
||||
sieveStages = catMaybes
|
||||
[ tracker <&> \case
|
||||
Left deckHash -> LocalStageDeckFollowers deckHash
|
||||
Right loomHash -> LocalStageLoomFollowers loomHash
|
||||
, LocalStageRepoFollowers <$> target
|
||||
, LocalStageRepoFollowers <$> origin
|
||||
, Just $ LocalStagePersonFollowers senderHash
|
||||
]
|
||||
sieve = makeRecipientSet sieveActors sieveStages
|
||||
localRecipsFinal = localRecipSieve sieve False localRecips
|
||||
deliverActivityDB
|
||||
(LocalActorPerson senderHash) (personActor senderPerson)
|
||||
localRecipsFinal remoteRecips fwdHosts offerID action
|
||||
|
||||
-- If Offer target is a local deck/loom, verify that it has received
|
||||
-- the Offer, insert a new Ticket to DB, and publish Accept
|
||||
maybeAcceptMaybePull <- for maybeLocalTrackerDB $ \ tracker -> do
|
||||
|
||||
-- Verify that tracker received the Offer
|
||||
let trackerActorID =
|
||||
case tracker of
|
||||
Left (_, actorID) -> actorID
|
||||
Right (_, actorID, _, _, _, _) -> actorID
|
||||
verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer"
|
||||
|
||||
-- Insert ticket/MR to DB
|
||||
acceptID <- lift $ do
|
||||
trackerActor <- getJust trackerActorID
|
||||
insertEmptyOutboxItem (actorOutbox trackerActor) now
|
||||
(ticketRoute, maybePull) <- lift $ do
|
||||
ticketID <- insertTicket now title desc source offerID acceptID
|
||||
case tracker of
|
||||
Left (deckID, _) ->
|
||||
(,Nothing) <$> insertTask deckID ticketID
|
||||
Right (loomID, _, originOrBundle, targetRepoID, maybeTargetBranch, tipInfo) -> do
|
||||
(clothID, route) <- insertMerge now loomID ticketID maybeTargetBranch originOrBundle
|
||||
let maybeTipInfo =
|
||||
case tipInfo of
|
||||
Left (b, mo) -> Left . (b,) <$> mo
|
||||
Right mo -> Right <$> mo
|
||||
hasBundle = isJust $ justThere originOrBundle
|
||||
pull = (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||
return (route, pull)
|
||||
|
||||
-- Insert an Accept activity to tracker's outbox
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
let acceptRecipActors = [LocalActorPerson senderHash]
|
||||
acceptRecipStages =
|
||||
[ case tracker of
|
||||
Left (deckID, _) ->
|
||||
LocalStageDeckFollowers $ hashDeck deckID
|
||||
Right (loomID, _, _, _, _, _) ->
|
||||
LocalStageLoomFollowers $ hashLoom loomID
|
||||
, LocalStagePersonFollowers senderHash
|
||||
]
|
||||
actionAccept <- prepareAccept ticketRoute luOffer acceptRecipActors acceptRecipStages
|
||||
let trackerByKey =
|
||||
case tracker of
|
||||
Left (deckID, _) -> LocalActorDeck deckID
|
||||
Right (loomID, _, _, _, _, _) -> LocalActorLoom loomID
|
||||
_luAccept <- lift $ updateOutboxItem trackerByKey acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
deliverHttpAccept <- do
|
||||
let trackerLocalActor =
|
||||
case tracker of
|
||||
Left (deckID, _) ->
|
||||
LocalActorDeck $ hashDeck deckID
|
||||
Right (loomID, _, _, _, _, _) ->
|
||||
LocalActorLoom $ hashLoom loomID
|
||||
localRecipsAccept =
|
||||
makeRecipientSet acceptRecipActors acceptRecipStages
|
||||
deliverActivityDB
|
||||
trackerLocalActor trackerActorID localRecipsAccept [] []
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients, and
|
||||
-- info for pulling origin branch to generate patches
|
||||
return (deliverHttpAccept, maybePull)
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients, and info
|
||||
-- for pulling origin branch to generate patches
|
||||
return (offerID, deliverHttpOffer, maybeAcceptMaybePull)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of Offer and Accept, and generate
|
||||
-- patches if we opened a local MR that mentions just an origin
|
||||
lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
|
||||
for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do
|
||||
lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept
|
||||
VA2.runActE $ traverse generatePatches maybePull
|
||||
|
||||
return offerID
|
||||
|
||||
where
|
||||
|
||||
insertTicket now title desc source offerID acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
insert_ TicketAuthorLocal
|
||||
{ ticketAuthorLocalTicket = tid
|
||||
, ticketAuthorLocalAuthor = senderPersonID
|
||||
, ticketAuthorLocalOpen = offerID
|
||||
}
|
||||
return tid
|
||||
|
||||
insertTask deckID ticketID = do
|
||||
ticketDeckID <- insert $ TicketDeck ticketID deckID
|
||||
TicketR <$> encodeKeyHashid deckID <*> encodeKeyHashid ticketDeckID
|
||||
|
||||
insertMerge
|
||||
:: UTCTime
|
||||
-> LoomId
|
||||
-> TicketId
|
||||
-> Maybe Text
|
||||
-> These
|
||||
(Either
|
||||
(RepoId, Maybe Text)
|
||||
(RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
|
||||
)
|
||||
Material
|
||||
-> AppDB (TicketLoomId, Route App)
|
||||
insertMerge now loomID ticketID maybeBranch originOrBundle = do
|
||||
clothID <- insert $ TicketLoom ticketID loomID maybeBranch
|
||||
for_ (justHere originOrBundle) $ \case
|
||||
Left (repoID, maybeOriginBranch) ->
|
||||
insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
|
||||
Right (remoteActorID, _uClone, maybeOriginBranch) -> do
|
||||
originID <- insert $ MergeOriginRemote clothID remoteActorID
|
||||
for_ maybeOriginBranch $ \ (mlu, b) ->
|
||||
insert_ $ MergeOriginRemoteBranch originID mlu b
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
bundleID <- insert $ Bundle clothID False
|
||||
insertMany_ $ NE.toList $ NE.reverse $
|
||||
NE.map (Patch bundleID now typ) diffs
|
||||
route <- ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID
|
||||
return (clothID, route)
|
||||
|
||||
prepareAccept ticketRoute luOffer actors stages = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let recips =
|
||||
map encodeRouteHome $
|
||||
map renderLocalActor actors ++
|
||||
map renderLocalStage stages
|
||||
return Action
|
||||
{ actionCapability = Nothing
|
||||
, actionSummary = Nothing
|
||||
, actionAudience = Audience recips [] [] [] [] []
|
||||
, actionFulfills = []
|
||||
, actionSpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult = Just $ encodeRouteLocal ticketRoute
|
||||
}
|
||||
}
|
||||
|
||||
{-
|
||||
verifyHosterRecip _ _ (Right _) = return ()
|
||||
verifyHosterRecip localRecips name (Left wi) =
|
||||
|
|
|
|||
|
|
@ -689,7 +689,7 @@ postPublishR = do
|
|||
<|> ResultCreateMR <$> result7
|
||||
<|> ResultOfferMR <$> result8
|
||||
|
||||
ep@(Entity _ p) <- requireVerifiedAuth
|
||||
ep@(Entity pid p) <- requireVerifiedAuth
|
||||
s <- runDB $ getJust $ personIdent p
|
||||
let shrAuthor = sharerIdent s
|
||||
|
||||
|
|
@ -1063,7 +1063,8 @@ postPublishOfferMergeR = do
|
|||
omgOriginRepo (Just omgOriginBranch)
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
makeServerInput Nothing summary audience $ AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) omgTracker
|
||||
offerID <- offerTicketC ep a Nothing localRecips remoteRecips fwdHosts action ticket omgTracker
|
||||
offerID <-
|
||||
handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
|
||||
if trackerLocal
|
||||
then nameExceptT "Offer published but" $ runDBExcept $ do
|
||||
ticketID <- do
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -684,9 +684,7 @@ postClothNewR loomHash = do
|
|||
lift $ C.makeServerInput Nothing maybeSummary audience $
|
||||
AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uLoom
|
||||
offerID <-
|
||||
offerTicketC
|
||||
person senderActor Nothing localRecips remoteRecips fwdHosts action
|
||||
ticket uLoom
|
||||
handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
|
||||
runDBExcept $ do
|
||||
mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
|
||||
tal <- fromMaybeE mtal "Offer processed bu no ticket created"
|
||||
|
|
|
|||
|
|
@ -460,17 +460,22 @@ postTicketNewR deckHash = do
|
|||
lift $ C.makeServerInput Nothing maybeSummary audience $
|
||||
AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uDeck
|
||||
offerID <-
|
||||
offerTicketC
|
||||
person actor Nothing localRecips remoteRecips fwdHosts action
|
||||
ticket uDeck
|
||||
handleViaActor pid Nothing localRecips remoteRecips fwdHosts action
|
||||
{-
|
||||
runDBExcept $ do
|
||||
mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
|
||||
tal <- fromMaybeE mtal "Offer processed bu no ticket created"
|
||||
return $ ticketAuthorLocalTicket tal
|
||||
-}
|
||||
return ()
|
||||
case errorOrTicket of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect $ TicketNewR deckHash
|
||||
Right () -> do
|
||||
setMessage "Offer activity sent"
|
||||
redirect $ DeckTicketsR deckHash
|
||||
{-
|
||||
Right ticketID -> do
|
||||
taskID <- do
|
||||
maybeTaskID <- runDB $ getKeyBy $ UniqueTicketDeck ticketID
|
||||
|
|
@ -480,6 +485,7 @@ postTicketNewR deckHash = do
|
|||
taskHash <- encodeKeyHashid taskID
|
||||
setMessage "Ticket created"
|
||||
redirect $ TicketR deckHash taskHash
|
||||
-}
|
||||
|
||||
postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler ()
|
||||
postTicketFollowR _ = error "Temporarily disabled"
|
||||
|
|
|
|||
Loading…
Reference in a new issue