S2S: Deck: Port the Offer{Ticket} handler from the old code

This commit is contained in:
Pere Lev 2023-11-03 10:56:25 +02:00
parent 7edb7a9760
commit 1694d77705
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
9 changed files with 247 additions and 209 deletions

View file

@ -130,6 +130,8 @@ import Vervis.Ticket
import Vervis.Web.Delivery import Vervis.Web.Delivery
import Vervis.Web.Repo import Vervis.Web.Repo
import qualified Vervis.Actor2 as VA2
handleViaActor handleViaActor
:: PersonId :: PersonId
-> Maybe -> Maybe
@ -626,7 +628,7 @@ applyC
applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action apply = do applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action apply = do
-- Check input -- Check input
maybeLocalTarget <- checkApplyLocalLoom apply maybeLocalTarget <- VA2.runActE $ checkApplyLocalLoom apply
capID <- fromMaybeE maybeCap "No capability provided" capID <- fromMaybeE maybeCap "No capability provided"
-- Verify that the bundle's loom is addressed -- Verify that the bundle's loom is addressed
@ -1530,7 +1532,7 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
-- Check input -- Check input
verifyNothingE maybeCap "Capability not needed" verifyNothingE maybeCap "Capability not needed"
(followee, hide) <- parseFollow follow (followee, hide) <- VA2.runActE $ parseFollow follow
case followee of case followee of
Left (FolloweeActor (LocalActorPerson personID)) Left (FolloweeActor (LocalActorPerson personID))
| personID == senderPersonID -> | personID == senderPersonID ->
@ -1672,7 +1674,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci
verifyNothingE maybeCap "Capability not needed" verifyNothingE maybeCap "Capability not needed"
(title, desc, source, tam) <- do (title, desc, source, tam) <- do
hostLocal <- asksSite siteInstanceHost hostLocal <- asksSite siteInstanceHost
WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget
unless (wioAuthor == Left senderPersonID) $ unless (wioAuthor == Left senderPersonID) $
throwE "Offering a Ticket attributed to someone else" throwE "Offering a Ticket attributed to someone else"
return (wioTitle, wioDesc, wioSource, wioRest) return (wioTitle, wioDesc, wioSource, wioRest)
@ -2345,7 +2347,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r
(\ r -> do (\ r -> do
wiByHash <- wiByHash <-
fromMaybeE (parseWorkItem r) "Not a work item route" fromMaybeE (parseWorkItem r) "Not a work item route"
unhashWorkItemE wiByHash "Work item invalid keyhashid" VA2.runActE $ unhashWorkItemE wiByHash "Work item invalid keyhashid"
) )
pure pure
routeOrRemote routeOrRemote
@ -2593,7 +2595,7 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo
return Nothing return Nothing
Just (Right (updateDB, ticketID)) -> do Just (Right (updateDB, ticketID)) -> do
wiByKey <- lift $ getWorkItem ticketID wiByKey <- lift $ getWorkItem ticketID
wiByHash <- hashWorkItem wiByKey wiByHash <- lift $ lift $ VA2.runAct $ hashWorkItem wiByKey
let resource = workItemResource wiByKey let resource = workItemResource wiByKey
actorByKey = workItemActor wiByKey actorByKey = workItemActor wiByKey
actorByHash = workItemActor wiByHash actorByHash = workItemActor wiByHash

View file

@ -63,11 +63,12 @@ import Vervis.Cloth
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Data.Discussion import Vervis.Data.Discussion
import Vervis.Data.Ticket
import Vervis.FedURI import Vervis.FedURI
import Vervis.Federation.Util import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model hiding (deckCreate) import Vervis.Model hiding (deckCreate)
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers)
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
@ -314,6 +315,176 @@ deckCreate now deckID verse (AP.Create obj _muTarget) =
_ -> throwE "Unsupported Create object for Deck" _ -> throwE "Unsupported Create object for Deck"
-- Meaning: An actor A is offering a ticket or a ticket dependency
-- Behavior:
-- * Verify I'm the target
-- * Insert the Offer to my inbox
-- * Create the new ticket in my DB
-- * Forward the Offer to my followers
-- * Publish an Accept to:
-- - My followers
-- - Offer sender+followers
deckOffer
:: UTCTime
-> DeckId
-> Verse
-> AP.Offer URIMode
-> ActE (Text, Act (), Next)
deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
-- Check input
(title, desc, source) <- do
ticket <-
case object of
AP.OfferTicket t -> pure t
_ -> throwE "Unsupported Offer.object type"
ObjURI hAuthor _ <- lift $ getActorURI authorIdMsig
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
unless (bimap LocalActorPerson id wioAuthor == author) $
throwE "Offering a Ticket attributed to someone else"
case wioRest of
TAM_Task deckID' ->
if deckID' == deckID
then return ()
else throwE
"Offer target is some other local deck, so I have \
\no use for this Offer. Was I supposed to receive \
\it?"
TAM_Merge _ _ ->
throwE
"Offer target is some local loom, so I have no use for \
\this Offer. Was I supposed to receive it?"
TAM_Remote _ _ ->
throwE
"Offer target is some remote tracker, so I have no use \
\for this Offer. Was I supposed to receive it?"
return (wioTitle, wioDesc, wioSource)
-- Verify the capability URI, if provided, is one of:
-- * Outbox item URI of a local actor, i.e. a local activity
-- * A remote URI
maybeCapability <-
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
nameExceptT "Offer.capability" $
first (\ (actor, _, item) -> (actor, item)) <$>
parseActivityURI' uCap
maybeNew <- withDBExcept $ do
-- Grab me from DB
(deckRecip, actorRecip) <- lift $ do
d <- getJust deckID
(d,) <$> getJust (deckActor d)
-- Insert the Offer to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
for mractid $ \ offerDB -> do
-- If a capability is provided, check it
for_ maybeCapability $ \ cap -> do
lcap <-
case cap of
Left c -> pure c
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
verifyCapability'
lcap
authorIdMsig
(GrantResourceDeck deckID)
AP.RoleReport
-- Prepare forwarding the Offer to my followers
let recipByID = grantResourceLocalActor $ GrantResourceDeck deckID
recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
-- Insert the new ticket to our DB
acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
offerDB' <-
bitraverse
(traverseOf _1 $ \case
LocalActorPerson personID -> pure personID
_ -> throwE "Local non-Person ticket authors not allowed"
)
pure
offerDB
taskID <- lift $ insertTask now title desc source deckID offerDB' acceptID
-- Prepare an Accept activity and insert to my outbox
accept@(actionAccept, _, _, _) <- lift $ prepareAccept taskID
let recipByKey = LocalActorDeck deckID
_luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
return (deckActor deckRecip, sieve, acceptID, accept)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (deckActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
forwardActivity
authorIdMsig body (LocalActorDeck deckID) deckActorID sieve
lift $ sendActivity
(LocalActorDeck deckID) deckActorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
done "Opened a ticket and forwarded the Offer"
where
insertTask now title desc source deckID offerDB 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
}
case offerDB of
Left (personID, _, offerID) ->
insert_ TicketAuthorLocal
{ ticketAuthorLocalTicket = tid
, ticketAuthorLocalAuthor = personID
, ticketAuthorLocalOpen = offerID
}
Right (author, _, offerID) ->
insert_ TicketAuthorRemote
{ ticketAuthorRemoteTicket = tid
, ticketAuthorRemoteAuthor = remoteAuthorId author
, ticketAuthorRemoteOpen = offerID
}
insert $ TicketDeck tid deckID
prepareAccept taskID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
audSender <- makeAudSenderWithFollowers authorIdMsig
deckHash <- encodeKeyHashid deckID
taskHash <- encodeKeyHashid taskID
let audDeck = AudLocal [] [LocalStageDeckFollowers deckHash]
uOffer <- lift $ getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audSender, audDeck]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uOffer]
, AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = uOffer
, AP.acceptResult =
Just $ encodeRouteLocal $ TicketR deckHash taskHash
}
}
return (action, recipientSet, remoteActors, fwdHosts)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Following -- Following
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -746,6 +917,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
AP.GrantActivity grant -> deckGrant now deckID verse grant AP.GrantActivity grant -> deckGrant now deckID verse grant
AP.InviteActivity invite -> deckInvite now deckID verse invite AP.InviteActivity invite -> deckInvite now deckID verse invite
AP.JoinActivity join -> deckJoin now deckID verse join AP.JoinActivity join -> deckJoin now deckID verse join
AP.OfferActivity offer -> deckOffer now deckID verse offer
AP.RejectActivity reject -> deckReject now deckID verse reject AP.RejectActivity reject -> deckReject now deckID verse reject
AP.RemoveActivity remove -> deckRemove now deckID verse remove AP.RemoveActivity remove -> deckRemove now deckID verse remove
AP.UndoActivity undo -> deckUndo now deckID verse undo AP.UndoActivity undo -> deckUndo now deckID verse undo

View file

@ -315,7 +315,7 @@ offerIssue
offerIssue senderHash title desc uTracker = do offerIssue senderHash title desc uTracker = do
tracker <- do tracker <- do
tracker <- checkTracker uTracker tracker <- runActE $ checkTracker uTracker
case tracker of case tracker of
TrackerDeck deckID -> Left <$> encodeKeyHashid deckID TrackerDeck deckID -> Left <$> encodeKeyHashid deckID
TrackerLoom _ -> throwE "Local patch tracker doesn't take issues" TrackerLoom _ -> throwE "Local patch tracker doesn't take issues"
@ -619,7 +619,7 @@ offerPatches
offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
tracker <- do tracker <- do
tracker <- checkTracker uTracker tracker <- runActE $ checkTracker uTracker
case tracker of case tracker of
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches" TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
@ -709,7 +709,7 @@ offerMerge
offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
tracker <- do tracker <- do
tracker <- checkTracker uTracker tracker <- runActE $ checkTracker uTracker
case tracker of case tracker of
TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches" TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
TrackerLoom loomID -> Left <$> encodeKeyHashid loomID TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
@ -790,7 +790,7 @@ applyPatches
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode) -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
applyPatches senderHash uObject = do applyPatches senderHash uObject = do
bundle <- parseBundleRoute "Apply object" uObject bundle <- runActE $ parseBundleRoute "Apply object" uObject
mrInfo <- mrInfo <-
bifor bundle bifor bundle
(\ (loomID, clothID, _) -> do (\ (loomID, clothID, _) -> do

View file

@ -25,6 +25,7 @@ module Vervis.Data.Actor
, parseLocalURI , parseLocalURI
, parseFedURIOld , parseFedURIOld
, parseLocalActorE , parseLocalActorE
, parseLocalActorE'
) )
where where
@ -189,3 +190,8 @@ parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
parseLocalActorE route = do parseLocalActorE route = do
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
unhashLocalActorE actorByHash "Invalid actor keyhashid" unhashLocalActorE actorByHash "Invalid actor keyhashid"
parseLocalActorE' :: Route App -> VA.ActE (LocalActorBy Key)
parseLocalActorE' route = do
actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
VA.unhashLocalActorE actorByHash "Invalid actor keyhashid"

View file

@ -29,7 +29,10 @@ import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Types import Database.Persist.Types
import Control.Concurrent.Actor
import Network.FedURI import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -39,12 +42,13 @@ import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Vervis.Actor
import Vervis.Data.Actor import Vervis.Data.Actor
import Vervis.Data.Ticket import Vervis.Data.Ticket
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Recipient import Vervis.Recipient (parseLocalActor)
data FolloweeBy f data FolloweeBy f
= FolloweeActor (LocalActorBy f) = FolloweeActor (LocalActorBy f)
@ -59,10 +63,9 @@ unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE w
parseFollow parseFollow
:: AP.Follow URIMode :: AP.Follow URIMode
-> ExceptT Text Handler -> ActE (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
(Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
parseFollow (AP.Follow uObject mluContext hide) = do parseFollow (AP.Follow uObject mluContext hide) = do
routeOrRemote <- parseFedURIOld uObject routeOrRemote <- parseFedURI uObject
(,hide) <$> (,hide) <$>
bitraverse bitraverse
(parseLocal mluContext) (parseLocal mluContext)
@ -77,7 +80,7 @@ parseFollow (AP.Follow uObject mluContext hide) = do
byKey <- unhashFolloweeE byHash "Followee invalid keyhashid" byKey <- unhashFolloweeE byHash "Followee invalid keyhashid"
for_ mlu $ \ lu -> nameExceptT "Follow context" $ do for_ mlu $ \ lu -> nameExceptT "Follow context" $ do
actorR <- parseLocalURI lu actorR <- parseLocalURI lu
actorByKey <- parseLocalActorE actorR actorByKey <- parseLocalActorE' actorR
unless (actorByKey == followeeActor byKey) $ unless (actorByKey == followeeActor byKey) $
throwE "Isn't object's actor" throwE "Isn't object's actor"
return byKey return byKey

View file

@ -62,8 +62,11 @@ import Yesod.Core
import qualified Control.Monad.Fail as F import qualified Control.Monad.Fail as F
import Control.Concurrent.Actor
import Development.PatchMediaType import Development.PatchMediaType
import Network.FedURI import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Web.Text import Web.Text
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Actor import Yesod.Actor
@ -72,9 +75,11 @@ import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import qualified Web.Actor.Persist as WAP
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Vervis.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Foundation import Vervis.Foundation
import Vervis.FedURI import Vervis.FedURI
@ -112,25 +117,25 @@ data WorkItemOffer = WorkItemOffer
, wioRest :: TrackerAndMerge , wioRest :: TrackerAndMerge
} }
checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI) checkAuthor :: FedURI -> ActE (Either PersonId FedURI)
checkAuthor u@(ObjURI h lu) = do checkAuthor u@(ObjURI h lu) = do
hl <- hostIsLocalOld h hl <- hostIsLocal h
if hl if hl
then do then do
route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route" route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route"
case route of case route of
PersonR personHash -> Left <$> decodeKeyHashidE personHash "Local author invalid person hash" PersonR personHash -> Left <$> WAP.decodeKeyHashidE personHash "Local author invalid person hash"
_ -> throwE "Local author not a person route" _ -> throwE "Local author not a person route"
else pure $ Right u else pure $ Right u
checkPatch :: Host -> AP.Patch URIMode -> ExceptT Text Handler (Either PersonId FedURI, PatchMediaType, Text) checkPatch :: Host -> AP.Patch URIMode -> ActE (Either PersonId FedURI, PatchMediaType, Text)
checkPatch h (AP.Patch mlocal attrib mpub typ content) = do checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
verifyNothingE mlocal "Patch has 'id'" verifyNothingE mlocal "Patch has 'id'"
author <- checkAuthor $ ObjURI h attrib author <- checkAuthor $ ObjURI h attrib
verifyNothingE mpub "Patch has 'published'" verifyNothingE mpub "Patch has 'published'"
return (author, typ, content) return (author, typ, content)
checkBundle :: Host -> AP.Bundle URIMode -> ExceptT Text Handler (Either PersonId FedURI, Material) checkBundle :: Host -> AP.Bundle URIMode -> ActE (Either PersonId FedURI, Material)
checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs" checkBundle _ (AP.BundleHosted _ _) = throwE "Patches specified as URIs"
checkBundle h (AP.BundleOffer mlocal patches) = do checkBundle h (AP.BundleOffer mlocal patches) = do
verifyNothingE mlocal "Bundle has 'id'" verifyNothingE mlocal "Bundle has 'id'"
@ -142,30 +147,29 @@ checkBundle h (AP.BundleOffer mlocal patches) = do
unless (all (== typ) typs) $ throwE "Different patch types" unless (all (== typ) typs) $ throwE "Different patch types"
return (author, Material typ (content :| contents)) return (author, Material typ (content :| contents))
checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI) checkTipURI :: FedURI -> ActE (Either RepoId FedURI)
checkTipURI u@(ObjURI h lu) = do checkTipURI u@(ObjURI h lu) = do
hl <- hostIsLocalOld h hl <- hostIsLocal h
if hl if hl
then Left <$> do then Left <$> do
route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route" route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route"
case route of case route of
RepoR repoHash -> decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid" RepoR repoHash -> WAP.decodeKeyHashidE repoHash "URI is local repo route but repo hash is invalid"
_ -> throwE "URI is local route but not a repo route" _ -> throwE "URI is local route but not a repo route"
else pure $ Right u else pure $ Right u
checkBranch :: Host -> AP.Branch URIMode -> ExceptT Text Handler (Either RepoId FedURI, Text) checkBranch :: Host -> AP.Branch URIMode -> ActE (Either RepoId FedURI, Text)
checkBranch h (AP.Branch name _ luRepo) = checkBranch h (AP.Branch name _ luRepo) =
(,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo) (,name) <$> nameExceptT "Branch repo" (checkTipURI $ ObjURI h luRepo)
checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ExceptT Text Handler Tip checkTip :: Either FedURI (Host, AP.Branch URIMode) -> ActE Tip
checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u checkTip (Left u) = either TipLocalRepo TipRemote <$> checkTipURI u
checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b checkTip (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b
checkMR checkMR
:: Host :: Host
-> AP.MergeRequest URIMode -> AP.MergeRequest URIMode
-> ExceptT Text Handler -> ActE (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
(Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
checkMR h (AP.MergeRequest muOrigin target mbundle) = checkMR h (AP.MergeRequest muOrigin target mbundle) =
(,,) (,,)
<$> traverse checkTip muOrigin <$> traverse checkTip muOrigin
@ -176,22 +180,22 @@ checkMR h (AP.MergeRequest muOrigin target mbundle) =
) )
<*> checkTip (bimap (ObjURI h) (h,) target) <*> checkTip (bimap (ObjURI h) (h,) target)
checkTracker :: FedURI -> ExceptT Text Handler Tracker checkTracker :: FedURI -> ActE Tracker
checkTracker u@(ObjURI h lu) = do checkTracker u@(ObjURI h lu) = do
hl <- hostIsLocalOld h hl <- hostIsLocal h
if hl if hl
then do then do
route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route" route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route"
case route of case route of
DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash" DeckR deckHash -> TrackerDeck <$> WAP.decodeKeyHashidE deckHash "Local tracker invalid deck hash"
LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash" LoomR loomHash -> TrackerLoom <$> WAP.decodeKeyHashidE loomHash "Local tracker invalid loom hash"
_ -> throwE "Local tracker not a deck/loom route" _ -> throwE "Local tracker not a deck/loom route"
else pure $ TrackerRemote u else pure $ TrackerRemote u
checkTicket checkTicket
:: Host :: Host
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> ExceptT Text Handler -> ActE
( Either PersonId FedURI ( Either PersonId FedURI
, Text, HTML, PandocMarkdown , Text, HTML, PandocMarkdown
, Maybe Tracker , Maybe Tracker
@ -214,14 +218,14 @@ checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary con
return $ Merge maybeOriginTip maybeBundle targetTip return $ Merge maybeOriginTip maybeBundle targetTip
return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge) return (author, decodeEntities summary, content, source, maybeTracker, maybeMerge)
checkTrackerAndMerge :: Tracker -> Maybe Merge -> ExceptT Text Handler TrackerAndMerge checkTrackerAndMerge :: Tracker -> Maybe Merge -> ActE TrackerAndMerge
checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID checkTrackerAndMerge (TrackerDeck deckID) Nothing = pure $ TAM_Task deckID
checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR" checkTrackerAndMerge (TrackerDeck _) (Just _) = throwE "Deck & MR"
checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR" checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR"
checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge
checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge checkTrackerAndMerge (TrackerRemote uTracker) maybeMerge = pure $ TAM_Remote uTracker maybeMerge
checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler WorkItemOffer checkOfferTicket :: Host -> AP.Ticket URIMode -> FedURI -> ActE WorkItemOffer
checkOfferTicket host ticket uTarget = do checkOfferTicket host ticket uTarget = do
target <- checkTracker uTarget target <- checkTracker uTarget
(author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket (author, title, desc, source, maybeTracker, maybeBundle) <- checkTicket host ticket
@ -231,7 +235,7 @@ checkOfferTicket host ticket uTarget = do
return $ WorkItemOffer author title desc source tam return $ WorkItemOffer author title desc source tam
parseBundleRoute name u@(ObjURI h lu) = do parseBundleRoute name u@(ObjURI h lu) = do
hl <- hostIsLocalOld h hl <- hostIsLocal h
if hl if hl
then Left <$> do then Left <$> do
route <- route <-
@ -240,24 +244,22 @@ parseBundleRoute name u@(ObjURI h lu) = do
case route of case route of
BundleR loom ticket bundle -> BundleR loom ticket bundle ->
(,,) (,,)
<$> decodeKeyHashidE loom (name <> ": Invalid lkhid") <$> WAP.decodeKeyHashidE loom (name <> ": Invalid lkhid")
<*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid") <*> WAP.decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
<*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid") <*> WAP.decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
_ -> throwE $ name <> ": not a bundle route" _ -> throwE $ name <> ": not a bundle route"
else return $ Right u else return $ Right u
checkApply checkApply
:: AP.Apply URIMode :: AP.Apply URIMode
-> ExceptT Text Handler -> ActE (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
(Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
checkApply (AP.Apply uObject target) = checkApply (AP.Apply uObject target) =
(,) <$> parseBundleRoute "Apply object" uObject (,) <$> parseBundleRoute "Apply object" uObject
<*> nameExceptT "Apply target" (checkTip target) <*> nameExceptT "Apply target" (checkTip target)
checkApplyLocalLoom checkApplyLocalLoom
:: AP.Apply URIMode :: AP.Apply URIMode
-> ExceptT Text Handler -> ActE (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
(Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
checkApplyLocalLoom apply = do checkApplyLocalLoom apply = do
(bundle, targetTip) <- checkApply apply (bundle, targetTip) <- checkApply apply
let maybeLocal = let maybeLocal =
@ -286,14 +288,14 @@ hashWorkItemPure ctx = f
WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c) WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)
getHashWorkItem getHashWorkItem
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
=> m (WorkItemBy Key -> WorkItemBy KeyHashid) => m (WorkItemBy Key -> WorkItemBy KeyHashid)
getHashWorkItem = do getHashWorkItem = do
ctx <- asksSite siteHashidsContext ctx <- asksEnv stageHashidsContext
return $ hashWorkItemPure ctx return $ hashWorkItemPure ctx
hashWorkItem hashWorkItem
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
=> WorkItemBy Key -> m (WorkItemBy KeyHashid) => WorkItemBy Key -> m (WorkItemBy KeyHashid)
hashWorkItem actor = do hashWorkItem actor = do
hash <- getHashWorkItem hash <- getHashWorkItem
@ -313,24 +315,24 @@ unhashWorkItemPure ctx = f
<*> decodeKeyHashidPure ctx c <*> decodeKeyHashidPure ctx c
unhashWorkItem unhashWorkItem
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
=> WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key)) => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
unhashWorkItem actor = do unhashWorkItem actor = do
ctx <- asksSite siteHashidsContext ctx <- asksEnv stageHashidsContext
return $ unhashWorkItemPure ctx actor return $ unhashWorkItemPure ctx actor
unhashWorkItemF unhashWorkItemF
:: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m)) :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
=> WorkItemBy KeyHashid -> String -> m (WorkItemBy Key) => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor
unhashWorkItemM unhashWorkItemM
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
=> WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key) => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
unhashWorkItemM = MaybeT . unhashWorkItem unhashWorkItemM = MaybeT . unhashWorkItem
unhashWorkItemE unhashWorkItemE
:: (MonadSite m, YesodHashids (SiteEnv m)) :: (MonadActor m, StageHashids (ActorEnv m))
=> WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key) => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
unhashWorkItemE actor e = unhashWorkItemE actor e =
ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor
@ -344,6 +346,10 @@ unhashWorkItem404
=> WorkItemBy KeyHashid => WorkItemBy KeyHashid
-> m (WorkItemBy Key) -> m (WorkItemBy Key)
unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
where
unhashWorkItem byHash = do
ctx <- asksSite siteHashidsContext
return $ unhashWorkItemPure ctx byHash
workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom

View file

@ -18,8 +18,7 @@
module Vervis.Federation.Ticket module Vervis.Federation.Ticket
( --personOfferTicketF ( --personOfferTicketF
deckOfferTicketF loomOfferTicketF
, loomOfferTicketF
--, repoAddBundleF --, repoAddBundleF
@ -323,159 +322,6 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept
return (tid, ltid) return (tid, ltid)
-} -}
deckOfferTicketF
:: UTCTime
-> KeyHashid Deck
-> RemoteAuthor
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Ticket URIMode
-> FedURI
-> ExceptT Text Handler Text
deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
error "deckOfferTicketF disabled for refactoring"
{-
-- Check input
recipDeckID <- decodeKeyHashid404 recipDeckHash
(title, desc, source) <- do
let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
unless (wioAuthor == Right (remoteAuthorURI author)) $
throwE "Offering a Ticket attributed to someone else"
case wioRest of
TAM_Task deckID ->
if deckID == recipDeckID
then return ()
else throwE
"Offer target is some other local deck, so I have \
\no use for this Offer. Was I supposed to receive \
\it?"
TAM_Merge _ _ ->
throwE
"Offer target is some local loom, so I have no use for \
\this Offer. Was I supposed to receive it?"
TAM_Remote _ _ ->
throwE
"Offer target is some remote tracker, so I have no use \
\for this Offer. Was I supposed to receive it?"
return (wioTitle, wioDesc, wioSource)
-- Find recipient deck in DB, returning 404 if doesn't exist because we're
-- in the deck's inbox post handler
maybeHttp <- runDBExcept $ do
(recipDeckActorID, recipDeckActor) <- lift $ do
deck <- get404 recipDeckID
let actorID = deckActor deck
(actorID,) <$> getJust actorID
-- Insert the Offer to deck's inbox
mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luOffer False
for mractid $ \ offerID -> do
-- Forward the Offer activity to relevant local stages, and
-- schedule delivery for unavailable remote members of them
maybeHttpFwdOffer <- lift $ for mfwd $ \ (localRecips, sig) -> do
let sieve =
makeRecipientSet
[]
[LocalStageDeckFollowers recipDeckHash]
forwardActivityDB
(actbBL body) localRecips sig recipDeckActorID
(LocalActorDeck recipDeckHash) sieve offerID
-- Insert the new ticket to our DB
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
taskID <- lift $ insertTask now title desc source recipDeckID offerID acceptID
-- Prepare an Accept activity and insert to deck's outbox
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
lift $ prepareAccept taskID
_luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
-- Deliver the Accept to local recipients, and schedule delivery
-- for unavailable remote recipients
deliverHttpAccept <-
deliverActivityDB
(LocalActorDeck recipDeckHash) recipDeckActorID
localRecipsAccept remoteRecipsAccept fwdHostsAccept
acceptID actionAccept
-- Return instructions for HTTP inbox-forwarding of the Offer
-- activity, and for HTTP delivery of the Accept activity to
-- remote recipients
return (maybeHttpFwdOffer, deliverHttpAccept)
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
-- delivery of the Accept activity
case maybeHttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just (maybeHttpFwdOffer, deliverHttpAccept) -> do
forkWorker "deckOfferTicketF Accept HTTP delivery" deliverHttpAccept
case maybeHttpFwdOffer of
Nothing -> return "Opened a ticket, no inbox-forwarding to do"
Just forwardHttpOffer -> do
forkWorker "deckOfferTicketF inbox-forwarding" forwardHttpOffer
return "Opened a ticket and ran inbox-forwarding of the Offer"
where
insertTask now title desc source deckID 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_ TicketAuthorRemote
{ ticketAuthorRemoteTicket = tid
, ticketAuthorRemoteAuthor = remoteAuthorId author
, ticketAuthorRemoteOpen = offerID
}
insert $ TicketDeck tid deckID
prepareAccept taskID = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
taskHash <- encodeKeyHashid taskID
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audSender =
AudRemote hAuthor
[luAuthor]
(maybeToList $ remoteActorFollowers ra)
audTracker = AudLocal [] [LocalStageDeckFollowers recipDeckHash]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audSender, audTracker]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = []
, AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = ObjURI hAuthor luOffer
, AP.acceptResult =
Just $ encodeRouteLocal $
TicketR recipDeckHash taskHash
}
}
return (action, recipientSet, remoteActors, fwdHosts)
-}
activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct

View file

@ -96,6 +96,7 @@ import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..)) import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
import Vervis.Actor2
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.API import Vervis.API
import Vervis.Data.Actor import Vervis.Data.Actor
@ -453,7 +454,7 @@ getFollowingCollection here actor hash = do
<*> getRemotes followerActorID <*> getRemotes followerActorID
hashActor <- getHashLocalActor hashActor <- getHashLocalActor
hashItem <- getHashWorkItem hashItem <- runAct getHashWorkItem
let locals = let locals =
map (renderLocalActor . hashActor) localActors ++ map (renderLocalActor . hashActor) localActors ++
map (workItemRoute . hashItem) workItems map (workItemRoute . hashItem) workItems

View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2020, 2022, 2023
- by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -76,6 +77,7 @@ import Vervis.Settings
import Vervis.Ticket import Vervis.Ticket
import Vervis.Widget.Discussion import Vervis.Widget.Discussion
import qualified Vervis.Actor2 as VA2
import qualified Vervis.Client as C import qualified Vervis.Client as C
getRepliesCollection getRepliesCollection
@ -240,7 +242,7 @@ serveMessage authorHash localMessageHash = do
case topic of case topic of
Left ticketID -> do Left ticketID -> do
wiByKey <- getWorkItem ticketID wiByKey <- getWorkItem ticketID
wiByHash <- hashWorkItem wiByKey wiByHash <- lift $ VA2.runAct $ hashWorkItem wiByKey
return $ encodeRouteHome $ workItemRoute wiByHash return $ encodeRouteHome $ workItemRoute wiByHash
Right rd -> do Right rd -> do
ro <- getJust $ remoteDiscussionIdent rd ro <- getJust $ remoteDiscussionIdent rd