{-# OPTIONS -fffi #-} #ifdef HAVE_CURSES #ifdef HAVE_TERMIO_H {-# INCLUDE #-} #endif {-# INCLUDE #-} {-# INCLUDE #-} #endif -- The termio bit above is a grim hack for Solaris 10 (at least). -- Without it, SGTTY isn't declared. Something in the ghc C headers -- which get included before term.h in the generated C is clobbering -- it. (If you edit that C and put the curses.h and term.h first, the -- error goes away.) -- [Putting this comment before any of the INCLUDE lines prevents them -- being acted on :-(.] module External ( copyFileOrUrl, copyFilesOrUrls, cloneTree, cloneTreeExcept, clonePartialsTree, clonePaths, fetchFilePS, gzFetchFilePS, sendEmail, sendEmailDoc, resendEmail, signString, verifyPS, execPipeIgnoreError, getTermNColors, pipeDoc_SSH_IgnoreError, execSSH, maybeURLCmd, Cachable(Cachable, Uncachable, MaxAge) ) where import List ( intersperse ) import Monad ( liftM, when, zipWithM_ ) import System ( ExitCode(..), system, getEnv ) import IO ( hPutStr, hPutStrLn, hClose, hFlush, try, stdout ) import System.IO.Error ( isDoesNotExistError ) import System.IO.Unsafe ( unsafePerformIO ) import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory ) import System.Directory ( createDirectory, getDirectoryContents, doesFileExist ) import Char ( toUpper ) import Foreign.C ( CString, withCString, CInt ) import Foreign.Ptr ( nullPtr ) #ifdef HAVE_CURSES import Foreign.C ( CChar ) import Foreign.Ptr ( Ptr ) import Foreign.Marshal.Alloc (allocaBytes) import Autoconf ( use_color ) #endif import Workaround ( createLink, createDirectoryIfMissing ) import Global ( atexit, sshControlMasterDisabled ) import DarcsFlags ( DarcsFlag( Quiet, SignAs, Sign, SignSSL, Verbose, Verify, VerifySSL ) ) import DarcsUtils ( withCurrentDirectory ) import FastPackedString ( PackedString, readFilePS, gzReadFilePS, writeFilePS, hPutPS, unpackPS, linesPS, unlinesPS, lengthPS, takePS, dropPS, packString, nullPS, nilPS, concatPS ) import Lock ( withTemp, withOpenTemp, readDocBinFile, canonFilename, writeDocBinFile, tempdir_loc, ) import CommandLine ( parseCmd, addUrlencoded ) import Autoconf ( have_libcurl, have_sendmail, have_mapi, sendmail_path, darcs_version ) import Curl ( copyUrl ) import Curl ( Cachable(..) ) import Exec ( exec, Redirects, Redirect(..), ) import DarcsURL ( is_file, is_url, is_ssh ) import DarcsUtils ( catchall ) import Printer ( Doc, hPutDoc, hPutDocLn, ($$), (<+>), renderPS, text, empty, packedString, vcat, renderString ) #include "impossible.h" fetchFilePS :: String -> Cachable -> IO PackedString fetchFilePS fou _ | is_file fou = readFilePS fou fetchFilePS fou cache = withTemp $ \t -> do copyFileOrUrl fou t cache readFilePS t gzFetchFilePS :: String -> Cachable -> IO PackedString gzFetchFilePS fou _ | is_file fou = gzReadFilePS fou gzFetchFilePS fou cache = withTemp $ \t-> do copyFileOrUrl fou t cache gzReadFilePS t copyFileOrUrl :: FilePath -> FilePath -> Cachable -> IO () copyFileOrUrl fou out _ | is_file fou = copyLocal fou out copyFileOrUrl fou out cache | is_url fou = copyRemote fou out cache copyFileOrUrl fou out _ | is_ssh fou = copySSH fou out copyFileOrUrl fou _ _ = fail $ "unknown transport protocol: " ++ fou copyLocal :: String -> FilePath -> IO () copyLocal fou out = createLink fou out `catchall` cloneFile fou out clonePaths :: FilePath -> FilePath -> [FilePath] -> IO () clonePaths source dest = mapM_ (clonePath source dest) clonePath :: FilePath -> FilePath -> FilePath -> IO () clonePath source dest path = do let source' = source ++ "/" ++ path dest' = dest ++ "/" ++ path fs <- getSymbolicLinkStatus source' if isDirectory fs then do createDirectoryIfMissing True dest' else if isRegularFile fs then do createDirectoryIfMissing True (dest ++ "/" ++ basename path) cloneFile source' dest' else fail ("clonePath: Bad file " ++ source') `catch` fail ("clonePath: Bad file " ++ source ++ "/" ++ path) where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse clonePartialsTree :: FilePath -> FilePath -> [FilePath] -> IO () clonePartialsTree source dest = mapM_ (clonePartialTree source dest) clonePartialTree :: FilePath -> FilePath -> FilePath -> IO () clonePartialTree source dest "" = cloneTree source dest clonePartialTree source dest pref = do createDirectoryIfMissing True (dest ++ "/" ++ basename pref) cloneSubTree (source ++ "/" ++ pref) (dest ++ "/" ++ pref) where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse cloneTree :: FilePath -> FilePath -> IO () cloneTree = cloneTreeExcept [] cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO () cloneTreeExcept except source dest = do fs <- getSymbolicLinkStatus source if isDirectory fs then do fps <- getDirectoryContents source let fps' = filter (`notElem` (".":"..":except)) fps mk_source fp = source ++ "/" ++ fp mk_dest fp = dest ++ "/" ++ fp zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') else fail ("cloneTreeExcept: Bad source " ++ source) `catch` fail ("cloneTreeExcept: Bad source " ++ source) cloneSubTree :: FilePath -> FilePath -> IO () cloneSubTree source dest = do fs <- getSymbolicLinkStatus source if isDirectory fs then do createDirectory dest fps <- getDirectoryContents source let fps' = filter (`notElem` [".", ".."]) fps mk_source fp = source ++ "/" ++ fp mk_dest fp = dest ++ "/" ++ fp zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps') else if isRegularFile fs then do cloneFile source dest else fail ("cloneSubTree: Bad source "++ source) `catch` (\e -> if isDoesNotExistError e then return () else ioError e) cloneFile :: FilePath -> FilePath -> IO () cloneFile source dest = readFilePS source >>= writeFilePS dest maybeURLCmd :: String -> String -> IO(Maybe(String)) maybeURLCmd what url = do let prot = map toUpper $ takeWhile (/= ':') url liftM Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot)) `catch` \_ -> return Nothing copyRemote :: String -> FilePath -> Cachable -> IO () copyRemote u v cache = do maybeget <- maybeURLCmd "GET" u case maybeget of Nothing -> copyRemoteNormal u v cache Just get -> do let cmd = head $ words get args = tail $ words get r <- exec cmd (args++[u]) (Null, File v, AsIs) when (r /= ExitSuccess) $ fail $ "(" ++ get ++ ") failed to fetch: " ++ u copyRemoteNormal :: String -> FilePath -> Cachable -> IO () copyRemoteNormal u v cache = if have_libcurl then Curl.copyUrl u v cache else copyRemoteCmd u v copySSH :: String -> FilePath -> IO () copySSH uRaw f = let u = escape_dollar uRaw in do r <- runSSH SCP u [] [u,f] (AsIs,AsIs,Null) when (r /= ExitSuccess) $ fail $ "(scp) failed to fetch: " ++ u where {- '$' in filenames is troublesome for scp, for some reason.. -} escape_dollar :: String -> String escape_dollar = concatMap tr where tr '$' = "\\$" tr c = [c] copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO () copyFilesOrUrls opts dou ns out _ | is_file dou = copyLocals opts dou ns out copyFilesOrUrls opts dou ns out c | is_url dou = copyRemotes opts dou ns out c copyFilesOrUrls _ dou ns out _ | is_ssh dou = copySSHs dou ns out copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: "++dou copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO () copyLocals opts u ns d = doWithPatches opts (\n -> copyLocal (u++"/"++n) (d++"/"++n)) ns copyRemotes :: [DarcsFlag] -> String -> [String] -> FilePath -> Cachable -> IO() copyRemotes opts u ns d cache = do maybeget <- maybeURLCmd "GET" u maybemget <- maybeURLCmd "MGET" u case (maybeget, maybemget) of (Nothing, _) -> copyRemotesNormal opts u ns d cache (Just _, Nothing) -> doWithPatches opts (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns (Just _, Just mget) -> mgetRemotes mget u ns d stringToInt :: String -> Int -> Int stringToInt num def = case reads num of [(x,"")] -> x _ -> def mgetRemotes :: String -> String -> [String] -> FilePath -> IO() mgetRemotes _ _ [] _ = return () mgetRemotes mget u ns d = do mgetmax <- getEnv "DARCS_MGETMAX" `catch` \_ -> return "" let (nsnow, nslater) = splitAt (stringToInt mgetmax 200) ns cmd = head $ words mget args = tail $ words mget urls = map (\n -> u++"/"++n) nsnow withCurrentDirectory d $ do r <- exec cmd (args++urls) (Null,Null,AsIs) when (r /= ExitSuccess) $ fail $ unlines $ ["(" ++ mget ++ ") failed to fetch files.", "source directory: " ++ d, "source files:"] ++ (upto 5 nsnow) ++ ["still to go:"] ++ (upto 5 nslater) mgetRemotes mget u nslater d where upto :: Integer -> [String] -> [String] upto _ [] = [] upto 0 l = [ "(" ++ (show (length l)) ++ " more)" ] upto n (h : t) = h : (upto (n - 1) t) copyRemotesNormal :: [DarcsFlag] -> String -> [String] -> FilePath -> Cachable -> IO() copyRemotesNormal opts u ns d cache = if have_libcurl then doWithPatches opts (\n -> copyRemote (u++"/"++n) (d++"/"++n) cache) ns else wgetRemotes u ns d -- Argh, this means darcs get will fail if we don't have libcurl and don't -- have wget. :( wgetRemotes :: String -> [String] -> FilePath -> IO () wgetRemotes u ns d = do wget_command <- getEnv "DARCS_WGET" `catch` \_ -> return "wget" let wget = head $ words wget_command wget_args = tail $ words wget_command input = unlines $ map (\n -> u++"/"++n) ns withCurrentDirectory d $ withOpenTemp $ \(th,tn) -> do hPutStr th input hClose th r <- exec wget (wget_args++["-i",tn]) (Null,Null,AsIs) when (r /= ExitSuccess) $ fail $ unlines $ ["(wget) failed to fetch files.", "source directory: " ++ d, "source files:"] ++ ns copySSHs :: String -> [String] -> FilePath -> IO () copySSHs u ns d = do let path = drop 1 $ dropWhile (/= ':') u host = takeWhile (/= ':') u cd = "cd "++path++"\n" input = cd++(unlines $ map ("get "++) ns) withCurrentDirectory d $ withOpenTemp $ \(th,tn) -> withTemp $ \sftpoutput -> do hPutStr th input hClose th r <- runSSH SFTP u [] [host] (File tn, File sftpoutput, Null) let files = if length ns > 5 then (take 5 ns) ++ ["and " ++ (show (length ns - 5)) ++ " more"] else ns hint = if take 1 path == "~" then ["sftp doesn't expand ~, use path/ instead of ~/path/"] else [] when (r /= ExitSuccess) $ do outputPS <- readFilePS sftpoutput fail $ unlines $ ["(sftp) failed to fetch files.", "source directory: " ++ path, "source files:"] ++ files ++ ["sftp output:",unpackPS outputPS] ++ hint copyRemoteCmd :: String -> FilePath -> IO () copyRemoteCmd s tmp = do let cmd = get_ext_cmd r <- stupidexec (cmd tmp s) (Null,Null,AsIs) when (r /= ExitSuccess) $ fail $ "failed to fetch: " ++ s ++" " ++ show r where stupidexec [] = bug "stupidexec without a command" stupidexec xs = exec (head xs) (tail xs) doWithPatches :: [DarcsFlag] -> (String -> IO ()) -> [String] -> IO () doWithPatches opts f patches = if Quiet `elem` opts then sequence_ $ map f patches else doWithCount patches 1 where verbose = Verbose `elem` opts total = show $ length patches doWithCount :: [String] -> Int -> IO () doWithCount (p:ps) index = do putStr $ if verbose then "Copying patch "++(show index)++" of "++total++": "++p++"\n" else "\rCopying patch "++(show index)++ " of "++total++"..." hFlush stdout f p doWithCount ps (index + 1) doWithCount [] index = do putStr $ if verbose then "" else "\rCopying patch "++(show $ index - 1)++ " of "++total++"... done.\n" hFlush stdout {-# NOINLINE get_ext_cmd #-} get_ext_cmd :: String -> String -> [String] -- Only need to find the command once.. get_ext_cmd = unsafePerformIO get_ext_cmd' -- Would be better to read possible command lines from config-file.. get_ext_cmd' :: IO (String -> String -> [String]) get_ext_cmd' = try_cmd cmds where cmds = [("wget", (("--version",0), -- use libcurl for proper cache control \t s -> ["wget", "-q", "--header=Pragma: no-cache", "--header=Cache-Control: no-cache", "-O",t,s])), ("curl", (("--version",2), \t s -> ["curl", "-s", "-f", "-L", "-H", "Pragma: no-cache", "-H", "Cache-Control: no-cache", "-o",t,s]))] try_cmd [] = fail $ "I need one of: " ++ cs where cs = concat $ intersperse ", " (map fst cmds) try_cmd ((c,(ok_check,f)):cs) = do True <- can_execute ok_check c return f `catch` (\_ -> try_cmd cs) -- | Run a command on a remote location without passing it any input or -- reading its output. Return its ExitCode execSSH :: String -> String -> IO ExitCode execSSH remoteAddr command = runSSH SSH remoteAddr [remoteAddr] [command] (AsIs,AsIs,Null) pipeDoc_SSH_IgnoreError :: String -> [String] -> Doc -> IO Doc pipeDoc_SSH_IgnoreError remoteAddr args input = do (ssh, ssh_args) <- getSSH SSH remoteAddr execPipeIgnoreError ssh (ssh_args++ (remoteAddr:args)) input sendEmail :: String -> String -> String -> String -> String -> String -> IO () sendEmail f t s cc scmd body = sendEmailDoc f t s cc scmd Nothing (text body) -- | Send an email, optionally containing a patch bundle -- (more precisely, its description and the bundle itself) sendEmailDoc :: String -> String -> String -> String -> String -> Maybe (Doc, Doc) -> Doc -> IO () sendEmailDoc _ "" _ "" _ _ _ = return () sendEmailDoc f "" s cc scmd mbundle body = sendEmailDoc f cc s "" scmd mbundle body sendEmailDoc f t s cc scmd mbundle body = if have_sendmail || scmd /= "" then do withOpenTemp $ \(h,fn) -> do hPutDocLn h $ text "To:" <+> text t $$ text "From:" <+> text f $$ text "Subject:" <+> text s $$ formated_cc $$ text "X-Mail-Originator: Darcs Version Control System" $$ text ("X-Darcs-Version: " ++ darcs_version) $$ body hClose h ftable' <- case mbundle of Just (content,bundle) -> withOpenTemp $ \(hat,at) -> do hPutDocLn hat $ bundle hClose hat return [ ('b', renderString content) , ('a', at) ] Nothing -> return [ ('b', renderString body) ] let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable' r <- execSendmail ftable scmd fn when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t) else if have_mapi then do r <- withCString t $ \tp -> withCString f $ \fp -> withCString cc $ \ccp -> withCString s $ \sp -> withOpenTemp $ \(h,fn) -> do hPutDoc h body hClose h writeDocBinFile "mailed_patch" body cfn <- canonFilename fn withCString cfn $ \pcfn -> c_send_email fp tp ccp sp nullPtr pcfn when (r /= 0) $ fail ("failed to send mail to: " ++ t) else fail $ "no mail facility (sendmail or mapi) located at configure time!" where formated_cc = if cc == "" then empty else text "Cc:" <+> text cc addressOnly a = case dropWhile (/= '<') a of ('<':a2) -> takeWhile (/= '>') a2 _ -> a resendEmail :: String -> String -> PackedString -> IO () resendEmail "" _ _ = return () resendEmail t scmd body = case (have_sendmail || scmd /= "", have_mapi) of (True, _) -> do withOpenTemp $ \(h,fn) -> do hPutStrLn h $ "To: "++ t hPutStrLn h $ find_from (linesPS body) hPutStrLn h $ find_subject (linesPS body) hPutDocLn h $ fixit $ linesPS body hClose h let ftable = [('t',t)] r <- execSendmail ftable scmd fn when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t) (_, True) -> fail "Don't know how to resend email with MAPI" _ -> fail $ "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!" where br = packString "\r" darcsurl = packString "DarcsURL:" content = packString "Content-" from_start = packString "From:" subject_start = packString "Subject:" fixit (l:ls) | nullPS l = packedString nilPS $$ vcat (map packedString ls) | l == br = packedString nilPS $$ vcat (map packedString ls) | takePS 9 l == darcsurl || takePS 8 l == content = packedString l $$ fixit ls | otherwise = fixit ls fixit [] = empty find_from (l:ls) | takePS 5 l == from_start = unpackPS l | otherwise = find_from ls find_from [] = "From: unknown" find_subject (l:ls) | takePS 8 l == subject_start = unpackPS l | otherwise = find_subject ls find_subject [] = "Subject: (no subject)" execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode execSendmail ftable scmd fn = if scmd == "" then exec sendmail_path ["-i", "-t"] (File fn, Null, AsIs) else case parseCmd (addUrlencoded ftable) scmd of Right (arg0:opts, wantstdin) -> do let stdin = if wantstdin then File fn else Null exec arg0 opts (stdin, Null, AsIs) Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e)) _ -> fail $ ("failed to send mail, invalid sendmail-command") #ifdef HAVE_MAPI foreign import ccall "win32/send_email.h send_email" c_send_email #else c_send_email #endif :: CString -> {- sender -} CString -> {- recipient -} CString -> {- cc -} CString -> {- subject -} CString -> {- body -} CString -> {- path -} IO Int #ifndef HAVE_MAPI c_send_email = impossible #endif execPSPipe :: String -> [String] -> PackedString -> IO PackedString execPSPipe c args ps = liftM renderPS $ execDocPipe c args $ packedString ps execDocPipe :: String -> [String] -> Doc -> IO Doc execDocPipe c args instr = withOpenTemp $ \(th,tn) -> do hPutDoc th instr hClose th withTemp $ \on -> do rval <- exec c args (File tn, File on, AsIs) case rval of ExitSuccess -> readDocBinFile on ExitFailure ec -> fail $ "External program '"++c++ "' failed with exit code "++ show ec -- The following is needed for diff, which returns non-zero whenever -- the files differ. execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc execPipeIgnoreError c args instr = withOpenTemp $ \(th,tn) -> do hPutDoc th instr hClose th withTemp $ \on -> do exec c args (File tn, File on, Stdout) readDocBinFile on signString :: [DarcsFlag] -> Doc -> IO Doc signString [] d = return d signString (Sign:_) d = signPGP [] d signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d signString (SignSSL idf:_) d = signSSL idf d signString (_:os) d = signString os d signPGP :: [String] -> Doc -> IO Doc signPGP args t = execDocPipe "gpg" ("--clearsign":args) t signSSL :: String -> Doc -> IO Doc signSSL idfile t = withTemp $ \cert -> do opensslPS ["req", "-new", "-key", idfile, "-outform", "PEM", "-days", "365"] (packString "\n\n\n\n\n\n\n\n\n\n\n") >>= opensslPS ["x509", "-req", "-extensions", "v3_ca", "-signkey", idfile, "-outform", "PEM", "-days", "365"] >>= opensslPS ["x509", "-outform", "PEM"] >>= writeFilePS cert opensslDoc ["smime", "-sign", "-signer", cert, "-inkey", idfile, "-noattr", "-text"] t where opensslDoc = execDocPipe "openssl" opensslPS = execPSPipe "openssl" verifyPS :: [DarcsFlag] -> PackedString -> IO (Maybe PackedString) verifyPS [] ps = return $ Just ps verifyPS (Verify pks:_) ps = verifyGPG pks ps verifyPS (VerifySSL auks:_) ps = verifySSL auks ps verifyPS (_:os) ps = verifyPS os ps verifyGPG :: FilePath -> PackedString -> IO (Maybe PackedString) verifyGPG goodkeys s = withOpenTemp $ \(th,tn) -> do hPutPS th s hClose th rval <- exec "gpg" ["--batch","--no-default-keyring", "--keyring",fix_path goodkeys, "--verify"] (File tn, Null, Null) case rval of ExitSuccess -> return $ Just gpg_fixed_s _ -> return Nothing where gpg_fixed_s = let not_begin_signature x = x /= packString "-----BEGIN PGP SIGNED MESSAGE-----" && x /= packString "-----BEGIN PGP SIGNED MESSAGE-----\r" in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s fix_line x | lengthPS x < 3 = x | takePS 3 x == packString "- -" = dropPS 2 x | otherwise = x #if defined(WIN32) fix_sep c | c=='/' = '\\' | otherwise = c fix_path p = map fix_sep p #else fix_path p = p #endif verifySSL :: FilePath -> PackedString -> IO (Maybe PackedString) verifySSL goodkeys s = do certdata <- opensslPS ["smime", "-pk7out"] s >>= opensslPS ["pkcs7", "-print_certs"] cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata let key_used = concatPS $ tail $ takeWhile (/= packString"-----END PUBLIC KEY-----") $ linesPS cruddy_pk in do allowed_keys <- linesPS `liftM` readFilePS goodkeys if not $ key_used `elem` allowed_keys then return Nothing -- Not an allowed key! else withTemp $ \cert -> withTemp $ \on -> withOpenTemp $ \(th,tn) -> do hPutPS th s hClose th writeFilePS cert certdata rval <- exec "openssl" ["smime", "-verify", "-CAfile", cert, "-certfile", cert] (File tn, File on, Null) case rval of ExitSuccess -> Just `liftM` readFilePS on _ -> return Nothing where opensslPS = execPSPipe "openssl" can_execute :: (String,Int) -> String -> IO Bool can_execute (arg,expected_return_value) exe = do withTemp $ \junk -> do ec <- system (unwords [exe,arg,">",junk]) case ec of ExitSuccess | expected_return_value == 0 -> return True ExitFailure r | r == expected_return_value -> return True _ -> return False {- - This function returns number of colours supported by current terminal - or -1 if colour output not supported or error occured. - Terminal type determined by TERM env. variable. -} getTermNColors :: IO CInt #ifdef HAVE_CURSES foreign import ccall "tgetnum" c_tgetnum :: CString -> IO CInt foreign import ccall "tgetent" c_tgetent :: Ptr CChar -> CString -> IO CInt termioBufSize :: Int termioBufSize = 4096 getTermNColors = if not use_color then return (-1) else do term <- getEnv "TERM" allocaBytes termioBufSize (getTermNColorsImpl term) `catch` \_ -> return (-1) getTermNColorsImpl :: String -> Ptr CChar -> IO CInt getTermNColorsImpl term buf = do rc <- withCString term $ \termp -> c_tgetent buf termp if (rc /= 1) then return (-1) else withCString "Co" $ \capap -> c_tgetnum capap #else getTermNColors = return (-1) #endif -- --------------------------------------------------------------------- -- ssh helper functions -- --------------------------------------------------------------------- data SSHCmd = SSH | SCP | SFTP instance Show SSHCmd where show SSH = "ssh" show SCP = "scp" show SFTP = "sftp" runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO ExitCode runSSH cmd remoteAddr preArgs postArgs redirs = do (ssh, args) <- getSSH cmd remoteAddr exec ssh (preArgs ++ args ++ postArgs) redirs -- | Return the command and arguments needed to run an ssh command -- along with any extra features like use of the control master. -- See 'getSSHOnly' getSSH :: SSHCmd -> String -- ^ remote path -> IO (String, [String]) getSSH cmd remoteAddr = do (ssh, ssh_args) <- getSSHOnly cmd -- control master cmPath <- controlMasterPath remoteAddr hasLaunchedCm <- doesFileExist cmPath when (not hasLaunchedCm && not sshControlMasterDisabled) $ launchSSHControlMaster remoteAddr hasCmFeature <- doesFileExist cmPath let cm_args = if hasCmFeature then [ "-o ControlPath=" ++ cmPath ] else [] verbosity = case cmd of SCP -> ["-q"] -- (p)scp is the only one that recognises -q -- sftp and (p)sftp do not, and plink neither _ -> [] -- return (ssh, verbosity ++ ssh_args ++ cm_args) -- | Return the command and arguments needed to run an ssh command. -- First try the appropriate darcs environment variable and SSH_PORT -- defaulting to "ssh" and no specified port. getSSHOnly :: SSHCmd -> IO (String, [String]) getSSHOnly cmd = do ssh_command <- getEnv (evar cmd) `catch` \_ -> return $ show cmd -- port p <- try $ getEnv "SSH_PORT" -- or DARCS_SSH_PORT ? let port = either (const []) (portFlag cmd) p ssh = head $ words ssh_command ssh_args = tail $ words ssh_command -- return (ssh, ssh_args ++ port) where evar SSH = "DARCS_SSH" evar SCP = "DARCS_SCP" evar SFTP = "DARCS_SFTP" portFlag SSH x = ["-p", x] portFlag SCP x = ["-P", x] portFlag SFTP x = ["-oPort="++x] -- | Return True if this version of ssh has a ControlMaster feature -- The ControlMaster functionality allows for ssh multiplexing hasSSHControlMaster :: Bool hasSSHControlMaster = unsafePerformIO hasSSHControlMasterIO -- Because of the unsafePerformIO above, this can be called at any -- point. It cannot rely on any state, not even the current directory. hasSSHControlMasterIO :: IO Bool hasSSHControlMasterIO = do (ssh, _) <- getSSHOnly SSH -- If ssh has the ControlMaster feature, it will recognise the -- the -O flag, but exit with status 255 because of the nonsense -- command. If it does not have the feature, it will simply dump -- a help message on the screen and exit with 1. sx <- exec ssh ["-O", "an_invalid_command"] (Null,Null,Null) case sx of ExitFailure 255 -> return True _ -> return False -- | Launch an SSH control master in the background, if available. -- We don't have to wait for it or anything. -- Note also that this will cleanup after itself when darcs exits launchSSHControlMaster :: String -> IO () launchSSHControlMaster rawAddr = when hasSSHControlMaster $ do let addr = takeWhile (/= ':') rawAddr (ssh, ssh_args) <- getSSHOnly SSH cmPath <- controlMasterPath addr -- -f : put ssh in the background once it succeeds in logging you in -- -M : launch as the control master for addr -- -N : don't run any commands -- -S : use cmPath as the ControlPath. Equivalent to -oControlPath= exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,AsIs) atexit $ exitSSHControlMaster addr return () -- | Tell the SSH control master for a given path to exit. exitSSHControlMaster :: String -> IO () exitSSHControlMaster addr = do (ssh, ssh_args) <- getSSHOnly SSH cmPath <- controlMasterPath addr exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null) return () -- | Create the directory ssh control master path for a given address controlMasterPath :: String -- ^ remote path (foo@bar.com:file is ok; the file part with be stripped) -> IO FilePath controlMasterPath rawAddr = do let addr = takeWhile (/= ':') rawAddr tmp <- tempdir_loc let tmpDarcsSsh = tmp ++ "darcs-ssh" createDirectoryIfMissing False tmpDarcsSsh return $ tmpDarcsSsh ++ "/" ++ addr