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