Here are the reworked patches for new exec interface.
Mon Sep 11 12:29:33 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* rewrite Exec.lhs, new exec interface with Redirects
Make the code structure a bit simpler and easier to understand.
Only one (fancy) version of exec.
Fri Sep 15 18:44:46 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* fix typo
This is the old one, but with a fix for the typo.
I've done the calls to the new exec properly this time. The
first attempt in the old patch was hasty work.
Sat Sep 16 00:22:26 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* update calls to exec and exec_fancy to new interface
This patch should change nothing of darcs behavior regarding
executing external commands. It's a plain translation to the new
interface.
Sat Sep 16 00:26:54 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* reindent some long lines
Sat Sep 16 00:29:23 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* simplify helper function stupidexec in copyRemoteCmd
These two are changes that don't have anything to do with the
new exec functionality.
Sat Sep 16 02:44:07 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* redirect errors to stderr where exec is checked and darcs fails
In these situations the user will get both the error message from the
failing external command and a message from darcs about what action it
could not perform.
Sat Sep 16 02:56:51 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* redirect errors to stderr where exec output is used
Error messages would destroy the result if they ended up in the output.
If the external command fails, darcs should (but does not always) fail.
Sat Sep 16 03:01:16 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* redirect errors to null where exec output is used but failure is not fatal
Error messages in the output would destroy the result, but if the command
fails some other action is taken, so error messages shall not be displayed
to the user.
I'm pretty confident these three does the right thing. (This
does not mean I'm confident I haven't introduced any new bugs.)
Sat Sep 16 03:06:45 CEST 2006 Tommy Pettersson <[EMAIL PROTECTED]>
* show error messages when starting and stoping the ssh control master
I don't know if this last patch is a good or a bad idea.
--
Tommy Pettersson <[EMAIL PROTECTED]>
New patches:
[Fix Windows stderr non-redirection.
Eric Kow <[EMAIL PROTECTED]>**20060909055204
(It was consistently redirecting to stdout.)
Also make the exec code more readable/transparent.
]
<
> {
hunk ./Exec.lhs 22
module Exec ( exec, exec_, exec_interactive
) where
+import Data.Maybe (maybe)
import System
import System.Cmd (rawSystem)
import IO
hunk ./Exec.lhs 39
wcss (s:ss) css = withCString s $ \cstr -> wcss ss (cstr:css)
#endif
+-- | Note that stderr is redirected to stdout
exec :: String -> [String] -> FilePath -> FilePath -> IO ExitCode
hunk ./Exec.lhs 41
-exec c args inp out = exec_ c args (Just inp) (Just out) Nothing
+exec c args inp out = execHelper c args (Just inp) (Just out) RedirectToStdout
-- lets you opt not to redirect streams, and to (optionally) redirect stderr
exec_ :: String -> [String] -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> IO ExitCode
hunk ./Exec.lhs 45
+exec_ c args minp mout merr =
+ execHelper c args minp mout $ maybe NoRedirect RedirectTo merr
+
+data StdErrRedirect = NoRedirect | RedirectToStdout | RedirectTo FilePath
+
+execHelper :: String -> [String] -> Maybe FilePath -> Maybe FilePath -> StdErrRedirect -> IO ExitCode
#ifdef WIN32
hunk ./Exec.lhs 53
-exec_ c args minp mout merr =
+execHelper c args minp mout merr =
let redirect side mp =
case mp of
Nothing -> ""
hunk ./Exec.lhs 61
Just p -> side ++ careful_unwords [p]
redirectErr =
case merr of
- Nothing -> "2>&1"
- Just e -> redirect " 2> " (Just e)
+ NoRedirect -> ""
+ RedirectToStdout -> "2>&1"
+ RedirectTo e -> redirect " 2> " (Just e)
in system $ c ++" "++careful_unwords args
++(redirect " < " minp)
++(redirect " > " mout)
hunk ./Exec.lhs 73
careful_unwords (a:as) = "\""++a++"\" "++ careful_unwords as
careful_unwords [] = ""
#else
-exec_ c args minp mout merr = do
+execHelper c args minp mout merr = do
fval <- c_fork
hunk ./Exec.lhs 75
- let -- set up stdin redirection if needed
+ let withRedirect :: FilePath -> CInt -> (CString -> IO CInt)
+ -> (CInt -> IO ExitCode) -> IO ExitCode
+ withRedirect path n openFn fjob =
+ withCString path $ \cpath -> do
+ fd <- openFn cpath
+ c_dup2 fd n
+ fjob fd
+ -- stdin redirection (if applicable)
withStdin job =
hunk ./Exec.lhs 84
- case minp of
- Nothing -> job
- Just inp -> withCString inp $ \in_c -> do
- fdin <- open_read in_c
- c_dup2 fdin 0
- job
- -- set up stdout/stderr redirection if needed
+ case minp of
+ Nothing -> job
+ Just inp -> withRedirect inp 0 open_read (const job)
+ -- stdout/stderr redirection (if applicable)
withStdout job =
hunk ./Exec.lhs 89
- case mout of
- -- no stdout redirection
- Nothing ->
- case merr of
- Nothing -> job
- Just e -> withCString e $ \err_c -> do
- fderr <- open_write err_c
- c_dup2 fderr 2
- job
- -- stdout redirection
- Just out -> withCString out $ \out_c -> do
- fdout <- open_write out_c
- c_dup2 fdout 1
- case merr of
- Nothing -> do c_dup2 fdout 2 -- stderr to stdout
- job
- Just e -> withCString e $ \err_c -> do
- fderr <- open_write err_c
- c_dup2 fderr 2
- job
+ case mout of
+ Nothing -> setupStderr (return ())
+ Just out -> withRedirect out 1 open_write $
+ \fd -> setupStderr (c_dup2 fd 2)
+ where
+ setupStderr redirectToOut =
+ case merr of
+ NoRedirect -> job
+ RedirectToStdout -> redirectToOut >> job
+ RedirectTo err -> withRedirect err 2 open_write (const job)
-- fork and go
case fval of
-1 -> return $ ExitFailure $ 1
}
[rewrite Exec.lhs, new exec interface with Redirects
Tommy Pettersson <[EMAIL PROTECTED]>**20060911102933
Make the code structure a bit simpler and easier to understand.
Only one (fancy) version of exec.
]
<
> {
hunk ./Exec.lhs 19
\begin{code}
{-# OPTIONS -fffi #-}
-module Exec ( exec, exec_, exec_interactive
+module Exec ( exec, exec_interactive,
+ Redirects, Redirect(..),
) where
hunk ./Exec.lhs 23
-import Data.Maybe (maybe)
import System
import System.Cmd (rawSystem)
import IO
hunk ./Exec.lhs 28
#ifndef WIN32
+
import System.Posix.IO ( setFdOption, FdOption(..), stdInput )
import Foreign
import Foreign.C
hunk ./Exec.lhs 33
import Monad ( liftM )
+#include "impossible.h"
withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a
withCStrings strings doit = wcss strings []
hunk ./Exec.lhs 39
where wcss [] css = withArray0 nullPtr (reverse css) $ \aack -> doit aack
wcss (s:ss) css = withCString s $ \cstr -> wcss ss (cstr:css)
+
#endif
hunk ./Exec.lhs 42
--- | Note that stderr is redirected to stdout
-exec :: String -> [String] -> FilePath -> FilePath -> IO ExitCode
-exec c args inp out = execHelper c args (Just inp) (Just out) RedirectToStdout
+{-
+ A redirection is a tipple of values (in, out, err).
+ The most common values are:
+
+ AsIs don't change it
+ Null /dev/null on Unix, NUL on Windows
+ File open a file for reading or writing
+
+ There is also the value Stdout, which is only meaningful for
+ redirection of errors, and is performed AFTER stdout is
+ redirected so that output and errors mix together. StdIn and
+ StdErr could be added as well if they are useful.
hunk ./Exec.lhs 55
--- lets you opt not to redirect streams, and to (optionally) redirect stderr
-exec_ :: String -> [String] -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> IO ExitCode
-exec_ c args minp mout merr =
- execHelper c args minp mout $ maybe NoRedirect RedirectTo merr
+ NOTE: Lots of care must be taken when redirecting stdin, stdout
+ and stderr to one of EACH OTHER, since the ORDER in which they
+ are changed have a significant effect on the result.
+-}
hunk ./Exec.lhs 60
-data StdErrRedirect = NoRedirect | RedirectToStdout | RedirectTo FilePath
+type Redirects = (Redirect, Redirect, Redirect)
+data Redirect = AsIs | Null | File FilePath
+ | Stdout
hunk ./Exec.lhs 64
-execHelper :: String -> [String] -> Maybe FilePath -> Maybe FilePath -> StdErrRedirect -> IO ExitCode
+exec :: String -> [String] -> Redirects -> IO ExitCode
#ifdef WIN32
hunk ./Exec.lhs 67
-execHelper c args minp mout merr =
- let redirect side mp =
- case mp of
- Nothing -> ""
- Just "/dev/null" -> side ++ "NUL"
- Just p -> side ++ careful_unwords [p]
- redirectErr =
- case merr of
- NoRedirect -> ""
- RedirectToStdout -> "2>&1"
- RedirectTo e -> redirect " 2> " (Just e)
- in system $ c ++" "++careful_unwords args
- ++(redirect " < " minp)
- ++(redirect " > " mout)
- ++redirectErr
hunk ./Exec.lhs 68
-careful_unwords :: [String] -> [Char]
-careful_unwords (a:as) = "\""++a++"\" "++ careful_unwords as
-careful_unwords [] = ""
+{-
+ On Windows we call the system function with a command line
+ string. The string has the arguments in quotes, and contains
+ redirection operators.
+-}
+
+exec cmd args (inp,out,err) =
+ system $ cmd ++ " " ++ in_quotes_unwords args
+ ++ (redirect "<" inp)
+ ++ (redirect ">" out)
+ ++ (redirect "2>" err) -- order is important if err is Stdout
+ where redirect op value =
+ case value of
+ -- FIXME: are all these spaces necessary?
+ AsIs -> ""
+ Null -> " " ++ op ++ " " ++ "NUL"
+ File "/dev/null" -> -- safety catch
+ " " ++ op ++ " " ++ "NUL"
+ File fp -> " " ++ op ++ " \"" ++ fp ++ "\"" -- fp in quotes
+ Stdout -> " " ++ op ++ "&1"
+
+in_quotes_unwords :: [String] -> [Char]
+in_quotes_unwords (a:as) = "\""++a++"\" "++ in_quotes_unwords as
+in_quotes_unwords [] = ""
+
#else
hunk ./Exec.lhs 94
-execHelper c args minp mout merr = do
+
+{-
+ On Unix we fork, use dup2 for redirections (after opening
+ relevant files). Then we exec the command in the child, and wait
+ for its exit status in the parent.
+-}
+
+exec cmd args redirs = do
fval <- c_fork
hunk ./Exec.lhs 103
- let withRedirect :: FilePath -> CInt -> (CString -> IO CInt)
- -> (CInt -> IO ExitCode) -> IO ExitCode
- withRedirect path n openFn fjob =
- withCString path $ \cpath -> do
- fd <- openFn cpath
- c_dup2 fd n
- fjob fd
- -- stdin redirection (if applicable)
- withStdin job =
- case minp of
- Nothing -> job
- Just inp -> withRedirect inp 0 open_read (const job)
- -- stdout/stderr redirection (if applicable)
- withStdout job =
- case mout of
- Nothing -> setupStderr (return ())
- Just out -> withRedirect out 1 open_write $
- \fd -> setupStderr (c_dup2 fd 2)
- where
- setupStderr redirectToOut =
- case merr of
- NoRedirect -> job
- RedirectToStdout -> redirectToOut >> job
- RedirectTo err -> withRedirect err 2 open_write (const job)
- -- fork and go
case fval of
hunk ./Exec.lhs 104
- -1 -> return $ ExitFailure $ 1
- 0 -> withStdin $ withStdout $
- withCString c $ \c_c ->
- withCStrings (c:args) $ \c_args -> do
+ -1 -> return $ ExitFailure $ 1
+ 0 -> -- child
+ withRedirects redirs $
+ withCString cmd $ \c_cmd ->
+ withCStrings (cmd:args) $ \c_args -> do
-- execvp only returns if there is an error:
hunk ./Exec.lhs 110
- ExitFailure `liftM` execvp_no_vtalarm c_c c_args
- pid -> do ecode <- smart_wait pid
+ ExitFailure `liftM` execvp_no_vtalarm c_cmd c_args
+ pid -> -- parent
+ do ecode <- smart_wait pid
if ecode == 0 then return ExitSuccess
else return $ ExitFailure ecode
hunk ./Exec.lhs 116
+withRedirects :: Redirects -> IO a -> IO a
+withRedirects (inp,out,err) job =
+ do redirect 0 inp
+ redirect 1 out
+ redirect 2 err -- order is important if err is Stdout
+ job
+ where redirect _ AsIs = return () -- a no-op
+ redirect std_fd Null = redirect std_fd (File "/dev/null")
+ redirect std_fd Stdout = c_dup2 1 std_fd >> return ()
+ redirect std_fd (File fp) = withCString fp $ \c_fp -> do
+ file_fd <- open_like std_fd c_fp
+ c_dup2 file_fd std_fd
+ return ()
+ open_like 0 = open_read
+ open_like 1 = open_write
+ open_like 2 = open_write
+ open_like _ = impossible
+
+
foreign import ccall unsafe "static unistd.h dup2" c_dup2
:: CInt -> CInt -> IO CInt
foreign import ccall unsafe "static compat.h smart_wait" smart_wait
hunk ./Exec.lhs 145
:: CString -> IO CInt
foreign import ccall unsafe "static unistd.h fork" c_fork
:: IO Int
-foreign import ccall unsafe "static compat.h execvp_no_vtalarm" execvp_no_vtalarm
+foreign import ccall unsafe
+ "static compat.h execvp_no_vtalarm" execvp_no_vtalarm
:: CString -> Ptr CString -> IO Int
hunk ./Exec.lhs 148
+
#endif
exec_interactive :: String -> [String] -> IO ExitCode
}
[fix typo
Tommy Pettersson <[EMAIL PROTECTED]>**20060915164446]
<
> {
hunk ./Exec.lhs 43
#endif
{-
- A redirection is a tipple of values (in, out, err).
+ A redirection is a three-tuple of values (in, out, err).
The most common values are:
AsIs don't change it
}
[update calls to exec and exec_fancy to new interface
Tommy Pettersson <[EMAIL PROTECTED]>**20060915222226]
<
> {
hunk ./Dist.lhs 30
import DarcsRepo
import RepoPrefs ( get_prefval )
import Lock ( withTemp, withTempDir, readBinFile )
-import Exec ( exec )
+import Exec ( exec, Redirect(..) )
\end{code}
\options{dist}
hunk ./Dist.lhs 94
Just pd -> system pd
setCurrentDirectory (tempdir)
exec "tar" ["-cf", "-", reverse $ takeWhile (/='/') $ reverse ddir]
- "/dev/null" tarfile
+ (Null, File tarfile, Stdout)
when verb $ withTemp $ \tar_listing -> do
hunk ./Dist.lhs 96
- exec "tar" ["-tf", "-"] tarfile tar_listing
+ exec "tar" ["-tf", "-"]
+ (File tarfile, File tar_listing, Stdout)
to <- readBinFile tar_listing
putStr to
hunk ./Dist.lhs 100
- exec "gzip" ["-c"] tarfile (formerdir++"/"++dn++".tar.gz")
+ exec "gzip" ["-c"]
+ (File tarfile, File (formerdir++"/"++dn++".tar.gz"), Stdout)
putStrLn $ "Created dist as "++dn++".tar.gz"
guess_repo_name :: IO String
hunk ./External.hs 51
import Autoconf ( have_libcurl, have_sendmail, have_mapi, sendmail_path, darcs_version )
import Curl ( copyUrl )
import Curl ( Cachable(..) )
-import Exec ( exec, exec_ )
+import Exec ( exec, Redirects, Redirect(..), )
import DarcsURL ( is_file, is_url, is_ssh )
import DarcsUtils ( catchall )
import Printer ( Doc, hPutDoc, hPutDocLn, ($$), (<+>), renderPS,
hunk ./External.hs 156
Just get ->
do let cmd = head $ words get
args = tail $ words get
- r <- exec cmd (args++[u]) "/dev/null" v
+ r <- exec cmd (args++[u]) (Null, File v, Stdout)
when (r /= ExitSuccess) $
fail $ "(" ++ get ++ ") failed to fetch: " ++ u
hunk ./External.hs 167
copySSH :: String -> FilePath -> IO ()
copySSH uRaw f = let u = escape_dollar uRaw in do
- r <- runSSH SCP u [] [u,f] Nothing Nothing
+ 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.. -}
hunk ./External.hs 210
args = tail $ words mget
urls = map (\n -> u++"/"++n) nsnow
withCurrentDirectory d $ do
- r <- exec cmd (args++urls) "/dev/null" "/dev/null"
+ r <- exec cmd (args++urls) (Null,Null,Null)
when (r /= ExitSuccess) $
fail $ unlines $
["(" ++ mget ++ ") failed to fetch files.",
hunk ./External.hs 242
do hPutStr th input
hClose th
r <- exec wget (wget_args++["-i",tn])
- "/dev/null" "/dev/null"
+ (Null,Null,Null)
when (r /= ExitSuccess) $
fail $ unlines $
["(wget) failed to fetch files.",
hunk ./External.hs 258
withTemp $ \sftpoutput ->
do hPutStr th input
hClose th
- r <- runSSH SFTP u [] [host] (Just tn) (Just sftpoutput)
+ 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"]
hunk ./External.hs 279
copyRemoteCmd :: String -> FilePath -> IO ()
copyRemoteCmd s tmp = do
let cmd = get_ext_cmd
- r <- stupidexec (cmd tmp s) "/dev/null" "/dev/null"
+ r <- stupidexec (cmd tmp s) (Null,Null,Null)
when (r /= ExitSuccess) $
fail $ "failed to fetch: " ++ s ++" " ++ show r
where stupidexec (c:args) inf outf = exec c args inf outf
hunk ./External.hs 337
-- reading its output. Return its ExitCode
execSSH :: String -> String -> IO ExitCode
execSSH remoteAddr command =
- runSSH SSH remoteAddr [remoteAddr] [command] Nothing Nothing
+ runSSH SSH remoteAddr [remoteAddr] [command] (AsIs,AsIs,Null)
pipeDoc_SSH_IgnoreError :: String -> [String] -> Doc -> IO Doc
pipeDoc_SSH_IgnoreError remoteAddr args input =
hunk ./External.hs 460
execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail ftable scmd fn =
if scmd == "" then
- exec sendmail_path ["-i", "-t"] fn "/dev/null"
+ exec sendmail_path ["-i", "-t"] (File fn, Null, Null)
else case parseCmd (addUrlencoded ftable) scmd of
Right (arg0:opts, wantstdin) ->
hunk ./External.hs 463
- do let stdin = if wantstdin then fn else "/dev/null"
- exec arg0 opts stdin "/dev/null"
+ do let stdin = if wantstdin then File fn else Null
+ exec arg0 opts (stdin, Null, Null)
Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))
_ -> fail $ ("failed to send mail, invalid sendmail-command")
hunk ./External.hs 495
hPutDoc th instr
hClose th
withTemp $ \on -> do
- rval <- exec c args tn on
+ rval <- exec c args (File tn, File on, Stdout)
case rval of
ExitSuccess -> readDocBinFile on
ExitFailure ec -> fail $ "External program '"++c++
hunk ./External.hs 508
withOpenTemp $ \(th,tn) -> do
hPutDoc th instr
hClose th
- withTemp $ \on -> do exec c args tn on
+ withTemp $ \on -> do exec c args (File tn, File on, Stdout)
readDocBinFile on
signString :: [DarcsFlag] -> Doc -> IO Doc
hunk ./External.hs 550
hPutPS th s
hClose th
rval <- exec "gpg" ["--batch","--no-default-keyring",
- "--keyring",fix_path goodkeys, "--verify"] tn "/dev/null"
+ "--keyring",fix_path goodkeys, "--verify"]
+ (File tn, Null, Null)
case rval of
ExitSuccess -> return $ Just gpg_fixed_s
_ -> return Nothing
hunk ./External.hs 589
hClose th
writeFilePS cert certdata
rval <- exec "openssl" ["smime", "-verify", "-CAfile",
- cert, "-certfile", cert] tn on
+ cert, "-certfile", cert]
+ (File tn, File on, Stdout)
case rval of
ExitSuccess -> Just `liftM` readFilePS on
_ -> return Nothing
hunk ./External.hs 649
show SCP = "scp"
show SFTP = "sftp"
-runSSH :: SSHCmd -> String -> [String] -> [String]
- -> Maybe FilePath -> Maybe FilePath -> IO ExitCode
-runSSH cmd remoteAddr preArgs postArgs minp mout =
+runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO ExitCode
+runSSH cmd remoteAddr preArgs postArgs redirs =
do (ssh, args) <- getSSH cmd remoteAddr
hunk ./External.hs 652
- exec_ ssh (preArgs ++ args ++ postArgs) minp mout (Just "/dev/null")
+ 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.
hunk ./External.hs 710
-- 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"] "/dev/null" "/dev/null"
+ sx <- exec ssh ["-O", "an_invalid_command"] (Null,Null,Null)
case sx of
ExitFailure 255 -> return True
_ -> return False
hunk ./External.hs 728
-- -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"]) "/dev/null" "/dev/null"
+ exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,Null)
atexit $ exitSSHControlMaster addr
return ()
hunk ./External.hs 737
exitSSHControlMaster addr = do
(ssh, ssh_args) <- getSSHOnly SSH
cmPath <- controlMasterPath addr
- exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) "/dev/null" "/dev/null"
+ exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null)
return ()
-- | Create the directory ssh control master path for a given address
hunk ./Resolution.lhs 36
import DarcsRepo ( slurp_recorded_and_unrecorded )
import Diff ( smart_diff )
import RepoPrefs ( filetype_function )
-import Exec ( exec )
+import Exec ( exec, Redirect(..) )
import Lock ( withTempDir )
import External ( cloneTree, clonePaths )
#include "impossible.h"
hunk ./Resolution.lhs 205
Right (c2,_) -> rr c2
where rr (command:args) = do putStrLn $ "Running command '" ++
unwords (command:args) ++ "'"
- exec command args "/dev/null" "/dev/null"
+ exec command args (Null,Null,Null)
rr [] = return ExitSuccess
(///) :: FilePath -> FilePath -> FilePath
}
[reindent some long lines
Tommy Pettersson <[EMAIL PROTECTED]>**20060915222654]
<
> {
hunk ./External.hs 250
"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
+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 ()
}
[simplify helper function stupidexec in copyRemoteCmd
Tommy Pettersson <[EMAIL PROTECTED]>**20060915222923]
<
> {
hunk ./External.hs 283
r <- stupidexec (cmd tmp s) (Null,Null,Null)
when (r /= ExitSuccess) $
fail $ "failed to fetch: " ++ s ++" " ++ show r
- where stupidexec (c:args) inf outf = exec c args inf outf
- stupidexec [] _ _ = bug "stupidexec without a command"
+ where stupidexec [] = bug "stupidexec without a command"
+ stupidexec xs = exec (head xs) (tail xs)
doWithPatches :: [DarcsFlag] -> (String -> IO ()) -> [String] -> IO ()
doWithPatches opts f patches =
}
[redirect errors to stderr where exec is checked and darcs fails
Tommy Pettersson <[EMAIL PROTECTED]>**20060916004407
In these situations the user will get both the error message from the
failing external command and a message from darcs about what action it
could not perform.
]
<
> {
hunk ./External.hs 156
Just get ->
do let cmd = head $ words get
args = tail $ words get
- r <- exec cmd (args++[u]) (Null, File v, Stdout)
+ r <- exec cmd (args++[u]) (Null, File v, AsIs)
when (r /= ExitSuccess) $
fail $ "(" ++ get ++ ") failed to fetch: " ++ u
hunk ./External.hs 210
args = tail $ words mget
urls = map (\n -> u++"/"++n) nsnow
withCurrentDirectory d $ do
- r <- exec cmd (args++urls) (Null,Null,Null)
+ r <- exec cmd (args++urls) (Null,Null,AsIs)
when (r /= ExitSuccess) $
fail $ unlines $
["(" ++ mget ++ ") failed to fetch files.",
hunk ./External.hs 242
do hPutStr th input
hClose th
r <- exec wget (wget_args++["-i",tn])
- (Null,Null,Null)
+ (Null,Null,AsIs)
when (r /= ExitSuccess) $
fail $ unlines $
["(wget) failed to fetch files.",
hunk ./External.hs 280
copyRemoteCmd :: String -> FilePath -> IO ()
copyRemoteCmd s tmp = do
let cmd = get_ext_cmd
- r <- stupidexec (cmd tmp s) (Null,Null,Null)
+ 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"
hunk ./External.hs 461
execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode
execSendmail ftable scmd fn =
if scmd == "" then
- exec sendmail_path ["-i", "-t"] (File fn, Null, Null)
+ 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
hunk ./External.hs 465
- exec arg0 opts (stdin, Null, 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")
hunk ./External.hs 496
hPutDoc th instr
hClose th
withTemp $ \on -> do
- rval <- exec c args (File tn, File on, Stdout)
+ rval <- exec c args (File tn, File on, AsIs)
case rval of
ExitSuccess -> readDocBinFile on
ExitFailure ec -> fail $ "External program '"++c++
}
[redirect errors to stderr where exec output is used
Tommy Pettersson <[EMAIL PROTECTED]>**20060916005651
Error messages would destroy the result if they ended up in the output.
If the external command fails, darcs should (but does not always) fail.
]
<
> {
hunk ./Dist.lhs 94
Just pd -> system pd
setCurrentDirectory (tempdir)
exec "tar" ["-cf", "-", reverse $ takeWhile (/='/') $ reverse ddir]
- (Null, File tarfile, Stdout)
+ (Null, File tarfile, AsIs)
when verb $ withTemp $ \tar_listing -> do
exec "tar" ["-tf", "-"]
(File tarfile, File tar_listing, Stdout)
hunk ./Dist.lhs 101
to <- readBinFile tar_listing
putStr to
exec "gzip" ["-c"]
- (File tarfile, File (formerdir++"/"++dn++".tar.gz"), Stdout)
+ (File tarfile, File (formerdir++"/"++dn++".tar.gz"), AsIs)
putStrLn $ "Created dist as "++dn++".tar.gz"
guess_repo_name :: IO String
}
[redirect errors to null where exec output is used but failure is not fatal
Tommy Pettersson <[EMAIL PROTECTED]>**20060916010116
Error messages in the output would destroy the result, but if the command
fails some other action is taken, so error messages shall not be displayed
to the user.
]
<
> {
hunk ./External.hs 591
writeFilePS cert certdata
rval <- exec "openssl" ["smime", "-verify", "-CAfile",
cert, "-certfile", cert]
- (File tn, File on, Stdout)
+ (File tn, File on, Null)
case rval of
ExitSuccess -> Just `liftM` readFilePS on
_ -> return Nothing
}
[show error messages when starting and stoping the ssh control master
Tommy Pettersson <[EMAIL PROTECTED]>**20060916010645]
<
> {
hunk ./External.hs 729
-- -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,Null)
+ exec ssh (ssh_args ++ [addr, "-S", cmPath, "-N", "-f", "-M"]) (Null,Null,AsIs)
atexit $ exitSSHControlMaster addr
return ()
hunk ./External.hs 738
exitSSHControlMaster addr = do
(ssh, ssh_args) <- getSSHOnly SSH
cmPath <- controlMasterPath addr
- exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null)
+ exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,AsIs)
return ()
-- | Create the directory ssh control master path for a given address
}
Context:
[Fix merge conflicts.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060906191317]
[fix bug in pristine handling when dealing with multiple patches.
David Roundy <[EMAIL PROTECTED]>**20060731111404]
[fix ordering of operations to call pull_first_middles properly.
David Roundy <[EMAIL PROTECTED]>**20060730111409]
[make amend-record.pl test a bit pickier.
David Roundy <[EMAIL PROTECTED]>**20060730103854]
[simplify code a tad in get.
David Roundy <[EMAIL PROTECTED]>**20060726121737]
[fix bug in refactoring of get.
David Roundy <[EMAIL PROTECTED]>**20060726121655]
[refactor Population.
David Roundy <[EMAIL PROTECTED]>**20060716034837]
[add TODO for refactoring get_markedup_file.
David Roundy <[EMAIL PROTECTED]>**20060716034339]
[partial refactoring in annotate.
David Roundy <[EMAIL PROTECTED]>**20060716034319]
[don't use DarcsRepo in list_authors.
David Roundy <[EMAIL PROTECTED]>**20060716033450]
[I've now eliminated need to export DarcsRepo.write_patch.
David Roundy <[EMAIL PROTECTED]>**20060716033109]
[partially refactor Optimize.
David Roundy <[EMAIL PROTECTED]>**20060716032934]
[partial refactoring of Get.
David Roundy <[EMAIL PROTECTED]>**20060716031605]
[refactor amend-record.
David Roundy <[EMAIL PROTECTED]>**20060716021003]
[add TODO to refactor unrevert handling.
David Roundy <[EMAIL PROTECTED]>**20060716020247]
[refactor Unrecord, adding tentativelyRemovePatches.
David Roundy <[EMAIL PROTECTED]>**20060716015150]
[refactor tag.
David Roundy <[EMAIL PROTECTED]>**20060716011853]
[refactor Repository to allow truly atomic updates.
David Roundy <[EMAIL PROTECTED]>**20060716011245]
[Do not redirect to or from /dev/null when calling ssh.
Eric Kow <[EMAIL PROTECTED]>**20060903214831
Redirection of stdin and stdout breaks putty, which uses these to
interact with the user. Quiet mode, and redirecting stderr are good
enough for making ssh silent.
]
[Ignore .git if _darcs found.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060831231933]
[overhaul the darcs.net front page.
Mark Stosberg <[EMAIL PROTECTED]>**20060820191415
The themes to this change are:
- Focus on the key benefits of darcs:
Distributed. Interactive. Smart.
- Recognize that the wiki is the central resource,
and remove some information that is duplicated here
and reference the wik instead.
I can post a demo of this HTML for easy comparison if you'd like.
Mark
]
[Reimplement --disable-ssh-cm flag (issue239).
Eric Kow <[EMAIL PROTECTED]>**20060812134856
My patch to "Only launch SSH control master on demand" accidentally
removed the ability to disable use of SSH ControlMaster. Also, the
way it was implemented is not compatible with launching on demand.
This implementation relies on a notion of global variables using
unsafe IORefs.
]
[Compile Global.lhs in place of AtExit.lhs.
Eric Kow <[EMAIL PROTECTED]>**20060812121943]
[Rename AtExit module to Global.
Eric Kow <[EMAIL PROTECTED]>**20060812121925
The goal is to capture some broad "global" notions like exit handlers
and global variables. Note the GPL header thrown in for good measure.
]
[Raise exception if unable to open logfile (issue142).
Zachary P. Landau <[EMAIL PROTECTED]>**20060810034035]
[Make the pull 'permission test' work when run as root
Jon Olsson <[EMAIL PROTECTED]>**20060831193834]
[TAG darcs-unstable-20060831
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060831191554]
[Fix issue 185: don't combine AddFile and RmFile in the same patch
[EMAIL PROTECTED]
For unknown reason (a possibly previous version of) darcs allows a
single patch to Add and Remove the same file in a single patch. The
"changes" command used to combine them, showing just a Remove. This
prevents combining those two events and shows two distinct actions.
]
[Check for module Text.Html in package html
Esa Ilari Vuokko <[EMAIL PROTECTED]>**20060815235739]
[Link to relevant symbol when checking for Control.Monad.Error
Esa Ilari Vuokko <[EMAIL PROTECTED]>**20060815235714]
[Workaround for HasBounds that was removed in base-2.0 (GHC 6.6)
Esa Ilari Vuokko <[EMAIL PROTECTED]>**20060815234127]
[remove TODO from pull.pl.
David Roundy <[EMAIL PROTECTED]>**20060805192700]
[fixes in pull.pl.
David Roundy <[EMAIL PROTECTED]>**20060805221055
The first fix avoids a false error that shows up because of identical
timestamps. The second verifies that revert -a doesn't prompt user.
]
[add new obliterate test.
David Roundy <[EMAIL PROTECTED]>**20060806122536]
[clean up docs on DarcsRepo format.
David Roundy <[EMAIL PROTECTED]>**20060808104321]
[Read sftp batch file in from stdin (part of issue237).
Eric Kow <[EMAIL PROTECTED]>**20060812143113
Passing the batch file in from stdin allows for sftp to be used with
password-based authentication. According to the sftp user manual regarding
the -b switch:
Since it lacks user interaction it should be
used in conjunction with non-interactive authentication
Credit for this idea goes to Ori Avtalion.
]
[Extend runSSH function to accept argument for stdin.
Eric Kow <[EMAIL PROTECTED]>**20060812142932]
[fail if replace token pattern contains spaces (issue231)
Tommy Pettersson <[EMAIL PROTECTED]>**20060806110807
It would otherwise create a badly formated patch in pending with unexpected
results for subsequent commands.
]
[fix negation of result in test
Tommy Pettersson <[EMAIL PROTECTED]>**20060806104215
Negation with ! "uses" the result and thus there is no "failure", so the
script wouldn't have exit with failure.
]
[add test that replace with spaces fail
Tommy Pettersson <[EMAIL PROTECTED]>**20060806103033]
[Do not run sftp with the -q flag (issue240).
Eric Kow <[EMAIL PROTECTED]>**20060811212030
sftp does not recognise it, and so any command which uses it fails.
]
[TAG 1.0.8
Tommy Pettersson <[EMAIL PROTECTED]>**20060616160213]
[make 1.0.8 latest stable on home page
Tommy Pettersson <[EMAIL PROTECTED]>**20060616150806]
[bump version to 1.0.8
Tommy Pettersson <[EMAIL PROTECTED]>**20060616150755]
[canonize Lele Gaifax
Tommy Pettersson <[EMAIL PROTECTED]>**20060616150524]
[Exec improvements : Windows redirection, and more redirection control.
Eric Kow <[EMAIL PROTECTED]>**20060707054134
- Implement ability to redirect to /dev/null under Windows
(eivuokko on #darcs points out that it is NUL under Windows)
- Add exec_ function, which does the same thing as exec,
but allows redirection on stderr, and also allows us
to NOT redirect stdin/stderr
]
[rename test 0_test to better name harness
Tommy Pettersson <[EMAIL PROTECTED]>**20060819214246]
[Test pull.pl, CREATE_DIR_ERROR: removed TODO now that directory name is printed in error message
Marnix Klooster <[EMAIL PROTECTED]>**20060304164033
Also removes a superfluous (and erroneous) chdir statement, which tried to
change to non-existing directory templ (last character was ell instead of one).
Also improves the description of this test.
]
[unset default author environment variables in test suite harness
Tommy Pettersson <[EMAIL PROTECTED]>**20060805151210
This makes it harder to accidently write tests that fail because no author
is set.
]
[set author in pull_two test so it doesn't hang
Tommy Pettersson <[EMAIL PROTECTED]>**20060804181518]
[add new test that triggers bug in refactoring.
David Roundy <[EMAIL PROTECTED]>**20060804103830]
[make test external stay in its temp1 dir
Tommy Pettersson <[EMAIL PROTECTED]>**20060804134139]
[remove some tabs from haskell source
Tommy Pettersson <[EMAIL PROTECTED]>**20060730122505]
[use FastPackeString when examining executable scripts in Get
Tommy Pettersson <[EMAIL PROTECTED]>**20060729130645]
[Fixed typo in documentation.
Michal Sojka <[EMAIL PROTECTED]>**20060514095212]
[Minor tweaks to list_authors.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060720180602]
[add some changelog entries
Tommy Pettersson <[EMAIL PROTECTED]>**20060718152611]
[add some changelog entries
Tommy Pettersson <[EMAIL PROTECTED]>**20060616150558]
[Added elc and pyc to binaries.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060713184214]
[Run ssh/scp/sftp quietly.
Eric Kow <[EMAIL PROTECTED]>**20060707025245
This is useful for silencing Putty, and could also be for OpenSSH should
we decide to stop redirecting to /dev/null.
]
[Refactor calls to ssh/scp/sftp.
Eric Kow <[EMAIL PROTECTED]>**20060706202509
]
[Added up links in web interface.
Peter Stuifzand <[EMAIL PROTECTED]>**20060610082238
Added a link to the 'projects' part of the cgi repository interface, so that
you go back to the project list.
]
[Merge makefile targets test_perl and test_shell into test_scripts.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060607223134
This should keep parallel make from breaking.
]
[bump version to 1.0.8pre1
Tommy Pettersson <[EMAIL PROTECTED]>**20060522122655]
[Add a test suite for calling external programs.
Eric Kow <[EMAIL PROTECTED]>**20060521045407
For now this only includes a test for ssh (issue171).
]
[Add warning to Eric's SSHControlMaster rework.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060528194136]
[Only launch SSH control master on demand (fixes issue171)
Eric Kow <[EMAIL PROTECTED]>**20060528093000
A secondary benefit is that this encapsulates the use of the control
master functionality and consequently simplifies calling ssh. There is
no need to deal with the details of launching or exiting the control
master.
]
[Fail with a sensible message when there is no default repository to pull from.
[EMAIL PROTECTED]
[Extend test suite for patch matching.
Eric Kow <[EMAIL PROTECTED]>**20060513192501
]
[Implement help --match (issue91).
Eric Kow <[EMAIL PROTECTED]>**20060513185610
Also, refactor matching code in a way that encourages developers
to document for help --match any new matchers they create.
]
[Replace dateparser.sh with more general match.pl for testing --match.
Eric Kow <[EMAIL PROTECTED]>**20060513104942
]
[Add tests for pristine error and quiet mode when removing a directory.
Eric Kow <[EMAIL PROTECTED]>**20060513100021]
[Suppress non-empty dir warning if Quiet.
Eric Kow <[EMAIL PROTECTED]>**20060513053456]
[Replace test rmdir.sh with rmdir.pl.
Eric Kow <[EMAIL PROTECTED]>**20060513043823]
[Add forgotten file umask.h.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060423174844]
[Add --umask to all commands that write to the current repository.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060407195655]
[Add option --umask.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060407194552]
[Actually switch umasks in withRepoLock.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060407194202]
[Implement withUMask.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060407193312]
[Add umask.c.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060407193255]
[Propagate opts to withRepoLock.
Juliusz Chroboczek <[EMAIL PROTECTED]>**20060325190622]
[TAG 1.0.7
Tommy Pettersson <[EMAIL PROTECTED]>**20060513171438]
Patch bundle hash:
94440d51bbc8809ba3799bbcf971f7533b939bda
_______________________________________________
darcs-devel mailing list
[email protected]
http://www.abridgegame.org/cgi-bin/mailman/listinfo/darcs-devel
