This allows handling "ssh://" urls. There is also some cleaning of Ssh.hs and
Darcs/URL.hs, with the idea of using less urls and more abstract type, but i've only looked at ssh urls for the moment.

2 patches for repository http://darcs.net/screened:

Mon Nov  1 17:12:05 CET 2010  Florent Becker <florent.becker@ens-lyon.org>
  * remove useless unsafePerformIO

Mon Nov  1 17:14:45 CET 2010  Florent Becker <florent.becker@ens-lyon.org>
  * resolve issue1970: allow ssh:// urls

Attachments

• remove-useless-unsafeperformio.dpatch
• unnamed

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.becker@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.becker@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 "user@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 @withoutconnection@.
> +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 (foo\@bar.com:file is ok; the file part with be stripped)
> +controlMasterPath :: SshFilePath -- ^ remote path (foo\@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

I forgot about the tests. Herre is what the screened branch passes
before these patches:

         Properties   Shell         Test Cases   Total        
 Passed  59           762           36           857          
 Failed  0            6             0            6            
 Total   59           768           36           863  

And after:

         Properties   Shell         Test Cases   Total        
 Passed  59           765           36           860          
 Failed  0            6             0            6            
 Total   59           771           36           866  


However, scrolling up in my terminals' histories doesn't show
differences (same tests fail), so I don't understand these numbers.

-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

Le 02/11/2010 09:32, gh a écrit :
> 
> 
> gh <guillaumh@gmail.com> added the comment:
> 
> I forgot about the tests. Herre is what the screened branch passes
> before these patches:
> 
>          Properties   Shell         Test Cases   Total        
>  Passed  59           762           36           857          
>  Failed  0            6             0            6            
>  Total   59           768           36           863  
> 
> And after:
> 
>          Properties   Shell         Test Cases   Total        
>  Passed  59           765           36           860          
>  Failed  0            6             0            6            
>  Total   59           771           36           866  
> 
> 
> However, scrolling up in my terminals' histories doesn't show
> differences (same tests fail), so I don't understand these numbers.
> 
The 6 failing tests you see should be resolved soon, they are due to
timezone problems. I don't know why there appears to be 3 more passing
shell tests, i didn't add any, and they don't show up when I test locally.

For the '   http://' urls, i'm sending a followup

Florent
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.10 (GNU/Linux)
Comment: Using GnuPG with Mozilla - http://enigmail.mozdev.org/

iEYEARECAAYFAkzP4f0ACgkQTCPcDztjGo7odwCfaniNleBgkMej+n3FVP0F6BA/
s/oAoJ0vUNp+vDUveOEQ395ZwpS0gcE1
=oyc7
-----END PGP SIGNATURE-----

Here comes the follow-up for initial spaces.

3 patches for repository http://darcs.net/screened:


Mon Nov  1 17:12:05 CET 2010  Florent Becker <florent.becker@ens-lyon.org>
  * remove useless unsafePerformIO

Mon Nov  1 17:14:45 CET 2010  Florent Becker <florent.becker@ens-lyon.org>
  * resolve issue1970: allow ssh:// urls

Tue Nov  2 11:31:47 CET 2010  Florent Becker <florent.becker@ens-lyon.org>
  * Cope with initial spaces in URLs

Attachments

• remove-useless-unsafeperformio.dpatch
• unnamed

Good to go, see below.

> [Cope with initial spaces in URLs
> Florent Becker <florent.becker@ens-lyon.org>**20101102103147
>  Ignore-this: f0d58cb6310ffa08cfd072190f2eaea5
> ] hunk ./src/Darcs/URL.hs 26
>  
>    Path resolving:
>  
> -    * A URL contains the sequence @\":\/\/\"@.
> +    * An http URL contains the sequence @\"http(s):\/\/\"@.

Ok.

>  
>      * A local filepath does not contain colons, except
>        as second character (windows drives) when this
> hunk ./src/Darcs/URL.hs 32
>        filepath is meant to be used as repository name
>  
> -    * A path that is neither a URL nor a local file
> +    * A path that is neither an http URL nor a local file

Ok.

>        is an ssh-path.
>  
>    Examples:


> hunk ./src/Darcs/URL.hs 57
>  
>  import Darcs.Global(darcsdir)
>  import Data.List ( isPrefixOf, isInfixOf )
> +import Data.Char ( isSpace )

Ok.

>  import qualified System.FilePath as FP (isRelative, isAbsolute, isValid)
>  
>  #include "impossible.h"
> hunk ./src/Darcs/URL.hs 75
>  isFile f = FP.isValid f
>  
>  isHttpUrl :: String -> Bool
> -isHttpUrl u = ("http://" `isPrefixOf`u) || ("https://" `isPrefixOf` u)
> +isHttpUrl u =
> +    let u' = dropWhile isSpace u in
> +            ("http://" `isPrefixOf` u') || ("https://" `isPrefixOf` u')

Ok.

>  
>  
>  isSshUrl :: String -> Bool


> hunk ./src/Darcs/URL.hs 81
> -isSshUrl s
> -  | "ssh://" `isPrefixOf` s = True
> -  | "://" `isInfixOf` s = False
> -  | otherwise = not (isFile s)
> +isSshUrl s = isu' (dropWhile isSpace s)
> +    where
> +      isu' s'
> +          | "ssh://" `isPrefixOf` s' = True
> +          | "://" `isInfixOf` s' = False
> +          | otherwise = ":" `isInfixOf` s'

Same ok.


>  
>  isSshNopath :: String -> Bool
>  isSshNopath s = case reverse s of
> hunk ./src/Darcs/URL.hs 96
>  -- | Gives the (user, host, dir) out of an ssh url
>  splitSshUrl :: String -> SshFilePath
>  splitSshUrl s | "ssh://" `isPrefixOf` s =
> -  let s' = drop (length "ssh://") s
> +  let s' = drop (length "ssh://") $ dropWhile isSpace s

Ok.

>        (dir, file) = cleanrepodir '/' s'
>    in
>    SshFP { sshUhost = takeWhile (/= '/') s'
> hunk ./src/Darcs/URL.hs 104
>          , sshFile = file }
>  splitSshUrl s =
>    let (dir, file) = cleanrepodir ':' s in
> -  SshFP { sshUhost = takeWhile (/= ':') s
> +  SshFP { sshUhost = dropWhile isSpace $ takeWhile (/= ':') s

Ok.

>          , sshRepo = dir
>          , sshFile = file }
>

I think the patch is ok to go, but maybe a committed should have a
second look before pushing.

This patch bundle (with 3 patches) was just applied to the repository http://darcs.net/.
This message was brought to you by DarcsWatch
http://darcswatch.nomeata.de/repo_http:__darcs.net_.html#bundle-a9391b09c5bc1be0e7431d2dc36f8ceb8428ddd0

This patch bundle (with 2 patches) was just applied to the repository http://darcs.net/.
This message was brought to you by DarcsWatch
http://darcswatch.nomeata.de/repo_http:__darcs.net_.html#bundle-d135afc03e6117dfef767940503c9ada90db38e3

This patch bundle (with 2 patches) was just applied to the repository http://darcs.net/reviewed.
This message was brought to you by DarcsWatch
http://darcswatch.nomeata.de/repo_http:__darcs.net_reviewed.html#bundle-d135afc03e6117dfef767940503c9ada90db38e3

This patch bundle (with 3 patches) was just applied to the repository http://darcs.net/reviewed.
This message was brought to you by DarcsWatch
http://darcswatch.nomeata.de/repo_http:__darcs.net_reviewed.html#bundle-a9391b09c5bc1be0e7431d2dc36f8ceb8428ddd0