From 1694d77705880487499439551e14c00f58e2cb56 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Fri, 3 Nov 2023 10:56:25 +0200 Subject: [PATCH] S2S: Deck: Port the Offer{Ticket} handler from the old code --- src/Vervis/API.hs | 12 ++- src/Vervis/Actor/Deck.hs | 174 +++++++++++++++++++++++++++++++- src/Vervis/Client.hs | 8 +- src/Vervis/Data/Actor.hs | 6 ++ src/Vervis/Data/Follow.hs | 15 +-- src/Vervis/Data/Ticket.hs | 76 +++++++------- src/Vervis/Federation/Ticket.hs | 156 +--------------------------- src/Vervis/Web/Actor.hs | 3 +- src/Vervis/Web/Discussion.hs | 6 +- 9 files changed, 247 insertions(+), 209 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index ffbe942..5b8ffab 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -130,6 +130,8 @@ import Vervis.Ticket import Vervis.Web.Delivery import Vervis.Web.Repo +import qualified Vervis.Actor2 as VA2 + handleViaActor :: PersonId -> Maybe @@ -626,7 +628,7 @@ applyC applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action apply = do -- Check input - maybeLocalTarget <- checkApplyLocalLoom apply + maybeLocalTarget <- VA2.runActE $ checkApplyLocalLoom apply capID <- fromMaybeE maybeCap "No capability provided" -- Verify that the bundle's loom is addressed @@ -1530,7 +1532,7 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re -- Check input verifyNothingE maybeCap "Capability not needed" - (followee, hide) <- parseFollow follow + (followee, hide) <- VA2.runActE $ parseFollow follow case followee of Left (FolloweeActor (LocalActorPerson personID)) | personID == senderPersonID -> @@ -1672,7 +1674,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor maybeCap localReci verifyNothingE maybeCap "Capability not needed" (title, desc, source, tam) <- do hostLocal <- asksSite siteInstanceHost - WorkItemOffer {..} <- checkOfferTicket hostLocal ticket uTarget + WorkItemOffer {..} <- VA2.runActE $ checkOfferTicket hostLocal ticket uTarget unless (wioAuthor == Left senderPersonID) $ throwE "Offering a Ticket attributed to someone else" return (wioTitle, wioDesc, wioSource, wioRest) @@ -2345,7 +2347,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r (\ r -> do wiByHash <- fromMaybeE (parseWorkItem r) "Not a work item route" - unhashWorkItemE wiByHash "Work item invalid keyhashid" + VA2.runActE $ unhashWorkItemE wiByHash "Work item invalid keyhashid" ) pure routeOrRemote @@ -2593,7 +2595,7 @@ undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remo return Nothing Just (Right (updateDB, ticketID)) -> do wiByKey <- lift $ getWorkItem ticketID - wiByHash <- hashWorkItem wiByKey + wiByHash <- lift $ lift $ VA2.runAct $ hashWorkItem wiByKey let resource = workItemResource wiByKey actorByKey = workItemActor wiByKey actorByHash = workItemActor wiByHash diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 32b139e..b711dc4 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -63,11 +63,12 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Discussion +import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation 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.Collab import Vervis.Persist.Discussion @@ -314,6 +315,176 @@ deckCreate now deckID verse (AP.Create obj _muTarget) = _ -> 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 ------------------------------------------------------------------------------ @@ -746,6 +917,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = AP.GrantActivity grant -> deckGrant now deckID verse grant AP.InviteActivity invite -> deckInvite now deckID verse invite 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.RemoveActivity remove -> deckRemove now deckID verse remove AP.UndoActivity undo -> deckUndo now deckID verse undo diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 2464d43..23af4d9 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -315,7 +315,7 @@ offerIssue offerIssue senderHash title desc uTracker = do tracker <- do - tracker <- checkTracker uTracker + tracker <- runActE $ checkTracker uTracker case tracker of TrackerDeck deckID -> Left <$> encodeKeyHashid deckID TrackerLoom _ -> throwE "Local patch tracker doesn't take issues" @@ -619,7 +619,7 @@ offerPatches offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do tracker <- do - tracker <- checkTracker uTracker + tracker <- runActE $ checkTracker uTracker case tracker of TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches" TrackerLoom loomID -> Left <$> encodeKeyHashid loomID @@ -709,7 +709,7 @@ offerMerge offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do tracker <- do - tracker <- checkTracker uTracker + tracker <- runActE $ checkTracker uTracker case tracker of TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches" TrackerLoom loomID -> Left <$> encodeKeyHashid loomID @@ -790,7 +790,7 @@ applyPatches -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode) applyPatches senderHash uObject = do - bundle <- parseBundleRoute "Apply object" uObject + bundle <- runActE $ parseBundleRoute "Apply object" uObject mrInfo <- bifor bundle (\ (loomID, clothID, _) -> do diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index ad69f3f..1184435 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -25,6 +25,7 @@ module Vervis.Data.Actor , parseLocalURI , parseFedURIOld , parseLocalActorE + , parseLocalActorE' ) where @@ -189,3 +190,8 @@ parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key) parseLocalActorE route = do actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route" 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" diff --git a/src/Vervis/Data/Follow.hs b/src/Vervis/Data/Follow.hs index a898182..db82eb2 100644 --- a/src/Vervis/Data/Follow.hs +++ b/src/Vervis/Data/Follow.hs @@ -29,7 +29,10 @@ import Data.Maybe import Data.Text (Text) import Database.Persist.Types +import Control.Concurrent.Actor import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -39,12 +42,13 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Vervis.Actor import Vervis.Data.Actor import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Foundation import Vervis.Model -import Vervis.Recipient +import Vervis.Recipient (parseLocalActor) data FolloweeBy f = FolloweeActor (LocalActorBy f) @@ -59,10 +63,9 @@ unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE w parseFollow :: AP.Follow URIMode - -> ExceptT Text Handler - (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool) + -> ActE (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool) parseFollow (AP.Follow uObject mluContext hide) = do - routeOrRemote <- parseFedURIOld uObject + routeOrRemote <- parseFedURI uObject (,hide) <$> bitraverse (parseLocal mluContext) @@ -76,8 +79,8 @@ parseFollow (AP.Follow uObject mluContext hide) = do byHash <- fromMaybeE (parseFollowee r) "Not a followee route" byKey <- unhashFolloweeE byHash "Followee invalid keyhashid" for_ mlu $ \ lu -> nameExceptT "Follow context" $ do - actorR <-parseLocalURI lu - actorByKey <- parseLocalActorE actorR + actorR <- parseLocalURI lu + actorByKey <- parseLocalActorE' actorR unless (actorByKey == followeeActor byKey) $ throwE "Isn't object's actor" return byKey diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 13e2206..99eca6d 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -62,8 +62,11 @@ import Yesod.Core import qualified Control.Monad.Fail as F +import Control.Concurrent.Actor import Development.PatchMediaType import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Web.Text import Yesod.ActivityPub import Yesod.Actor @@ -72,9 +75,11 @@ import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Web.Actor.Persist as WAP import Control.Monad.Trans.Except.Local +import Vervis.Actor import Vervis.Data.Collab import Vervis.Foundation import Vervis.FedURI @@ -112,25 +117,25 @@ data WorkItemOffer = WorkItemOffer , wioRest :: TrackerAndMerge } -checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI) +checkAuthor :: FedURI -> ActE (Either PersonId FedURI) checkAuthor u@(ObjURI h lu) = do - hl <- hostIsLocalOld h + hl <- hostIsLocal h if hl then do route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route" 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" 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 verifyNothingE mlocal "Patch has 'id'" author <- checkAuthor $ ObjURI h attrib verifyNothingE mpub "Patch has 'published'" 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 h (AP.BundleOffer mlocal patches) = do verifyNothingE mlocal "Bundle has 'id'" @@ -142,30 +147,29 @@ checkBundle h (AP.BundleOffer mlocal patches) = do unless (all (== typ) typs) $ throwE "Different patch types" 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 - hl <- hostIsLocalOld h + hl <- hostIsLocal h if hl then Left <$> do route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route" 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" 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) = (,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 (Right (h, b)) = uncurry ($) . first (either TipLocalBranch TipRemoteBranch) <$> checkBranch h b checkMR :: Host -> AP.MergeRequest URIMode - -> ExceptT Text Handler - (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip) + -> ActE (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip) checkMR h (AP.MergeRequest muOrigin target mbundle) = (,,) <$> traverse checkTip muOrigin @@ -176,22 +180,22 @@ checkMR h (AP.MergeRequest muOrigin target mbundle) = ) <*> checkTip (bimap (ObjURI h) (h,) target) -checkTracker :: FedURI -> ExceptT Text Handler Tracker +checkTracker :: FedURI -> ActE Tracker checkTracker u@(ObjURI h lu) = do - hl <- hostIsLocalOld h + hl <- hostIsLocal h if hl then do route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route" case route of - DeckR deckHash -> TrackerDeck <$> decodeKeyHashidE deckHash "Local tracker invalid deck hash" - LoomR loomHash -> TrackerLoom <$> decodeKeyHashidE loomHash "Local tracker invalid loom hash" + DeckR deckHash -> TrackerDeck <$> WAP.decodeKeyHashidE deckHash "Local tracker invalid deck hash" + LoomR loomHash -> TrackerLoom <$> WAP.decodeKeyHashidE loomHash "Local tracker invalid loom hash" _ -> throwE "Local tracker not a deck/loom route" else pure $ TrackerRemote u checkTicket :: Host -> AP.Ticket URIMode - -> ExceptT Text Handler + -> ActE ( Either PersonId FedURI , Text, HTML, PandocMarkdown , Maybe Tracker @@ -214,14 +218,14 @@ checkTicket h (AP.Ticket mlocal attrib mpublished mupdated muContext summary con return $ Merge maybeOriginTip maybeBundle targetTip 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 _) (Just _) = throwE "Deck & MR" checkTrackerAndMerge (TrackerLoom _) Nothing = throwE "Loom & no MR" checkTrackerAndMerge (TrackerLoom loomID) (Just merge) = pure $ TAM_Merge loomID merge 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 target <- checkTracker uTarget (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 parseBundleRoute name u@(ObjURI h lu) = do - hl <- hostIsLocalOld h + hl <- hostIsLocal h if hl then Left <$> do route <- @@ -240,24 +244,22 @@ parseBundleRoute name u@(ObjURI h lu) = do case route of BundleR loom ticket bundle -> (,,) - <$> decodeKeyHashidE loom (name <> ": Invalid lkhid") - <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid") - <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid") + <$> WAP.decodeKeyHashidE loom (name <> ": Invalid lkhid") + <*> WAP.decodeKeyHashidE ticket (name <> ": Invalid tlkhid") + <*> WAP.decodeKeyHashidE bundle (name <> ": Invalid bnkhid") _ -> throwE $ name <> ": not a bundle route" else return $ Right u checkApply :: AP.Apply URIMode - -> ExceptT Text Handler - (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip) + -> ActE (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip) checkApply (AP.Apply uObject target) = (,) <$> parseBundleRoute "Apply object" uObject <*> nameExceptT "Apply target" (checkTip target) checkApplyLocalLoom :: AP.Apply URIMode - -> ExceptT Text Handler - (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId)) + -> ActE (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId)) checkApplyLocalLoom apply = do (bundle, targetTip) <- checkApply apply let maybeLocal = @@ -286,14 +288,14 @@ hashWorkItemPure ctx = f WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c) getHashWorkItem - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadActor m, StageHashids (ActorEnv m)) => m (WorkItemBy Key -> WorkItemBy KeyHashid) getHashWorkItem = do - ctx <- asksSite siteHashidsContext + ctx <- asksEnv stageHashidsContext return $ hashWorkItemPure ctx hashWorkItem - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadActor m, StageHashids (ActorEnv m)) => WorkItemBy Key -> m (WorkItemBy KeyHashid) hashWorkItem actor = do hash <- getHashWorkItem @@ -313,24 +315,24 @@ unhashWorkItemPure ctx = f <*> decodeKeyHashidPure ctx c unhashWorkItem - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadActor m, StageHashids (ActorEnv m)) => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key)) unhashWorkItem actor = do - ctx <- asksSite siteHashidsContext + ctx <- asksEnv stageHashidsContext return $ unhashWorkItemPure ctx actor unhashWorkItemF - :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m)) + :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m)) => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key) unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor unhashWorkItemM - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadActor m, StageHashids (ActorEnv m)) => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key) unhashWorkItemM = MaybeT . unhashWorkItem unhashWorkItemE - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadActor m, StageHashids (ActorEnv m)) => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key) unhashWorkItemE actor e = ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor @@ -344,6 +346,10 @@ unhashWorkItem404 => WorkItemBy KeyHashid -> m (WorkItemBy Key) unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor + where + unhashWorkItem byHash = do + ctx <- asksSite siteHashidsContext + return $ unhashWorkItemPure ctx byHash workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 68de873..d51af5b 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -18,8 +18,7 @@ module Vervis.Federation.Ticket ( --personOfferTicketF - deckOfferTicketF - , loomOfferTicketF + loomOfferTicketF --, repoAddBundleF @@ -323,159 +322,6 @@ insertLocalTicket now author txl summary content source ractidOffer obiidAccept 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 instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 8c92be0..9d09bf8 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -96,6 +96,7 @@ import qualified Data.Aeson.Encode.Pretty.ToEncoding as P import qualified Web.ActivityPub as AP import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..)) +import Vervis.Actor2 import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor @@ -453,7 +454,7 @@ getFollowingCollection here actor hash = do <*> getRemotes followerActorID hashActor <- getHashLocalActor - hashItem <- getHashWorkItem + hashItem <- runAct getHashWorkItem let locals = map (renderLocalActor . hashActor) localActors ++ map (workItemRoute . hashItem) workItems diff --git a/src/Vervis/Web/Discussion.hs b/src/Vervis/Web/Discussion.hs index 105c936..f2ea926 100644 --- a/src/Vervis/Web/Discussion.hs +++ b/src/Vervis/Web/Discussion.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020, 2022 by fr33domlover . + - Written in 2016, 2019, 2020, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -76,6 +77,7 @@ import Vervis.Settings import Vervis.Ticket import Vervis.Widget.Discussion +import qualified Vervis.Actor2 as VA2 import qualified Vervis.Client as C getRepliesCollection @@ -240,7 +242,7 @@ serveMessage authorHash localMessageHash = do case topic of Left ticketID -> do wiByKey <- getWorkItem ticketID - wiByHash <- hashWorkItem wiByKey + wiByHash <- lift $ VA2.runAct $ hashWorkItem wiByKey return $ encodeRouteHome $ workItemRoute wiByHash Right rd -> do ro <- getJust $ remoteDiscussionIdent rd