From ec6e97be4d7974654005e51cda1a9fd185ab8376 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jul 2015 18:38:23 -0400 Subject: basic gitlab support in webapp This works, but needs more testing and work on cases like encrypted repos, enabling existing repositories, etc. This commit was sponsored by Shaun Westmacott. --- Assistant/Pairing/MakeRemote.hs | 3 +- Assistant/Ssh.hs | 72 +++++++++++++++++++++++++++++------------ 2 files changed, 54 insertions(+), 21 deletions(-) (limited to 'Assistant') diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 75a266fa2..e847edd39 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -34,7 +34,7 @@ setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pai - the host we paired with. -} finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant () finishedLocalPairing msg keypair = do - sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg + sshdata <- liftIO $ installSshKeyPair keypair =<< pairMsgToSshData msg {- Ensure that we know the ssh host key for the host we paired with. - If we don't, ssh over to get it. -} liftIO $ unlessM (knownHost $ sshHostName sshdata) $ @@ -69,6 +69,7 @@ pairMsgToSshData msg = do , sshPort = 22 , needsPubKey = True , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] + , sshRepoUrl = Nothing } {- Finds the best hostname to use for the host that sent the PairMsg. diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 88afec713..cd29d5036 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -28,28 +28,37 @@ data SshData = SshData , sshPort :: Int , needsPubKey :: Bool , sshCapabilities :: [SshServerCapability] + , sshRepoUrl :: Maybe String } deriving (Read, Show, Eq) -data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable +data SshServerCapability + = GitAnnexShellCapable -- server has git-annex-shell installed + | GitCapable -- server has git installed + | RsyncCapable -- server supports raw rsync access (not only via git-annex-shell) + | PushCapable -- repo on server is set up already, and ready to accept pushes deriving (Read, Show, Eq) hasCapability :: SshData -> SshServerCapability -> Bool hasCapability d c = c `elem` sshCapabilities d +addCapability :: SshData -> SshServerCapability -> SshData +addCapability d c = d { sshCapabilities = c : sshCapabilities d } + onlyCapability :: SshData -> SshServerCapability -> Bool onlyCapability d c = all (== c) (sshCapabilities d) +type SshPubKey = String +type SshPrivKey = String + data SshKeyPair = SshKeyPair - { sshPubKey :: String - , sshPrivKey :: String + { sshPubKey :: SshPubKey + , sshPrivKey :: SshPrivKey } instance Show SshKeyPair where show = sshPubKey -type SshPubKey = String - {- ssh -ofoo=bar command-line option -} sshOpt :: String -> String -> String sshOpt k v = concat ["-o", k, "=", v] @@ -60,10 +69,12 @@ genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host {- Generates a ssh or rsync url from a SshData. -} genSshUrl :: SshData -> String -genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $ - if (onlyCapability sshdata RsyncCapable) - then [u, h, T.pack ":", sshDirectory sshdata] - else [T.pack "ssh://", u, h, d] +genSshUrl sshdata = case sshRepoUrl sshdata of + Just repourl -> repourl + Nothing -> addtrailingslash $ T.unpack $ T.concat $ + if (onlyCapability sshdata RsyncCapable) + then [u, h, T.pack ":", sshDirectory sshdata] + else [T.pack "ssh://", u, h, d] where u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata h = sshHostName sshdata @@ -90,6 +101,7 @@ parseSshUrl u , sshPort = 22 , needsPubKey = True , sshCapabilities = [] + , sshRepoUrl = Nothing } where (user, host) = if '@' `elem` userhost @@ -222,24 +234,44 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do - when git-annex and git try to access the remote, if its - host key has changed. -} -setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData -setupSshKeyPair sshkeypair sshdata = do +installSshKeyPair :: SshKeyPair -> SshData -> IO SshData +installSshKeyPair sshkeypair sshdata = do sshdir <- sshDir - createDirectoryIfMissing True $ parentDir $ sshdir sshprivkeyfile + createDirectoryIfMissing True $ parentDir $ sshdir sshPrivKeyFile sshdata - unlessM (doesFileExist $ sshdir sshprivkeyfile) $ - writeFileProtected (sshdir sshprivkeyfile) (sshPrivKey sshkeypair) - unlessM (doesFileExist $ sshdir sshpubkeyfile) $ - writeFile (sshdir sshpubkeyfile) (sshPubKey sshkeypair) + unlessM (doesFileExist $ sshdir sshPrivKeyFile sshdata) $ + writeFileProtected (sshdir sshPrivKeyFile sshdata) (sshPrivKey sshkeypair) + unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ + writeFile (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) setSshConfig sshdata - [ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) + [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata) , ("IdentitiesOnly", "yes") , ("StrictHostKeyChecking", "yes") ] - where - sshprivkeyfile = "git-annex" "key." ++ mangleSshHostName sshdata - sshpubkeyfile = sshprivkeyfile ++ ".pub" + +sshPrivKeyFile :: SshData -> FilePath +sshPrivKeyFile sshdata = "git-annex" "key." ++ mangleSshHostName sshdata + +sshPubKeyFile :: SshData -> FilePath +sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" + +{- Generates an installs a new ssh key pair if one is not already + - installed. Returns the modified SshData that will use the key pair, + - and the key pair. -} +setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair) +setupSshKeyPair sshdata = do + sshdir <- sshDir + mprivkey <- catchMaybeIO $ readFile (sshdir sshPrivKeyFile sshdata) + mpubkey <- catchMaybeIO $ readFile (sshdir sshPubKeyFile sshdata) + keypair <- case (mprivkey, mpubkey) of + (Just privkey, Just pubkey) -> return $ SshKeyPair + { sshPubKey = pubkey + , sshPrivKey = privkey + } + _ -> genSshKeyPair + sshdata' <- installSshKeyPair keypair sshdata + return (sshdata', keypair) {- Fixes git-annex ssh key pairs configured in .ssh/config - by old versions to set IdentitiesOnly. -- cgit v1.2.3