S2S: Re-implement and re-enable deckResolveF

src/Vervis/Federation/Ticket.hs

@@ -25,7 +25,7 @@ module Vervis.Federation.Ticket
     --, deckOfferDepF
     --, repoOfferDepF
 
-    --, deckResolveF
+    , deckResolveF
     --, repoResolveF
     )
 where
@@ -91,6 +91,7 @@ import qualified Data.Text.UTF8.Local as TU
 
 import Development.PatchMediaType
 
+import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -1870,135 +1871,165 @@ deckResolveF
     -> ActivityBody
     -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Resolve URIMode
+    -> AP.Resolve URIMode
-    -> ExceptT Text Handler Text
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-deckResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
+deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
-    error "projectResolveF temporarily disabled"
 
+    -- Check input
+    recipDeckID <- decodeKeyHashid404 recipDeckHash
+    taskID <- 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 == recipDeckHash ->
+                decodeKeyHashidE taskHash "Invalid task keyhashid"
+            _ -> throwE "Local route but not a ticket of mine"
 
-{-
+    -- 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
 
-    object <- parseWorkItem "Resolve object" uObject
+        -- Find recipient deck in DB, returning 404 if doesn't exist because
-    mmmmhttp <- runDBExcept $ do
+        -- we're in the deck's inbox post handler
-        (Entity jidRecip projectRecip, actorRecip) <- lift $ do
+        recipDeck <- lift $ get404 recipDeckID
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
+        let recipDeckActorID = deckActor recipDeck
-            ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
+        recipDeckActor <- lift $ getJust recipDeckActorID
-            (ej,) <$> getJust (projectActor j)
+
-        mltid <-
+        -- Insert the Resolve to deck's inbox
-            case relevantObject object of
+        mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luResolve False
-                Nothing -> do
+        for mractid $ \ resolveID -> do
-                    case object of
+
-                        Left wi -> verifyWorkItemExists wi
+            -- Find ticket in DB, verify it's not resolved
-                        Right _ -> return ()
+            ticketID <- do
-                    return Nothing
+                maybeTicket <- lift $ getTicket recipDeckID taskID
-                Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
+                (_deck, _task, Entity ticketID _, _author, maybeResolve) <-
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luResolve False
+                    fromMaybeE maybeTicket "I don't have such a ticket in DB"
-        lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
+                unless (isNothing maybeResolve) $
-            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+                    throwE "Ticket is already resolved"
-                ltkhid <- encodeKeyHashid ltid
+                return ticketID
+
+            -- Verify the sender is authorized by the deck 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 deck"
+            verifyCapability
+                capability
+                (Right $ remoteAuthorId author)
+                (GrantResourceDeck recipDeckID)
+
+            -- Forward the Resolve activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeHttpFwdResolve <- lift $ for mfwd $ \ (localRecips, sig) -> do
+                taskHash <- encodeKeyHashid taskID
                 let sieve =
                         makeRecipientSet
                             []
-                            [ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
+                            [ LocalStageDeckFollowers recipDeckHash
-                            , LocalPersonCollectionProjectTeam shrRecip prjRecip
+                            , LocalStageTicketFollowers recipDeckHash taskHash
-                            , LocalPersonCollectionProjectFollowers shrRecip prjRecip
                             ]
-                remoteRecips <-
+                forwardActivityDB
-                    insertRemoteActivityToLocalInboxes
+                    (actbBL body) localRecips sig recipDeckActorID
-                        False ractid $
+                    (LocalActorDeck recipDeckHash) sieve resolveID
-                            localRecipSieve'
+
-                                sieve False False localRecips
+            -- Mark ticket in DB as resolved by the Resolve
-                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
+            acceptID <-
-            obiidAccept <- insertEmptyOutboxItem (actorOutbox actorRecip) now
+                lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
-            mmtrrid <- insertResolve author ltid ractid obiidAccept
+            lift $ insertResolve ticketID resolveID acceptID
-            case mmtrrid of
+
-                Just (Just _) -> update tid [TicketStatus =. TSClosed]
+            -- Prepare an Accept activity and insert to deck's outbox
-                _ -> delete obiidAccept
+            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-            for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
+                lift $ prepareAccept taskID
-                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+            _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
-                    insertAccept luResolve ltid obiidAccept
+
-                knownRemoteRecipsAccept <-
+            -- Deliver the Accept to local recipients, and schedule delivery
-                    deliverLocal'
+            -- for unavailable remote recipients
-                        False
+            deliverHttpAccept <-
-                        (LocalActorProject shrRecip prjRecip)
+                deliverActivityDB
-                        (actorInbox actorRecip)
+                    (LocalActorDeck recipDeckHash) recipDeckActorID
-                        obiidAccept
+                    localRecipsAccept remoteRecipsAccept fwdHostsAccept
-                        localRecipsAccept
+                    acceptID actionAccept
-                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
+
-                    deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+            -- Return instructions for HTTP inbox-forwarding of the Resolve
-    case mmmmhttp of
+            -- activity, and for HTTP delivery of the Accept activity to
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
+            -- remote recipients
-        Just mmmhttp ->
+            return (maybeHttpFwdResolve, deliverHttpAccept)
-            case mmmhttp of
+
-                Nothing -> return "Object not mine, just stored in inbox"
+    -- Launch asynchronous HTTP forwarding of the Resolve activity and HTTP
-                Just mmhttp ->
+    -- delivery of the Accept activity
-                    case mmhttp of
+    case maybeHttp of
-                        Nothing -> return "Ticket already resolved"
+        Nothing ->
-                        Just mhttp ->
+            return "I already have this activity in my inbox, doing nothing"
-                            case mhttp of
+        Just (maybeHttpFwdResolve, deliverHttpAccept) -> do
-                                Nothing -> return "Activity already resolved a ticket"
+            for_ maybeHttpFwdResolve $
-                                Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
+                forkWorker "deckResolveF inbox-forwarding"
-                                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+            forkWorker "deckResolveF Accept HTTP delivery" deliverHttpAccept
-                                        forkWorker "projectResolveF inbox-forwarding" $
-                                            deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
-                                    forkWorker "projectResolveF Accept HTTP delivery" $
-                                        deliverRemoteHttp' fwdHosts obiid doc recips
             return $
-                                        if isJust mremotesHttpFwd
+                case maybeHttpFwdResolve of
-                                            then "Ticket is mine, now resolved, did inbox-forwarding"
+                    Nothing -> "Resolved ticket, no inbox-forwarding to do"
-                                            else "Ticket is mine, now resolved, no inbox-forwarding to do"
+                    Just _ ->
+                        "Resolved ticket and ran inbox-forwarding of the Resolve"
+
     where
-    relevantObject (Left (WorkItemProjectTicket shr prj ltid))
-        | shr == shrRecip && prj == prjRecip = Just ltid
-    relevantObject _ = Nothing
 
-    getObjectLtid ltid = do
+    insertResolve ticketID resolveID acceptID = do
-        (_, _, Entity tid _, _, _, _, _, _) <- do
+        trid <- insert TicketResolve
-            mticket <- lift $ getProjectTicket shrRecip prjRecip ltid
+            { ticketResolveTicket = ticketID
-            fromMaybeE mticket $ "Object" <> ": No such project-ticket"
+            , ticketResolveAccept = acceptID
-        return tid
+            }
+        insert_ TicketResolveRemote
+            { ticketResolveRemoteTicket   = trid
+            , ticketResolveRemoteActivity = resolveID
+            , ticketResolveRemoteActor    = remoteAuthorId author
+            }
 
-    insertAccept luResolve ltid obiidAccept = do
+    prepareAccept taskID = do
-        encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
-        hLocal <- asksSite siteInstanceHost
+
-        obikhidAccept <- encodeKeyHashid obiidAccept
+        taskHash <- encodeKeyHashid taskID
-        ltkhid <- encodeKeyHashid ltid
+
         ra <- getJust $ remoteAuthorId author
+
         let ObjURI hAuthor luAuthor = remoteAuthorURI author
 
-            audAuthor =
+            audSender =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+                AudRemote hAuthor
-
+                    [luAuthor]
-            audTicket =
+                    (maybeToList $ remoteActorFollowers ra)
+            audTracker =
                 AudLocal
                     []
-                    [ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
+                    [ LocalStageDeckFollowers recipDeckHash
-                    , LocalPersonCollectionProjectTeam shrRecip prjRecip
+                    , LocalStageTicketFollowers recipDeckHash taskHash
-                    , LocalPersonCollectionProjectFollowers shrRecip prjRecip
                     ]
 
             (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audAuthor, audTicket]
+                collectAudience [audSender, audTracker]
 
             recips = map encodeRouteHome audLocal ++ audRemote
-            doc = Doc hLocal Activity
+            action = AP.Action
-                { activityId       =
+                { AP.actionCapability = Nothing
-                    Just $ encodeRouteLocal $
+                , AP.actionSummary    = Nothing
-                        ProjectOutboxItemR shrRecip prjRecip obikhidAccept
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
-                , activityActor    = encodeRouteLocal $ ProjectR shrRecip prjRecip
+                , AP.actionFulfills   = []
-                , activityCapability = Nothing
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
-                , activitySummary  = Nothing
+                    { AP.acceptObject   = ObjURI hAuthor luResolve
-                , activityAudience = Audience recips [] [] [] [] []
+                    , AP.acceptResult   = Nothing
-                , activitySpecific = AcceptActivity Accept
-                    { acceptObject = ObjURI hAuthor luResolve
-                    , acceptResult = Nothing
                     }
                 }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+
-        return (doc, recipientSet, remoteActors, fwdHosts)
+        return (action, recipientSet, remoteActors, fwdHosts)
--}
 
 repoResolveF
     :: UTCTime

src/Vervis/Handler/Deck.hs

@@ -211,9 +211,9 @@ postDeckInboxR recipDeckHash =
                         projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
                     -}
                     _ -> return ("Unsupported offer object type for decks", Nothing)
+            AP.ResolveActivity resolve ->
+                deckResolveF now recipDeckHash author body mfwd luActivity resolve
             {-
-            ResolveActivity resolve ->
-                (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
             UndoActivity undo ->
                 (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
             -}