1 {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 3 module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..), 4 environmentHelpSsh, environmentHelpScp, environmentHelpSshPort 5 ) where 6 7 import Prelude hiding ( lookup, catch ) 8 9 import System.Exit ( ExitCode(..) ) 10 import System.Environment ( getEnv ) 11 #ifndef WIN32 12 import System.Posix.Process ( getProcessID ) 13 #else 14 import Darcs.Utils ( showHexLen ) 15 import Data.Bits ( (.&.) ) 16 import System.Random ( randomIO ) 17 #endif 18 import System.IO ( Handle, hPutStr, hPutStrLn, hGetLine, hGetContents, hClose, hFlush ) 19 import System.IO.Unsafe ( unsafePerformIO ) 20 import System.Directory ( doesFileExist, createDirectoryIfMissing ) 21 import Control.Monad ( when ) 22 import System.Process ( runInteractiveProcess ) 23 24 import Data.Map ( Map, empty, insert, lookup ) 25 import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) 26 27 import Darcs.SignalHandler ( catchNonSignal ) 28 import Darcs.Utils ( withCurrentDirectory, breakCommand, prettyException, catchall ) 29 import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, withDebugMode ) 30 import Darcs.Lock ( withTemp, withOpenTemp, tempdir_loc, removeFileMayNotExist ) 31 import Exec ( exec, Redirects, Redirect(..), ) 32 import Progress ( withoutProgress, debugMessage, debugFail, progressList ) 33 34 import qualified Data.ByteString as B (ByteString, hGet, writeFile, readFile) 35 import qualified Data.ByteString.Char8 as BC (unpack) 36 37 #include "impossible.h" 38 39 {-# NOINLINE sshConnections #-} 40 sshConnections :: IORef (Map String (Maybe Connection)) 41 sshConnections = unsafePerformIO $ newIORef empty 42 43 data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: String -> IO () } 44 45 withSSHConnection :: String -> (Connection -> IO a) -> IO a -> IO a 46 withSSHConnection x withconnection withoutconnection = 47 withoutProgress $ 48 do cs <- readIORef sshConnections 49 let uhost = takeWhile (/= ':') x 50 url = cleanrepourl x 51 case lookup url (cs :: Map String (Maybe Connection)) of 52 Just Nothing -> withoutconnection 53 Just (Just c) -> withconnection c 54 Nothing -> 55 do mc <- do (ssh,sshargs_) <- getSSHOnly SSH 56 let sshargs = sshargs_ ++ [uhost,"darcs","transfer-mode","--repodir",cleanrepodir x] 57 debugMessage $ "ssh "++unwords sshargs 58 (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing 59 l <- hGetLine o 60 if l == "Hello user, I am darcs transfer mode" 61 then return () 62 else debugFail "Couldn't start darcs transfer-mode on server" 63 let c = C { inp = i, out = o, err = e, 64 deb = \s -> debugMessage ("with ssh (transfer-mode) "++uhost++": "++s) } 65 modifyIORef sshConnections (insert url (Just c)) 66 return $ Just c 67 `catchNonSignal` 68 \e -> do debugMessage $ "Failed to start ssh connection:\n "++ 69 prettyException e 70 severSSHConnection x 71 debugMessage $ unlines $ 72 [ "NOTE: the server may be running a version of darcs prior to 2.0.0." 73 , "" 74 , "Installing darcs 2 on the server will speed up ssh-based commands." 75 ] 76 return Nothing 77 maybe withoutconnection withconnection mc 78 79 severSSHConnection :: String -> IO () 80 severSSHConnection x = do debugMessage $ "Severing ssh failed connection to "++x 81 modifyIORef sshConnections (insert (cleanrepourl x) Nothing) 82 83 cleanrepourl :: String -> String 84 cleanrepourl zzz | take (length dd) zzz == dd = "" 85 where dd = darcsdir++"/" 86 cleanrepourl (z:zs) = z : cleanrepourl zs 87 cleanrepourl "" = "" 88 89 cleanrepodir :: String -> String 90 cleanrepodir = cleanrepourl . drop 1 . dropWhile (/= ':') 91 92 grabSSH :: String -> Connection -> IO B.ByteString 93 grabSSH x c = do 94 let dir = drop 1 $ dropWhile (/= ':') x 95 dd = darcsdir++"/" 96 clean zzz | take (length dd) zzz == dd = drop (length dd) zzz 97 clean (_:zs) = clean zs 98 clean "" = bug $ "Buggy path in grabSSH: "++x 99 file = clean dir 100 failwith e = do severSSHConnection x 101 eee <- hGetContents (err c) -- ratify hGetContents: it's okay 102 -- here because we're only grabbing 103 -- stderr, and we're also about to 104 -- throw the contents. 105 debugFail $ e ++ " grabbing ssh file "++x++"\n"++eee 106 deb c $ "get "++file 107 hPutStrLn (inp c) $ "get " ++ file 108 hFlush (inp c) 109 l2 <- hGetLine (out c) 110 if l2 == "got "++file 111 then do showlen <- hGetLine (out c) 112 case reads showlen of 113 [(len,"")] -> B.hGet (out c) len 114 _ -> failwith "Couldn't get length" 115 else if l2 == "error "++file 116 then do e <- hGetLine (out c) 117 case reads e of 118 (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg 119 [] -> failwith "An error occurred" 120 else failwith "Error" 121 122 sshStdErrMode :: IO Redirect 123 sshStdErrMode = withDebugMode $ \amdebugging -> 124 return $ if amdebugging then AsIs else Null 125 126 copySSH :: String -> FilePath -> IO () 127 copySSH uRaw f = withSSHConnection uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $ 128 do let u = escape_dollar uRaw 129 stderr_behavior <- sshStdErrMode 130 r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior) 131 when (r /= ExitSuccess) $ 132 debugFail $ "(scp) failed to fetch: " ++ u 133 where {- '$' in filenames is troublesome for scp, for some reason.. -} 134 escape_dollar :: String -> String 135 escape_dollar = concatMap tr 136 where tr '$' = "\\$" 137 tr c = [c] 138 139 copySSHs :: String -> [String] -> FilePath -> IO () 140 copySSHs u ns d = 141 withSSHConnection u (\c -> withCurrentDirectory d $ 142 mapM_ (\n -> grabSSH (u++"/"++n) c >>= B.writeFile n) $ 143 progressList "Copying via ssh" ns) $ 144 do let path = drop 1 $ dropWhile (/= ':') u 145 host = takeWhile (/= ':') u 146 cd = "cd "++path++"\n" 147 input = cd++(unlines $ map ("get "++) ns) 148 withCurrentDirectory d $ withOpenTemp $ \(th,tn) -> 149 withTemp $ \sftpoutput -> 150 do hPutStr th input 151 hClose th 152 stderr_behavior <- sshStdErrMode 153 r <- runSSH SFTP u [] [host] (File tn, File sftpoutput, stderr_behavior) 154 let files = if length ns > 5 155 then (take 5 ns) ++ ["and " 156 ++ (show (length ns - 5)) ++ " more"] 157 else ns 158 hint = if take 1 path == "~" 159 then ["sftp doesn't expand ~, use path/ instead of ~/path/"] 160 else [] 161 when (r /= ExitSuccess) $ do 162 outputPS <- B.readFile sftpoutput 163 debugFail $ unlines $ 164 ["(sftp) failed to fetch files.", 165 "source directory: " ++ path, 166 "source files:"] ++ files ++ 167 ["sftp output:",BC.unpack outputPS] ++ 168 hint 169 170 -- --------------------------------------------------------------------- 171 -- older ssh helper functions 172 -- --------------------------------------------------------------------- 173 174 data SSHCmd = SSH | SCP | SFTP 175 176 instance Show SSHCmd where 177 show SSH = "ssh" 178 show SCP = "scp" 179 show SFTP = "sftp" 180 181 runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO ExitCode 182 runSSH cmd remoteAddr preArgs postArgs redirs = 183 do (ssh, args) <- getSSH cmd remoteAddr 184 exec ssh (preArgs ++ args ++ postArgs) redirs 185 186 -- | Return the command and arguments needed to run an ssh command 187 -- along with any extra features like use of the control master. 188 -- See 'getSSHOnly' 189 getSSH :: SSHCmd -> String -- ^ remote path 190 -> IO (String, [String]) 191 getSSH cmd remoteAddr = 192 do (ssh, ssh_args) <- getSSHOnly cmd 193 cm_args <- if sshControlMasterDisabled 194 then return [] 195 else do -- control master 196 cmPath <- controlMasterPath remoteAddr 197 hasLaunchedCm <- doesFileExist cmPath 198 when (not hasLaunchedCm) $ launchSSHControlMaster remoteAddr 199 hasCmFeature <- doesFileExist cmPath 200 return $ if hasCmFeature then [ "-o ControlPath=" ++ cmPath ] else [] 201 let verbosity = case cmd of 202 SCP -> ["-q"] -- (p)scp is the only one that recognises -q 203 -- sftp and (p)sftp do not, and plink neither 204 _ -> [] 205 -- 206 return (ssh, verbosity ++ ssh_args ++ cm_args) 207 208 -- | Return the command and arguments needed to run an ssh command. 209 -- First try the appropriate darcs environment variable and SSH_PORT 210 -- defaulting to "ssh" and no specified port. 211 getSSHOnly :: SSHCmd -> IO (String, [String]) 212 getSSHOnly cmd = 213 do ssh_command <- getEnv (evar cmd) `catchall` return (show cmd) 214 -- port 215 port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return [] 216 let (ssh, ssh_args) = breakCommand ssh_command 217 -- 218 return (ssh, ssh_args ++ port) 219 where 220 evar SSH = "DARCS_SSH" 221 evar SCP = "DARCS_SCP" 222 evar SFTP = "DARCS_SFTP" 223 portFlag SSH x = ["-p", x] 224 portFlag SCP x = ["-P", x] 225 portFlag SFTP x = ["-oPort="++x] 226 227 environmentHelpSsh :: ([String], [String]) 228 environmentHelpSsh = (["DARCS_SSH"], [ 229 "Repositories of the form [user@]host:[dir] are taken to be remote", 230 "repositories, which Darcs accesses with the external program ssh(1).", 231 "", 232 "The environment variable $DARCS_SSH can be used to specify an", 233 "alternative SSH client. Arguments may be included, separated by", 234 "whitespace. The value is not interpreted by a shell, so shell", 235 "constructs cannot be used; in particular, it is not possible for the", 236 "program name to contain whitespace by using quoting or escaping."]) 237 238 environmentHelpScp :: ([String], [String]) 239 environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [ 240 "When reading from a remote repository, Darcs will attempt to run", 241 "`darcs transfer-mode' on the remote host. This will fail if the", 242 "remote host only has Darcs 1 installed, doesn't have Darcs installed", 243 "at all, or only allows SFTP.", 244 "", 245 "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).", 246 "The commands invoked can be customized with the environment variables", 247 "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.", 248 "If the remote end allows only sftp, try setting DARCS_SCP=sftp."]) 249 250 environmentHelpSshPort :: ([String], [String]) 251 environmentHelpSshPort = (["SSH_PORT"], [ 252 "If this environment variable is set, it will be used as the port", 253 "number for all SSH calls made by Darcs (when accessing remote", 254 "repositories over SSH). This is useful if your SSH server does not", 255 "run on the default port, and your SSH client does not support", 256 "ssh_config(5). OpenSSH users will probably prefer to put something", 257 "like `Host *.example.net Port 443' into their ~/.ssh/config file."]) 258 259 -- | Return True if this version of ssh has a ControlMaster feature 260 -- The ControlMaster functionality allows for ssh multiplexing 261 hasSSHControlMaster :: Bool 262 hasSSHControlMaster = unsafePerformIO hasSSHControlMasterIO 263 264 -- Because of the unsafePerformIO above, this can be called at any 265 -- point. It cannot rely on any state, not even the current directory. 266 hasSSHControlMasterIO :: IO Bool 267 hasSSHControlMasterIO = do 268 (ssh, _) <- getSSHOnly SSH 269 -- If ssh has the ControlMaster feature, it will recognise the 270 -- the -O flag, but exit with status 255 because of the nonsense 271 -- command. If it does not have the feature, it will simply dump 272 -- a help message on the screen and exit with 1. 273 sx <- exec ssh ["-O", "an_invalid_command"] (Null,Null,Null) 274 case sx of 275 ExitFailure 255 -> return True 276 _ -> return False 277 278 -- | Launch an SSH control master in the background, if available. 279 -- We don't have to wait for it or anything. 280 -- Note also that this will cleanup after itself when darcs exits 281 launchSSHControlMaster :: String -> IO () 282 launchSSHControlMaster rawAddr = 283 when hasSSHControlMaster $ do 284 let addr = takeWhile (/= ':') rawAddr 285 (ssh, ssh_args) <- getSSHOnly SSH 286 cmPath <- controlMasterPath addr 287 removeFileMayNotExist cmPath 288 -- -f : put ssh in the background once it succeeds in logging you in 289 -- -M : launch as the control master for addr 290 -- -N : don't run any commands 291 -- -S : use cmPath as the ControlPath. Equivalent to -oControlPath= 292 exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,AsIs) 293 atexit $ exitSSHControlMaster addr 294 return () 295 296 -- | Tell the SSH control master for a given path to exit. 297 exitSSHControlMaster :: String -> IO () 298 exitSSHControlMaster addr = do 299 (ssh, ssh_args) <- getSSHOnly SSH 300 cmPath <- controlMasterPath addr 301 exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null) 302 return () 303 304 -- | Create the directory ssh control master path for a given address 305 controlMasterPath :: String -- ^ remote path (foo\@bar.com:file is ok; the file part with be stripped) 306 -> IO FilePath 307 controlMasterPath rawAddr = do 308 let addr = takeWhile (/= ':') rawAddr 309 tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdir_loc 310 #ifdef WIN32 311 r <- randomIO 312 let suffix = (showHexLen 6 (r .&. 0xFFFFFF :: Int)) 313 #else 314 suffix <- show `fmap` getProcessID 315 #endif 316 let tmpDarcsSsh = tmp /// "darcs-ssh" 317 createDirectoryIfMissing True tmpDarcsSsh 318 return $ tmpDarcsSsh /// addr ++ suffix 319 320 (///) :: FilePath -> FilePath -> FilePath 321 d /// f = d ++ "/" ++ f