use mangled hostname for gitlab repo when using a dedicated git-annex ssh key
This commit is contained in:
parent
3972312a4f
commit
26d4eaa4e0
2 changed files with 15 additions and 7 deletions
|
@ -325,11 +325,16 @@ setSshConfig sshdata config = do
|
|||
(settings ++ config)
|
||||
setSshConfigMode configfile
|
||||
|
||||
return $ sshdata { sshHostName = T.pack mangledhost }
|
||||
return $ sshdata
|
||||
{ sshHostName = T.pack mangledhost
|
||||
, sshRepoUrl = replace orighost mangledhost
|
||||
<$> sshRepoUrl sshdata
|
||||
}
|
||||
where
|
||||
orighost = T.unpack $ sshHostName sshdata
|
||||
mangledhost = mangleSshHostName sshdata
|
||||
settings =
|
||||
[ ("Hostname", T.unpack $ sshHostName sshdata)
|
||||
[ ("Hostname", orighost)
|
||||
, ("Port", show $ sshPort sshdata)
|
||||
]
|
||||
|
||||
|
|
|
@ -708,17 +708,20 @@ parseGitLabUrl (GitLabUrl t) =
|
|||
testGitLabUrl :: GitLabUrl -> Annex (ServerStatus, Maybe SshData, UUID)
|
||||
testGitLabUrl glu = case parseGitLabUrl glu of
|
||||
Nothing -> return (UnusableServer badGitLabUrl, Nothing, NoUUID)
|
||||
Just sshdata -> do
|
||||
Just sshdata ->
|
||||
checkor sshdata $ do
|
||||
(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
|
||||
checkor sshdata' $
|
||||
return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID)
|
||||
where
|
||||
checkor sshdata ora = do
|
||||
u <- probeuuid sshdata
|
||||
if u /= NoUUID
|
||||
then return (UsableServer (sshCapabilities sshdata), Just sshdata, u)
|
||||
else ifM (verifysshworks sshdata)
|
||||
( return (UsableServer (sshCapabilities sshdata), Just sshdata, NoUUID)
|
||||
, do
|
||||
(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
|
||||
return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID)
|
||||
, ora
|
||||
)
|
||||
where
|
||||
probeuuid sshdata = do
|
||||
r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata)
|
||||
getUncachedUUID . either (const r) fst <$>
|
||||
|
|
Loading…
Add table
Reference in a new issue