From 1694d77705880487499439551e14c00f58e2cb56 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
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 <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.
-
@@ -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