forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source 
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
This commit is contained in:
fr33domlover 2022-09-22 06:02:14 +00:00
parent e7ab9e701c
commit 2e7c5f767c
3 changed files with 27 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
src/Vervis/API.hs
View file

@ -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

2
src/Vervis/Handler/Repo.hs
View file

@ -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 =

5
src/Web/ActivityPub.hs
View file

@ -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