--
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

module Darcs.Util.Ssh
    (
      SshSettings(..)
    , defaultSsh
    , windows
    , copySSH
    , SSHCmd(..)
    , getSSH
    , environmentHelpSsh
    , environmentHelpScp
    , environmentHelpSshPort
    , transferModeHeader
    , resetSshConnections
    ) 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 ( forM_, unless, void, (>=>) )

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
    ( ProcessHandle
    , readProcessWithExitCode
    , runInteractiveProcess
    , terminateProcess
    , waitForProcess
    )

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" String -> String -> Bool
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
(Int -> SshSettings -> ShowS)
-> (SshSettings -> String)
-> ([SshSettings] -> ShowS)
-> Show SshSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SshSettings -> ShowS
showsPrec :: Int -> SshSettings -> ShowS
$cshow :: SshSettings -> String
show :: SshSettings -> String
$cshowList :: [SshSettings] -> ShowS
showList :: [SshSettings] -> ShowS
Show, SshSettings -> SshSettings -> Bool
(SshSettings -> SshSettings -> Bool)
-> (SshSettings -> SshSettings -> Bool) -> Eq SshSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SshSettings -> SshSettings -> Bool
== :: SshSettings -> SshSettings -> Bool
$c/= :: SshSettings -> SshSettings -> Bool
/= :: 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 #-}

-- | Expected properties:
--
-- * only ever runs once in the lifetime of the program
-- * environment variables override all
-- * tries Putty first on Windows
-- * falls back to plain old ssh
detectSsh :: IO SshSettings
detectSsh :: IO SshSettings
detectSsh = do
    IO () -> IO ()
whenDebugMode (String -> IO ()
putStrLn String
"Detecting SSH settings")
    vanilla <-  if Bool
windows
                  then do
                    plinkStr <- ((ExitCode, String, String) -> String
forall {a} {b} {c}. (a, b, c) -> b
snd3 ((ExitCode, String, String) -> String)
-> IO (ExitCode, String, String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"plink" [] String
"")
                                  IO String -> (SomeException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                    whenDebugMode $ putStrLn $
                        "SSH settings (plink): " ++
                        (concat . take 1 . lines $ plinkStr)
                    if "PuTTY" `isPrefixOf` plinkStr
                      then return (SshSettings "plink" "pscp -q" "psftp")
                      else return rawVanilla
                  else SshSettings -> IO SshSettings
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SshSettings
rawVanilla
    settings <- SshSettings <$> fromEnv (ssh vanilla)  "DARCS_SSH"
                            <*> fromEnv (scp vanilla)  "DARCS_SCP"
                            <*> fromEnv (sftp vanilla) "DARCS_SFTP"
    whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)
    return 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 = (IOError -> Maybe ())
-> IO String -> (() -> IO String) -> IO String
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)
                            (IO String -> () -> IO String
forall a b. a -> b -> a
const (String -> IO String
forall a. a -> IO a
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 () -> 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 #-}

-- | A re-usable connection to a remote darcs in transfer-mode.
-- It contains the three standard handles.
data Connection = C
    { Connection -> Handle
inp :: !Handle
    , Connection -> Handle
out :: !Handle
    , Connection -> Handle
err :: !Handle
    , Connection -> ProcessHandle
proc :: !ProcessHandle
    }

-- | Identifier (key) for a connection.
type RepoId = (String, String) -- (user@host,repodir)

-- | Global mutable variable that contains open connections,
-- identified by the repoid part of the ssh file name.
-- Only one thread can use a connection at a time, which is why
-- we stuff them behind their own 'MVar's.
--
-- We distinguish between a failed connection (represented by a
-- 'Nothing' entry in the map) and one that was never established
-- (the repoid is not in the map). Once a connection fails,
-- either when trying to establish it or during usage, it will not
-- be tried again.
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 #-}

-- | Wait for an existing connection to become available or, if none
-- is available, try to create a new one and cache it.
getSshConnection :: String                       -- ^ remote darcs command
                 -> SshFilePath                  -- ^ destination
                 -> IO (Maybe (MVar Connection)) -- ^ wrapper for the action
getSshConnection :: String -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection String
rdarcs 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
$ \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
    Maybe (Maybe (MVar Connection))
Nothing -> do
      -- we have not yet tried with this key, do it now
      mc <- String -> SshFilePath -> IO (Maybe Connection)
newSshConnection String
rdarcs SshFilePath
sshfp
      case mc of
        Maybe Connection
Nothing ->
          -- failed, remember it, so we don't try again
          (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
-> IO
     (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
forall a. a -> IO a
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 Connection
c -> do
          -- success, remember and use
          v <- Connection -> IO (MVar Connection)
forall a. a -> IO (MVar a)
newMVar Connection
c
          return (insert key (Just v) cmap, Just v)
    Just Maybe (MVar Connection)
Nothing ->
      -- we have tried to connect before, don't do it again
      (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
-> IO
     (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
forall a. a -> IO a
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 MVar Connection
v) ->
      -- we do have a connection, return an action that
      -- waits until it is available
      (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
-> IO
     (Map RepoId (Maybe (MVar Connection)), Maybe (MVar Connection))
forall a. a -> IO a
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)

-- | Try to create a new ssh connection to a remote darcs that runs the
-- transfer-mode command. This is tried only once per repoid.
newSshConnection :: String -> SshFilePath -> IO (Maybe Connection)
newSshConnection :: String -> SshFilePath -> IO (Maybe Connection)
newSshConnection String
rdarcs SshFilePath
sshfp = do
  (sshcmd,sshargs_) <- SSHCmd -> IO (String, [String])
getSSH SSHCmd
SSH
  debugMessage $ "Starting new ssh connection to " ++ sshUhost sshfp
  let sshargs = [String]
sshargs_ [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--", SshFilePath -> String
sshUhost SshFilePath
sshfp, String
rdarcs,
                             String
"transfer-mode", String
"--repodir", SshFilePath -> String
sshRepo SshFilePath
sshfp]
  debugMessage $ "Exec: " ++ showCommandLine (sshcmd:sshargs)
  (i,o,e,ph) <- runInteractiveProcess sshcmd sshargs Nothing Nothing
  do
    hSetBinaryMode i True
    hSetBinaryMode o True
    l <- hGetLine o
    unless (l == transferModeHeader) $
      fail "Couldn't start darcs transfer-mode on server"
    return $ Just C { inp = i, out = o, err = e, proc = ph }
    `catchNonSignal` \SomeException
exn -> do
      String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to start ssh connection: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
prettyException SomeException
exn
      String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
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."
                    ]
      Maybe Connection -> IO (Maybe Connection)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Connection
forall a. Maybe a
Nothing

-- | Terminate all child processes that run a remote "darcs transfer-mode" and
-- remove them from the 'sshConnections', causing subsequent 'copySSH' calls to
-- start a fresh child.
resetSshConnections :: IO ()
resetSshConnections :: IO ()
resetSshConnections =
  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))))
 -> IO ())
-> (Map RepoId (Maybe (MVar Connection))
    -> IO (Map RepoId (Maybe (MVar Connection))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map RepoId (Maybe (MVar Connection))
cmap -> do
    Map RepoId (Maybe (MVar Connection))
-> (Maybe (MVar Connection) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Map RepoId (Maybe (MVar Connection))
cmap ((Maybe (MVar Connection) -> IO ()) -> IO ())
-> (Maybe (MVar Connection) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      Just MVar Connection
mvarc -> do
        MVar Connection -> (Connection -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Connection
mvarc ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \C{ proc :: Connection -> ProcessHandle
proc = ProcessHandle
ph } -> do
          ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph
          IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      Maybe (MVar Connection)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Map RepoId (Maybe (MVar Connection))
-> IO (Map RepoId (Maybe (MVar Connection)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map RepoId (Maybe (MVar Connection))
forall k a. Map k a
empty

-- | Mark any connection associated with the given ssh file path
-- as failed, so it won't be tried again.
dropSshConnection :: RepoId -> IO ()
dropSshConnection :: RepoId -> IO ()
dropSshConnection RepoId
key = do
  String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Dropping ssh failed connection to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RepoId -> String
forall a b. (a, b) -> a
fst RepoId
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ RepoId -> String
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 a. a -> IO a
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 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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"grabSSH src=" String -> ShowS
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)
                        -- hGetContents is ok here because we're
                        -- only grabbing stderr, and we're also
                        -- about to throw the contents.
                      eee <- Handle -> IO String
Ratified.hGetContents (Connection -> Handle
err Connection
c)
                      fail $ e ++ " grabbing ssh file " ++
                        sshFilePathOf src ++"\n" ++ eee
      file :: String
file = SshFilePath -> String
sshFile SshFilePath
src
  Handle -> String -> IO ()
hPutStrLn (Connection -> Handle
inp Connection
c) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"get " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file
  Handle -> IO ()
hFlush (Connection -> Handle
inp Connection
c)
  l2 <- Handle -> IO String
hGetLine (Connection -> Handle
out Connection
c)
  if l2 == "got "++file
    then do showlen <- hGetLine (out c)
            case reads showlen of
              [(Int
len,String
"")] -> Handle -> Int -> IO ByteString
B.hGet (Connection -> Handle
out Connection
c) Int
len
              [(Int, String)]
_ -> String -> IO ByteString
forall a. String -> IO a
failwith String
"Couldn't get length"
    else if l2 == "error "++file
         then do e <- hGetLine (out c)
                 case reads e of
                   (String
msg,String
_):[RepoId]
_ -> String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"Error reading file remotely:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
msg
                   [] -> String -> IO ByteString
forall a. String -> IO a
failwith String
"An error occurred"
         else failwith "Error"

copySSH :: String -> SshFilePath -> FilePath -> IO ()
copySSH :: String -> SshFilePath -> String -> IO ()
copySSH String
rdarcs SshFilePath
src String
dest = do
  String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"copySSH file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SshFilePath -> String
sshFilePathOf SshFilePath
src
  -- TODO why do we disable progress reporting here?
  IO () -> IO ()
forall a. IO a -> IO a
withoutProgress (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    mc <- String -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection String
rdarcs SshFilePath
src
    case mc of
      Just 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
>=> String -> ByteString -> IO ()
B.writeFile String
dest)
      Maybe (MVar Connection)
Nothing -> do
        -- remote 'darcs transfer-mode' does not work => use scp
        let u :: String
u = ShowS
escape_dollar ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SshFilePath -> String
sshFilePathOf SshFilePath
src
        (scpcmd, args) <- SSHCmd -> IO (String, [String])
getSSH SSHCmd
SCP
        let scp_args = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"-q") [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--", String
u, String
dest]
        debugMessage $ "Exec: " ++ showCommandLine (scpcmd:scp_args)
        (r, scp_err) <- readInteractiveProcess scpcmd scp_args
        unless (r == ExitSuccess) $
          throwIO $ ExecException scpcmd scp_args (AsIs,AsIs,AsIs) scp_err
  where
    -- '$' in filenames is troublesome for scp, for some reason.
    escape_dollar :: String -> String
    escape_dollar :: ShowS
escape_dollar = (Char -> String) -> ShowS
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]

-- | Show a command and its arguments for debug messages.
showCommandLine :: [String] -> String
showCommandLine :: [String] -> String
showCommandLine = [String] -> String
unwords ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall a. Show a => a -> String
show

transferModeHeader :: String
transferModeHeader :: String
transferModeHeader = String
"Hello user, I am darcs transfer mode"

-- ---------------------------------------------------------------------
-- older ssh helper functions
-- ---------------------------------------------------------------------

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

-- | Return the command and arguments needed to run an ssh command
--   First try the appropriate darcs environment variable and SSH_PORT
--   defaulting to "ssh" and no specified port.
getSSH :: SSHCmd
       -> IO (String, [String])
getSSH :: SSHCmd -> IO (String, [String])
getSSH SSHCmd
cmd = do
    port <- (SSHCmd -> String -> [String]
portFlag SSHCmd
cmd (String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
getEnv String
"SSH_PORT") IO [String] -> IO [String] -> IO [String]
forall a. IO a -> IO a -> IO a
`catchall` [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    let (sshcmd, ssh_args) = breakCommand command
    return (sshcmd, ssh_args ++ 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=" String -> ShowS
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.",
    String
"",
    String
"scp is also used by `darcs clone` if the destination is a remote ssh",
    String
"directory. This operation can be made quite a bit faster by setting",
    String
"DARCS_SCP=rsync."])

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."])