module Darcs.Util.Ssh
(
SshSettings(..)
, defaultSsh
, windows
, copySSH
, SSHCmd(..)
, getSSH
, environmentHelpSsh
, environmentHelpScp
, environmentHelpSshPort
, transferModeHeader
) where
import Darcs.Prelude
import System.Environment ( getEnv )
import System.Exit ( ExitCode(..) )
import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, modifyMVar_ )
import Control.Exception ( throwIO, catch, catchJust, SomeException )
import Control.Monad ( unless, (>=>) )
import qualified Data.ByteString as B (ByteString, hGet, writeFile )
import Data.Map ( Map, empty, insert, lookup )
import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )
import System.IO.Unsafe ( unsafePerformIO )
import System.Process ( runInteractiveProcess, readProcessWithExitCode )
import Darcs.Util.SignalHandler ( catchNonSignal )
import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile )
import Darcs.Util.Exception ( prettyException, catchall )
import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) )
import Darcs.Util.Progress ( withoutProgress, debugMessage )
import qualified Darcs.Util.Ratified as Ratified ( hGetContents )
import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isPrefixOf )
import System.Info ( os )
import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )
import Darcs.Util.Global ( whenDebugMode )
windows :: Bool
windows :: Bool
windows = String
"mingw" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
os
data SshSettings = SshSettings
{ SshSettings -> String
ssh :: String
, SshSettings -> String
scp :: String
, SshSettings -> String
sftp :: String
} deriving (Int -> SshSettings -> ShowS
[SshSettings] -> ShowS
SshSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SshSettings] -> ShowS
$cshowList :: [SshSettings] -> ShowS
show :: SshSettings -> String
$cshow :: SshSettings -> String
showsPrec :: Int -> SshSettings -> ShowS
$cshowsPrec :: Int -> SshSettings -> ShowS
Show, SshSettings -> SshSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SshSettings -> SshSettings -> Bool
$c/= :: SshSettings -> SshSettings -> Bool
== :: SshSettings -> SshSettings -> Bool
$c== :: SshSettings -> SshSettings -> Bool
Eq)
_defaultSsh :: IORef SshSettings
_defaultSsh :: IORef SshSettings
_defaultSsh = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SshSettings
detectSsh
{-# NOINLINE _defaultSsh #-}
detectSsh :: IO SshSettings
detectSsh :: IO SshSettings
detectSsh = do
IO () -> IO ()
whenDebugMode (String -> IO ()
putStrLn String
"Detecting SSH settings")
SshSettings
vanilla <- if Bool
windows
then do
String
plinkStr <- (forall {a} {b} {c}. (a, b, c) -> b
snd3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"plink" [] String
"")
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Show a => a -> String
show SomeException
e)
IO () -> IO ()
whenDebugMode forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
String
"SSH settings (plink): " forall a. [a] -> [a] -> [a]
++
(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
plinkStr)
if String
"PuTTY" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
plinkStr
then forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> String -> SshSettings
SshSettings String
"plink" String
"pscp -q" String
"psftp")
else forall (m :: * -> *) a. Monad m => a -> m a
return SshSettings
rawVanilla
else forall (m :: * -> *) a. Monad m => a -> m a
return SshSettings
rawVanilla
SshSettings
settings <- String -> String -> String -> SshSettings
SshSettings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO String
fromEnv (SshSettings -> String
ssh SshSettings
vanilla) String
"DARCS_SSH"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> IO String
fromEnv (SshSettings -> String
scp SshSettings
vanilla) String
"DARCS_SCP"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> IO String
fromEnv (SshSettings -> String
sftp SshSettings
vanilla) String
"DARCS_SFTP"
IO () -> IO ()
whenDebugMode (String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"SSH settings: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SshSettings
settings)
forall (m :: * -> *) a. Monad m => a -> m a
return SshSettings
settings
where
snd3 :: (a, b, c) -> b
snd3 (a
_, b
x, c
_) = b
x
rawVanilla :: SshSettings
rawVanilla = String -> String -> String -> SshSettings
SshSettings String
"ssh" String
"scp -q" String
"sftp"
fromEnv :: String -> String -> IO String
fromEnv :: String -> String -> IO String
fromEnv String
d String
v = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust IOError -> Maybe ()
notFound
(String -> IO String
getEnv String
v)
(forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return String
d))
notFound :: IOError -> Maybe ()
notFound IOError
e = if IOErrorType -> Bool
isDoesNotExistErrorType (IOError -> IOErrorType
ioeGetErrorType IOError
e)
then forall a. a -> Maybe a
Just ()
else forall a. Maybe a
Nothing
defaultSsh :: SshSettings
defaultSsh :: SshSettings
defaultSsh = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef SshSettings
_defaultSsh
{-# NOINLINE defaultSsh #-}
data Connection = C
{ Connection -> Handle
inp :: !Handle
, Connection -> Handle
out :: !Handle
, Connection -> Handle
err :: !Handle
}
type RepoId = (String, String)
sshConnections :: MVar (Map RepoId (Maybe (MVar Connection)))
sshConnections :: MVar (Map RepoId (Maybe (MVar Connection)))
sshConnections = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
empty
{-# NOINLINE sshConnections #-}
getSshConnection :: String
-> SshFilePath
-> IO (Maybe (MVar Connection))
getSshConnection :: String -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection String
rdarcs SshFilePath
sshfp = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map RepoId (Maybe (MVar Connection)))
sshConnections forall a b. (a -> b) -> a -> b
$ \Map RepoId (Maybe (MVar Connection))
cmap -> do
let key :: RepoId
key = SshFilePath -> RepoId
repoid SshFilePath
sshfp
case forall k a. Ord k => k -> Map k a -> Maybe a
lookup RepoId
key Map RepoId (Maybe (MVar Connection))
cmap of
Maybe (Maybe (MVar Connection))
Nothing -> do
Maybe Connection
mc <- String -> SshFilePath -> IO (Maybe Connection)
newSshConnection String
rdarcs SshFilePath
sshfp
case Maybe Connection
mc of
Maybe Connection
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
insert RepoId
key forall a. Maybe a
Nothing Map RepoId (Maybe (MVar Connection))
cmap, forall a. Maybe a
Nothing)
Just Connection
c -> do
MVar Connection
v <- forall a. a -> IO (MVar a)
newMVar Connection
c
forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
insert RepoId
key (forall a. a -> Maybe a
Just MVar Connection
v) Map RepoId (Maybe (MVar Connection))
cmap, forall a. a -> Maybe a
Just MVar Connection
v)
Just Maybe (MVar Connection)
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Map RepoId (Maybe (MVar Connection))
cmap, forall a. Maybe a
Nothing)
Just (Just MVar Connection
v) ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Map RepoId (Maybe (MVar Connection))
cmap, forall a. a -> Maybe a
Just MVar Connection
v)
newSshConnection :: String -> SshFilePath -> IO (Maybe Connection)
newSshConnection :: String -> SshFilePath -> IO (Maybe Connection)
newSshConnection String
rdarcs SshFilePath
sshfp = do
(String
sshcmd,[String]
sshargs_) <- SSHCmd -> IO (String, [String])
getSSH SSHCmd
SSH
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Starting new ssh connection to " forall a. [a] -> [a] -> [a]
++ SshFilePath -> String
sshUhost SshFilePath
sshfp
let sshargs :: [String]
sshargs = [String]
sshargs_ forall a. [a] -> [a] -> [a]
++ [String
"--", SshFilePath -> String
sshUhost SshFilePath
sshfp, String
rdarcs,
String
"transfer-mode", String
"--repodir", SshFilePath -> String
sshRepo SshFilePath
sshfp]
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Exec: " forall a. [a] -> [a] -> [a]
++ [String] -> String
showCommandLine (String
sshcmdforall a. a -> [a] -> [a]
:[String]
sshargs)
(Handle
i,Handle
o,Handle
e,ProcessHandle
_) <- String
-> [String]
-> Maybe String
-> Maybe [RepoId]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
sshcmd [String]
sshargs forall a. Maybe a
Nothing forall a. Maybe a
Nothing
do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
i Bool
True
Handle -> Bool -> IO ()
hSetBinaryMode Handle
o Bool
True
String
l <- Handle -> IO String
hGetLine Handle
o
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
l forall a. Eq a => a -> a -> Bool
== String
transferModeHeader) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't start darcs transfer-mode on server"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just C { inp :: Handle
inp = Handle
i, out :: Handle
out = Handle
o, err :: Handle
err = Handle
e }
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` \SomeException
exn -> do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Failed to start ssh connection: " forall a. [a] -> [a] -> [a]
++ SomeException -> String
prettyException SomeException
exn
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"NOTE: the server may be running a version of darcs prior to 2.0.0."
, String
""
, String
"Installing darcs 2 on the server will speed up ssh-based commands."
]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
dropSshConnection :: RepoId -> IO ()
dropSshConnection :: RepoId -> IO ()
dropSshConnection RepoId
key = do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Dropping ssh failed connection to " forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> a
fst RepoId
key forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> b
snd RepoId
key
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map RepoId (Maybe (MVar Connection)))
sshConnections (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
insert RepoId
key forall a. Maybe a
Nothing)
repoid :: SshFilePath -> RepoId
repoid :: SshFilePath -> RepoId
repoid SshFilePath
sshfp = (SshFilePath -> String
sshUhost SshFilePath
sshfp, SshFilePath -> String
sshRepo SshFilePath
sshfp)
grabSSH :: SshFilePath -> Connection -> IO B.ByteString
grabSSH :: SshFilePath -> Connection -> IO ByteString
grabSSH SshFilePath
src Connection
c = do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"grabSSH src=" forall a. [a] -> [a] -> [a]
++ SshFilePath -> String
sshFilePathOf SshFilePath
src
let failwith :: String -> IO b
failwith String
e = do RepoId -> IO ()
dropSshConnection (SshFilePath -> RepoId
repoid SshFilePath
src)
String
eee <- Handle -> IO String
Ratified.hGetContents (Connection -> Handle
err Connection
c)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
e forall a. [a] -> [a] -> [a]
++ String
" grabbing ssh file " forall a. [a] -> [a] -> [a]
++
SshFilePath -> String
sshFilePathOf SshFilePath
src forall a. [a] -> [a] -> [a]
++String
"\n" forall a. [a] -> [a] -> [a]
++ String
eee
file :: String
file = SshFilePath -> String
sshFile SshFilePath
src
Handle -> String -> IO ()
hPutStrLn (Connection -> Handle
inp Connection
c) forall a b. (a -> b) -> a -> b
$ String
"get " forall a. [a] -> [a] -> [a]
++ String
file
Handle -> IO ()
hFlush (Connection -> Handle
inp Connection
c)
String
l2 <- Handle -> IO String
hGetLine (Connection -> Handle
out Connection
c)
if String
l2 forall a. Eq a => a -> a -> Bool
== String
"got "forall a. [a] -> [a] -> [a]
++String
file
then do String
showlen <- Handle -> IO String
hGetLine (Connection -> Handle
out Connection
c)
case forall a. Read a => ReadS a
reads String
showlen of
[(Int
len,String
"")] -> Handle -> Int -> IO ByteString
B.hGet (Connection -> Handle
out Connection
c) Int
len
[(Int, String)]
_ -> forall {b}. String -> IO b
failwith String
"Couldn't get length"
else if String
l2 forall a. Eq a => a -> a -> Bool
== String
"error "forall a. [a] -> [a] -> [a]
++String
file
then do String
e <- Handle -> IO String
hGetLine (Connection -> Handle
out Connection
c)
case forall a. Read a => ReadS a
reads String
e of
(String
msg,String
_):[RepoId]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Error reading file remotely:\n"forall a. [a] -> [a] -> [a]
++String
msg
[] -> forall {b}. String -> IO b
failwith String
"An error occurred"
else forall {b}. String -> IO b
failwith String
"Error"
copySSH :: String -> SshFilePath -> FilePath -> IO ()
copySSH :: String -> SshFilePath -> String -> IO ()
copySSH String
rdarcs SshFilePath
src String
dest = do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"copySSH file: " forall a. [a] -> [a] -> [a]
++ SshFilePath -> String
sshFilePathOf SshFilePath
src
forall a. IO a -> IO a
withoutProgress forall a b. (a -> b) -> a -> b
$ do
Maybe (MVar Connection)
mc <- String -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection String
rdarcs SshFilePath
src
case Maybe (MVar Connection)
mc of
Just MVar Connection
v -> forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Connection
v (SshFilePath -> Connection -> IO ByteString
grabSSH SshFilePath
src forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> ByteString -> IO ()
B.writeFile String
dest)
Maybe (MVar Connection)
Nothing -> do
let u :: String
u = ShowS
escape_dollar forall a b. (a -> b) -> a -> b
$ SshFilePath -> String
sshFilePathOf SshFilePath
src
(String
scpcmd, [String]
args) <- SSHCmd -> IO (String, [String])
getSSH SSHCmd
SCP
let scp_args :: [String]
scp_args = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=String
"-q") [String]
args forall a. [a] -> [a] -> [a]
++ [String
"--", String
u, String
dest]
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Exec: " forall a. [a] -> [a] -> [a]
++ [String] -> String
showCommandLine (String
scpcmdforall a. a -> [a] -> [a]
:[String]
scp_args)
(ExitCode
r, String
scp_err) <- String -> [String] -> IO (ExitCode, String)
readInteractiveProcess String
scpcmd [String]
scp_args
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
r forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> [String] -> Redirects -> String -> ExecException
ExecException String
scpcmd [String]
scp_args (Redirect
AsIs,Redirect
AsIs,Redirect
AsIs) String
scp_err
where
escape_dollar :: String -> String
escape_dollar :: ShowS
escape_dollar = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
tr
where
tr :: Char -> String
tr Char
'$' = String
"\\$"
tr Char
c = [Char
c]
showCommandLine :: [String] -> String
showCommandLine :: [String] -> String
showCommandLine = [String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show
transferModeHeader :: String
= String
"Hello user, I am darcs transfer mode"
data SSHCmd = SSH
| SCP
| SFTP
fromSshCmd :: SshSettings
-> SSHCmd
-> String
fromSshCmd :: SshSettings -> SSHCmd -> String
fromSshCmd SshSettings
s SSHCmd
SSH = SshSettings -> String
ssh SshSettings
s
fromSshCmd SshSettings
s SSHCmd
SCP = SshSettings -> String
scp SshSettings
s
fromSshCmd SshSettings
s SSHCmd
SFTP = SshSettings -> String
sftp SshSettings
s
getSSH :: SSHCmd
-> IO (String, [String])
getSSH :: SSHCmd -> IO (String, [String])
getSSH SSHCmd
cmd = do
[String]
port <- (SSHCmd -> String -> [String]
portFlag SSHCmd
cmd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
getEnv String
"SSH_PORT") forall a. IO a -> IO a -> IO a
`catchall` forall (m :: * -> *) a. Monad m => a -> m a
return []
let (String
sshcmd, [String]
ssh_args) = String -> (String, [String])
breakCommand String
command
forall (m :: * -> *) a. Monad m => a -> m a
return (String
sshcmd, [String]
ssh_args forall a. [a] -> [a] -> [a]
++ [String]
port)
where
command :: String
command = SshSettings -> SSHCmd -> String
fromSshCmd SshSettings
defaultSsh SSHCmd
cmd
portFlag :: SSHCmd -> String -> [String]
portFlag SSHCmd
SSH String
x = [String
"-p", String
x]
portFlag SSHCmd
SCP String
x = [String
"-P", String
x]
portFlag SSHCmd
SFTP String
x = [String
"-oPort=" forall a. [a] -> [a] -> [a]
++ String
x]
breakCommand :: String -> (String, [String])
breakCommand String
s =
case String -> [String]
words String
s of
(String
arg0:[String]
args) -> (String
arg0, [String]
args)
[] -> (String
s, [])
environmentHelpSsh :: ([String], [String])
environmentHelpSsh :: ([String], [String])
environmentHelpSsh = ([String
"DARCS_SSH"], [
String
"Repositories of the form [user@]host:[dir] are taken to be remote",
String
"repositories, which Darcs accesses with the external program ssh(1).",
String
"",
String
"The environment variable $DARCS_SSH can be used to specify an",
String
"alternative SSH client. Arguments may be included, separated by",
String
"whitespace. The value is not interpreted by a shell, so shell",
String
"constructs cannot be used; in particular, it is not possible for the",
String
"program name to contain whitespace by using quoting or escaping."])
environmentHelpScp :: ([String], [String])
environmentHelpScp :: ([String], [String])
environmentHelpScp = ([String
"DARCS_SCP", String
"DARCS_SFTP"], [
String
"When reading from a remote repository, Darcs will attempt to run",
String
"`darcs transfer-mode` on the remote host. This will fail if the",
String
"remote host only has Darcs 1 installed, doesn't have Darcs installed",
String
"at all, or only allows SFTP.",
String
"",
String
"If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",
String
"The commands invoked can be customized with the environment variables",
String
"$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",
String
"If the remote end allows only sftp, try setting DARCS_SCP=sftp."])
environmentHelpSshPort :: ([String], [String])
environmentHelpSshPort :: ([String], [String])
environmentHelpSshPort = ([String
"SSH_PORT"], [
String
"If this environment variable is set, it will be used as the port",
String
"number for all SSH calls made by Darcs (when accessing remote",
String
"repositories over SSH). This is useful if your SSH server does not",
String
"run on the default port, and your SSH client does not support",
String
"ssh_config(5). OpenSSH users will probably prefer to put something",
String
"like `Host *.example.net Port 443` into their ~/.ssh/config file."])