C2S: Re-implement and enable resolveC, followC, undoC

src/Vervis/API.hs

@@ -25,12 +25,12 @@ module Vervis.API
     , createPatchTrackerC
     , createRepositoryC
     , createTicketTrackerC
-    --, followC
+    , followC
     , inviteC
     , offerTicketC
     --, offerDepC
-    --, resolveC
+    , resolveC
-    --, undoC
+    , undoC
     --, pushCommitsC
     )
 where
@@ -102,6 +102,7 @@ import Vervis.Darcs
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Discussion
+import Vervis.Data.Follow
 import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Fetch
@@ -116,13 +117,13 @@ import Vervis.Path
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.Persist.Follow
 import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
 import Vervis.Query
 import Vervis.Ticket
-import Vervis.WorkItem
 import Vervis.Web.Delivery
 import Vervis.Web.Repo
 
@@ -1666,16 +1667,6 @@ createTicketTrackerC (Entity pidUser personUser) senderActor maybeCap localRecip
                 }
         update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
 
-{-
-data Followee
-    = FolloweePerson (KeyHashid Person)
-    | FolloweeGroup  (KeyHashid Group)
-    | FolloweeRepo   (KeyHashid Repo)
-    | FolloweeDeck   (KeyHashid Deck)
-    | FolloweeLoom   (KeyHashid Loom)
-    | FolloweeTicket (KeyHashid Deck) (KeyHashid TicketDeck)
-    | FolloweeCloth  (KeyHashid Loom) (KeyHashid TicketLoom)
-
 followC
     :: Entity Person
     -> Actor
@@ -1690,158 +1681,130 @@ followC
     -> AP.Action URIMode
     -> AP.Follow URIMode
     -> ExceptT Text Handler OutboxItemId
-followC (Entity pidSender personSender) _senderActor maybeCap localRecips remoteRecips fwdHosts action follow@(AP.Follow uObject muContext hide) = do
+followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action follow = do
+
+    -- Check input
     verifyNothingE maybeCap "Capability not needed"
-    now <- liftIO getCurrentTime
+    (followee, hide) <- parseFollow follow
-    senderHash <- encodeKeyHashid pidSender
-    mfollowee <- do
-        let ObjURI h luObject = uObject
-        local <- hostIsLocal h
-        if local
-            then Just <$> do
-                route <-
-                    fromMaybeE
-                        (decodeRouteLocal luObject)
-                        "Follow object isn't a valid route"
-                followee <-
-                    fromMaybeE
-                        (parseFollowee route)
-                        "Follow object isn't a followee route"
-                let actor = followeeActor followee
-                unless (actorRecips actor == localRecips) $
-                    throwE "Follow object isn't the recipient"
     case followee of
-                    FolloweePerson p | p == senderHash ->
+        Left (FolloweeActor (LocalActorPerson personID))
-                        throwE "User trying to follow themselves"
+            | personID == senderPersonID ->
-                    _ -> return ()
+                throwE "Trying to follow yourself"
-                return (followee, actor)
+        _ -> pure ()
-            else do
-                unless (localRecips == RecipientRoutes [] [] [] [] []) $
-                    throwE "Follow object is remote but local recips listed"
-                return Nothing
-    (obiidFollow, doc, remotesHttp) <- runDBExcept $ do
-        let actorSenderID = personActor personSender
-        actorSender <- lift $ getJust actorSenderID
-        let ibidSender = actorInbox actorSender
-            obidSender = actorOutbox actorSender
-        obiidFollow <- lift $ insertEmptyOutboxItem obidSender now
-        luFollow <- lift $ updateOutboxItem (LocalActorPerson pidSender) obiidFollow action
-        case mfollowee of
-            Nothing -> lift $ insert_ $ FollowRemoteRequest pidSender uObject muContext (not hide) obiidFollow
-            Just (followee, actorRecip) -> do
-                (actorRecipID, mfsid, unread) <- getFollowee followee
-                actorRecipDB <- lift $ getJust actorRecipID
-                let obidRecip = actorOutbox actorRecipDB
-                obiidAccept <- lift $ insertAcceptToOutbox senderHash luFollow actorRecip obidRecip
-                let ibidRecip = actorInbox actorRecipDB
-                    fsid = fromMaybe (actorFollowers actorRecipDB) mfsid
-                deliverFollowLocal now actorSenderID fsid unread obiidFollow obiidAccept ibidRecip
-                lift $ deliverAcceptLocal now obiidAccept ibidSender
-        remotesHttp <- lift $ deliverRemoteDB fwdHosts obiidFollow remoteRecips []
-        return (obiidFollow, doc, remotesHttp)
-    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp
-    return obiidFollow
-    where
-    parseFollowee (PersonR p)   = Just $ FolloweePerson p
-    parseFollowee (GroupR g)    = Just $ FolloweeGroup g
-    parseFollowee (RepoR r)     = Just $ FolloweeRepo r
-    parseFollowee (DeckR d)     = Just $ FolloweeDeck d
-    parseFollowee (LoomR l)     = Just $ FolloweeLoom l
-    parseFollowee (TicketR d t) = Just $ FolloweeTicket d t
-    parseFollowee (ClothR l c)  = Just $ FolloweeCloth l c
-    parseFollowee _             = Nothing
 
-    followeeActor (FolloweePerson p)   = LocalActorPerson p
+    -- Verify that followee's actor is addressed
-    followeeActor (FolloweeGroup g)    = LocalActorGroup g
+    case followee of
-    followeeActor (FolloweeRepo r)     = LocalActorRepo r
+        Left f -> do
-    followeeActor (FolloweeDeck d)     = LocalActorDeck d
+            actorByHash <- hashLocalActor $ followeeActor f
-    followeeActor (FolloweeLoom l)     = LocalActorLoom l
+            unless (actorIsAddressed localRecips actorByHash) $
-    followeeActor (FolloweeTicket d _) = LocalActorDeck d
+                throwE "Followee's actor not addressed by the Follow"
-    followeeActor (FolloweeCloth l _)  = LocalActorLoom l
+        Right (h, luActor, luObject) ->
+            verifyRemoteAddressed remoteRecips $ ObjURI h luActor
 
-    getFollowee (FolloweePerson personHash) = do
-        personID <- decodeKeyHashidE personHash "Follow object: No such person hash"
-        (,Nothing,True) . personActor <$> getE personID "Follow object: No such person in DB"
-    getFollowee (FolloweeGroup groupHash) = do
-        groupID <- decodeKeyHashidE groupHash "Follow object: No such group hash"
-        (,Nothing,False) . groupActor <$> getE groupID "Follow object: No such group in DB"
-    getFollowee (FolloweeRepo repoHash) = do
-        repoID <- decodeKeyHashidE repoHash "Follow object: No such repo hash"
-        (,Nothing,False) . repoActor <$> getE repoID "Follow object: No such repo in DB"
-    getFollowee (FolloweeDeck deckHash) = do
-        deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash"
-        (,Nothing,False) . deckActor <$> getE deckID "Follow object: No such deck in DB"
-    getFollowee (FolloweeLoom loomHash) = do
-        loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash"
-        (,Nothing,False) . loomActor <$> getE loomID "Follow object: No such loom in DB"
-    getFollowee (FolloweeTicket deckHash ticketHash) = do
-        deckID <- decodeKeyHashidE deckHash "Follow object: No such deck hash"
-        actor <- deckActor <$> getE deckID "Follow object: No such deck in DB"
-        ticketID <- decodeKeyHashidE ticketHash "Follow object: No such ticket hash"
-        (_, _, Entity _ ticket, _, _) <- do
-            mticket <- lift $ getTicket deckID ticketID
-            fromMaybeE mticket "Follow object: No such ticket in DB"
-        return (actor, Just $ ticketFollowers ticket, False)
-    getFollowee (FolloweeCloth loomHash clothHash) = do
-        loomID <- decodeKeyHashidE loomHash "Follow object: No such loom hash"
-        actor <- loomActor <$> getE loomID "Follow object: No such loom in DB"
-        clothID <- decodeKeyHashidE clothHash "Follow object: No such cloth hash"
-        (_, _, Entity _ ticket, _, _, _) <- do
-            mticket <- lift $ getCloth loomID clothID
-            fromMaybeE mticket "Follow object: No such cloth in DB"
-        return (actor, Just $ ticketFollowers ticket, False)
-
-    insertAcceptToOutbox senderHash luFollow actorRecip obidRecip = do
     now <- liftIO getCurrentTime
-        summary <-
+    senderHash <- encodeKeyHashid senderPersonID
-            renderHTML <$>
-                withUrlRenderer
-                    [hamlet|
-                        <p>
-                          <a href=@{PersonR senderHash}>
-                            #{username2text $ personUsername personSender}
-                          's follow request accepted by #
-                          <a href=#{renderObjURI uObject}>
-                            #{localUriPath $ objUriLocal uObject}
-                    |]
-        hLocal <- asksSite siteInstanceHost
-        encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteHome <- getEncodeRouteHome
-        let recips = [encodeRouteHome $ PersonR senderHash]
-            accept mluAct = Doc hLocal Activity
-                { activityId       = mluAct
-                , activityActor    = objUriLocal uObject
-                , activityCapability = Nothing
-                , activitySummary  = Just summary
-                , activityAudience = Audience recips [] [] [] [] []
-                , activityFulfills = []
-                , activitySpecific = AcceptActivity Accept
-                    { acceptObject = ObjURI hLocal luFollow
-                    , acceptResult = Nothing
-                    }
-                }
-        obiid <- insert OutboxItem
-            { outboxItemOutbox    = obidRecip
-            , outboxItemActivity  =
-                persistJSONObjectFromDoc $ accept Nothing
-            , outboxItemPublished = now
-            }
-        obikhid <- encodeKeyHashid obiid
-        let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid
-            doc = accept $ Just luAct
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return obiid
 
-    deliverFollowLocal now aidSender fsid unread obiidF obiidA ibidRecip = do
+    (followID, deliverHttpFollow, maybeDeliverHttpAccept) <- runDBExcept $ do
-        mfid <- lift $ insertUnique $ Follow aidSender fsid (not hide) obiidF obiidA
+
+        -- If followee is local, find it in our DB
+        followeeDB <- bitraverse getFollowee pure followee
+
+        -- Insert Follow activity to author's outbox
+        followID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        luFollow <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) followID action
+
+        -- Deliver the Follow activity to local recipients, and schedule
+        -- delivery for unavailable remote recipients
+        deliverHttpFollow <- do
+            sieve <- do
+                (actors, stages) <-
+                    case followeeDB of
+                        Left (actorByKey, _, _) -> do
+                            actorByHash <- hashLocalActor actorByKey
+                            return
+                                ( [actorByHash]
+                                , [localActorFollowers actorByHash]
+                                )
+                        Right _ -> pure ([], [])
+                let stages' = LocalStagePersonFollowers senderHash : stages
+                return $ makeRecipientSet actors stages'
+            let localRecipsFinal = localRecipSieve sieve False localRecips
+            deliverActivityDB
+                (LocalActorPerson senderHash) (personActor senderPerson)
+                localRecipsFinal remoteRecips fwdHosts followID action
+
+        maybeDeliverHttpAccept <-
+            case followeeDB of
+                Right (h, luActor, luObject) -> lift $ do
+
+                    -- For remote followee, just remember the request in our DB
+                    let uObject = ObjURI h luObject
+                        muContext =
+                            if luActor == luObject
+                                then Nothing
+                                else Just $ ObjURI h luActor
+                    insert_ $ FollowRemoteRequest senderPersonID uObject muContext (not hide) followID
+                    return Nothing
+
+                Left (actorByKey, actorID, maybeFollowerSetID) -> Just <$> do
+
+                    -- Verify followee's actor has received the Accept
+                    verifyActorHasItem actorID followID "Followee's actor didn't receive the Follow"
+
+                    -- Insert an Accept activity to followee's outbox
+                    actor <- lift $ getJust actorID
+                    acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
+                    let acceptActors = [LocalActorPerson senderHash]
+                        acceptStages = []
+                    actionAccept <- prepareAccept luFollow acceptActors acceptStages
+                    _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
+
+                    -- Insert author to followee's followers collection
+                    let fsid =
+                            fromMaybe (actorFollowers actor) maybeFollowerSetID
+                    mfid <-
+                        lift $ insertUnique $
+                        Follow (personActor senderPerson) fsid (not hide) followID acceptID
                     _ <- fromMaybeE mfid "Already following this object"
-        ibiid <- lift $ insert $ InboxItem unread now
-        lift $ insert_ $ InboxItemLocal ibidRecip obiidF ibiid
 
-    deliverAcceptLocal now obiidAccept ibidAuthor = do
+                    -- Deliver the Accept activity to local recipients, and
-        ibiid <- insert $ InboxItem True now
+                    -- schedule delivery for unavailable remote recipients
-        insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
+                    let localRecipsAccept = makeRecipientSet acceptActors acceptStages
--}
+                    actorByHash <- hashLocalActor actorByKey
+                    deliverActivityDB
+                        actorByHash actorID localRecipsAccept [] []
+                        acceptID actionAccept
+
+        -- Return instructions for HTTP delivery to remote recipients
+        return (followID, deliverHttpFollow, maybeDeliverHttpAccept)
+
+    -- Launch asynchronous HTTP delivery of Follow and Accept
+    lift $ do
+        forkWorker "followC: async HTTP Follow delivery" deliverHttpFollow
+        for_ maybeDeliverHttpAccept $
+            forkWorker "followC: async HTTP Accept delivery"
+
+    return followID
+
+    where
+
+    prepareAccept luFollow actors stages = do
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        let recips =
+                map encodeRouteHome $
+                        map renderLocalActor actors ++
+                        map renderLocalStage stages
+        return AP.Action
+            { AP.actionCapability = Nothing
+            , AP.actionSummary    = Nothing
+            , AP.actionAudience   = Audience recips [] [] [] [] []
+            , AP.actionFulfills   = []
+            , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                { AP.acceptObject   = ObjURI hLocal luFollow
+                , AP.acceptResult   = Nothing
+                }
+            }
 
 inviteC
     :: Entity Person
@@ -2042,13 +2005,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             routes <- lookup p $ recipPeople localRecips
             guard $ routePerson routes
 
-    verifyRemoteAddressed remoteRecips u =
-        fromMaybeE (verify u) "Given remote entity not addressed"
-        where
-        verify (ObjURI h lu) = do
-            lus <- lookup h remoteRecips
-            guard $ lu `elem` lus
-
     insertCollab resource recipient inviteID = do
         collabID <- insert Collab
         case resource of
@@ -2740,279 +2696,377 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve
 
 resolveC
     :: Entity Person
-    -> Maybe HTML
+    -> Actor
-    -> Audience URIMode
+    -> Maybe
-    -> Resolve URIMode
+        (Either
-    -> ExceptT Text Handler OutboxItemId
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-resolveC (Entity pidUser personUser) summary audience (Resolve uObject) = do
+            FedURI
-    error "resolveC temporarily disabled"
-
-{-
-
-
-    let shrUser = sharerIdent sharerUser
-    object <- parseWorkItem "Resolve object" uObject
-    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
-        mrecips <- parseAudience audience
-        fromMaybeE mrecips "Offer Ticket with no recipients"
-    federation <- asksSite $ appFederation . appSettings
-    unless (federation || null remoteRecips) $
-        throwE "Federation disabled, but remote recipients specified"
-    verifyHosterRecip localRecips "Parent" object
-    now <- liftIO getCurrentTime
-    ticketDetail <- runWorkerExcept $ getWorkItemDetail "Object" object
-    (obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do
-        (obiidResolve, docResolve, luResolve) <- lift $ insertResolveToOutbox shrUser now (personOutbox personUser) blinded
-        remotesHttpResolve <- do
-            wiFollowers <- askWorkItemFollowers
-            let sieve =
-                    let (actors, colls) =
-                            workItemRecipSieve wiFollowers ticketDetail
-                    in  makeRecipientSet
-                            actors
-                            (LocalPersonCollectionSharerFollowers shrUser :
-                             colls
         )
-            moreRemoteRecips <-
+    -> RecipientRoutes
-                lift $
+    -> [(Host, NonEmpty LocalURI)]
-                    deliverLocal'
+    -> [Host]
-                        True
+    -> AP.Action URIMode
-                        (LocalActorSharer shrUser)
+    -> AP.Resolve URIMode
-                        (personInbox personUser)
+    -> ExceptT Text Handler OutboxItemId
-                        obiidResolve
+resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Resolve uObject) = do
-                        (localRecipSieve sieve False localRecips)
-            unless (federation || null moreRemoteRecips) $
-                throwE "Federation disabled, but recipient collection remote members found"
-            lift $ deliverRemoteDB fwdHosts obiidResolve remoteRecips moreRemoteRecips
-        maccept <-
-            case widIdent ticketDetail of
-                Right _ -> return Nothing
-                Left (wi, ltid) -> Just <$> do
-                    mhoster <-
-                        lift $ runMaybeT $
-                        case wi of
-                            WorkItemSharerTicket shr _ _ -> do
-                                sid <- MaybeT $ getKeyBy $ UniqueSharer shr
-                                p <- MaybeT (getValBy $ UniquePersonIdent sid)
-                                return (personOutbox p, personInbox p)
-                            WorkItemProjectTicket shr prj _ -> do
-                                sid <- MaybeT $ getKeyBy $ UniqueSharer shr
-                                j <- MaybeT $ getValBy $ UniqueProject prj sid
-                                a <- lift $ getJust $ projectActor j
-                                return (actorOutbox a, actorInbox a)
-                            WorkItemRepoProposal shr rp _ -> do
-                                sid <- MaybeT $ getKeyBy $ UniqueSharer shr
-                                r <- MaybeT (getValBy $ UniqueRepo rp sid)
-                                return (repoOutbox r, repoInbox r)
-                    (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB"
-                    obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now
-                    lift $ insertResolve ltid obiidResolve obiidAccept
-                    (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                        lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiidResolve obiidAccept
-                    knownRemoteRecipsAccept <-
-                        lift $
-                        deliverLocal'
-                            False
-                            (workItemActor wi)
-                            ibidHoster
-                            obiidAccept
-                            localRecipsAccept
-                    lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$>
-                        deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-        return (obiidResolve, docResolve, remotesHttpResolve, maccept)
-    lift $ do
-        forkWorker "resolveC: async HTTP Resolve delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp
-        for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
-            forkWorker "resolveC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
-    return obiid
-    where
-    insertResolveToOutbox shrUser now obid blinded = do
-        hLocal <- asksSite siteInstanceHost
-        obiid <- insertEmptyOutboxItem obid now
-        encodeRouteLocal <- getEncodeRouteLocal
-        obikhid <- encodeKeyHashid obiid
-        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
-            doc = Doc hLocal Activity
-                { activityId       = Just luAct
-                , activityActor    = encodeRouteLocal $ SharerR shrUser
-                , activityCapability = Nothing
-                , activitySummary  = summary
-                , activityAudience = blinded
-                , activitySpecific = ResolveActivity $ Resolve uObject
-                }
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (obiid, doc, luAct)
 
-    insertResolve ltid obiidResolve obiidAccept = do
+    -- Check input
+    maybeLocalWorkItem <-
+        nameExceptT "Resolve object" $ either Just (const Nothing) <$> do
+            routeOrRemote <- parseFedURI uObject
+            bitraverse
+                (\ r -> do
+                    wiByHash <-
+                        fromMaybeE (parseWorkItem r) "Not a work item route"
+                    unhashWorkItemE wiByHash "Work item invalid keyhashid"
+                )
+                pure
+                routeOrRemote
+    capID <- fromMaybeE maybeCap "No capability provided"
+
+    -- Verify that the work item's tracker is addressed
+    for_ maybeLocalWorkItem $ \ wi -> do
+        trackerByHash <- hashLocalActor $ workItemActor wi
+        unless (actorIsAddressed localRecips trackerByHash) $
+            throwE "Work item's tracker not addressed by the Resolve"
+
+    senderHash <- encodeKeyHashid senderPersonID
+    now <- liftIO getCurrentTime
+
+    (resolveID, deliverHttpResolve, maybeDeliverHttpAccept) <- runDBExcept $ do
+
+        workItemDB <- for maybeLocalWorkItem $ \ wi -> do
+
+            -- Find the work item and its tracker in DB, and verify the work
+            -- item isn't already resolved
+            (resource, actor, ticketID) <-
+                case wi of
+                    WorkItemTicket deckID taskID -> do
+                        maybeTicket <- lift $ getTicket deckID taskID
+                        (Entity _ deck, _task, Entity ticketID _, _author, resolve) <-
+                            fromMaybeE maybeTicket "No such ticket in DB"
+                        verifyNothingE resolve "Ticket already resolved"
+                        actor <- lift $ getJustEntity $ deckActor deck
+                        return (GrantResourceDeck deckID, actor, ticketID)
+                    WorkItemCloth loomID clothID -> do
+                        maybeCloth <- lift $ getCloth loomID clothID
+                        (Entity _ loom, _cloth, Entity ticketID _, _author, resolve, _merge) <-
+                            fromMaybeE maybeCloth "No such MR in DB"
+                        verifyNothingE resolve "MR already resolved"
+                        actor <- lift $ getJustEntity $ loomActor loom
+                        return (GrantResourceLoom loomID, actor, ticketID)
+
+            -- Verify the sender is authorized by the tracker to resolve work
+            -- items
+            capability <-
+                case capID of
+                    Left (capActor, _, capItem) -> return (capActor, capItem)
+                    Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
+            verifyCapability capability (Left senderPersonID) resource
+
+            return (wi, actor, ticketID)
+
+        -- Insert Resolve to sender's outbox
+        resolveID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        luResolve <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) resolveID action
+
+        -- Deliver the Resolve activity to local recipients, and schedule
+        -- delivery for unavailable remote recipients
+        deliverHttpResolve <- do
+            sieve <- do
+                (actors, stages) <-
+                    case maybeLocalWorkItem of
+                        Nothing -> pure ([], [])
+                        Just (WorkItemTicket deckID taskID) -> do
+                            deckHash <- encodeKeyHashid deckID
+                            taskHash <- encodeKeyHashid taskID
+                            return
+                                ( [LocalActorDeck deckHash]
+                                , [ LocalStageDeckFollowers deckHash
+                                  , LocalStageTicketFollowers deckHash taskHash
+                                  ]
+                                )
+                        Just (WorkItemCloth loomID clothID) -> do
+                            loomHash <- encodeKeyHashid loomID
+                            clothHash <- encodeKeyHashid clothID
+                            return
+                                ( [LocalActorLoom loomHash]
+                                , [ LocalStageLoomFollowers loomHash
+                                  , LocalStageClothFollowers loomHash clothHash
+                                  ]
+                                )
+                let stages' = LocalStagePersonFollowers senderHash : stages
+                return $ makeRecipientSet actors stages'
+            let localRecipsFinal = localRecipSieve sieve False localRecips
+            deliverActivityDB
+                (LocalActorPerson senderHash) (personActor senderPerson)
+                localRecipsFinal remoteRecips fwdHosts resolveID action
+
+        -- Verify that the tracker has received the Resolve, resolve the work
+        -- item in DB, and publish Accept
+        maybeDeliverHttpAccept <- for workItemDB $ \ (wi, Entity trackerActorID trackerActor, ticketID) -> do
+
+            -- Verify tracker received the Resolve
+            verifyActorHasItem
+                trackerActorID
+                resolveID
+                "Local tracker didn't receive the Resolve"
+
+            -- Mark work item in DB as resolved by the Resolve
+            acceptID <-
+                lift $ insertEmptyOutboxItem (actorOutbox trackerActor) now
+            lift $ insertResolve ticketID resolveID acceptID
+
+            -- Insert an Accept activity to tracker's outbox
+            trackerStages <-
+                case wi of
+                    WorkItemTicket deckID taskID -> do
+                        deckHash <- encodeKeyHashid deckID
+                        taskHash <- encodeKeyHashid taskID
+                        return
+                            [ LocalStageDeckFollowers deckHash
+                            , LocalStageTicketFollowers deckHash taskHash
+                            ]
+                    WorkItemCloth loomID clothID -> do
+                        loomHash <- encodeKeyHashid loomID
+                        clothHash <- encodeKeyHashid clothID
+                        return
+                            [ LocalStageLoomFollowers loomHash
+                            , LocalStageClothFollowers loomHash clothHash
+                            ]
+            let acceptActors = [LocalActorPerson senderHash]
+                acceptStages =
+                    LocalStagePersonFollowers senderHash : trackerStages
+            actionAccept <- prepareAccept luResolve acceptActors acceptStages
+            let trackerByKey = workItemActor wi
+            _ <- lift $ updateOutboxItem trackerByKey acceptID actionAccept
+
+            -- Deliver the Accept activity to local recipients, and schedule
+            -- delivery for unavailable remote recipients
+            let localRecipsAccept = makeRecipientSet acceptActors acceptStages
+            trackerByHash <- hashLocalActor trackerByKey
+            deliverActivityDB
+                trackerByHash trackerActorID localRecipsAccept [] []
+                acceptID actionAccept
+
+        -- Return instructions for HTTP delivery of Resolve and Accept to
+        -- remote recipients
+        return
+            ( resolveID
+            , deliverHttpResolve
+            , maybeDeliverHttpAccept
+            )
+
+    -- Launch asynchronous HTTP delivery of Resolve and Accept
+    lift $ do
+        forkWorker "resolveC: async HTTP Resolve delivery" deliverHttpResolve
+        for_ maybeDeliverHttpAccept $
+            forkWorker "resolveC: async HTTP Accept delivery"
+
+    return resolveID
+
+    where
+
+    insertResolve ticketID resolveID acceptID = do
         trid <- insert TicketResolve
-            { ticketResolveTicket = ltid
+            { ticketResolveTicket = ticketID
-            , ticketResolveAccept = obiidAccept
+            , ticketResolveAccept = acceptID
             }
         insert_ TicketResolveLocal
             { ticketResolveLocalTicket   = trid
-            , ticketResolveLocalActivity = obiidResolve
+            , ticketResolveLocalActivity = resolveID
+            }
+
+    prepareAccept luResolve actors stages = do
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        let recips =
+                map encodeRouteHome $
+                        map renderLocalActor actors ++
+                        map renderLocalStage stages
+        return AP.Action
+            { AP.actionCapability = Nothing
+            , AP.actionSummary    = Nothing
+            , AP.actionAudience   = Audience recips [] [] [] [] []
+            , AP.actionFulfills   = []
+            , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                { AP.acceptObject   = ObjURI hLocal luResolve
+                , AP.acceptResult   = Nothing
+                }
             }
-        tid <- localTicketTicket <$> getJust ltid
-        update tid [TicketStatus =. TSClosed]
--}
 
 undoC
     :: Entity Person
-    -> Maybe HTML
+    -> Actor
-    -> Audience URIMode
+    -> Maybe
-    -> Undo URIMode
+        (Either
-    -> ExceptT Text Handler OutboxItemId
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-undoC (Entity _pidUser personUser) summary audience undo@(Undo uObject) = do
+            FedURI
-    error "undoC temporarily disabled"
-
-{-
-
-
-    let shrUser = sharerIdent sharerUser
-    object <- parseActivity uObject
-    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
-        mrecips <- parseAudience audience
-        fromMaybeE mrecips "Undo with no recipients"
-    federation <- asksSite $ appFederation . appSettings
-    unless (federation || null remoteRecips) $
-        throwE "Federation disabled, but remote recipients specified"
-    now <- liftIO getCurrentTime
-    (obiid, doc, _lu, mwi) <- runDBExcept $ do
-        (obiidUndo, docUndo, luUndo) <- lift $ insertUndoToOutbox shrUser now (personOutbox personUser) blinded
-        mltid <- fmap join $ runMaybeT $ do
-            object' <- MaybeT $ getActivity object
-            deleteFollow shrUser object' <|> deleteResolve object'
-        mwi <- lift $ traverse getWorkItem mltid
-        return (obiidUndo, docUndo, luUndo, mwi)
-    mticketDetail <-
-        for mwi $ \ wi ->
-            (wi,) <$> runWorkerExcept (getWorkItemDetail "Object" $ Left wi)
-    wiFollowers <- askWorkItemFollowers
-    let sieve =
-            case mticketDetail of
-                Nothing -> makeRecipientSet [] [LocalPersonCollectionSharerFollowers shrUser]
-                Just (_wi, ticketDetail) ->
-                    let (actors, colls) =
-                            workItemRecipSieve wiFollowers ticketDetail
-                    in  makeRecipientSet
-                            actors
-                            (LocalPersonCollectionSharerFollowers shrUser :
-                             colls
         )
-    (remotes, maybeAccept) <- runDBExcept $ do
+    -> RecipientRoutes
-        remotesHttpUndo <- do
+    -> [(Host, NonEmpty LocalURI)]
-            moreRemoteRecips <-
+    -> [Host]
-                lift $
+    -> AP.Action URIMode
-                    deliverLocal'
+    -> AP.Undo URIMode
-                        True
+    -> ExceptT Text Handler OutboxItemId
-                        (LocalActorSharer shrUser)
+undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Undo uObject) = do
-                        (personInbox personUser)
+
-                        obiid
+    -- Check input
-                        (localRecipSieve sieve True localRecips)
+    undone <-
-            unless (federation || null moreRemoteRecips) $
+        first (\ (actor, _, item) -> (actor, item)) <$>
-                throwE "Federation disabled, but recipient collection remote members found"
+            parseActivityURI uObject
-            lift $ deliverRemoteDB fwdHosts obiid remoteRecips moreRemoteRecips
+
-        maccept <- for mticketDetail $ \ (wi, ticketDetail) -> do
+    now <- liftIO getCurrentTime
-            mhoster <-
+    senderHash <- encodeKeyHashid senderPersonID
+
+    (undoID, deliverHttpUndo, maybeDeliverHttpAccept) <- runDBExcept $ do
+
+        -- Find the undone activity in our DB
+        undoneDB <- do
+            a <- getActivity undone
+            fromMaybeE a "Can't find undone in DB"
+
+        -- See if the undone activity is a Follow/Resolve on a local target
+        -- If it is, verify the relevant actor is addressed, verify
+        -- permissions, and perform the actual undoing in the DB
+        maybeUndoLocal <- do
+            maybeUndo <-
                 lift $ runMaybeT $
-                case wi of
+                    Left <$> MaybeT (tryUnfollow undoneDB) <|>
-                    WorkItemSharerTicket shr _ _ -> do
+                    Right <$> MaybeT (tryUnresolve undoneDB)
-                        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            case maybeUndo of
-                        p <- MaybeT (getValBy $ UniquePersonIdent sid)
+                Nothing -> pure Nothing
-                        return (personOutbox p, personInbox p)
+                Just (Left (updateDB, actorID, Left followerSetID)) -> do
-                    WorkItemProjectTicket shr prj _ -> do
+                    actorByKey <- lift $ getLocalActor actorID
-                        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+                    unless (actorByKey == LocalActorPerson senderPersonID) $
-                        j <- MaybeT $ getValBy $ UniqueProject prj sid
+                        throwE "Tryin to undo a Follow of someone else"
-                        a <- lift $ getJust $ projectActor j
+                    (fByKey, fActorID, _) <- do
-                        return (actorOutbox a, actorInbox a)
+                        followee <- lift $ getFollowee' followerSetID
-                    WorkItemRepoProposal shr rp _ -> do
+                        getFollowee followee
-                        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+                    fByHash <- hashLocalActor fByKey
-                        r <- MaybeT (getValBy $ UniqueRepo rp sid)
+                    unless (actorIsAddressed localRecips fByHash) $
-                        return (repoOutbox r, repoInbox r)
+                        throwE "Followee's actor not addressed by the Undo"
-            (obidHoster, ibidHoster) <- fromMaybeE mhoster "Ticket hoster not in DB"
+                    lift updateDB
-            obiidAccept <- lift $ insertEmptyOutboxItem obidHoster now
+                    fActor <- lift $ getJust fActorID
-            (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    return $ Just
-                lift $ insertAcceptOnTicketStatus shrUser wi ticketDetail obiid obiidAccept
+                        ( fByKey
-            knownRemoteRecipsAccept <-
+                        , Entity fActorID fActor
-                lift $
+                        , makeRecipientSet
-                deliverLocal'
+                            [fByHash]
-                    False
+                            [LocalStagePersonFollowers senderHash]
-                    (workItemActor wi)
+                        , [LocalActorPerson senderHash]
-                    ibidHoster
+                        , []
-                    obiidAccept
+                        )
-                    localRecipsAccept
+                Just (Left (updateDB, actorID, Right uTarget)) -> do
-            lift $ (obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    actorByKey <- lift $ getLocalActor actorID
-                deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+                    unless (actorByKey == LocalActorPerson senderPersonID) $
-        return (remotesHttpUndo, maccept)
+                        throwE "Trying to undo a Follow of someone else"
-    lift $ do
+                    verifyRemoteAddressed remoteRecips uTarget
-        forkWorker "undoC: async HTTP Undo delivery" $
+                    lift updateDB
-            deliverRemoteHttp' fwdHosts obiid doc remotes
-        for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
-            forkWorker "undoC: async HTTP Accept delivery" $
-                deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
-    return obiid
-    where
-    insertUndoToOutbox shrUser now obid blinded = do
-        hLocal <- asksSite siteInstanceHost
-        obiid <- insertEmptyOutboxItem obid now
-        encodeRouteLocal <- getEncodeRouteLocal
-        obikhid <- encodeKeyHashid obiid
-        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
-            doc = Doc hLocal Activity
-                { activityId       = Just luAct
-                , activityActor    = encodeRouteLocal $ SharerR shrUser
-                , activityCapability = Nothing
-                , activitySummary  = summary
-                , activityAudience = blinded
-                , activitySpecific = UndoActivity $ Undo uObject
-                }
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (obiid, doc, luAct)
-
-    deleteFollow shr (Left (actor, obiid)) = do
-        deleteFollowLocal <|> deleteFollowRemote <|> deleteFollowRequest
                     return Nothing
-        where
+                Just (Right (updateDB, ticketID)) -> do
-        deleteFollowLocal = do
+                    wiByKey <- lift $ getWorkItem ticketID
-            fid <- MaybeT $ lift $  getKeyBy $ UniqueFollowFollow obiid
+                    wiByHash <- hashWorkItem wiByKey
-            unless (actor == LocalActorSharer shr) $
+                    let resource = workItemResource wiByKey
-                lift $ throwE "Undoing someone else's follow"
+                        actorByKey = workItemActor wiByKey
-            lift $ lift $ delete fid
+                        actorByHash = workItemActor wiByHash
-        deleteFollowRemote = do
+                    unless (actorIsAddressed localRecips actorByHash) $
-            frid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteFollow obiid
+                        throwE "Work item's actor not addressed by the Undo"
-            unless (actor == LocalActorSharer shr) $
+                    capID <- fromMaybeE maybeCap "No capability provided"
-                lift $ throwE "Undoing someone else's follow"
+                    capability <-
-            lift $ lift $ delete frid
+                        case capID of
-        deleteFollowRequest = do
+                            Left (capActor, _, capItem) -> return (capActor, capItem)
-            frrid <- MaybeT $ lift $ getKeyBy $ UniqueFollowRemoteRequestActivity obiid
+                            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
-            unless (actor == LocalActorSharer shr) $
+                    verifyCapability capability (Left senderPersonID) resource
-                lift $ throwE "Undoing someone else's follow"
+                    lift updateDB
-            lift $ lift $ delete frrid
+                    actorID <- do
-    deleteFollow _ (Right _) = mzero
+                        maybeActor <- lift $ getLocalActorEntity actorByKey
+                        case localActorID <$> maybeActor of
+                            Nothing -> error "Actor entity not in DB"
+                            Just aid -> pure aid
+                    actor <- lift $ getJust actorID
+                    return $ Just
+                        ( actorByKey
+                        , Entity actorID actor
+                        , makeRecipientSet
+                            [actorByHash]
+                            [ localActorFollowers actorByHash
+                            , workItemFollowers wiByHash
+                            , LocalStagePersonFollowers senderHash
+                            ]
+                        , [LocalActorPerson senderHash]
+                        , [ localActorFollowers actorByHash
+                          , workItemFollowers wiByHash
+                          , LocalStagePersonFollowers senderHash
+                          ]
+                        )
 
-    deleteResolve (Left (_, obiid)) = do
+        -- Insert the Undo activity to author's outbox
-        Entity trlid trl <- MaybeT $ lift $ getBy $ UniqueTicketResolveLocalActivity obiid
+        undoID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        lift $ lift $ do
+        luUndo <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) undoID action
-            let trid = ticketResolveLocalTicket trl
+
-            tr <- getJust trid
+        -- Deliver the Undo activity to local recipients, and schedule delivery
-            delete trlid
+        -- for unavailable remote recipients
-            delete trid
+        deliverHttpUndo <- do
-            let ltid = ticketResolveTicket tr
+            let sieve =
-            tid <- localTicketTicket <$> getJust ltid
+                    case maybeUndoLocal of
-            update tid [TicketStatus =. TSTodo]
+                        Nothing ->
-            return $ Just ltid
+                            makeRecipientSet
-    deleteResolve (Right ractid) = do
+                                [] [LocalStagePersonFollowers senderHash]
-        Entity trrid trr <- MaybeT $ lift $ getBy $ UniqueTicketResolveRemoteActivity ractid
+                        Just (_, _, s, _, _) -> s
-        lift $ lift $ do
+                localRecipsFinal = localRecipSieve sieve False localRecips
-            let trid = ticketResolveRemoteTicket trr
+            deliverActivityDB
-            tr <- getJust trid
+                (LocalActorPerson senderHash) (personActor senderPerson)
-            delete trrid
+                localRecipsFinal remoteRecips fwdHosts undoID action
-            delete trid
+
-            let ltid = ticketResolveTicket tr
+        maybeDeliverHttpAccept <- for maybeUndoLocal $ \ (actorByKey, Entity actorID actor, _, acceptActors, acceptStages) -> do
-            tid <- localTicketTicket <$> getJust ltid
+
-            update tid [TicketStatus =. TSTodo]
+            -- Verify the relevant actor has received the Undp
-            return $ Just ltid
+            verifyActorHasItem actorID undoID "Actor didn't receive the Undo"
--}
+
+            -- Insert an Accept activity to actor's outbox
+            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
+            actionAccept <- prepareAccept luUndo acceptActors acceptStages
+            _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
+
+            -- Deliver the Accept activity to local recipients, and schedule
+            -- delivery for unavailable remote recipients
+            let localRecipsAccept = makeRecipientSet acceptActors acceptStages
+            actorByHash <- hashLocalActor actorByKey
+            deliverActivityDB
+                actorByHash actorID localRecipsAccept [] []
+                acceptID actionAccept
+
+        -- Return instructions for HTTP delivery to remote recipients
+        return (undoID, deliverHttpUndo, maybeDeliverHttpAccept)
+
+    -- Launch asynchronous HTTP delivery of Undo and Accept
+    lift $ do
+        forkWorker "undoC: async HTTP Undo delivery" deliverHttpUndo
+        for_ maybeDeliverHttpAccept $
+            forkWorker "undoC: async HTTP Accept delivery"
+
+    return undoID
+
+    where
+
+    prepareAccept luUndo actors stages = do
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        let recips =
+                map encodeRouteHome $
+                        map renderLocalActor actors ++
+                        map renderLocalStage stages
+        return AP.Action
+            { AP.actionCapability = Nothing
+            , AP.actionSummary    = Nothing
+            , AP.actionAudience   = Audience recips [] [] [] [] []
+            , AP.actionFulfills   = []
+            , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                { AP.acceptObject   = ObjURI hLocal luUndo
+                , AP.acceptResult   = Nothing
+                }
+            }
 
 pushCommitsC
     :: Entity Person

src/Vervis/Client.hs

@@ -86,7 +86,6 @@ import Vervis.Model
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Ticket
-import Vervis.WorkItem
 
 makeServerInput
     :: (MonadSite m, SiteEnv m ~ App)
@@ -782,7 +781,7 @@ applyPatches
     -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], Apply URIMode)
 applyPatches senderHash uObject = do
 
-    bundle <- parseProposalBundle "Apply object" uObject
+    bundle <- parseBundleRoute "Apply object" uObject
     mrInfo <-
         bifor bundle
             (\ (loomID, clothID, _) -> do

src/Vervis/Data/Actor.hs

@@ -20,6 +20,9 @@ module Vervis.Data.Actor
     , stampRoute
     , parseStampRoute
     , localActorID
+    , parseLocalURI
+    , parseFedURI
+    , parseLocalActorE
     )
 where
 
@@ -104,3 +107,18 @@ localActorID (LocalActorGroup (Entity _ g))  = groupActor g
 localActorID (LocalActorRepo (Entity _ r))   = repoActor r
 localActorID (LocalActorDeck (Entity _ d))   = deckActor d
 localActorID (LocalActorLoom (Entity _ l))   = loomActor l
+
+parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App)
+parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
+
+parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI)
+parseFedURI u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> parseLocalURI lu
+        else pure $ Right u
+
+parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
+parseLocalActorE route = do
+    actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
+    unhashLocalActorE actorByHash "Invalid actor keyhashid"

src/Vervis/Data/Discussion.hs

@@ -39,26 +39,12 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 
+import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
 
-parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App)
-parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
-
-parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI)
-parseFedURI u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
-    if hl
-        then Left <$> parseLocalURI lu
-        else pure $ Right u
-
-parseLocalActorE :: Route App -> ExceptT Text Handler (LocalActorBy Key)
-parseLocalActorE route = do
-    actorByHash <- fromMaybeE (parseLocalActor route) "Not an actor route"
-    unhashLocalActorE actorByHash "Invalid actor keyhashid"
-
 parseCommentId
     :: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId)
 parseCommentId (PersonMessageR p m) =

src/Vervis/Data/Follow.hs

@@ -0,0 +1,84 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Data.Follow
+    ( FolloweeBy (..)
+    , followeeActor
+    , parseFollow
+    )
+where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Except
+import Data.Bitraversable
+import Data.Foldable
+import Data.Maybe
+import Data.Text (Text)
+import Database.Persist.Types
+
+import Network.FedURI
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+
+import Vervis.Data.Actor
+import Vervis.Data.Ticket
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Recipient
+
+data FolloweeBy f
+    = FolloweeActor (LocalActorBy f)
+    | FolloweeWorkItem (WorkItemBy f)
+
+followeeActor :: FolloweeBy f -> LocalActorBy f
+followeeActor (FolloweeActor a) = a
+followeeActor (FolloweeWorkItem wi) = workItemActor wi
+
+unhashFolloweeE (FolloweeActor a) e = FolloweeActor <$> unhashLocalActorE a e
+unhashFolloweeE (FolloweeWorkItem wi) e = FolloweeWorkItem <$> unhashWorkItemE wi e
+
+parseFollow
+    :: AP.Follow URIMode
+    -> ExceptT Text Handler
+        (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
+parseFollow (AP.Follow uObject mluContext hide) = do
+    routeOrRemote <- parseFedURI uObject
+    (,hide) <$>
+        bitraverse
+            (parseLocal mluContext)
+            (pure . makeRemote mluContext)
+            routeOrRemote
+    where
+    parseFollowee r =
+        FolloweeActor <$> parseLocalActor r <|>
+        FolloweeWorkItem <$> parseWorkItem r
+    parseLocal mlu r = 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
+            unless (actorByKey == followeeActor byKey) $
+                throwE "Isn't object's actor"
+        return byKey
+    makeRemote mlu (ObjURI h lu) = (h, fromMaybe lu mlu, lu)

src/Vervis/Data/Ticket.hs

@@ -22,6 +22,27 @@ module Vervis.Data.Ticket
     , checkOfferTicket
     , checkApplyLocalLoom
 
+    , parseBundleRoute
+
+    , WorkItemBy (..)
+
+    , hashWorkItemPure
+    , getHashWorkItem
+    , hashWorkItem
+
+    , unhashWorkItemPure
+    , unhashWorkItem
+    , unhashWorkItemF
+    , unhashWorkItemM
+    , unhashWorkItemE
+    , unhashWorkItem404
+
+    , workItemResource
+    , workItemActor
+    , workItemFollowers
+    , workItemRoute
+    , parseWorkItem
+
     -- These are exported only for Vervis.Client
     , Tracker (..)
     , checkTracker
@@ -30,11 +51,16 @@ where
 
 import Control.Monad
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Data.Bifunctor
 import Data.Foldable
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text (Text)
 import Data.Traversable
+import Web.Hashids
+import Yesod.Core
+
+import qualified Control.Monad.Fail as F
 
 import Development.PatchMediaType
 import Network.FedURI
@@ -42,15 +68,17 @@ import Web.Text
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 
+import Vervis.Access
 import Vervis.Foundation
 import Vervis.FedURI
 import Vervis.Model
-import Vervis.Ticket
+import Vervis.Recipient
 
 data Tip
     = TipLocalRepo RepoId
@@ -201,12 +229,28 @@ checkOfferTicket host ticket uTarget = do
     tam <- checkTrackerAndMerge target maybeBundle
     return $ WorkItemOffer author title desc source tam
 
+parseBundleRoute name u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> do
+            route <-
+                fromMaybeE (decodeRouteLocal lu) $
+                    name <> ": Not a valid route"
+            case route of
+                BundleR loom ticket bundle ->
+                    (,,)
+                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
+                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
+                        <*> 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)
 checkApply (AP.Apply uObject target) =
-    (,) <$> parseProposalBundle "Apply object" uObject
+    (,) <$> parseBundleRoute "Apply object" uObject
         <*> nameExceptT "Apply target" (checkTip target)
 
 checkApplyLocalLoom
@@ -227,3 +271,91 @@ checkApplyLocalLoom apply = do
                 Left b -> pure b
                 Right _ -> throwE "Applying a remote bundle on local loom"
         return (repoID, maybeBranch, loomID, clothID, bundleID)
+
+data WorkItemBy f
+    = WorkItemTicket (f Deck) (f TicketDeck)
+    | WorkItemCloth (f Loom) (f TicketLoom)
+
+hashWorkItemPure :: HashidsContext -> WorkItemBy Key -> WorkItemBy KeyHashid
+hashWorkItemPure ctx = f
+    where
+    f (WorkItemTicket d t) =
+        WorkItemTicket (encodeKeyHashidPure ctx d) (encodeKeyHashidPure ctx t)
+    f (WorkItemCloth l c) =
+        WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)
+
+getHashWorkItem
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => m (WorkItemBy Key -> WorkItemBy KeyHashid)
+getHashWorkItem = do
+    ctx <- asksSite siteHashidsContext
+    return $ hashWorkItemPure ctx
+
+hashWorkItem
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => WorkItemBy Key -> m (WorkItemBy KeyHashid)
+hashWorkItem actor = do
+    hash <- getHashWorkItem
+    return $ hash actor
+
+unhashWorkItemPure
+    :: HashidsContext -> WorkItemBy KeyHashid -> Maybe (WorkItemBy Key)
+unhashWorkItemPure ctx = f
+    where
+    f (WorkItemTicket d t) =
+        WorkItemTicket
+            <$> decodeKeyHashidPure ctx d
+            <*> decodeKeyHashidPure ctx t
+    f (WorkItemCloth l c) =
+        WorkItemCloth
+            <$> decodeKeyHashidPure ctx l
+            <*> decodeKeyHashidPure ctx c
+
+unhashWorkItem
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
+unhashWorkItem actor = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashWorkItemPure ctx actor
+
+unhashWorkItemF
+    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
+    => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
+unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor
+
+unhashWorkItemM
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
+unhashWorkItemM = MaybeT . unhashWorkItem
+
+unhashWorkItemE
+    :: (MonadSite m, YesodHashids (SiteEnv m))
+    => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
+unhashWorkItemE actor e =
+    ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor
+
+unhashWorkItem404
+    :: ( MonadSite m
+       , MonadHandler m
+       , HandlerSite m ~ SiteEnv m
+       , YesodHashids (HandlerSite m)
+       )
+    => WorkItemBy KeyHashid
+    -> m (WorkItemBy Key)
+unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
+
+workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
+workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom
+
+workItemActor (WorkItemTicket deck _) = LocalActorDeck deck
+workItemActor (WorkItemCloth loom _) = LocalActorLoom loom
+
+workItemFollowers (WorkItemTicket d t) = LocalStageTicketFollowers d t
+workItemFollowers (WorkItemCloth l c) = LocalStageClothFollowers l c
+
+workItemRoute (WorkItemTicket d t) = TicketR d t
+workItemRoute (WorkItemCloth l c) = ClothR l c
+
+parseWorkItem (TicketR deck task) = Just $ WorkItemTicket deck task
+parseWorkItem (ClothR loom cloth) = Just $ WorkItemCloth loom cloth
+parseWorkItem _ = Nothing

src/Vervis/Federation/Ticket.hs

@@ -113,7 +113,6 @@ import Vervis.Query
 import Vervis.Recipient
 import Vervis.Ticket
 import Vervis.Web.Repo
-import Vervis.WorkItem
 
 {-
 checkBranch

src/Vervis/Fetch.hs

@@ -102,7 +102,6 @@ import Vervis.RemoteActorStore
 import Vervis.Settings
 import Vervis.Query
 import Vervis.Ticket
-import Vervis.WorkItem
 
 data Result
     = ResultSomeException SomeException

src/Vervis/Handler/Cloth.hs

@@ -128,6 +128,7 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.Paginate
 import Vervis.Persist.Actor
+import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Style

src/Vervis/Handler/Person.hs

@@ -335,10 +335,7 @@ postPersonOutboxR personHash = do
                         addBundleC eperson sharer summary audience patches target
                     _ -> throwE "Unsupported Add 'object' type"
             -}
-            {-
+            AP.FollowActivity follow -> run followC follow
-            FollowActivity follow ->
-                followC shr summary audience follow
-            -}
             AP.OfferActivity (AP.Offer obj target) ->
                 case obj of
                     AP.OfferTicket ticket -> run offerTicketC ticket target
@@ -347,12 +344,8 @@ postPersonOutboxR personHash = do
                         offerDepC eperson sharer summary audience dep target
                     -}
                     _ -> throwE "Unsupported Offer 'object' type"
-            {-
+            AP.ResolveActivity resolve -> run resolveC resolve
-            ResolveActivity resolve ->
+            AP.UndoActivity undo -> run undoC undo
-                resolveC eperson sharer summary audience resolve
-            UndoActivity undo ->
-                undoC eperson sharer summary audience undo
-            -}
             _ -> throwE "Unsupported activity type"
 
 getPersonOutboxItemR

src/Vervis/Handler/Ticket.hs

@@ -151,6 +151,7 @@ import Vervis.Model.Workflow
 import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Persist.Discussion
+import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Style

src/Vervis/Persist/Follow.hs

@@ -0,0 +1,138 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Persist.Follow
+    ( getFollowee
+    , getFollowee'
+    , tryUnfollow
+    )
+where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Barbie
+import Data.Bitraversable
+import Data.Functor
+import Data.Maybe
+import Data.Text (Text)
+import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
+
+import qualified Data.Text as T
+import qualified Database.Esqueleto as E
+
+import Crypto.ActorKey
+import Database.Persist.JSON
+import Network.FedURI
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Database.Persist.Local
+
+import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Follow
+import Vervis.Data.Ticket
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Persist.Actor
+import Vervis.Persist.Ticket
+import Vervis.Recipient
+import Vervis.Settings
+import Vervis.Ticket
+
+getFollowee
+    :: MonadIO m
+    => FolloweeBy Key
+    -> ExceptT Text (ReaderT SqlBackend m)
+        (LocalActorBy Key, ActorId, Maybe FollowerSetId)
+getFollowee (FolloweeActor actorByKey) = do
+    actorByEntity <- do
+        maybeActor <- lift $ getLocalActorEntity actorByKey
+        fromMaybeE maybeActor "Actor not found in DB"
+    return (actorByKey, localActorID actorByEntity, Nothing)
+getFollowee (FolloweeWorkItem wi) =
+    case wi of
+        WorkItemTicket deckID taskID -> do
+            actorID <- deckActor <$> getE deckID "No such deck in DB"
+            (_, _, Entity _ ticket, _, _) <- do
+                mticket <- lift $ getTicket deckID taskID
+                fromMaybeE mticket "No such ticket in DB"
+            return
+                ( LocalActorDeck deckID
+                , actorID
+                , Just $ ticketFollowers ticket
+                )
+        WorkItemCloth loomID clothID -> do
+            actorID <- loomActor <$> getE loomID "No such loom in DB"
+            (_, _, Entity _ ticket, _, _, _) <- do
+                mcloth <- lift $ getCloth loomID clothID
+                fromMaybeE mcloth "No such MR in DB"
+            return
+                ( LocalActorLoom loomID
+                , actorID
+                , Just $ ticketFollowers ticket
+                )
+
+getFollowee' followerSetID = do
+    actorOrTicket <-
+        requireEitherAlt
+            (getKeyBy $ UniqueActorFollowers followerSetID)
+            (getKeyBy $ UniqueTicketFollowers followerSetID)
+            "Can't find who's using this FollowerSet"
+            "Multi use of FollowerSet"
+    either FolloweeActor FolloweeWorkItem <$>
+        bitraverse getLocalActor getWorkItem actorOrTicket
+
+tryUnfollow (Left (_actorByKey, _actorEntity, itemID)) =
+    runMaybeT $
+        MaybeT forRemoteRequest <|> MaybeT forRemote <|> MaybeT forLocal
+    where
+    forRemoteRequest = do
+        maybeFollow <- getBy $ UniqueFollowRemoteRequestActivity itemID
+        for maybeFollow $ \ (Entity requestID request) -> do
+            actorID <-
+                personActor <$> getJust (followRemoteRequestPerson request)
+            let uTarget =
+                    fromMaybe (followRemoteRequestTarget request) $
+                        followRemoteRequestRecip request
+            return (delete requestID, actorID, Right uTarget)
+    forRemote = do
+        maybeFollow <- getBy $ UniqueFollowRemoteFollow itemID
+        for maybeFollow $ \ (Entity remoteID remote) -> do
+            let actorID = followRemoteActor remote
+            uTarget <- getRemoteActorURI =<< getJust (followRemoteRecip remote)
+            return (delete remoteID, actorID, Right uTarget)
+    forLocal = do
+        maybeFollow <- getBy $ UniqueFollowFollow itemID
+        return $ maybeFollow <&> \ (Entity followID follow) ->
+            let actorID = followActor follow
+                followerSetID = followTarget follow
+            in  (delete followID, actorID, Left followerSetID)
+tryUnfollow (Right _) = pure Nothing

src/Vervis/Persist/Ticket.hs

@@ -14,19 +14,27 @@
  -}
 
 module Vervis.Persist.Ticket
-    ( checkApplyDB
+    ( getTicketResolve
+    , getWorkItem
+    , checkApplyDB
+    , tryUnresolve
     )
 where
 
 import Control.Monad
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Bitraversable
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.Text (Text)
 import Data.These
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
 
 import qualified Data.List.NonEmpty as NE
 
@@ -34,15 +42,57 @@ import Development.PatchMediaType
 import Yesod.Hashids
 
 import Control.Monad.Trans.Except.Local
+import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.Access
 import Vervis.Cloth
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Persist.Actor
 import Vervis.Recipient
 
+getTicketResolve (Entity _ tr, resolve) = do
+    time <- outboxItemPublished <$> getJust (ticketResolveAccept tr)
+    closer <- bitraverse getCloserLocal getCloserRemote resolve
+    return (time, closer)
+    where
+    getCloserLocal (Entity _ trl) = do
+        outboxID <-
+            outboxItemOutbox <$>
+                getJust (ticketResolveLocalActivity trl)
+        Entity actorID actor <- do
+            maybeActor <- getBy $ UniqueActorOutbox outboxID
+            case maybeActor of
+                Nothing -> error "No actor for outbox"
+                Just a -> pure a
+        actorByEntity <- getLocalActorEnt actorID
+        person <-
+            case actorByEntity of
+                LocalActorPerson p -> pure p
+                _ -> error "Surprise! Ticket closer isn't a Person"
+        return (person, actor)
+    getCloserRemote (Entity _ trr) = do
+        ra <- getJust $ ticketResolveRemoteActor trr
+        ro <- getJust $ remoteActorIdent ra
+        i <- getJust $ remoteObjectInstance ro
+        return (i, ro, ra)
+
+getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m (WorkItemBy Key)
+getWorkItem tid = do
+    tracker <-
+        requireEitherAlt
+            (getBy $ UniqueTicketDeck tid)
+            (getBy $ UniqueTicketLoom tid)
+            "Neither TD nor TD found"
+            "Both TD and TL found"
+    return $
+        case tracker of
+            Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid
+            Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid
+
 -- | Given:
 --
 -- * A local tip (i.e. a repository or a branch), parsed from a URI
@@ -142,3 +192,24 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
                     else throwE "Patch type mismatch with repo VCS type"
 
     return (loom, ticketID, diffs)
+
+tryUnresolve (Left (_actorByKey, _actorEntity, itemID)) = do
+    maybeResolve <- getBy $ UniqueTicketResolveLocalActivity itemID
+    for maybeResolve $ \ (Entity resolveLocalID resolveLocal) -> do
+        let resolveID = ticketResolveLocalTicket resolveLocal
+        resolve <- getJust resolveID
+        let ticketID = ticketResolveTicket resolve
+        return
+            ( delete resolveLocalID >> delete resolveID
+            , ticketID
+            )
+tryUnresolve (Right remoteActivityID) = do
+    maybeResolve <- getBy $ UniqueTicketResolveRemoteActivity remoteActivityID
+    for maybeResolve $ \ (Entity resolveRemoteID resolveRemote) -> do
+        let resolveID = ticketResolveRemoteTicket resolveRemote
+        resolve <- getJust resolveID
+        let ticketID = ticketResolveTicket resolve
+        return
+            ( delete resolveRemoteID >> delete resolveID
+            , ticketID
+            )

src/Vervis/Ticket.hs

@@ -39,16 +39,9 @@ module Vervis.Ticket
     --, getDependencyCollection
     --, getReverseDependencyCollection
 
-    , WorkItem (..)
+    --, getWorkItem
-    , getWorkItemRoute
-    , askWorkItemRoute
-    , getWorkItem
-    , parseWorkItem
-    , parseProposalBundle
 
-    , checkDepAndTarget
+    --, checkDepAndTarget
-
-    , getTicketResolve
     )
 where
 
@@ -85,6 +78,7 @@ import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -690,74 +684,7 @@ getReverseDependencyCollection here getLocalTicketId404 = do
             return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
 -}
 
-data WorkItem
+{-
-    = WorkItemTicket DeckId TicketDeckId
-    | WorkItemCloth LoomId TicketLoomId
-    deriving Eq
-
-getWorkItemRoute
-    :: (MonadSite m, YesodHashids (SiteEnv m)) => WorkItem -> m (Route App)
-getWorkItemRoute wi = ($ wi) <$> askWorkItemRoute
-
-askWorkItemRoute
-    :: (MonadSite m, YesodHashids (SiteEnv m)) => m (WorkItem -> Route App)
-askWorkItemRoute = do
-    hashDID <- getEncodeKeyHashid
-    hashLID <- getEncodeKeyHashid
-    hashTDID <- getEncodeKeyHashid
-    hashTLID <- getEncodeKeyHashid
-    let route (WorkItemTicket did tdid) = TicketR (hashDID did) (hashTDID tdid)
-        route (WorkItemCloth lid tlid)  = ClothR (hashLID lid) (hashTLID tlid)
-    return route
-
-getWorkItem :: MonadIO m => TicketId -> ReaderT SqlBackend m WorkItem
-getWorkItem tid = do
-    tracker <-
-        requireEitherAlt
-            (getBy $ UniqueTicketDeck tid)
-            (getBy $ UniqueTicketLoom tid)
-            "Neither TD nor TD found"
-            "Both TD and TL found"
-    return $
-        case tracker of
-            Left (Entity tdid td) -> WorkItemTicket (ticketDeckDeck td) tdid
-            Right (Entity tlid tl) -> WorkItemCloth (ticketLoomLoom tl) tlid
-
-parseWorkItem name u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
-    if hl
-        then Left <$> do
-            route <-
-                fromMaybeE (decodeRouteLocal lu) $
-                    name <> ": Not a valid route"
-            case route of
-                TicketR deck ticket ->
-                    WorkItemTicket
-                        <$> decodeKeyHashidE deck   (name <> ": Invalid dkhid")
-                        <*> decodeKeyHashidE ticket (name <> ": Invalid tdkhid")
-                ClothR loom ticket ->
-                    WorkItemCloth
-                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
-                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
-                _ -> throwE $ name <> ": not a work item route"
-        else return $ Right u
-
-parseProposalBundle name u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
-    if hl
-        then Left <$> do
-            route <-
-                fromMaybeE (decodeRouteLocal lu) $
-                    name <> ": Not a valid route"
-            case route of
-                BundleR loom ticket bundle ->
-                    (,,)
-                        <$> decodeKeyHashidE loom   (name <> ": Invalid lkhid")
-                        <*> decodeKeyHashidE ticket (name <> ": Invalid tlkhid")
-                        <*> decodeKeyHashidE bundle (name <> ": Invalid bnkhid")
-                _ -> throwE $ name <> ": not a bundle route"
-        else return $ Right u
-
 checkDepAndTarget
     :: (MonadSite m, SiteEnv m ~ App)
     => TicketDependency URIMode
@@ -798,29 +725,4 @@ checkDepAndTarget
     checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
     checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
     checkParentAndTarget (Right _) (Right _) = return ()
-
+-}
-getTicketResolve (Entity _ tr, resolve) = do
-    time <- outboxItemPublished <$> getJust (ticketResolveAccept tr)
-    closer <- bitraverse getCloserLocal getCloserRemote resolve
-    return (time, closer)
-    where
-    getCloserLocal (Entity _ trl) = do
-        outboxID <-
-            outboxItemOutbox <$>
-                getJust (ticketResolveLocalActivity trl)
-        Entity actorID actor <- do
-            maybeActor <- getBy $ UniqueActorOutbox outboxID
-            case maybeActor of
-                Nothing -> error "No actor for outbox"
-                Just a -> pure a
-        actorByEntity <- getLocalActorEnt actorID
-        person <-
-            case actorByEntity of
-                LocalActorPerson p -> pure p
-                _ -> error "Surprise! Ticket closer isn't a Person"
-        return (person, actor)
-    getCloserRemote (Entity _ trr) = do
-        ra <- getJust $ ticketResolveRemoteActor trr
-        ro <- getJust $ remoteActorIdent ra
-        i <- getJust $ remoteObjectInstance ro
-        return (i, ro, ra)

src/Vervis/Web/Actor.hs

@@ -97,6 +97,7 @@ import qualified Web.ActivityPub as AP
 import Vervis.ActivityPub
 import Vervis.API
 import Vervis.Data.Actor
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Foundation
@@ -433,10 +434,10 @@ getFollowingCollection here actor hash = do
             <*> getRemotes followerActorID
 
     hashActor <- getHashLocalActor
-    workItemRoute <- askWorkItemRoute
+    hashItem <- getHashWorkItem
     let locals =
             map (renderLocalActor . hashActor) localActors ++
-            map workItemRoute workItems
+            map (workItemRoute . hashItem) workItems
     unless (length locals == localTotal) $
         error "Bug! List length mismatch"
 

src/Vervis/Web/Discussion.hs

@@ -62,6 +62,7 @@ import Yesod.Persist.Local
 
 import Vervis.API
 import Vervis.Data.Discussion
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Form.Discussion
 import Vervis.Foundation
@@ -69,6 +70,7 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Persist.Actor
 import Vervis.Persist.Discussion
+import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
@@ -220,7 +222,6 @@ serveMessage authorHash localMessageHash = do
     localMessageID <- decodeKeyHashid404 localMessageHash
 
     encodeRouteHome <- getEncodeRouteHome
-    workItemRoute <- askWorkItemRoute
     noteAP <- runDB $ do
         author <- get404 authorID
         localMessage <- get404 localMessageID
@@ -236,8 +237,10 @@ serveMessage authorHash localMessageHash = do
                     "Neither T nor RD found"
                     "Both T and RD found"
             case topic of
-                Left ticketID ->
+                Left ticketID -> do
-                    encodeRouteHome . workItemRoute <$> getWorkItem ticketID
+                    wiByKey <- getWorkItem ticketID
+                    wiByHash <- hashWorkItem wiByKey
+                    return $ encodeRouteHome $ workItemRoute wiByHash
                 Right rd -> do
                     ro <- getJust $ remoteDiscussionIdent rd
                     i <- getJust $ remoteObjectInstance ro

src/Web/ActivityPub.hs

@@ -1513,21 +1513,21 @@ encodeCreate (Create obj target)
 
 data Follow u = Follow
     { followObject  :: ObjURI u
-    , followContext :: Maybe (ObjURI u)
+    , followContext :: Maybe LocalURI
     , followHide    :: Bool
     }
 
 parseFollow :: UriMode u => Object -> Parser (Follow u)
-parseFollow o =
+parseFollow o = do
-    Follow
+    u@(ObjURI h _) <- o .:  "object"
-        <$> o .:  "object"
+    Follow u
-        <*> o .:? "context"
+        <$> withAuthorityMaybeO h (o .:? "context")
         <*> o .:? "hide" .!= False
 
 encodeFollow :: UriMode u => Follow u -> Series
 encodeFollow (Follow obj mcontext hide)
     =  "object"  .=  obj
-    <> "context" .=? mcontext
+    <> "context" .=? (ObjURI (objUriAuthority obj) <$> mcontext)
     <> "hide"    .=  hide
 
 data Grant u = Grant

vervis.cabal

@@ -143,6 +143,7 @@ library
                        Vervis.Data.Actor
                        Vervis.Data.Collab
                        Vervis.Data.Discussion
+                       Vervis.Data.Follow
                        Vervis.Data.Ticket
 
                        --Vervis.Federation
@@ -211,6 +212,7 @@ library
                        Vervis.Persist.Actor
                        Vervis.Persist.Collab
                        Vervis.Persist.Discussion
+                       Vervis.Persist.Follow
                        Vervis.Persist.Ticket
 
                        Vervis.Query
@@ -246,7 +248,7 @@ library
                        Vervis.Widget.Tracker
                        -- Vervis.Widget.Workflow
                        -- Vervis.Wiki
-                       Vervis.WorkItem
+                       --Vervis.WorkItem
 
   default-extensions:  TemplateHaskell
                        QuasiQuotes