S2S: Re-enable deckCreateNoteF

src/Vervis/Federation/Discussion.hs

@@ -15,7 +15,7 @@
 
 module Vervis.Federation.Discussion
     ( personCreateNoteF
-    --, deckCreateNoteF
+    , deckCreateNoteF
     --, loomCreateNoteF
     )
 where
@@ -53,13 +53,14 @@ import Yesod.HttpSignature
 import Database.Persist.JSON
 import Network.FedURI
 import Network.HTTP.Digest
-import Web.ActivityPub hiding (ActorLocal (..))
 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 Data.Tuple.Local
 import Database.Persist.Local
@@ -78,6 +79,7 @@ import Vervis.Persist.Discussion
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
+import Vervis.Web.Delivery
 
 -- | Insert the new remote comment into the discussion tree. If we didn't have
 -- this comment before, return the database ID of the newly created cached
@@ -170,7 +172,7 @@ personCreateNoteF
     -> ActivityBody
     -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Note URIMode
+    -> AP.Note URIMode
     -> ExceptT Text Handler Text
 personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
 
@@ -238,35 +240,51 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
                         unless (messageRoot m == did) $
                             throwE "Remote parent belongs to a different discussion"
 
-{-
+deckCreateNoteF
-projectCreateNoteF
     :: UTCTime
-    -> KeyHashid Project
+    -> KeyHashid Deck
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Note URIMode
+    -> AP.Note URIMode
     -> ExceptT Text Handler Text
-projectCreateNoteF now deckRecip author body mfwd luCreate note = do
+deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
-    (luNote, published, context, mparent, source, content) <- checkNote note
+
-    case context of
+    recipDeckID <- decodeKeyHashid404 recipDeckHash
-        Right _ -> return "Not using; context isn't local"
+    (luNote, published, Comment maybeParent topic source content) <- do
-        Left (NoteContextProjectTicket shr prj ltid) -> do
+        (luId, luAuthor, published, comment) <- parseRemoteComment note
-            mremotesHttp <- runDBExcept $ do
+        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
-                (jid, ibid) <- lift getProjectRecip404
+            throwE "Create author != note author"
-                (_, _, _, Entity _ lt, _, Entity _ tpl, _, _) <- do
+        return (luId, published, comment)
-                    mticket <- lift $ getProjectTicket shr prj ltid
+
-                    fromMaybeE mticket "Context: No such project-ticket"
+    case topic of
-                if ticketProjectLocalProject tpl == jid
+        Right _ ->
-                    then do
+            pure "Topic is remote, i.e. not mine, so ignoring activity"
-                        mractid <- lift $ insertToInbox now author body ibid luCreate False
+        Left (CommentTopicCloth _ _) ->
+            pure "Topic is a local cloth, i.e. not mine, so ignoring activity"
+        Left (CommentTopicTicket deckID taskID)
+            | deckID /= recipDeckID ->
+                pure "Topic is some other deck's ticket, so ignoring activity"
+            | otherwise -> do
+                msgOrForward <- runDBExcept $ do
+
+                    Entity recipActorID recipActor <- lift $ do
+                        deck <- get404 recipDeckID
+                        let actorID = deckActor deck
+                        Entity actorID <$> getJust actorID
+
+                    (_d, _td, Entity _ ticket, _a, _r) <- do
+                        mticket <- lift $ getTicket recipDeckID taskID
+                        fromMaybeE mticket "Topic: No such ticket in DB"
+
+                    mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luCreate False
                     case mractid of
                         Nothing -> return $ Left "Activity already in my inbox"
-                            Just ractid -> do
+                        Just createID -> do
-                                let did = localTicketDiscuss lt
+                            let did = ticketDiscuss ticket
-                                meparent <- traverse (getParent did) mparent
+                            meparent <- traverse (getMessageParent did) maybeParent
-                                mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
+                            mmid <- lift $ insertToDiscussion author luNote published source content did meparent createID
                             case mmid of
                                 Nothing -> return $ Left "I already have this comment, just storing in inbox"
                                 Just mid -> lift $ do
@@ -275,31 +293,21 @@ projectCreateNoteF now deckRecip author body mfwd luCreate note = do
                                         Nothing ->
                                             return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
                                         Just (localRecips, sig) -> Right <$> do
-                                                ltkhid <- encodeKeyHashid ltid
+                                            taskHash <- encodeKeyHashid taskID
                                             let sieve =
                                                     makeRecipientSet
                                                         []
-                                                            [ LocalPersonCollectionProjectFollowers shrRecip prjRecip
+                                                        [ LocalStageDeckFollowers recipDeckHash
-                                                            , LocalPersonCollectionProjectTeam shrRecip prjRecip
+                                                        , LocalStageTicketFollowers recipDeckHash taskHash
-                                                            , LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
-                                                            --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
                                                         ]
-                                                remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+                                            forwardActivityDB
-                                                (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
+                                                (actbBL body) localRecips sig recipActorID
-                    else return $ Left "Context is a project-ticket of another project"
+                                                (LocalActorDeck recipDeckHash) sieve createID
-            case mremotesHttp of
+                case msgOrForward of
                     Left msg -> return msg
-                Right (sig, remotesHttp) -> do
+                    Right forwardHttp -> do
-                    forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
+                        forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                         return "Stored to inbox, cached comment, and did inbox forwarding"
-        Left (NoteContextRepoProposal _ _ _) -> return "Context is a repo-patch, ignoring activity"
-    where
-    getProjectRecip404 = do
-        sid <- getKeyBy404 $ UniqueSharer shrRecip
-        Entity jid j <- getBy404 $ UniqueProject prjRecip sid
-        a <- getJust $ projectActor j
-        return (jid, actorInbox a)
--}
 
 {-
 repoCreateNoteF

src/Vervis/Handler/Deck.hs

@@ -100,6 +100,7 @@ import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Collab
+import Vervis.Federation.Discussion
 import Vervis.Federation.Ticket
 import Vervis.FedURI
 import Vervis.Form.Project
@@ -184,14 +185,12 @@ postDeckInboxR recipDeckHash =
         case specific of
             AP.AcceptActivity accept ->
                 deckAcceptF now recipDeckHash author body mfwd luActivity accept
-            {-
+            AP.CreateActivity (AP.Create obj mtarget) ->
-            CreateActivity (Create obj mtarget) ->
                 case obj of
-                    CreateNote _ note ->
+                    AP.CreateNote _ note ->
-                        (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
+                        (,Nothing) <$> deckCreateNoteF now recipDeckHash author body mfwd luActivity note
-                    CreateTicket _ ticket ->
+                    _ -> error "Unsupported create object type for decks"
-                        (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
+            {-
-                    _ -> error "Unsupported create object type for projects"
             FollowActivity follow ->
                 (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
             -}