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

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

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

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

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"

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
+    -> ActE (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
-        (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
+            actorR <- parseLocalURI lu
-            actorByKey <- parseLocalActorE actorR
+            actorByKey <- parseLocalActorE' actorR
             unless (actorByKey == followeeActor byKey) $
                 throwE "Isn't object's actor"
         return byKey

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
+    -> ActE (Maybe Tip, Maybe (Either PersonId FedURI, Material), Tip)
-        (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"
+                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"
         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")
+                        <$> 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"
         else return $ Right u
 
 checkApply
     :: AP.Apply URIMode
-    -> ExceptT Text Handler
+    -> ActE (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
-        (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
+    -> ActE (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
-        (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

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

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

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