S2S: Port Deck's & Loom's Resolve handlers from the old system

src/Vervis/Actor/Deck.hs

@@ -485,6 +485,166 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+-- Meaning: An actor is asking to close a ticket
+-- Behavior:
+--      * Verify it's my ticket
+--      * Verify the Resolve is authorized
+--      * Insert the Resolve to my inbox
+--      * Close the ticket in my DB
+--      * Forward the Resolve to my followers & ticket followers
+--      * Publish an Accept to:
+--          - My followers
+--          - Ticket's followers
+--          - Resolve sender+followers
+deckResolve
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> AP.Resolve URIMode
+    -> ActE (Text, Act (), Next)
+deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
+
+    -- Check input
+    deckHash <- encodeKeyHashid deckID
+    taskHash <- nameExceptT "Resolve.object" $ do
+        route <- do
+            routeOrRemote <- parseFedURI uObject
+            case routeOrRemote of
+                Left route -> pure route
+                Right _ -> throwE "Remote, so definitely not mine"
+        case route of
+            TicketR deckHash' taskHash | deckHash' == deckHash ->
+                return taskHash
+            _ -> throwE "Local route but not a ticket of mine"
+    taskID <- decodeKeyHashidE taskHash "Invalid TicketDeck keyhashid"
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Resolve.capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (deckRecip, actorRecip) <- lift $ do
+            d <- getJust deckID
+            (d,) <$> getJust (deckActor d)
+
+        -- Find ticket in DB, verify it's not resolved
+        ticketID <- do
+            maybeTicket <- lift $ getTicket deckID taskID
+            (_deck, _task, Entity ticketID _, _author, maybeResolve) <-
+                fromMaybeE maybeTicket "I don't have such a ticket in DB"
+            unless (isNothing maybeResolve) $
+                throwE "Ticket is already resolved"
+            return ticketID
+
+        -- Insert the Resolve to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+        for mractid $ \ resolveDB -> do
+
+            -- Verify the sender is authorized by the tracker to resolve a ticket
+            verifyCapability'
+                capability
+                authorIdMsig
+                (GrantResourceDeck deckID)
+                AP.RoleTriage
+
+            -- Prepare forwarding the Resolve to my followers & ticket
+            -- followers
+            let sieve =
+                    makeRecipientSet []
+                        [ LocalStageDeckFollowers deckHash
+                        , LocalStageTicketFollowers deckHash taskHash
+                        ]
+
+            -- Mark ticket in DB as resolved by the Resolve
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            lift $ insertResolve ticketID resolveDB 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 "Resolved ticket and forwarded the Resolve"
+
+    where
+
+    insertResolve ticketID resolveDB acceptID = do
+        trid <- insert TicketResolve
+            { ticketResolveTicket = ticketID
+            , ticketResolveAccept = acceptID
+            }
+        case resolveDB of
+            Left (_actorByKey, _, resolveID) ->
+                insert_ TicketResolveLocal
+                    { ticketResolveLocalTicket   = trid
+                    , ticketResolveLocalActivity = resolveID
+                    }
+            Right (author, _, resolveID) ->
+                insert_ TicketResolveRemote
+                    { ticketResolveRemoteTicket   = trid
+                    , ticketResolveRemoteActivity = resolveID
+                    , ticketResolveRemoteActor    = remoteAuthorId author
+                    }
+
+    prepareAccept taskID = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        audSender <- makeAudSenderWithFollowers authorIdMsig
+        deckHash <- encodeKeyHashid deckID
+        taskHash <- encodeKeyHashid taskID
+        let audDeck =
+                AudLocal
+                    []
+                    [ LocalStageDeckFollowers deckHash
+                    , LocalStageTicketFollowers deckHash taskHash
+                    ]
+        uResolve <- 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   = [uResolve]
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uResolve
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 ------------------------------------------------------------------------------
 -- Following
 ------------------------------------------------------------------------------
@@ -920,6 +1080,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
         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.ResolveActivity resolve -> deckResolve now deckID verse resolve
         AP.UndoActivity undo     -> deckUndo now deckID verse undo
         _ -> throwE "Unsupported activity type for Deck"
 deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck"

src/Vervis/Actor/Loom.hs

@@ -409,10 +409,171 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+-- Meaning: An actor is asking to close a MR
+-- Behavior:
+--      * Verify it's my MR
+--      * Verify the Resolve is authorized
+--      * Insert the Resolve to my inbox
+--      * Close the MR in my DB
+--      * Forward the Resolve to my followers & MR followers
+--      * Publish an Accept to:
+--          - My followers
+--          - MR's followers
+--          - Resolve sender+followers
+loomResolve
+    :: UTCTime
+    -> LoomId
+    -> Verse
+    -> AP.Resolve URIMode
+    -> ActE (Text, Act (), Next)
+loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
+
+    -- Check input
+    loomHash <- encodeKeyHashid loomID
+    clothHash <- nameExceptT "Resolve.object" $ do
+        route <- do
+            routeOrRemote <- parseFedURI uObject
+            case routeOrRemote of
+                Left route -> pure route
+                Right _ -> throwE "Remote, so definitely not mine"
+        case route of
+            ClothR loomHash' clothHash | loomHash' == loomHash ->
+                return clothHash
+            _ -> throwE "Local route but not a MR of mine"
+    clothID <- decodeKeyHashidE clothHash "Invalid TicketLoom keyhashid"
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Resolve.capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (loomRecip, actorRecip) <- lift $ do
+            d <- getJust loomID
+            (d,) <$> getJust (loomActor d)
+
+        -- Find ticket in DB, verify it's not resolved
+        ticketID <- do
+            maybeCloth <- lift $ getCloth loomID clothID
+            (_loom, _cloth, Entity ticketID _, _author, maybeResolve, _merge) <-
+                fromMaybeE maybeCloth "I don't have such a MR in DB"
+            unless (isNothing maybeResolve) $
+                throwE "MR is already resolved"
+            return ticketID
+
+        -- Insert the Resolve to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+        for mractid $ \ resolveDB -> do
+
+            -- Verify the sender is authorized by the tracker to resolve a ticket
+            verifyCapability'
+                capability
+                authorIdMsig
+                (GrantResourceLoom loomID)
+                AP.RoleTriage
+
+            -- Prepare forwarding the Resolve to my followers & ticket
+            -- followers
+            let sieve =
+                    makeRecipientSet []
+                        [ LocalStageLoomFollowers loomHash
+                        , LocalStageClothFollowers loomHash clothHash
+                        ]
+
+            -- Mark ticket in DB as resolved by the Resolve
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            lift $ insertResolve ticketID resolveDB acceptID
+
+            -- Prepare an Accept activity and insert to my outbox
+            accept@(actionAccept, _, _, _) <- lift $ prepareAccept clothID
+            let recipByKey = LocalActorLoom loomID
+            _luAccept <- lift $ updateOutboxItem' recipByKey acceptID actionAccept
+
+            return (loomActor loomRecip, sieve, acceptID, accept)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (loomActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorLoom loomID) loomActorID sieve
+            lift $ sendActivity
+                (LocalActorLoom loomID) loomActorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            done "Resolved ticket and forwarded the Resolve"
+
+    where
+
+    insertResolve ticketID resolveDB acceptID = do
+        trid <- insert TicketResolve
+            { ticketResolveTicket = ticketID
+            , ticketResolveAccept = acceptID
+            }
+        case resolveDB of
+            Left (_actorByKey, _, resolveID) ->
+                insert_ TicketResolveLocal
+                    { ticketResolveLocalTicket   = trid
+                    , ticketResolveLocalActivity = resolveID
+                    }
+            Right (author, _, resolveID) ->
+                insert_ TicketResolveRemote
+                    { ticketResolveRemoteTicket   = trid
+                    , ticketResolveRemoteActivity = resolveID
+                    , ticketResolveRemoteActor    = remoteAuthorId author
+                    }
+
+    prepareAccept clothID = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        audSender <- makeAudSenderWithFollowers authorIdMsig
+        loomHash <- encodeKeyHashid loomID
+        clothHash <- encodeKeyHashid clothID
+        let audLoom =
+                AudLocal
+                    []
+                    [ LocalStageLoomFollowers loomHash
+                    , LocalStageClothFollowers loomHash clothHash
+                    ]
+        uResolve <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender, audLoom]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uResolve]
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uResolve
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next)
 loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
-        AP.OfferActivity offer   -> loomOffer now loomID verse offer
+        AP.OfferActivity offer     -> loomOffer now loomID verse offer
+        AP.ResolveActivity resolve -> loomResolve now loomID verse resolve
         _ -> throwE "Unsupported activity type for Loom"
 loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom"
 

src/Vervis/Federation/Ticket.hs

@@ -25,9 +25,6 @@ module Vervis.Federation.Ticket
 
     --, deckOfferDepF
     --, repoOfferDepF
-
-    , deckResolveF
-    , loomResolveF
     )
 where
 
@@ -1387,251 +1384,3 @@ insertResolve author ltid ractid obiidAccept = do
             , ticketResolveRemoteActor    = remoteAuthorId author
             }
 -}
-
-trackerResolveF
-    :: ( PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r
-       , ToBackendKey SqlBackend wi
-       )
-    => (Route App -> Maybe (KeyHashid wi))
-    -> (r -> ActorId)
-    -> (  Key r
-       -> Key wi
-       -> ExceptT Text AppDB
-            ( TicketId
-            , Maybe
-                ( Entity TicketResolve
-                , Either
-                    (Entity TicketResolveLocal)
-                    (Entity TicketResolveRemote)
-                )
-            )
-       )
-    -> (Key r -> GrantResourceBy Key)
-    -> (KeyHashid r -> LocalStageBy KeyHashid)
-    -> (KeyHashid r -> KeyHashid wi -> LocalStageBy KeyHashid)
-    -> (forall f. f r -> LocalActorBy f)
-    -> UTCTime
-    -> KeyHashid r
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Resolve URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
-    error "trackerResolveF disabled for refactoring"
-{-
-    -- Check input
-    recipID <- decodeKeyHashid404 recipHash
-    wiID <- nameExceptT "Resolve object" $ do
-        route <- do
-            routeOrRemote <- parseFedURIOld uObject
-            case routeOrRemote of
-                Left route -> pure route
-                Right _ -> throwE "Remote, so definitely not mine"
-        case maybeWorkItem route of
-            Nothing -> throwE "Local route but not a work item of mine"
-            Just wiHash ->
-                decodeKeyHashidE wiHash "Invalid work item keyhashid"
-
-    -- Verify the capability URI is one of:
-    --   * Outbox item URI of a local actor, i.e. a local activity
-    --   * A remote URI
-    capID <- do
-        uCap <- do
-            fromMaybeE
-                (activityCapability $ actbActivity body)
-                "Asking to resolve ticket but no capability provided"
-        nameExceptT "Resolve capability" $ parseActivityURI uCap
-
-    maybeHttp <- runDBExcept $ do
-
-        -- Find recipient tracker in DB, returning 404 if doesn't exist because
-        -- we're in the tracker's inbox post handler
-        recip <- lift $ get404 recipID
-        let recipActorID = grabActor recip
-        recipActor <- lift $ getJust recipActorID
-
-        -- Insert the Resolve to tracker's inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luResolve False
-        for mractid $ \ resolveID -> do
-
-            -- Find ticket in DB, verify it's not resolved
-            ticketID <- do
-                (ticketID, maybeResolve) <- getWorkItem recipID wiID
-                unless (isNothing maybeResolve) $
-                    throwE "Work item is already resolved"
-                return ticketID
-
-            -- Verify the sender is authorized by the tracker to resolve a ticket
-            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
-                (Right $ remoteAuthorId author)
-                (makeResource recipID)
-
-            -- Forward the Resolve activity to relevant local stages, and
-            -- schedule delivery for unavailable remote members of them
-            maybeHttpFwdResolve <- lift $ for mfwd $ \ (localRecips, sig) -> do
-                wiHash <- encodeKeyHashid wiID
-                let sieve =
-                        makeRecipientSet
-                            []
-                            [ trackerFollowers recipHash
-                            , itemFollowers recipHash wiHash
-                            ]
-                forwardActivityDB
-                    (actbBL body) localRecips sig recipActorID
-                    (makeLocalActor recipHash) sieve resolveID
-
-            -- Mark ticket in DB as resolved by the Resolve
-            acceptID <-
-                lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
-            lift $ insertResolve ticketID resolveID acceptID
-
-            -- Prepare an Accept activity and insert to tracker's outbox
-            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                lift $ prepareAccept wiID
-            _luAccept <- lift $ updateOutboxItem (makeLocalActor recipID) acceptID actionAccept
-
-            -- Deliver the Accept to local recipients, and schedule delivery
-            -- for unavailable remote recipients
-            deliverHttpAccept <-
-                deliverActivityDB
-                    (makeLocalActor recipHash) recipActorID
-                    localRecipsAccept remoteRecipsAccept fwdHostsAccept
-                    acceptID actionAccept
-
-            -- Return instructions for HTTP inbox-forwarding of the Resolve
-            -- activity, and for HTTP delivery of the Accept activity to
-            -- remote recipients
-            return (maybeHttpFwdResolve, deliverHttpAccept)
-
-    -- Launch asynchronous HTTP forwarding of the Resolve activity and HTTP
-    -- delivery of the Accept activity
-    case maybeHttp of
-        Nothing ->
-            return "I already have this activity in my inbox, doing nothing"
-        Just (maybeHttpFwdResolve, deliverHttpAccept) -> do
-            for_ maybeHttpFwdResolve $
-                forkWorker "trackerResolveF inbox-forwarding"
-            forkWorker "trackerResolveF Accept HTTP delivery" deliverHttpAccept
-            return $
-                case maybeHttpFwdResolve of
-                    Nothing -> "Resolved ticket, no inbox-forwarding to do"
-                    Just _ ->
-                        "Resolved ticket and ran inbox-forwarding of the Resolve"
-
-    where
-
-    insertResolve ticketID resolveID acceptID = do
-        trid <- insert TicketResolve
-            { ticketResolveTicket = ticketID
-            , ticketResolveAccept = acceptID
-            }
-        insert_ TicketResolveRemote
-            { ticketResolveRemoteTicket   = trid
-            , ticketResolveRemoteActivity = resolveID
-            , ticketResolveRemoteActor    = remoteAuthorId author
-            }
-
-    prepareAccept wiID = do
-        encodeRouteHome <- getEncodeRouteHome
-
-        wiHash <- encodeKeyHashid wiID
-
-        ra <- getJust $ remoteAuthorId author
-
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-
-            audSender =
-                AudRemote hAuthor
-                    [luAuthor]
-                    (maybeToList $ remoteActorFollowers ra)
-            audTracker =
-                AudLocal
-                    []
-                    [ trackerFollowers recipHash
-                    , itemFollowers recipHash wiHash
-                    ]
-
-            (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 luResolve
-                    , AP.acceptResult   = Nothing
-                    }
-                }
-
-        return (action, recipientSet, remoteActors, fwdHosts)
--}
-
-deckResolveF
-    :: UTCTime
-    -> KeyHashid Deck
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Resolve URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-deckResolveF now deckHash =
-    trackerResolveF
-        (\case
-            TicketR trackerHash taskHash | trackerHash == deckHash ->
-                Just taskHash
-            _ -> Nothing
-        )
-        deckActor
-        (\ deckID taskID -> do
-            maybeTicket <- lift $ getTicket deckID taskID
-            (_deck, _task, Entity ticketID _, _author, maybeResolve) <-
-                fromMaybeE maybeTicket "I don't have such a ticket in DB"
-            return (ticketID, maybeResolve)
-        )
-        GrantResourceDeck
-        LocalStageDeckFollowers
-        LocalStageTicketFollowers
-        LocalActorDeck
-        now
-        deckHash
-
-loomResolveF
-    :: UTCTime
-    -> KeyHashid Loom
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Resolve URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-loomResolveF now loomHash =
-    trackerResolveF
-        (\case
-            ClothR trackerHash clothHash | trackerHash == loomHash ->
-                Just clothHash
-            _ -> Nothing
-        )
-        loomActor
-        (\ loomID clothID -> do
-            maybeCloth <- lift $ getCloth loomID clothID
-            (_loom, _cloth, Entity ticketID _, _author, maybeResolve, _merge) <-
-                fromMaybeE maybeCloth "I don't have such a MR in DB"
-            return (ticketID, maybeResolve)
-        )
-        GrantResourceLoom
-        LocalStageLoomFollowers
-        LocalStageClothFollowers
-        LocalActorLoom
-        now
-        loomHash