gh <guilla...@gmail.com> added the comment: Review comes below.
You should fix isHttpUrl (former isUrl) so that it strips suffix whitespaces in its argument. (Could be done in a followup patch I guess). Indeed, with your patches, replacing in the file _darcs/prefs/defaultrepo the line http://darcs.net by http://darcs.net Got me this error when I did a pull: darcs failed: Not a repository: http://darcs.net (unknown transport protocol: http://darcs.net/_darcs/inventory) Otherwise it looks all good. Guillaume > > New patches: > > [remove useless unsafePerformIO > Florent Becker <florent.bec...@ens-lyon.org>**20101101161205 > Ignore-this: c13a931f08355bc9c21a8ab498f2a7e0 > ] hunk ./src/Ssh.hs 273 > > -- | Return True if this version of ssh has a ControlMaster feature > -- The ControlMaster functionality allows for ssh multiplexing > -hasSSHControlMaster :: Bool > -hasSSHControlMaster = unsafePerformIO hasSSHControlMasterIO Indeed no longer needed. > - > --- 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 > +hasSSHControlMaster :: IO Bool > +hasSSHControlMaster = do Just a change in the function name. > (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 > hunk ./src/Ssh.hs 289 > -- 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 > - removeFileMayNotExist cmPath > - -- -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 () > +launchSSHControlMaster rawAddr = do > + hasMaster <- hasSSHControlMaster The only change in this function, because hasSSHControlMaster is now in IO. > + when hasMaster $ do > + let addr = takeWhile (/= ':') rawAddr > + (ssh, ssh_args) <- getSSHOnly SSH > + cmPath <- controlMasterPath addr > + removeFileMayNotExist cmPath > + -- -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 () This is just indentation, unnecessary since the original code was syntactically correct without it. > > -- | Tell the SSH control master for a given path to exit. > exitSSHControlMaster :: String -> IO () Patch is ok to go in. Second patch: > [resolve issue1970: allow ssh:// urls > Florent Becker <florent.bec...@ens-lyon.org>**20101101161445 > Ignore-this: 90ada77620504d0e4f1183a401e47da1 > ] replace ./src/Darcs/Commands/Push.lhs [A-Za-z_0-9] isUrl isHttpUrl > hunk ./src/Darcs/Commands/Put.lhs 29 > import Darcs.Witnesses.Ordered ( RL(..), nullFL ) > import Darcs.Match ( havePatchsetMatch, getOnePatchset ) > import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo ) > -import Darcs.URL ( isUrl, isFile ) > +import Darcs.URL ( isUrl, isFile, splitSshUrl, SshFilePath(..) ) Ok. > import Darcs.Utils ( withCurrentDirectory ) > import Progress ( debugMessage ) > import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath ) > hunk ./src/Darcs/Commands/Put.lhs 102 > then do createDirectory req_absolute_repo_dir > withCurrentDirectory req_absolute_repo_dir $ (commandCommand > initialize) initopts [] > else do -- isSsh req_absolute_repo_dir > - remoteInit req_absolute_repo_dir initopts > + remoteInit (splitSshUrl req_absolute_repo_dir) initopts Because remoteInit now needs a SshFilePath as 1sr argument. > > withCurrentDirectory cur_absolute_repo_dir $ > withRepoReadLock opts $- \repository -> (do > hunk ./src/Darcs/Commands/Put.lhs 129 > ExitSuccess -> putInfo opts $ text "Put successful.") :: IO () > putCmd _ _ = impossible > > -remoteInit :: FilePath -> [DarcsFlag] -> IO () > +remoteInit :: SshFilePath -> [DarcsFlag] -> IO () Ok. > remoteInit repo opts = do > let args = catMaybes $ map (flagToString $ commandBasicOptions > initialize) opts > hunk ./src/Darcs/Commands/Put.lhs 132 > - command = "darcs initialize --repodir='" ++ path ++ "' " ++ unwords > args > - exitCode <- execSSH addr command > + command = "darcs initialize --repodir='" ++ (sshRepo repo) ++ "' " > ++ unwords args > + exitCode <- execSSH repo command Ok. > when (exitCode /= ExitSuccess) $ > fail "Couldn't initialize remote repository." > hunk ./src/Darcs/Commands/Put.lhs 136 > - where (addr,':':path) = break (==':') repo No longer needed because already done as repo. > \end{code} > replace ./src/Darcs/Commands/Put.lhs [A-Za-z_0-9] isSsh isSshUrl > replace ./src/Darcs/Commands/Put.lhs [A-Za-z_0-9] isUrl isHttpUrl This is imported from Darcs.URL . > hunk ./src/Darcs/External.hs 72 > import Ssh ( getSSH, copySSH, copySSHs, SSHCmd(..) ) > import URL ( Cachable(..) ) > import Exec ( exec, Redirect(..), withoutNonBlock ) > -import Darcs.URL ( isFile, isUrl, isSsh ) > +import Darcs.URL ( isFile, isUrl, isSsh, splitSshUrl, SshFilePath, sshUhost ) OK (sshUhost is a record function for SshFilePath ). > import Darcs.Utils ( catchall ) > import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, > hPutDocWith, ($$), renderPS, > simplePrinters, > hunk ./src/Darcs/External.hs 172 > copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO () > copyFileOrUrl _ fou out _ | isFile fou = copyLocal fou out > copyFileOrUrl _ fou out cache | isUrl fou = copyRemote fou out cache > -copyFileOrUrl rd fou out _ | isSsh fou = copySSH rd fou out > +copyFileOrUrl rd fou out _ | isSsh fou = copySSH rd (splitSshUrl fou) > out Ok. > copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ > fou > > speculateFileOrUrl :: String -> FilePath -> IO () > hunk ./src/Darcs/External.hs 276 > copyFilesOrUrls :: RemoteDarcs -> FilePath -> [String] -> FilePath -> > Cachable -> IO () > copyFilesOrUrls _ dou ns out _ | isFile dou = copyLocals dou ns out > copyFilesOrUrls _ dou ns out c | isUrl dou = copyRemotes dou ns out c > -copyFilesOrUrls remote dou ns out _ | isSsh dou = copySSHs remote dou ns out > +copyFilesOrUrls remote dou ns out _ > + | isSsh dou = copySSHs remote (splitSshUrl dou) ns out Ok. > copyFilesOrUrls _ dou _ _ _ = fail $ "unknown transport protocol: > "++dou > > > hunk ./src/Darcs/External.hs 330 > > -- | 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 :: SshFilePath -> String -> IO ExitCode Ok. > execSSH remoteAddr command = > do (ssh, ssh_args) <- getSSH SSH remoteAddr > - debugMessage $ unwords (ssh:ssh_args++[remoteAddr,command]) > - withoutProgress $ do hid <- runProcess ssh > (ssh_args++[remoteAddr,command]) > + debugMessage $ unwords (ssh:ssh_args++[sshUhost remoteAddr,command]) > + withoutProgress $ do hid <- runProcess ssh (ssh_args++[sshUhost > remoteAddr,command]) Ok because remoteAddr is now SshFilePath. > Nothing Nothing Nothing Nothing Nothing > waitForProcess hid > > hunk ./src/Darcs/External.hs 361 > putStrLn $ "Command not found:\n "++ show (c:args) > return rval > > -pipeDocSSH :: String -> [String] -> Doc -> IO ExitCode > +pipeDocSSH :: SshFilePath -> [String] -> Doc -> IO ExitCode Ok. > pipeDocSSH remoteAddr args input = > do (ssh, ssh_args) <- getSSH SSH remoteAddr > hunk ./src/Darcs/External.hs 364 > - pipeDoc ssh (ssh_args++ (remoteAddr:args)) input > + pipeDoc ssh (ssh_args++ (sshUhost remoteAddr:args)) input Ok. > > sendEmail :: String -> String -> String -> String -> String -> String -> IO > () > sendEmail f t s cc scmd body = > replace ./src/Darcs/External.hs [A-Za-z_0-9] isSsh isSshUrl > replace ./src/Darcs/External.hs [A-Za-z_0-9] isUrl isHttpUrl Consistent with previous replaces. > hunk ./src/Darcs/Lock.hs 144 > hClose h > return f > > --- |'withOpenTemp' creates an already open temporary > --- file. Both of them run their argument and then delete the file. Also, > +-- |'withOpenTemp' creates a temporary file, and opens it. > +-- Both of them run their argument and then delete the file. Also, Reads better. Is irrelevant to this patch though. > -- both of them (to my knowledge) are not susceptible to race conditions on > -- the temporary file (as long as you never delete the temporary file; that > -- would reintroduce a race condition). > hunk ./src/Darcs/RemoteApply.hs 10 > > import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ), remoteDarcs ) > import Darcs.Utils ( breakCommand ) > -import Darcs.URL ( isUrl, isSsh ) > +import Darcs.URL ( isUrl, isSsh, splitSshUrl, SshFilePath(..) ) As usual now. > import Darcs.External ( darcsProgram, pipeDoc, pipeDocSSH, maybeURLCmd ) > import qualified Ssh( remoteDarcs ) > import Printer ( Doc ) > hunk ./src/Darcs/RemoteApply.hs 19 > remoteApply opts repodir bundle > = case applyAs opts of > Nothing -> if isSsh repodir > - then applyViaSsh opts repodir bundle > + then applyViaSsh opts (splitSshUrl repodir) bundle Ok since applyViaSsh takes now a SshFilePath as 2nd argument (see below). > else if isUrl repodir > then applyViaUrl opts repodir bundle > else applyViaLocal opts repodir bundle > hunk ./src/Darcs/RemoteApply.hs 24 > Just un -> if isSsh repodir > - then applyViaSshAndSudo opts repodir un bundle > + then applyViaSshAndSudo opts (splitSshUrl repodir) un > bundle Ok again. > else applyViaSudo un repodir bundle > > applyAs :: [DarcsFlag] -> Maybe String > hunk ./src/Darcs/RemoteApply.hs 49 > do let (cmd, args) = breakCommand apply > pipeDoc cmd (args ++ [repo]) bundle > > -applyViaSsh :: [DarcsFlag] -> String -> Doc -> IO ExitCode > +applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode Ok. > applyViaSsh opts repo bundle = > - pipeDocSSH addr [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all > "++unwords (applyopts opts)++ > - " --repodir '"++path++"'"] bundle > - where (addr,':':path) = break (==':') repo > + pipeDocSSH repo [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all > "++unwords (applyopts opts)++ > + " --repodir '"++(sshRepo repo)++"'"] bundle Ok, reflects applyViaSsh's type change, ,and pipeDocSSH also. > > hunk ./src/Darcs/RemoteApply.hs 54 > -applyViaSshAndSudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode > +applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO > ExitCode Same ok. > applyViaSshAndSudo opts repo username bundle = > - pipeDocSSH addr ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs > opts)++ > - " apply --all --repodir '"++path++"'"] bundle > - where (addr,':':path) = break (==':') repo > + pipeDocSSH repo ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs > opts)++ > + " apply --all --repodir '"++(sshRepo repo)++"'"] bundle Same ok. > > applyopts :: [DarcsFlag] -> [String] > applyopts opts = if Debug `elem` opts then ["--debug"] else [] > replace ./src/Darcs/RemoteApply.hs [A-Za-z_0-9] isSsh isSshUrl > replace ./src/Darcs/RemoteApply.hs [A-Za-z_0-9] isUrl isHttpUrl Ok again. > replace ./src/Darcs/RepoPath.hs [A-Za-z_0-9] isSsh isSshUrl Ok. > replace ./src/Darcs/Repository/Cache.hs [A-Za-z_0-9] isSsh isSshUrl > replace ./src/Darcs/Repository/Cache.hs [A-Za-z_0-9] isUrl isHttpUrl Ok. > hunk ./src/Darcs/URL.hs 52 > > module Darcs.URL ( > isFile, isUrl, isSsh, isRelative, isAbsolute, > - isSshNopath > + isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl Reflaces the changes that follows. I would have written SshFilePath(..) but putting every record accessor is better for searching maybe. > ) where > > hunk ./src/Darcs/URL.hs 55 > +import Darcs.Global(darcsdir) > +import Data.List ( isPrefixOf, isInfixOf ) Ok. > import qualified System.FilePath as FP (isRelative, isAbsolute, isValid) > > #include "impossible.h" > hunk ./src/Darcs/URL.hs 74 > isFile f = FP.isValid f > > isUrl :: String -> Bool > -isUrl (':':'/':'/':_:_) = True > -isUrl (_:x) = isUrl x > -isUrl "" = False > +isUrl u = ("http://"; `isPrefixOf`u) || ("https://"; `isPrefixOf` u) > + Good but see my remark at start of mail. > > isSsh :: String -> Bool > hunk ./src/Darcs/URL.hs 78 > -isSsh s = not (isFile s || isUrl s) > +isSsh s > + | "ssh://" `isPrefixOf` s = True > + | "://" `isInfixOf` s = False > + | otherwise = not (isFile s) First case ok. Second case is to catch http:// or https:// Final case I am not sure why it isn't just False? Since it's similar to the pre-patch definition, I guess it's fine. > > isSshNopath :: String -> Bool > isSshNopath s = case reverse s of > hunk ./src/Darcs/URL.hs 88 > ':':x@(_:_:_) -> ':' `notElem` x > _ -> False > > +-- | Gives the (user, host, dir) out of an ssh url > +splitSshUrl :: String -> SshFilePath > +splitSshUrl s | "ssh://" `isPrefixOf` s = > + let s' = drop (length "ssh://") s > + (dir, file) = cleanrepodir '/' s' > + in > + SshFP { sshUhost = takeWhile (/= '/') s' > + , sshRepo = dir > + , sshFile = file } > +splitSshUrl s = > + let (dir, file) = cleanrepodir ':' s in > + SshFP { sshUhost = takeWhile (/= ':') s > + , sshRepo = dir > + , sshFile = file } The field sshUhost is the string "u...@host". sshRepo is the path to the repository. sshFile is when one refers to a file inside the repository directory. It is also possible to use Data.List.stripPrefix on the argument instead of having two guards. > + > + > +cleanrepourl :: String -> (String, String) > +cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz) > + where dd = darcsdir++"/" > +cleanrepourl (z:zs) = > + let (repo',file) = cleanrepourl zs in > + (z : repo', file) > +cleanrepourl "" = ([],[]) This is to keep track of the file inside of the _darcs directory we want to access. I don't know whether this is new. > + > +cleanrepodir :: Char -> String -> (String, String) > +cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep) Ok. (After reading below, these functions come from the Ssh module, so ok with the move also). > + > +data SshFilePath = SshFP { sshUhost :: String > + , sshRepo :: String > + , sshFile :: String} > + Ok. > +urlOf :: SshFilePath -> String > +urlOf (SshFP uhost dir file) = uhost ++ ":" ++ dir ++ "/" ++ darcsdir ++ "/" > ++ file Reconstitutes the url of the repos. So even if there is no sshFile field, there is always a _darcs suffix to this string? urlOf is used in the Ssh module. > replace ./src/Darcs/URL.hs [A-Za-z_0-9] isSsh isSshUrl > replace ./src/Darcs/URL.hs [A-Za-z_0-9] isUrl isHttpUrl Ok. > hunk ./src/Ssh.hs 3 > {-# LANGUAGE CPP, ForeignFunctionInterface #-} > > -module Ssh ( grabSSH, runSSH, getSSH, copySSH, copySSHs, SSHCmd(..), > - environmentHelpSsh, environmentHelpScp, environmentHelpSshPort, > - remoteDarcs > - ) where > +module Ssh ( > + copySSH, copySSHs, SSHCmd(..), runSSH, getSSH, > + environmentHelpSsh, environmentHelpScp, environmentHelpSshPort, > + remoteDarcs > + ) where grabSSH no longer exported since not used ouside of this module, so ok. > > import Prelude hiding ( lookup, catch ) > import qualified Ratified( hGetContents ) > hunk ./src/Ssh.hs 35 > import Darcs.Utils ( withCurrentDirectory, breakCommand, prettyException, > catchall ) > import Darcs.Global ( atexit, sshControlMasterDisabled, darcsdir, > withDebugMode ) > import Darcs.Lock ( withTemp, withOpenTemp, tempdirLoc, > removeFileMayNotExist ) > +import Darcs.URL (SshFilePath(..), urlOf) Ok. > import Exec ( exec, Redirects, Redirect(..), ) > import Progress ( withoutProgress, debugMessage, debugFail, progressList ) > import Darcs.Flags( RemoteDarcs(..) ) > hunk ./src/Ssh.hs 51 > > data Connection = C { inp :: !Handle, out :: !Handle, err :: !Handle, deb :: > String -> IO () } > > -withSSHConnection :: String -> String -> (Connection -> IO a) -> IO a -> IO a > +-- | @withSSHConnection rdarcs destination withconnection withoutconnection@ > +-- performs an action on a remote host. If we are already connected to > @destination@, > +-- then it does @withconnection@, else @withoutconnect...@. > +withSSHConnection :: String -> SshFilePath -> (Connection -> IO a) -> IO a > -> IO a Ok. > withSSHConnection rdarcs repoid withconnection withoutconnection = > withoutProgress $ > do cs <- readIORef sshConnections > hunk ./src/Ssh.hs 58 > - let uhost = takeWhile (/= ':') repoid > - url = cleanrepourl repoid > - case lookup url (cs :: Map String (Maybe Connection)) of > + case lookup (urlOf repoid) (cs :: Map String (Maybe Connection)) of Alright. I still have doubts with the fact that urlOf has _darcs/ at its end. > Just Nothing -> withoutconnection > Just (Just c) -> withconnection c > Nothing -> > do mc <- do (ssh,sshargs_) <- getSSHOnly SSH > - let sshargs = sshargs_ ++ [uhost,rdarcs, > - > "transfer-mode","--repodir",cleanrepodir repoid] > + let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs, > + > "transfer-mode","--repodir",sshRepo repoid] Ok, using sshUhost and sshRepo. > debugMessage $ "ssh "++unwords sshargs > (i,o,e,_) <- runInteractiveProcess ssh sshargs > Nothing Nothing > hSetBinaryMode i True > hunk ./src/Ssh.hs 74 > then return () > else debugFail "Couldn't start darcs > transfer-mode on server" > let c = C { inp = i, out = o, err = e, > - deb = \s -> debugMessage ("with ssh > (transfer-mode) "++uhost++": "++s) } > - modifyIORef sshConnections (insert url (Just c)) > + deb = \s -> debugMessage ("with ssh > (transfer-mode) "++sshUhost repoid++s) } > + modifyIORef sshConnections (insert (urlOf repoid) > (Just c)) OK so it's consistent with what I doubted above. > return $ Just c > `catchNonSignal` > \e -> do debugMessage $ "Failed to start ssh > connection:\n "++ > hunk ./src/Ssh.hs 89 > return Nothing > maybe withoutconnection withconnection mc > > -severSSHConnection :: String -> IO () > -severSSHConnection x = do debugMessage $ "Severing ssh failed connection to > "++x > - modifyIORef sshConnections (insert (cleanrepourl > x) Nothing) > +severSSHConnection :: SshFilePath -> IO () > +severSSHConnection x = do debugMessage $ "Severing ssh failed connection to > "++(sshUhost x) > + modifyIORef sshConnections (insert (urlOf x) > Nothing) Ok. > > hunk ./src/Ssh.hs 93 > -cleanrepourl :: String -> String > -cleanrepourl zzz | dd `isPrefixOf` zzz = "" > - where dd = darcsdir++"/" > -cleanrepourl (z:zs) = z : cleanrepourl zs > -cleanrepourl "" = "" > - > -cleanrepodir :: String -> String > -cleanrepodir = cleanrepourl . drop 1 . dropWhile (/= ':') Moved in Darcs.URL : ok. > - > -grabSSH :: String -> Connection -> IO B.ByteString > -grabSSH x c = do > - let dir = drop 1 $ dropWhile (/= ':') x > - dd = darcsdir++"/" > - clean zzz | dd `isPrefixOf` zzz = drop (length dd) zzz > - clean (_:zs) = clean zs > - clean "" = bug $ "Buggy path in grabSSH: "++x > - file = clean dir No longer needed thanks to SshFilePath datatype. > - failwith e = do severSSHConnection x > - -- hGetContents is ok here because we're > - -- only grabbing stderr, and we're also > - -- about to throw the contents. > - eee <- Ratified.hGetContents (err c) > - debugFail $ e ++ " grabbing ssh file > "++x++"\n"++eee > - deb c $ "get "++file > - hPutStrLn (inp c) $ "get " ++ file > - hFlush (inp c) > - l2 <- hGetLine (out c) > - if l2 == "got "++file > - then do showlen <- hGetLine (out c) > - case reads showlen of > - [(len,"")] -> B.hGet (out c) len > - _ -> failwith "Couldn't get length" > - else if l2 == "error "++file > - then do e <- hGetLine (out c) > - case reads e of > - (msg,_):_ -> debugFail $ "Error reading > file remotely:\n"++msg > - [] -> failwith "An error occurred" > - else failwith "Error" > +grabSSH :: SshFilePath -> Connection -> IO B.ByteString 1st argument is now SshFilePath. > +grabSSH dest c = do > + debugMessage $ "grabSSH dest=" ++ urlOf dest New debug message. Why not. > + let failwith e = do severSSHConnection dest > + -- hGetContents is ok here because we're > + -- only grabbing stderr, and we're also > + -- about to throw the contents. > + eee <- Ratified.hGetContents (err c) > + debugFail $ e ++ " grabbing ssh file "++ > + urlOf dest++"/"++ file ++"\n"++eee > + file = sshFile dest Ok. (Use of urlOf makes sense here since we want to have the full path.) What follows is exactly as before (except indentation). > + deb c $ "get "++ file > + hPutStrLn (inp c) $ "get " ++ file > + hFlush (inp c) > + l2 <- hGetLine (out c) > + if l2 == "got "++file > + then do showlen <- hGetLine (out c) > + case reads showlen of > + [(len,"")] -> B.hGet (out c) len > + _ -> failwith "Couldn't get length" > + else if l2 == "error "++file > + then do e <- hGetLine (out c) > + case reads e of > + (msg,_):_ -> debugFail $ "Error reading file > remotely:\n"++msg > + [] -> failwith "An error occurred" > + else failwith "Error" > > sshStdErrMode :: IO Redirect > sshStdErrMode = withDebugMode $ \amdebugging -> > hunk ./src/Ssh.hs 128 > remoteDarcs DefaultRemoteDarcs = "darcs" > remoteDarcs (RemoteDarcs x) = x > > -copySSH :: RemoteDarcs -> String -> FilePath -> IO () > -copySSH remote uRaw f | rdarcs <- remoteDarcs remote = > - withSSHConnection rdarcs uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $ > - do let u = escape_dollar uRaw > +copySSH :: RemoteDarcs -> SshFilePath -> FilePath -> IO () Use SshFilePath as 2nd argument. > +copySSH remote dest to | rdarcs <- remoteDarcs remote = do > + debugMessage $ "copySSH file: " ++ urlOf dest > + withSSHConnection rdarcs dest (\c -> grabSSH dest c >>= B.writeFile to) $ > + do let u = escape_dollar $ urlOf dest One extra debug message, different indentation and argument renaming, ok. > stderr_behavior <- sshStdErrMode > - r <- runSSH SCP u [] [u,f] (AsIs,AsIs,stderr_behavior) > + r <- runSSH SCP dest [u,to] (AsIs,AsIs,stderr_behavior) Variable renaming. > when (r /= ExitSuccess) $ > debugFail $ "(scp) failed to fetch: " ++ u > where {- '$' in filenames is troublesome for scp, for some reason.. -} > hunk ./src/Ssh.hs 143 > where tr '$' = "\\$" > tr c = [c] > > -copySSHs :: RemoteDarcs -> String -> [String] -> FilePath -> IO () > -copySSHs remote u ns d | rdarcs <- remoteDarcs remote = > - withSSHConnection rdarcs u (\c -> withCurrentDirectory d $ > - mapM_ (\n -> grabSSH (u++"/"++n) c >>= > B.writeFile n) $ > - progressList "Copying via ssh" ns) $ > - 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) -> > +copySSHs :: RemoteDarcs -> SshFilePath -> [FilePath] -> FilePath -> IO () Use SshFilePath as previoulsy, ok. > +copySSHs remote repo ns d | rdarcs <- remoteDarcs remote = > + withSSHConnection rdarcs repo > + (\c -> withCurrentDirectory d $ > + mapM_ (\n -> grabSSH (repo {sshFile = n}) c >>= B.writeFile n) $ > + progressList "Copying via ssh" ns) $ > + do Indentation and variable renaming. No longer need variable host (see below). > + let path = sshRepo repo Ok. > + cd = "cd "++path++"/"++darcsdir++"\n" > + input = cd++(unlines $ map ("get "++) ns) > + withCurrentDirectory d $ withOpenTemp $ \(th,tn) -> > withTemp $ \sftpoutput -> > do hPutStr th input > hClose th > hunk ./src/Ssh.hs 158 > stderr_behavior <- sshStdErrMode > - r <- runSSH SFTP u [] [host] (File tn, File sftpoutput, > stderr_behavior) > + r <- runSSH SFTP repo [] (File tn, File sftpoutput, > stderr_behavior) No need host since variable "repo" contains it. > let files = if length ns > 5 > then (take 5 ns) ++ ["and " > ++ (show (length ns - 5)) ++ " more"] > hunk ./src/Ssh.hs 186 > show SCP = "scp" > show SFTP = "sftp" > > -runSSH :: SSHCmd -> String -> [String] -> [String] -> Redirects -> IO > ExitCode > -runSSH cmd remoteAddr preArgs postArgs redirs = > +runSSH :: SSHCmd -> SshFilePath -> [String] -> Redirects -> IO ExitCode > +runSSH cmd remoteAddr postArgs redirs = > do (ssh, args) <- getSSH cmd remoteAddr > - exec ssh (preArgs ++ args ++ postArgs) redirs > + exec ssh (args ++ [sshUhost remoteAddr] ++ postArgs) redirs Use 2nd argument of type SshFilePath, rename args, remove argument preArgs::[String] ; grepping the code shows runSSH is always called with this argument empty. I ignore the implications of this change but when needed the argument could be reintroduced. > > -- | Return the command and arguments needed to run an ssh command > -- along with any extra features like use of the control master. > hunk ./src/Ssh.hs 194 > -- See 'getSSHOnly' > -getSSH :: SSHCmd -> String -- ^ remote path > +getSSH :: SSHCmd -> SshFilePath -- ^ remote path Ok. > -> IO (String, [String]) > getSSH cmd remoteAddr = > do (ssh, ssh_args) <- getSSHOnly cmd > hunk ./src/Ssh.hs 281 > -- | 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 = do > +launchSSHControlMaster :: SshFilePath -> IO () > +launchSSHControlMaster dest = do Ok. > hasMaster <- hasSSHControlMaster > when hasMaster $ do > hunk ./src/Ssh.hs 285 > - let addr = takeWhile (/= ':') rawAddr Ok. > (ssh, ssh_args) <- getSSHOnly SSH > hunk ./src/Ssh.hs 286 > - cmPath <- controlMasterPath addr > + cmPath <- controlMasterPath dest Ok. > removeFileMayNotExist cmPath > -- -f : put ssh in the background once it succeeds in logging you in > -- -M : launch as the control master for addr > hunk ./src/Ssh.hs 292 > -- -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 > + exec ssh (ssh_args ++ [sshUhost dest, "-S", cmPath, "-N", "-f", "-M"]) > (Null,Null,AsIs) > + atexit $ exitSSHControlMaster dest Ok. > return () > > -- | Tell the SSH control master for a given path to exit. > hunk ./src/Ssh.hs 297 > -exitSSHControlMaster :: String -> IO () > +exitSSHControlMaster :: SshFilePath -> IO () Ok. > exitSSHControlMaster addr = do > (ssh, ssh_args) <- getSSHOnly SSH > cmPath <- controlMasterPath addr > hunk ./src/Ssh.hs 301 > - exec ssh (ssh_args ++ [addr, "-S", cmPath, "-O", "exit"]) (Null,Null,Null) > + exec ssh (ssh_args ++ [sshUhost addr, "-S", cmPath, "-O", "exit"]) > (Null,Null,Null) Ok. > return () > > -- | Create the directory ssh control master path for a given address > hunk ./src/Ssh.hs 305 > -controlMasterPath :: String -- ^ remote path (f...@bar.com:file is ok; the > file part with be stripped) > +controlMasterPath :: SshFilePath -- ^ remote path (f...@bar.com:file is ok; > the file part with be stripped) Ok. > -> IO FilePath > hunk ./src/Ssh.hs 307 > -controlMasterPath rawAddr = do > - let addr = takeWhile (/= ':') rawAddr > +controlMasterPath dest = do > + let addr = sshUhost dest Ok. > tmp <- (fmap (/// ".darcs") $ getEnv "HOME") `catchall` tempdirLoc > #ifdef WIN32 > r <- randomIO __________________________________ Darcs bug tracker <b...@darcs.net> <http://bugs.darcs.net/patch444> __________________________________ _______________________________________________ darcs-users mailing list darcs-users@darcs.net http://lists.osuosl.org/mailman/listinfo/darcs-users
