S2S: Implement loomResolveF, allowing to close MR without Applying

src/Vervis/Federation/Ticket.hs

@@ -13,6 +13,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE RankNTypes #-}
+
 module Vervis.Federation.Ticket
     ( --personOfferTicketF
       deckOfferTicketF
@@ -26,7 +28,7 @@ module Vervis.Federation.Ticket
     --, repoOfferDepF
 
     , deckResolveF
-    --, repoResolveF
+    , loomResolveF
     )
 where
 
@@ -1864,29 +1866,50 @@ insertResolve author ltid ractid obiidAccept = do
             }
 -}
 
-deckResolveF
-    :: UTCTime
-    -> KeyHashid Deck
+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))
-deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
+trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
 
     -- Check input
-    recipDeckID <- decodeKeyHashid404 recipDeckHash
-    taskID <- nameExceptT "Resolve object" $ do
+    recipID <- decodeKeyHashid404 recipHash
+    wiID <- 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"
+        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
@@ -1900,64 +1923,62 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) =
 
     maybeHttp <- runDBExcept $ do
 
-        -- Find recipient deck in DB, returning 404 if doesn't exist because
-        -- we're in the deck's inbox post handler
-        recipDeck <- lift $ get404 recipDeckID
-        let recipDeckActorID = deckActor recipDeck
-        recipDeckActor <- lift $ getJust recipDeckActorID
+        -- 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 deck's inbox
-        mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luResolve False
+        -- 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
-                maybeTicket <- lift $ getTicket recipDeckID taskID
-                (_deck, _task, Entity ticketID _, _author, maybeResolve) <-
-                    fromMaybeE maybeTicket "I don't have such a ticket in DB"
+                (ticketID, maybeResolve) <- getWorkItem recipID wiID
                 unless (isNothing maybeResolve) $
-                    throwE "Ticket is already resolved"
+                    throwE "Work item is already resolved"
                 return ticketID
 
-            -- Verify the sender is authorized by the deck to resolve a ticket
+            -- 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 deck"
+                    Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
             verifyCapability
                 capability
                 (Right $ remoteAuthorId author)
-                (GrantResourceDeck recipDeckID)
+                (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
-                taskHash <- encodeKeyHashid taskID
+                wiHash <- encodeKeyHashid wiID
                 let sieve =
                         makeRecipientSet
                             []
-                            [ LocalStageDeckFollowers recipDeckHash
-                            , LocalStageTicketFollowers recipDeckHash taskHash
+                            [ trackerFollowers recipHash
+                            , itemFollowers recipHash wiHash
                             ]
                 forwardActivityDB
-                    (actbBL body) localRecips sig recipDeckActorID
-                    (LocalActorDeck recipDeckHash) sieve resolveID
+                    (actbBL body) localRecips sig recipActorID
+                    (makeLocalActor recipHash) sieve resolveID
 
             -- Mark ticket in DB as resolved by the Resolve
             acceptID <-
-                lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
+                lift $ insertEmptyOutboxItem (actorOutbox recipActor) now
             lift $ insertResolve ticketID resolveID acceptID
 
-            -- Prepare an Accept activity and insert to deck's outbox
+            -- Prepare an Accept activity and insert to tracker's outbox
             (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                lift $ prepareAccept taskID
-            _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
+                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
-                    (LocalActorDeck recipDeckHash) recipDeckActorID
+                    (makeLocalActor recipHash) recipActorID
                     localRecipsAccept remoteRecipsAccept fwdHostsAccept
                     acceptID actionAccept
 
@@ -1973,8 +1994,8 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) =
             return "I already have this activity in my inbox, doing nothing"
         Just (maybeHttpFwdResolve, deliverHttpAccept) -> do
             for_ maybeHttpFwdResolve $
-                forkWorker "deckResolveF inbox-forwarding"
-            forkWorker "deckResolveF Accept HTTP delivery" deliverHttpAccept
+                forkWorker "trackerResolveF inbox-forwarding"
+            forkWorker "trackerResolveF Accept HTTP delivery" deliverHttpAccept
             return $
                 case maybeHttpFwdResolve of
                     Nothing -> "Resolved ticket, no inbox-forwarding to do"
@@ -1994,10 +2015,10 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) =
             , ticketResolveRemoteActor    = remoteAuthorId author
             }
 
-    prepareAccept taskID = do
+    prepareAccept wiID = do
         encodeRouteHome <- getEncodeRouteHome
 
-        taskHash <- encodeKeyHashid taskID
+        wiHash <- encodeKeyHashid wiID
 
         ra <- getJust $ remoteAuthorId author
 
@@ -2010,8 +2031,8 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) =
             audTracker =
                 AudLocal
                     []
-                    [ LocalStageDeckFollowers recipDeckHash
-                    , LocalStageTicketFollowers recipDeckHash taskHash
+                    [ trackerFollowers recipHash
+                    , itemFollowers recipHash wiHash
                     ]
 
             (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
@@ -2031,139 +2052,62 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) =
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-repoResolveF
+deckResolveF
     :: UTCTime
-    -> KeyHashid Repo
+    -> KeyHashid Deck
     -> RemoteAuthor
     -> ActivityBody
     -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Resolve URIMode
-    -> ExceptT Text Handler Text
-repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
-    error "repoResolveF temporarily disabled"
+    -> 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
 
-
-
-{-
-
-
-    object <- parseWorkItem "Resolve object" uObject
-    mmmmhttp <- runDBExcept $ do
-        Entity ridRecip repoRecip <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            getBy404 $ UniqueRepo rpRecip sid
-        mltid <-
-            case relevantObject object of
-                Nothing -> do
-                    case object of
-                        Left wi -> verifyWorkItemExists wi
-                        Right _ -> return ()
-                    return Nothing
-                Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
-        mractid <- lift $ insertToInbox now author body (repoInbox repoRecip) luResolve False
-        lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
-            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
-                ltkhid <- encodeKeyHashid ltid
-                let sieve =
-                        makeRecipientSet
-                            []
-                            [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
-                            , LocalPersonCollectionRepoTeam shrRecip rpRecip
-                            , LocalPersonCollectionRepoFollowers shrRecip rpRecip
-                            ]
-                remoteRecips <-
-                    insertRemoteActivityToLocalInboxes
-                        False ractid $
-                            localRecipSieve'
-                                sieve False False localRecips
-                (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
-            obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
-            mmtrrid <- insertResolve author ltid ractid obiidAccept
-            case mmtrrid of
-                Just (Just _) -> update tid [TicketStatus =. TSClosed]
-                _ -> delete obiidAccept
-            for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
-                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                    insertAccept luResolve ltid obiidAccept
-                knownRemoteRecipsAccept <-
-                    deliverLocal'
-                        False
-                        (LocalActorRepo shrRecip rpRecip)
-                        (repoInbox repoRecip)
-                        obiidAccept
-                        localRecipsAccept
-                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
-                    deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-    case mmmmhttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just mmmhttp ->
-            case mmmhttp of
-                Nothing -> return "Object not mine, just stored in inbox"
-                Just mmhttp ->
-                    case mmhttp of
-                        Nothing -> return "Ticket already resolved"
-                        Just mhttp ->
-                            case mhttp of
-                                Nothing -> return "Activity already resolved a ticket"
-                                Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
-                                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
-                                        forkWorker "repoResolveF inbox-forwarding" $
-                                            deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
-                                    forkWorker "repoResolveF Accept HTTP delivery" $
-                                        deliverRemoteHttp' fwdHosts obiid doc recips
-                                    return $
-                                        if isJust mremotesHttpFwd
-                                            then "Ticket is mine, now resolved, did inbox-forwarding"
-                                            else "Ticket is mine, now resolved, no inbox-forwarding to do"
-    where
-    relevantObject (Left (WorkItemRepoProposal shr rp ltid))
-        | shr == shrRecip && rp == rpRecip = Just ltid
-    relevantObject _ = Nothing
-
-    getObjectLtid ltid = do
-        (_, _, Entity tid _, _, _, _, _, _, _) <- do
-            mticket <- lift $ getRepoProposal shrRecip rpRecip ltid
-            fromMaybeE mticket $ "Object" <> ": No such repo-patch"
-        return tid
-
-    insertAccept luResolve ltid obiidAccept = do
-        encodeRouteLocal <- getEncodeRouteLocal
-        encodeRouteHome <- getEncodeRouteHome
-        hLocal <- asksSite siteInstanceHost
-        obikhidAccept <- encodeKeyHashid obiidAccept
-        ltkhid <- encodeKeyHashid ltid
-        ra <- getJust $ remoteAuthorId author
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-
-            audAuthor =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-
-            audTicket =
-                AudLocal
-                    []
-                    [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
-                    , LocalPersonCollectionRepoTeam shrRecip rpRecip
-                    , LocalPersonCollectionRepoFollowers shrRecip rpRecip
-                    ]
-
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audAuthor, audTicket]
-
-            recips = map encodeRouteHome audLocal ++ audRemote
-            doc = Doc hLocal Activity
-                { activityId       =
-                    Just $ encodeRouteLocal $
-                        RepoOutboxItemR shrRecip rpRecip obikhidAccept
-                , activityActor    = encodeRouteLocal $ RepoR shrRecip rpRecip
-                , activityCapability = Nothing
-                , activitySummary  = Nothing
-                , activityAudience = Audience recips [] [] [] [] []
-                , activitySpecific = AcceptActivity Accept
-                    { acceptObject = ObjURI hAuthor luResolve
-                    , acceptResult = Nothing
-                    }
-                }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return (doc, recipientSet, remoteActors, fwdHosts)
--}
+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

src/Vervis/Handler/Loom.hs

@@ -166,6 +166,8 @@ postLoomInboxR recipLoomHash =
                     AP.OfferTicket ticket ->
                         loomOfferTicketF now recipLoomHash author body mfwd luActivity ticket target
                     _ -> return ("Unsupported offer object type for looms", Nothing)
+            AP.ResolveActivity resolve ->
+                loomResolveF now recipLoomHash author body mfwd luActivity resolve
             _ -> return ("Unsupported activity type for looms", Nothing)
 
 getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent