Add 'cloneUri' to AP.Repo, publish in getRepoR, grab in offerTicketC

In offerTicketC it can be used for fetching commits from the remote origin
repo, by knowing its clone URI

Only HTTP clone URIs are supported for now, because it's enough for finishing
the federated MR implementation. Apparently user@host:path isn't a valid URI
and I'll later add a parser for that

src/Vervis/API.hs

@@ -2537,11 +2537,11 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                     TipLocalRepo repoID -> pure $ Left (repoID, Nothing)
                     TipLocalBranch repoID branch -> pure $ Left (repoID, Just branch)
                     TipRemote uOrigin -> Right <$> do
-                        (vcs, raid, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
+                        (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
-                        return (vcs, raid, first Just <$> mb)
+                        return (vcs, raid, uClone, first Just <$> mb)
                     TipRemoteBranch uRepo branch -> Right <$> do
-                        (vcs, raid) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
+                        (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo
-                        return (vcs, raid, Just (Nothing, branch))
+                        return (vcs, raid, uClone, Just (Nothing, branch))
                 originOrBundle <-
                     fromMaybeE
                         (align maybeOrigin maybeBundle)
@@ -2588,8 +2588,8 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                                     Left (repoID, maybeBranch) -> do
                                         repo <- getE repoID "MR origin local repo not found in DB"
                                         return (repoVcs repo, Left (repoID, maybeBranch))
-                                    Right (vcs, remoteActorID, maybeBranch) ->
+                                    Right (vcs, remoteActorID, uClone, maybeBranch) ->
-                                        pure (vcs, Right (remoteActorID, maybeBranch))
+                                        pure (vcs, Right (remoteActorID, uClone, maybeBranch))
                             unless (vcs == repoVcs targetRepo) $
                                 throwE "Origin repo VCS differs from target repo VCS"
                             return origin'
@@ -2607,9 +2607,9 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                             Left (originRepoID, maybeOriginBranch) -> do
                                 originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
                                 return (Left originRepoID, originBranch)
-                            Right (remoteActorID, maybeOriginBranch) -> do
+                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
                                 (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
-                                return (Right remoteActorID, originBranch)
+                                return (Right uClone, originBranch)
                         return $ Left (targetBranch, maybeOrigin)
                     VCSDarcs -> do
                         verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
@@ -2617,9 +2617,9 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                             Left (originRepoID, maybeOriginBranch) -> do
                                 verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
                                 return $ Left originRepoID
-                            Right (remoteActorID, maybeOriginBranch) -> do
+                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
                                 verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
-                                return $ Right remoteActorID
+                                return $ Right uClone
                         return $ Right $ maybeOriginRepo
 
                 return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch)
@@ -2776,6 +2776,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         -> ExceptT Result Handler
             ( VersionControlSystem
             , RemoteActorId
+            , FedURI
             , Maybe (LocalURI, Text)
             )
     httpGetRemoteTip (ObjURI host localURI) = do
@@ -2785,13 +2786,15 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 remoteActorID <-
                     lift $ runSiteDB $
                         insertRemoteActor host localURI $ AP.repoActor repo
-                return (AP.repoVcs repo, remoteActorID, Nothing)
+                let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+                return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
             Right (AP.Branch name _ luRepo) -> do
                 repo <- fetchRepoE host luRepo
                 remoteActorID <-
                     lift $ runSiteDB $
                         insertRemoteActor host luRepo $ AP.repoActor repo
-                return (AP.repoVcs repo, remoteActorID, Just (localURI, name))
+                let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+                return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
         where
         fetchTipE h lu = do
             manager <- asksSite getHttpManager
@@ -2799,13 +2802,15 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 fetchTip manager h lu
 
     httpGetRemoteRepo
-        :: FedURI -> ExceptT Result Handler (VersionControlSystem, RemoteActorId)
+        :: FedURI
+        -> ExceptT Result Handler (VersionControlSystem, RemoteActorId, FedURI)
     httpGetRemoteRepo (ObjURI host localURI) = do
         repo <- fetchRepoE host localURI
         remoteActorID <-
             lift $ runSiteDB $
                 insertRemoteActor host localURI $ AP.repoActor repo
-        return (AP.repoVcs repo, remoteActorID)
+        let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+        return (AP.repoVcs repo, remoteActorID, uClone)
 
     insertOfferToOutbox senderHash blinded offerID = do
         encodeRouteLocal <- getEncodeRouteLocal
@@ -2859,7 +2864,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         -> These
             (Either
                 (RepoId, Maybe Text)
-                (RemoteActorId, Maybe (Maybe LocalURI, Text))
+                (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
             )
             Material
         -> AppDB (Route App)
@@ -2868,7 +2873,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         for_ (justHere originOrBundle) $ \case
             Left (repoID, maybeOriginBranch) ->
                 insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
-            Right (remoteActorID, maybeOriginBranch) -> do
+            Right (remoteActorID, _uClone, maybeOriginBranch) -> do
                 originID <- insert $ MergeOriginRemote clothID remoteActorID
                 for_ maybeOriginBranch $ \ (mlu, b) ->
                     insert_ $ MergeOriginRemoteBranch originID mlu b

src/Vervis/Handler/Repo.hs

@@ -89,6 +89,7 @@ import Data.Git.Types (Blob (..), Person (..), entName)
 import Data.Graph.Inductive.Graph (noNodes)
 import Data.Graph.Inductive.Query.Topsort
 import Data.List (inits)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.String
 import Data.Text (Text, unpack)
@@ -212,6 +213,7 @@ getRepoR repoHash = do
             , AP.repoVcs  = repoVcs repo
             , AP.repoLoom =
                 encodeRouteLocal . LoomR . hashLoom <$> repoLoom repo
+            , AP.repoClone = encodeRouteLocal (RepoR repoHash) :| []
             }
 
         next =

src/Web/ActivityPub.hs

@@ -463,6 +463,7 @@ data Repo u = Repo
     , repoTeam  :: Maybe LocalURI
     , repoVcs   :: VersionControlSystem
     , repoLoom  :: Maybe LocalURI
+    , repoClone :: NonEmpty LocalURI
     }
 
 instance ActivityPub Repo where
@@ -476,11 +477,13 @@ instance ActivityPub Repo where
                 <$> withAuthorityMaybeO h (o .:|? "team")
                 <*> o .: "versionControlSystem"
                 <*> withAuthorityMaybeO h (o .:? "sendPatchesTo")
-    toSeries authority (Repo actor team vcs loom)
+                <*> (traverse (withAuthorityO h . pure) =<< o .:*+ "cloneUri")
+    toSeries authority (Repo actor team vcs loom clone)
         =  toSeries authority actor
         <> "team"                 .= (ObjURI authority <$> team)
         <> "versionControlSystem" .= vcs
         <> "sendPatchesTo"        .=? (ObjURI authority <$> loom)
+        <> "cloneUri"             .=*+ (ObjURI authority <$> clone)
 
 data TicketTracker u = TicketTracker
     { ticketTrackerActor :: Actor u