In S2S Follow, projects allow following their tickets

src/Vervis/Federation/Offer.hs

@@ -234,11 +234,12 @@ repoRejectF shr rp = rejectF getIbid route
 -}
 
 followF
-    :: AppDB a
+    :: (Route App -> Maybe a)
     -> Route App
-    -> (a -> InboxId)
+    -> (a -> AppDB b)
-    -> (a -> OutboxId)
+    -> (b -> InboxId)
-    -> (a -> FollowerSetId)
+    -> (b -> OutboxId)
+    -> (b -> FollowerSetId)
     -> (KeyHashid OutboxItem -> Route App)
     -> UTCTime
     -> RemoteAuthor
@@ -246,22 +247,23 @@ followF
     -> AP.Follow URIMode
     -> ExceptT Text Handler Text
 followF
-    getRecip recipRoute recipInbox recipOutbox recipFollowers outboxItemRoute
+    objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute
     now author body (AP.Follow (ObjURI hObj luObj) hide) = do
-        me <- do
+        mobj <- do
             local <- hostIsLocal hObj
             return $
-                case decodeRouteLocal luObj of
+                if local
-                    Just r | local && r == recipRoute -> True
+                    then Nothing
-                    _ -> False
+                    else objRoute =<< decodeRouteLocal luObj
-        if me
+        case mobj of
-            then do
+            Nothing -> return "Follow object unrelated to me, ignoring activity"
+            Just obj -> do
                 luFollow <-
                     fromMaybeE
                         (activityId $ actbActivity body)
                         "Follow without 'id'"
                 emsg <- lift $ runDB $ do
-                    recip <- getRecip
+                    recip <- getRecip obj
                     newItem <- insertToInbox luFollow $ recipInbox recip
                     if newItem
                         then do
@@ -287,7 +289,6 @@ followF
                         forkWorker "followF: Accept delivery" $
                             deliverRemoteHttp dont obiid doc remotesHttp
                         return "Follow request accepted"
-            else return "Follow object unrelated to me, ignoring activity"
     where
     dont = Authority "dont-do.any-forwarding" Nothing
 
@@ -357,14 +358,18 @@ sharerFollowF
     -> ExceptT Text Handler Text
 sharerFollowF shr =
     followF
-        getRecip
+        objRoute
         (SharerR shr)
+        getRecip
         personInbox
         personOutbox
         personFollowers
         (SharerOutboxItemR shr)
     where
-    getRecip = do
+    objRoute (SharerR shr') | shr == shr' = Just ()
+    objRoute _                            = Nothing
+
+    getRecip () = do
         sid <- getKeyBy404 $ UniqueSharer shr
         getValBy404 $ UniquePersonIdent sid
 
@@ -378,16 +383,28 @@ projectFollowF
     -> ExceptT Text Handler Text
 projectFollowF shr prj =
     followF
-        getRecip
+        objRoute
         (ProjectR shr prj)
-        projectInbox
+        getRecip
-        projectOutbox
+        (projectInbox . fst)
-        projectFollowers
+        (projectOutbox . fst)
+        followers
         (ProjectOutboxItemR shr prj)
     where
-    getRecip = do
+    objRoute (ProjectR shr' prj')
+        | shr == shr' && prj == prj' = Just Nothing
+    objRoute (TicketR shr' prj' num)
+        | shr == shr' && prj == prj' = Just $ Just num
+    objRoute _ = Nothing
+
+    getRecip mnum = do
         sid <- getKeyBy404 $ UniqueSharer shr
-        getValBy404 $ UniqueProject prj sid
+        Entity jid j <- getBy404 $ UniqueProject prj sid
+        mt <- for mnum $ \ num -> getValBy404 $ UniqueTicket jid num
+        return (j, mt)
+
+    followers (j, Nothing) = projectFollowers j
+    followers (_, Just t)  = ticketFollowers t
 
 repoFollowF
     :: ShrIdent
@@ -399,13 +416,17 @@ repoFollowF
     -> ExceptT Text Handler Text
 repoFollowF shr rp =
     followF
-        getRecip
+        objRoute
         (RepoR shr rp)
+        getRecip
         repoInbox
         repoOutbox
         repoFollowers
         (RepoOutboxItemR shr rp)
     where
-    getRecip = do
+    objRoute (RepoR shr' rp') | shr == shr' && rp == rp' = Just ()
+    objRoute _                                           = Nothing
+
+    getRecip () = do
         sid <- getKeyBy404 $ UniqueSharer shr
         getValBy404 $ UniqueRepo rp sid