S2S: Implement loomCreateNoteF

src/Vervis/Federation/Discussion.hs

@@ -16,7 +16,7 @@
 module Vervis.Federation.Discussion
     ( personCreateNoteF
     , deckCreateNoteF
-    --, loomCreateNoteF
+    , loomCreateNoteF
     )
 where
 
@@ -309,65 +309,71 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
                         forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
                         return "Stored to inbox, cached comment, and did inbox forwarding"
 
-{-
+loomCreateNoteF
-repoCreateNoteF
     :: UTCTime
-    -> KeyHashid Repo
+    -> KeyHashid Loom
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> Note URIMode
+    -> AP.Note URIMode
     -> ExceptT Text Handler Text
-repoCreateNoteF now repoRecip author body mfwd luCreate note = do
+loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
-    (luNote, published, context, mparent, source, content) <- checkNote note
+
-    case context of
+    recipLoomID <- decodeKeyHashid404 recipLoomHash
-        Right _ -> return "Not using; context isn't local"
+    (luNote, published, Comment maybeParent topic source content) <- do
-        Left (NoteContextProjectTicket _ _ _) ->
+        (luId, luAuthor, published, comment) <- parseRemoteComment note
-            return "Context is a project-ticket, ignoring activity"
+        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
-        Left (NoteContextRepoProposal shr rp ltid) -> do
+            throwE "Create author != note author"
-            mremotesHttp <- runDBExcept $ do
+        return (luId, published, comment)
-                (rid, ibid) <- lift getRepoRecip404
+
-                (_, _, _, Entity _ lt, _, Entity _ trl, _, _, _) <- do
+    case topic of
-                    mticket <- lift $ getRepoProposal shr rp ltid
+        Right _ ->
-                    fromMaybeE mticket "Context: No such repo-patch"
+            pure "Topic is remote, i.e. not mine, so ignoring activity"
-                if ticketRepoLocalRepo trl == rid
+        Left (CommentTopicTicket _ _) ->
-                    then do
+            pure "Topic is a local issue, i.e. not mine, so ignoring activity"
-                        mractid <- lift $ insertToInbox now author body ibid luCreate False
+        Left (CommentTopicCloth loomID clothID)
-                        case mractid of
+            | loomID /= recipLoomID ->
-                            Nothing -> return $ Left "Activity already in my inbox"
+                pure "Topic is some other loom's MR, so ignoring activity"
-                            Just ractid -> do
+            | otherwise -> do
-                                let did = localTicketDiscuss lt
+                msgOrForward <- runDBExcept $ do
-                                meparent <- traverse (getParent did) mparent
+
-                                mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
+                    Entity recipActorID recipActor <- lift $ do
-                                case mmid of
+                        loom <- get404 recipLoomID
-                                    Nothing -> return $ Left "I already have this comment, just storing in inbox"
+                        let actorID = loomActor loom
-                                    Just mid -> lift $ do
+                        Entity actorID <$> getJust actorID
-                                        updateOrphans author luNote did mid
+
-                                        case mfwd of
+                    (_l, _tl, Entity _ ticket, _a, _r, _) <- do
-                                            Nothing ->
+                        mcloth <- lift $ getCloth recipLoomID clothID
-                                                return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
+                        fromMaybeE mcloth "Topic: No such cloth in DB"
-                                            Just (localRecips, sig) -> Right <$> do
+
-                                                ltkhid <- encodeKeyHashid ltid
+                    mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luCreate False
-                                                let sieve =
+                    case mractid of
-                                                        makeRecipientSet
+                        Nothing -> return $ Left "Activity already in my inbox"
-                                                            []
+                        Just createID -> do
-                                                            [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                            let did = ticketDiscuss ticket
-                                                            , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                            meparent <- traverse (getMessageParent did) maybeParent
-                                                            , LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
+                            mmid <- lift $ insertToDiscussion author luNote published source content did meparent createID
-                                                            --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
+                            case mmid of
-                                                            ]
+                                Nothing -> return $ Left "I already have this comment, just storing in inbox"
-                                                remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+                                Just mid -> lift $ do
-                                                (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
+                                    updateOrphans author luNote did mid
-                    else return $ Left "Context is a repo-patch of another repo"
+                                    case mfwd of
-            case mremotesHttp of
+                                        Nothing ->
-                Left msg -> return msg
+                                            return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
-                Right (sig, remotesHttp) -> do
+                                        Just (localRecips, sig) -> Right <$> do
-                    forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp
+                                            clothHash <- encodeKeyHashid clothID
-                    return "Stored to inbox, cached comment, and did inbox forwarding"
+                                            let sieve =
-    where
+                                                    makeRecipientSet
-    getRepoRecip404 = do
+                                                        []
-        sid <- getKeyBy404 $ UniqueSharer shrRecip
+                                                        [ LocalStageLoomFollowers recipLoomHash
-        Entity rid r <- getBy404 $ UniqueRepo rpRecip sid
+                                                        , LocalStageClothFollowers recipLoomHash clothHash
-        return (rid, repoInbox r)
+                                                        ]
--}
+                                            forwardActivityDB
+                                                (actbBL body) localRecips sig recipActorID
+                                                (LocalActorLoom recipLoomHash) sieve createID
+                case msgOrForward of
+                    Left msg -> return msg
+                    Right forwardHttp -> do
+                        forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp
+                        return "Stored to inbox, cached comment, and did inbox forwarding"

src/Vervis/Handler/Deck.hs

@@ -189,7 +189,7 @@ postDeckInboxR recipDeckHash =
                 case obj of
                     AP.CreateNote _ note ->
                         (,Nothing) <$> deckCreateNoteF now recipDeckHash author body mfwd luActivity note
-                    _ -> error "Unsupported create object type for decks"
+                    _ -> return ("Unsupported create object type for decks", Nothing)
             {-
             FollowActivity follow ->
                 (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow

src/Vervis/Handler/Loom.hs

@@ -77,6 +77,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
@@ -152,6 +153,11 @@ postLoomInboxR recipLoomHash =
                 loomAcceptF now recipLoomHash author body mfwd luActivity accept
             AP.ApplyActivity apply->
                 loomApplyF now recipLoomHash author body mfwd luActivity apply
+            AP.CreateActivity (AP.Create obj _mtarget) ->
+                case obj of
+                    AP.CreateNote _ note ->
+                        (,Nothing) <$> loomCreateNoteF now recipLoomHash author body mfwd luActivity note
+                    _ -> return ("Unsupported create object type for looms", Nothing)
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
             AP.OfferActivity (AP.Offer obj target) ->