From 2e7c5f767c54aa2a255695cdc1016cf0076f101d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 22 Sep 2022 06:02:14 +0000 Subject: [PATCH] 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 | 37 +++++++++++++++++++++---------------- src/Vervis/Handler/Repo.hs | 2 ++ src/Web/ActivityPub.hs | 5 ++++- 3 files changed, 27 insertions(+), 17 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 82ea642..a478084 100644 --- a/src/Vervis/API.hs +++ b/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 - return (vcs, raid, first Just <$> mb) + (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin + return (vcs, raid, uClone, first Just <$> mb) TipRemoteBranch uRepo branch -> Right <$> do - (vcs, raid) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo - return (vcs, raid, Just (Nothing, branch)) + (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uRepo + 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) -> - pure (vcs, Right (remoteActorID, maybeBranch)) + Right (vcs, remoteActorID, uClone, 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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 8a99107..09ab0c6 100644 --- a/src/Vervis/Handler/Repo.hs +++ 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 = diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 92dc208..0f8514c 100644 --- a/src/Web/ActivityPub.hs +++ b/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