S2S: loomFollowF & repoFollowF

src/Vervis/Federation/Offer.hs

@@ -22,7 +22,8 @@ module Vervis.Federation.Offer
 
       personFollowF
     , deckFollowF
-    --, repoFollowF
+    , loomFollowF
+    , repoFollowF
 
     --, sharerUndoF
     --, projectUndoF
@@ -615,53 +616,65 @@ deckFollowF now recipDeckHash =
         now
         recipDeckHash
 
-{-
-repoFollowF
-    :: KeyHashid Repo
-    -> UTCTime
+loomFollowF
+    :: UTCTime
+    -> KeyHashid Loom
     -> RemoteAuthor
     -> ActivityBody
-    -> Maybe (LocalRecipientSet, ByteString)
+    -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.Follow URIMode
-    -> ExceptT Text Handler Text
-repoFollowF repoHash =
-    error "repoFollowF temporarily disabled"
-
-
-
-
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+loomFollowF now recipLoomHash =
     followF
-        objRoute
-        (RepoR shr rp)
-        getRecip
-        (repoInbox . fst)
-        (repoOutbox . fst)
-        followers
-        (RepoOutboxItemR shr rp)
-    where
-    objRoute (RepoR shr' rp')
-        | shr == shr' && rp == rp' = Just Nothing
-    objRoute (RepoProposalR shr' rp' ltkhid)
-        | shr == shr' && rp == rp' = Just $ Just ltkhid
-    objRoute _ = Nothing
+        (\case
+            LoomR l | l == recipLoomHash -> pure Nothing
+            ClothR l c | l == recipLoomHash ->
+                Just <$> decodeKeyHashidE c "Invalid cloth keyhashid"
+            _ -> throwE "Asking to follow someone else"
+        )
+        loomActor
+        False
+        (\ recipLoomID recipLoomActor maybeClothID ->
+            case maybeClothID of
+                Nothing -> pure $ actorFollowers recipLoomActor
+                Just clothID -> do
+                    maybeCloth <- lift $ getCloth recipLoomID clothID
+                    (_loom, _cloth, Entity _ ticket, _author, _resolve, _merge) <-
+                        fromMaybeE maybeCloth "I don't have this MR in DB"
+                    return $ ticketFollowers ticket
+        )
+        (\ _ -> pure $ makeRecipientSet [] [])
+        LocalActorLoom
+        (\ _ -> pure [])
+        now
+        recipLoomHash
 
-    getRecip mltkhid = do
-        sid <- getKeyBy404 $ UniqueSharer shr
-        r <- getValBy404 $ UniqueRepo rp sid
-        mmt <- for mltkhid $ \ ltkhid -> runMaybeT $ do
-            ltid <- decodeKeyHashidM ltkhid
-            (_, _, _, Entity _ lt, _, _, _, _, _) <- MaybeT $ getRepoProposal shr rp ltid
-            return lt
-        return $
-            case mmt of
-                Nothing -> Just (r, Nothing)
-                Just Nothing -> Nothing
-                Just (Just t) -> Just (r, Just t)
-
-    followers (r, Nothing) = repoFollowers r
-    followers (_, Just lt) = localTicketFollowers lt
--}
+repoFollowF
+    :: UTCTime
+    -> KeyHashid Repo
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Follow URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+repoFollowF now recipRepoHash =
+    followF
+        (\case
+            RepoR r | r == recipRepoHash -> pure ()
+            _ -> throwE "Asking to follow someone else"
+        )
+        repoActor
+        False
+        (\ _recipRepoID recipRepoActor () ->
+            pure $ actorFollowers recipRepoActor
+        )
+        (\ () -> pure $ makeRecipientSet [] [])
+        LocalActorRepo
+        (\ () -> pure [])
+        now
+        recipRepoHash
 
 {-
 getFollow (Left _)        = return Nothing

src/Vervis/Handler/Loom.hs

@@ -78,6 +78,7 @@ import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Collab
 import Vervis.Federation.Discussion
+import Vervis.Federation.Offer
 import Vervis.Federation.Ticket
 import Vervis.FedURI
 import Vervis.Form.Ticket
@@ -159,6 +160,8 @@ postLoomInboxR recipLoomHash =
                     AP.CreateNote _ note ->
                         (,Nothing) <$> loomCreateNoteF now recipLoomHash author body mfwd luActivity note
                     _ -> return ("Unsupported create object type for looms", Nothing)
+            AP.FollowActivity follow ->
+                loomFollowF now recipLoomHash author body mfwd luActivity follow
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
             AP.OfferActivity (AP.Offer obj target) ->

src/Vervis/Handler/Repo.hs

@@ -160,6 +160,7 @@ import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Collab
+import Vervis.Federation.Offer
 import Vervis.FedURI
 import Vervis.Form.Repo
 import Vervis.Foundation
@@ -265,9 +266,9 @@ postRepoInboxR recipRepoHash =
                     CreateTicket _ ticket ->
                         (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget
                     _ -> error "Unsupported create object type for repos"
-            FollowActivity follow ->
-                (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
             -}
+            AP.FollowActivity follow ->
+                repoFollowF now recipRepoHash author body mfwd luActivity follow
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity invite
             {-