S2S: Implement deckUndoF

src/Vervis/Federation/Offer.hs

@@ -26,7 +26,7 @@ module Vervis.Federation.Offer
     , repoFollowF
 
     --, sharerUndoF
-    --, projectUndoF
+    , deckUndoF
     --, repoUndoF
     )
 where
@@ -79,6 +79,7 @@ import Data.Tuple.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -676,6 +677,217 @@ repoFollowF now recipRepoHash =
         now
         recipRepoHash
 
+deckUndoF
+    :: UTCTime
+    -> KeyHashid Deck
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Undo URIMode
+    -> ExceptT Text Handler Text
+deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do
+
+    -- Check input
+    recipDeckID <- decodeKeyHashid404 recipDeckHash
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI uObject
+
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Undo capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI uCap
+
+    maybeHttp <- runDBExcept $ do
+
+        -- Find recipient deck in DB, returning 404 if doesn't exist because we're
+        -- in the deck's inbox post handler
+        (recipDeckActorID, recipDeckActor) <- lift $ do
+            deck <- get404 recipDeckID
+            let actorID = deckActor deck
+            (actorID,) <$> getJust actorID
+
+        -- Insert the Undo to deck's inbox
+        mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luUndo False
+        for mractid $ \ undoID -> do
+
+            -- Find the undone activity in our DB
+            undoneDB <- do
+                a <- getActivity undone
+                fromMaybeE a "Can't find undone in DB"
+
+            (sieve, acceptAudience) <- do
+                maybeUndo <- do
+                    let followers = actorFollowers recipDeckActor
+                    lift $ runMaybeT $
+                        Left <$> tryUnfollow recipDeckID followers undoneDB <|>
+                        Right <$> tryUnresolve recipDeckID undoneDB
+                undo <- fromMaybeE maybeUndo "Undone activity isn't a Follow or Resolve related to me"
+                (audSenderOnly, audSenderAndFollowers) <- do
+                    ra <- lift $ getJust $ remoteAuthorId author
+                    let ObjURI hAuthor luAuthor = remoteAuthorURI author
+                    return
+                        ( AudRemote hAuthor [luAuthor] []
+                        , AudRemote hAuthor
+                            [luAuthor]
+                            (maybeToList $ remoteActorFollowers ra)
+                        )
+                case undo of
+                    Left (remoteFollowID, followerID) -> do
+                        unless (followerID == remoteAuthorId author) $
+                            throwE "Trying to undo someone else's Follow"
+                        lift $ delete remoteFollowID
+                        return
+                            ( makeRecipientSet [] []
+                            , [audSenderOnly]
+                            )
+                    Right (deleteFromDB, taskID) -> do
+
+                        -- Verify the sender is authorized by the deck to unresolve a ticket
+                        capability <- do
+                            cap <-
+                                fromMaybeE
+                                    maybeCapability
+                                    "Asking to unresolve ticket but no capability provided"
+                            case cap of
+                                Left c -> pure c
+                                Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
+                        verifyCapability
+                            capability
+                            (Right $ remoteAuthorId author)
+                            (GrantResourceDeck recipDeckID)
+
+                        lift deleteFromDB
+
+                        taskHash <- encodeKeyHashid taskID
+                        return
+                            ( makeRecipientSet
+                                [LocalActorDeck recipDeckHash]
+                                [ LocalStageDeckFollowers recipDeckHash
+                                , LocalStageTicketFollowers recipDeckHash taskHash
+                                ]
+                            , [ AudLocal
+                                    []
+                                    [ LocalStageDeckFollowers recipDeckHash
+                                    , LocalStageTicketFollowers recipDeckHash taskHash
+                                    ]
+                              , audSenderAndFollowers
+                              ]
+                            )
+
+            -- Forward the Undo activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
+                forwardActivityDB
+                    (actbBL body) localRecips sig recipDeckActorID
+                    (LocalActorDeck recipDeckHash) sieve undoID
+
+
+            -- Prepare an Accept activity and insert to deck's outbox
+            acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
+            (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                lift . lift $ prepareAccept acceptAudience
+            _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
+
+            -- Deliver the Accept to local recipients, and schedule delivery
+            -- for unavailable remote recipients
+            deliverHttpAccept <-
+                deliverActivityDB
+                    (LocalActorDeck recipDeckHash) recipDeckActorID
+                    localRecipsAccept remoteRecipsAccept fwdHostsAccept
+                    acceptID actionAccept
+
+            -- Return instructions for HTTP inbox-forwarding of the Undo
+            -- activity, and for HTTP delivery of the Accept activity to
+            -- remote recipients
+            return (maybeHttpFwdUndo, deliverHttpAccept)
+
+    -- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
+    -- delivery of the Accept activity
+    case maybeHttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just (maybeHttpFwdUndo, deliverHttpAccept) -> do
+            forkWorker "deckUndoF Accept HTTP delivery" deliverHttpAccept
+            case maybeHttpFwdUndo of
+                Nothing -> return "Undid, no inbox-forwarding to do"
+                Just forwardHttpUndo -> do
+                    forkWorker "deckUndoF inbox-forwarding" forwardHttpUndo
+                    return "Undid and ran inbox-forwarding of the Undo"
+
+    where
+
+    tryUnfollow _      _               (Left _)                 = mzero
+    tryUnfollow deckID deckFollowersID (Right remoteActivityID) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        if followerSetID == deckFollowersID
+            then pure ()
+            else do
+                ticketID <-
+                    MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID
+                TicketDeck _ d <-
+                    MaybeT $ getValBy $ UniqueTicketDeck ticketID
+                guard $ d == deckID
+        return (remoteFollowID, followerID)
+
+    tryUnresolve deckID undone = do
+        (deleteFromDB, ticketID) <- findTicket undone
+        Entity taskID (TicketDeck _ d) <-
+            MaybeT $ getBy $ UniqueTicketDeck ticketID
+        guard $ d == deckID
+        return (deleteFromDB, taskID)
+        where
+        findTicket (Left (_actorByKey, _actorEntity, itemID)) = do
+            Entity resolveLocalID resolveLocal <-
+                MaybeT $ getBy $ UniqueTicketResolveLocalActivity itemID
+            let resolveID = ticketResolveLocalTicket resolveLocal
+            resolve <- lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveLocalID >> delete resolveID
+                , ticketID
+                )
+        findTicket (Right remoteActivityID) = do
+            Entity resolveRemoteID resolveRemote <-
+                MaybeT $ getBy $
+                    UniqueTicketResolveRemoteActivity remoteActivityID
+            let resolveID = ticketResolveRemoteTicket resolveRemote
+            resolve <- lift $ getJust resolveID
+            let ticketID = ticketResolveTicket resolve
+            return
+                ( delete resolveRemoteID >> delete resolveID
+                , ticketID
+                )
+
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        let ObjURI hAuthor _ = remoteAuthorURI author
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            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 luUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 {-
 getFollow (Left _)        = return Nothing
 getFollow (Right ractid)  = getBy $ UniqueRemoteFollowFollow ractid
@@ -850,108 +1062,6 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
         return ([ticketFollowers], [audAuthor, audTicket])
 -}
 
-{-
-projectUndoF
-    :: KeyHashid Project
-    -> UTCTime
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
-    -> LocalURI
-    -> Undo URIMode
-    -> ExceptT Text Handler Text
-projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
-    error "projectUndoF temporarily disabled"
-
-
-
-
-
-
-
-
-    object <- parseActivity uObj
-    mmmhttp <- runDBExcept $ do
-        (Entity jid j, a) <- lift $ do
-            sid <- getKeyBy404 $ UniqueSharer shrRecip
-            ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
-            (ej,) <$> getJust (projectActor j)
-        mractid <- lift $ insertToInbox now author body (actorInbox a) luUndo False
-        for mractid $ \ ractid -> do
-            mobject' <- getActivity object
-            lift $ for mobject' $ \ object' -> do
-                mobject'' <- runMaybeT $
-                    Left <$> MaybeT (getFollow object') <|>
-                    Right <$> MaybeT (getResolve object')
-                for mobject'' $ \ object'' -> do
-                    (result, mfwdColl, macceptAuds) <-
-                        case object'' of
-                            Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (actorFollowers a) erf
-                            Right tr -> deleteResolve myWorkItem prepareAccept tr
-                    mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
-                        let sieve = makeRecipientSet [] colls
-                        remoteRecips <-
-                            insertRemoteActivityToLocalInboxes
-                                False ractid $
-                                    localRecipSieve'
-                                        sieve False False localRecips
-                        (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
-                    mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
-                        obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
-                        (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds
-                        knownRemoteRecipsAccept <-
-                            deliverLocal'
-                                False
-                                (LocalActorProject shrRecip prjRecip)
-                                (actorInbox a)
-                                obiidAccept
-                                localRecipsAccept
-                        (obiidAccept,docAccept,fwdHostsAccept,) <$>
-                            deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-                    return (result, mremotesHttpFwd, mremotesHttpAccept)
-    case mmmhttp of
-        Nothing -> return "Activity already in my inbox"
-        Just mmhttp ->
-            case mmhttp of
-                Nothing -> return "Undo object isn't a known activity"
-                Just mhttp ->
-                    case mhttp of
-                        Nothing -> return "Undo object isn't in use"
-                        Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
-                            for_ mremotesHttpFwd $ \ (sig, remotes) ->
-                                forkWorker "projectUndoF inbox-forwarding" $
-                                    deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
-                            for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
-                                forkWorker "projectUndoF Accept HTTP delivery" $
-                                    deliverRemoteHttp' fwdHosts obiid doc remotes
-                            let fwdMsg =
-                                    case mremotesHttpFwd of
-                                        Nothing -> "No inbox-forwarding"
-                                        Just _ -> "Did inbox-forwarding"
-                                acceptMsg =
-                                    case mremotesHttpAccept of
-                                        Nothing -> "Didn't send Accept"
-                                        Just _ -> "Sent Accept"
-                            return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
-    where
-    myWorkItem (WorkItemProjectTicket shr prj ltid)
-        | shr == shrRecip && prj == prjRecip = Just ltid
-    myWorkItem _ = Nothing
-
-    prepareAccept ltid = do
-        ltkhid <- encodeKeyHashid ltid
-        ra <- getJust $ remoteAuthorId author
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
-            ticketFollowers =
-                LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
-            audAuthor =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
-            audTicket =
-                AudLocal [] [ticketFollowers]
-        return ([ticketFollowers], [audAuthor, audTicket])
--}
-
 {-
 repoUndoF
     :: KeyHashid Repo

src/Vervis/Handler/Deck.hs

@@ -212,10 +212,8 @@ postDeckInboxR recipDeckHash =
                     _ -> return ("Unsupported offer object type for decks", Nothing)
             AP.ResolveActivity resolve ->
                 deckResolveF now recipDeckHash author body mfwd luActivity resolve
-            {-
+            AP.UndoActivity undo ->
-            UndoActivity undo ->
+                (,Nothing) <$> deckUndoF now recipDeckHash author body mfwd luActivity undo
-                (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
-            -}
             _ -> return ("Unsupported activity type for decks", Nothing)
 
 getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent