S2S: Support commenting on sharer-patch and repo-patch

src/Vervis/API.hs

@@ -37,6 +37,7 @@ import Control.Monad.Trans.Reader
 import Crypto.Hash
 import Data.Aeson
 import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Either
 import Data.Foldable
@@ -111,6 +112,7 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
 import Vervis.Settings
+import Vervis.Patch
 import Vervis.Ticket
 
 verifyIsLoggedInUser
@@ -201,29 +203,44 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
                     let actors =
                             case mproject of
                                 Nothing -> []
-                                Just (shr, prj) -> [LocalActorProject shr prj]
+                                Just (Left (shr, prj)) -> [LocalActorProject shr prj]
+                                Just (Right (shr, rp)) -> [LocalActorRepo shr rp]
                         collections =
                             let project =
                                     case mproject of
                                         Nothing -> []
-                                        Just (shr, prj) ->
+                                        Just (Left (shr, prj)) ->
                                             [ LocalPersonCollectionProjectTeam shr prj
                                             , LocalPersonCollectionProjectFollowers shr prj
                                             ]
+                                        Just (Right (shr, rp)) ->
+                                            [ LocalPersonCollectionRepoTeam shr rp
+                                            , LocalPersonCollectionRepoFollowers shr rp
+                                            ]
                                 ticket =
                                     case context of
                                         Left nc ->
                                             case nc of
-                                                NoteContextSharerTicket shr talid ->
+                                                NoteContextSharerTicket shr talid False ->
                                                     let talkhid = hashTAL talid
                                                     in  [ -- LocalPersonCollectionSharerTicketTeam shr talkhid
                                                           LocalPersonCollectionSharerTicketFollowers shr talkhid
                                                         ]
+                                                NoteContextSharerTicket shr talid True ->
+                                                    let talkhid = hashTAL talid
+                                                    in  [ -- LocalPersonCollectionSharerPatchTeam shr talkhid
+                                                          LocalPersonCollectionSharerPatchFollowers shr talkhid
+                                                        ]
                                                 NoteContextProjectTicket shr prj ltid ->
                                                     let ltkhid = hashLT ltid
                                                     in  [ -- LocalPersonCollectionProjectTicketTeam shr prj ltkhid
                                                           LocalPersonCollectionProjectTicketFollowers shr prj ltkhid
                                                         ]
+                                                NoteContextRepoPatch shr rp ltid ->
+                                                    let ltkhid = hashLT ltid
+                                                    in  [ -- LocalPersonCollectionRepoPatchTeam shr rp ltkhid
+                                                          LocalPersonCollectionRepoPatchFollowers shr rp ltkhid
+                                                        ]
                                         Right _ -> []
                                 commenter = [LocalPersonCollectionSharerFollowers shrUser]
                             in  project ++ ticket ++ commenter
@@ -251,15 +268,25 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
         parseTopic name route =
             case route of
                 SharerTicketR shr talkhid ->
-                    NoteContextSharerTicket shr <$>
+                    flip (NoteContextSharerTicket shr) False <$>
                         decodeKeyHashidE
                             talkhid
                             (name <> " sharer ticket invalid talkhid")
+                SharerPatchR shr talkhid ->
+                    flip (NoteContextSharerTicket shr) True <$>
+                        decodeKeyHashidE
+                            talkhid
+                            (name <> " sharer patch invalid talkhid")
                 ProjectTicketR shr prj ltkhid ->
                     NoteContextProjectTicket shr prj <$>
                         decodeKeyHashidE
                             ltkhid
                             (name <> " project ticket invalid ltkhid")
+                RepoPatchR shr rp ltkhid ->
+                    NoteContextRepoPatch shr rp <$>
+                        decodeKeyHashidE
+                            ltkhid
+                            (name <> " repo patch invalid ltkhid")
                 _ -> throwE $ name <> " isn't a discussion topic route"
         parseNoteContext u@(ObjURI h lu) = do
             hl <- hostIsLocal h
@@ -306,7 +333,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
         unless (any ((== h) . fst) remoteRecips) $
             throwE
                 "Context is remote but no recipients of that host are listed"
-    verifyContextRecip (Left (NoteContextSharerTicket shr _)) localRecips _ =
+    verifyContextRecip (Left (NoteContextSharerTicket shr _ _)) localRecips _ =
         fromMaybeE
             verify
             "Local context ticket's hosting sharer isn't listed as a recipient"
@@ -323,6 +350,15 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
             sharerSet <- lookup shr localRecips
             projectSet <- lookup prj $ localRecipProjectRelated sharerSet
             guard $ localRecipProject $ localRecipProjectDirect projectSet
+    verifyContextRecip (Left (NoteContextRepoPatch shr rp _)) localRecips _ =
+        fromMaybeE
+            verify
+            "Local context patch's hosting repo isn't listed as a recipient"
+        where
+        verify = do
+            sharerSet <- lookup shr localRecips
+            repoSet <- lookup rp $ localRecipRepoRelated sharerSet
+            guard $ localRecipRepo $ localRecipRepoDirect repoSet
     insertEmptyOutboxItem obid now = do
         h <- asksSite siteInstanceHost
         insert OutboxItem
@@ -334,23 +370,41 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
         j <- getJust $ ticketProjectLocalProject tpl
         s <- getJust $ projectSharer j
         return (sharerIdent s, projectIdent j)
+    getRepo trl = do
+        r <- getJust $ ticketRepoLocalRepo trl
+        s <- getJust $ repoSharer r
+        return (sharerIdent s, repoIdent r)
     getTopicAndParent (Left context) mparent = do
         (mproject, did) <-
             case context of
-                NoteContextSharerTicket shr talid -> do
+                NoteContextSharerTicket shr talid False -> do
                     (_, Entity _ lt, _, project) <- do
                         mticket <- lift $ getSharerTicket shr talid
                         fromMaybeE mticket "Note context no such local sharer-hosted ticket"
                     mproj <-
                         case project of
-                            Left (_, Entity _ tpl) -> lift $ Just <$> getProject tpl
+                            Left (_, Entity _ tpl) -> lift $ Just . Left <$> getProject tpl
+                            Right _ -> return Nothing
+                    return (mproj, localTicketDiscuss lt)
+                NoteContextSharerTicket shr talid True -> do
+                    (_, Entity _ lt, _, repo, _) <- do
+                        mticket <- lift $ getSharerPatch shr talid
+                        fromMaybeE mticket "Note context no such local sharer-hosted patch"
+                    mproj <-
+                        case repo of
+                            Left (_, Entity _ trl) -> lift $ Just . Right <$> getRepo trl
                             Right _ -> return Nothing
                     return (mproj, localTicketDiscuss lt)
                 NoteContextProjectTicket shr prj ltid -> do
                     (_, _, _, Entity _ lt, _, _, _) <- do
                         mticket <- lift $ getProjectTicket shr prj ltid
                         fromMaybeE mticket "Note context no such local project-hosted ticket"
-                    return (Just (shr, prj), localTicketDiscuss lt)
+                    return (Just $ Left (shr, prj), localTicketDiscuss lt)
+                NoteContextRepoPatch shr rp ltid -> do
+                    (_, _, _, Entity _ lt, _, _, _, _) <- do
+                        mticket <- lift $ getRepoPatch shr rp ltid
+                        fromMaybeE mticket "Note context no such local project-hosted ticket"
+                    return (Just $ Right (shr, rp), localTicketDiscuss lt)
         mmidParent <- for mparent $ \ parent ->
             case parent of
                 Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
@@ -377,9 +431,14 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
                         rt <- MaybeT $ getValBy $ UniqueRemoteTicketDiscuss rdid
                         tar <- lift $ getJust $ remoteTicketTicket rt
                         let tclid = ticketAuthorRemoteTicket tar
-                        tpl <-
+                        txl <-
-                            MaybeT $ getValBy $ UniqueTicketProjectLocal tclid
+                            lift $
-                        lift $ getProject tpl
+                            requireEitherAlt
+                                (getValBy $ UniqueTicketProjectLocal tclid)
+                                (getValBy $ UniqueTicketRepoLocal tclid)
+                                "No specific TCL"
+                                "Both TPL and TRL"
+                        lift $ bitraverse getProject getRepo txl
                     return (mproj, rd, False)
                 Nothing -> do
                     did <- insert Discussion

src/Vervis/ActivityPub.hs

@@ -130,8 +130,9 @@ import Vervis.Widget.Repo
 import Vervis.Widget.Sharer
 
 data NoteContext
-    = NoteContextSharerTicket ShrIdent TicketAuthorLocalId
+    = NoteContextSharerTicket ShrIdent TicketAuthorLocalId Bool
     | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
+    | NoteContextRepoPatch ShrIdent RpIdent LocalTicketId
     deriving Eq
 
 hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
@@ -158,12 +159,18 @@ parseContext uContext = do
                 Just r -> return r
             case route of
                 SharerTicketR shr talkhid ->
-                    NoteContextSharerTicket shr <$>
+                    flip (NoteContextSharerTicket shr) False <$>
+                        decodeKeyHashidE talkhid "Note context invalid talkhid"
+                SharerPatchR shr talkhid ->
+                    flip (NoteContextSharerTicket shr) True <$>
                         decodeKeyHashidE talkhid "Note context invalid talkhid"
                 ProjectTicketR shr prj ltkhid ->
                     NoteContextProjectTicket shr prj <$>
                         decodeKeyHashidE ltkhid "Note context invalid ltkhid"
-                _ -> throwE "Local context isn't a ticket route"
+                RepoPatchR shr rp ltkhid ->
+                    NoteContextRepoPatch shr rp <$>
+                        decodeKeyHashidE ltkhid "Note context invalid ltkhid"
+                _ -> throwE "Local context isn't a ticket/patch route"
         else return $ Right uContext
 
 parseParent

src/Vervis/Federation.hs

@@ -336,6 +336,11 @@ handleRepoInbox now shrRecip rpRecip auth body = do
             ActivityAuthLocal local -> throwE $ errorLocalForwarded local
             ActivityAuthRemote ra -> return ra
     case activitySpecific $ actbActivity body of
+        CreateActivity (Create obj mtarget) ->
+            case obj of
+                CreateNote note ->
+                    repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
+                _ -> error "Unsupported create object type for repos"
         FollowActivity follow ->
             repoFollowF shrRecip rpRecip now remoteAuthor body follow
         UndoActivity undo->

src/Vervis/Federation/Discussion.hs

@@ -16,6 +16,7 @@
 module Vervis.Federation.Discussion
     ( sharerCreateNoteF
     , projectCreateNoteF
+    , repoCreateNoteF
     )
 where
 
@@ -72,6 +73,7 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Settings
 import Vervis.Ticket
+import Vervis.Patch
 
 -- | Check the note in the remote Create Note activity delivered to us.
 checkNote
@@ -256,12 +258,21 @@ sharerCreateNoteF now shrRecip author body note = do
                 case mractid of
                     Nothing -> "I already have this activity in my inbox, doing nothing"
                     Just _ -> "Context is remote, so just inserting to my inbox"
-        Left (NoteContextSharerTicket shr talid) -> do
+        Left (NoteContextSharerTicket shr talid patch) -> do
             mremotesHttp <- runDBExcept $ do
                 (sid, pid, ibid) <- lift getRecip404
-                (Entity _ tal, Entity _ lt, _, _) <- do
+                (tal, lt, followers) <-
-                    mticket <- lift $ getSharerTicket shr talid
+                    if patch
-                    fromMaybeE mticket "Context: No such sharer-ticket"
+                        then do
+                            (Entity _ tal, Entity _ lt, _, _, _) <- do
+                                mticket <- lift $ getSharerPatch shr talid
+                                fromMaybeE mticket "Context: No such sharer-patch"
+                            return (tal, lt, LocalPersonCollectionSharerPatchFollowers)
+                        else do
+                            (Entity _ tal, Entity _ lt, _, _) <- do
+                                mticket <- lift $ getSharerTicket shr talid
+                                fromMaybeE mticket "Context: No such sharer-ticket"
+                            return (tal, lt, LocalPersonCollectionSharerTicketFollowers)
                 if ticketAuthorLocalAuthor tal == pid
                     then do
                         mractid <- lift $ insertToInbox now author body ibid luCreate True
@@ -283,7 +294,7 @@ sharerCreateNoteF now shrRecip author body note = do
                                                 let sieve =
                                                         makeRecipientSet
                                                             []
-                                                            [ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
+                                                            [ followers shrRecip talkhid
                                                             --, LocalPersonCollectionSharerTicketTeam shrRecip talkhid
                                                             ]
                                                 remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
@@ -315,6 +326,20 @@ sharerCreateNoteF now shrRecip author body note = do
                 case mractid of
                     Nothing -> "I already have this activity in my inbox, doing nothing"
                     Just _ -> "Context is a project-ticket, so just inserting to my inbox"
+        Left (NoteContextRepoPatch shr rp ltid) -> runDBExcept $ do
+            personRecip <- lift $ do
+                sid <- getKeyBy404 $ UniqueSharer shrRecip
+                getValBy404 $ UniquePersonIdent sid
+            (_, _, _, Entity _ lt, _, _, _, _) <- do
+                mticket <- lift $ getRepoPatch shr rp ltid
+                fromMaybeE mticket "Context: No such repo-patch"
+            let did = localTicketDiscuss lt
+            _ <- traverse (getParent did) mparent
+            mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
+            return $
+                case mractid of
+                    Nothing -> "I already have this activity in my inbox, doing nothing"
+                    Just _ -> "Context is a repo-patch, so just inserting to my inbox"
     where
     getRecip404 = do
         sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -361,7 +386,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
     msig <- checkForward $ LocalActorProject shrRecip prjRecip
     case context of
         Right _ -> return "Not using; context isn't local"
-        Left (NoteContextSharerTicket shr talid) -> do
+        Left (NoteContextSharerTicket shr talid False) -> do
             mremotesHttp <- runDBExcept $ do
                 (jid, ibid) <- lift getProjectRecip404
                 (_, _, _, project) <- do
@@ -396,6 +421,7 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
                 Right (sig, remotesHttp) -> do
                     forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
                     return "Stored to inbox and did inbox forwarding"
+        Left (NoteContextSharerTicket _ _ True) -> return "Context is a sharer-patch, ignoring activity"
         Left (NoteContextProjectTicket shr prj ltid) -> do
             mremotesHttp <- runDBExcept $ do
                 (jid, ibid) <- lift getProjectRecip404
@@ -436,8 +462,112 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
                 Right (sig, remotesHttp) -> do
                     forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
                     return "Stored to inbox, cached comment, and did inbox forwarding"
+        Left (NoteContextRepoPatch _ _ _) -> return "Context is a repo-patch, ignoring activity"
     where
     getProjectRecip404 = do
         sid <- getKeyBy404 $ UniqueSharer shrRecip
         Entity jid j <- getBy404 $ UniqueProject prjRecip sid
         return (jid, projectInbox j)
+
+repoCreateNoteF
+    :: UTCTime
+    -> ShrIdent
+    -> RpIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Note URIMode
+    -> ExceptT Text Handler Text
+repoCreateNoteF now shrRecip rpRecip author body note = do
+    luCreate <-
+        fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
+    (luNote, published, context, mparent, source, content) <- checkNote note
+    (localRecips, _remoteRecips) <- do
+        mrecips <- parseAudience $ activityAudience $ actbActivity body
+        fromMaybeE mrecips "Create Note with no recipients"
+    msig <- checkForward $ LocalActorRepo shrRecip rpRecip
+    case context of
+        Right _ -> return "Not using; context isn't local"
+        Left (NoteContextSharerTicket _ _ False) ->
+            return "Context is a sharer-ticket, ignoring activity"
+        Left (NoteContextSharerTicket shr talid True) -> do
+            mremotesHttp <- runDBExcept $ do
+                (rid, ibid) <- lift getRepoRecip404
+                (_, _, _, repo, _) <- do
+                    mticket <- lift $ getSharerPatch shr talid
+                    fromMaybeE mticket "Context: No such sharer-ticket"
+                case repo of
+                    Left (_, Entity _ trl)
+                        | ticketRepoLocalRepo trl == rid -> do
+                            mractid <- lift $ insertToInbox now author body ibid luCreate False
+                            case mractid of
+                                Nothing -> return $ Left "Activity already in my inbox"
+                                Just ractid ->
+                                    case msig of
+                                        Nothing ->
+                                            return $ Left
+                                                "Context is a sharer-patch, \
+                                                \but no inbox forwarding \
+                                                \header for me, so doing \
+                                                \nothing, just storing in inbox"
+                                        Just sig -> lift $ Right <$> do
+                                            let sieve =
+                                                    makeRecipientSet
+                                                        []
+                                                        [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                                                        , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                                                        ]
+                                            remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+                                            (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
+                    _ -> return $ Left "Context is a sharer-patch of another repo"
+            case mremotesHttp of
+                Left msg -> return msg
+                Right (sig, remotesHttp) -> do
+                    forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp
+                    return "Stored to inbox and did inbox forwarding"
+        Left (NoteContextProjectTicket _ _ _) ->
+            return "Context is a project-ticket, ignoring activity"
+        Left (NoteContextRepoPatch shr rp ltid) -> do
+            mremotesHttp <- runDBExcept $ do
+                (rid, ibid) <- lift getRepoRecip404
+                (_, _, _, Entity _ lt, _, Entity _ trl, _, _) <- do
+                    mticket <- lift $ getRepoPatch shr rp ltid
+                    fromMaybeE mticket "Context: No such repo-patch"
+                if ticketRepoLocalRepo trl == rid
+                    then do
+                        mractid <- lift $ insertToInbox now author body ibid luCreate False
+                        case mractid of
+                            Nothing -> return $ Left "Activity already in my inbox"
+                            Just ractid -> do
+                                let did = localTicketDiscuss lt
+                                meparent <- traverse (getParent did) mparent
+                                mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
+                                case mmid of
+                                    Nothing -> return $ Left "I already have this comment, just storing in inbox"
+                                    Just mid -> lift $ do
+                                        updateOrphans author luNote did mid
+                                        case msig of
+                                            Nothing ->
+                                                return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
+                                            Just sig -> Right <$> do
+                                                ltkhid <- encodeKeyHashid ltid
+                                                let sieve =
+                                                        makeRecipientSet
+                                                            []
+                                                            [ LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                                                            , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                                                            , LocalPersonCollectionRepoPatchFollowers shrRecip rpRecip ltkhid
+                                                            --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
+                                                            ]
+                                                remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
+                                                (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
+                    else return $ Left "Context is a repo-patch of another repo"
+            case mremotesHttp of
+                Left msg -> return msg
+                Right (sig, remotesHttp) -> do
+                    forkWorker "repoCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotesHttp
+                    return "Stored to inbox, cached comment, and did inbox forwarding"
+    where
+    getRepoRecip404 = do
+        sid <- getKeyBy404 $ UniqueSharer shrRecip
+        Entity rid r <- getBy404 $ UniqueRepo rpRecip sid
+        return (rid, repoInbox r)