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