--
--
-- 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
    ) 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 = [Char]
"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 #-}

-- | 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 ([Char] -> IO ()
putStrLn [Char]
"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 [Char]
"plink" [] [Char]
"")
                                  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
$
                        [Char]
"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 Int
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 [Char]
"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 [Char]
"plink" [Char]
"pscp -q" [Char]
"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)  [Char]
"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)  [Char]
"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) [Char]
"DARCS_SFTP"
    IO () -> IO ()
whenDebugMode ([Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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 (a
_, b
x, c
_) = b
x
    rawVanilla :: SshSettings
rawVanilla = [Char] -> [Char] -> [Char] -> SshSettings
SshSettings [Char]
"ssh" [Char]
"scp -q" [Char]
"sftp"
    fromEnv :: String -> String -> IO String
    fromEnv :: [Char] -> [Char] -> IO [Char]
fromEnv [Char]
d [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 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
    }

-- | 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 :: [Char] -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection [Char]
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
      Maybe Connection
mc <- [Char] -> SshFilePath -> IO (Maybe Connection)
newSshConnection [Char]
rdarcs SshFilePath
sshfp
      case Maybe Connection
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 (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
          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 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 (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 (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 :: [Char] -> SshFilePath -> IO (Maybe Connection)
newSshConnection [Char]
rdarcs SshFilePath
sshfp = do
  ([Char]
sshcmd,[[Char]]
sshargs_) <- SSHCmd -> IO ([Char], [[Char]])
getSSH SSHCmd
SSH
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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]
++ [[Char]
"--", SshFilePath -> [Char]
sshUhost SshFilePath
sshfp, [Char]
rdarcs,
                             [Char]
"transfer-mode", [Char]
"--repodir", SshFilePath -> [Char]
sshRepo SshFilePath
sshfp]
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Exec: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
showCommandLine ([Char]
sshcmd[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
sshargs)
  (Handle
i,Handle
o,Handle
e,ProcessHandle
_) <- [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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 C :: 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` \SomeException
exn -> do
      [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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
                    [ [Char]
"NOTE: the server may be running a version of darcs prior to 2.0.0."
                    , [Char]
""
                    , [Char]
"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

-- | 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
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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]
":" [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 SshFilePath
sshfp = (SshFilePath -> [Char]
sshUhost SshFilePath
sshfp, SshFilePath -> [Char]
sshRepo SshFilePath
sshfp)

grabSSH :: SshFilePath -> Connection -> IO B.ByteString
grabSSH :: SshFilePath -> Connection -> IO ByteString
grabSSH SshFilePath
src Connection
c = do
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"grabSSH src=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SshFilePath -> [Char]
sshFilePathOf SshFilePath
src
  let failwith :: [Char] -> IO b
failwith [Char]
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.
                      [Char]
eee <- Handle -> IO [Char]
Ratified.hGetContents (Connection -> Handle
err Connection
c)
                      [Char] -> IO b
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO b) -> [Char] -> IO b
forall a b. (a -> b) -> a -> b
$ [Char]
e [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" grabbing ssh file " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                        SshFilePath -> [Char]
sshFilePathOf SshFilePath
src [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"\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
$ [Char]
"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
== [Char]
"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
              [(Int
len,[Char]
"")] -> Handle -> Int -> IO ByteString
B.hGet (Connection -> Handle
out Connection
c) Int
len
              [(Int, [Char])]
_ -> [Char] -> IO ByteString
forall b. [Char] -> IO b
failwith [Char]
"Couldn't get length"
    else if [Char]
l2 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"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
                   ([Char]
msg,[Char]
_):[RepoId]
_ -> [Char] -> IO ByteString
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Error reading file remotely:\n"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
msg
                   [] -> [Char] -> IO ByteString
forall b. [Char] -> IO b
failwith [Char]
"An error occurred"
         else [Char] -> IO ByteString
forall b. [Char] -> IO b
failwith [Char]
"Error"

copySSH :: String -> SshFilePath -> FilePath -> IO ()
copySSH :: [Char] -> SshFilePath -> [Char] -> IO ()
copySSH [Char]
rdarcs SshFilePath
src [Char]
dest = do
  [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"copySSH file: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SshFilePath -> [Char]
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
    Maybe (MVar Connection)
mc <- [Char] -> SshFilePath -> IO (Maybe (MVar Connection))
getSshConnection [Char]
rdarcs SshFilePath
src
    case Maybe (MVar Connection)
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
>=> [Char] -> ByteString -> IO ()
B.writeFile [Char]
dest)
      Maybe (MVar Connection)
Nothing -> do
        -- remote 'darcs transfer-mode' does not work => use scp
        let u :: [Char]
u = ShowS
escape_dollar ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SshFilePath -> [Char]
sshFilePathOf SshFilePath
src
        ([Char]
scpcmd, [[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
/=[Char]
"-q") [[Char]]
args [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--", [Char]
u, [Char]
dest]
        [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Exec: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
showCommandLine ([Char]
scpcmd[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
scp_args)
        (ExitCode
r, [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
    -- '$' in filenames is troublesome for scp, for some reason.
    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 Char
'$' = [Char]
"\\$"
        tr Char
c = [Char
c]

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

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

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

data SSHCmd = SSH
            | SCP
            | SFTP


fromSshCmd :: SshSettings
           -> SSHCmd
           -> String
fromSshCmd :: SshSettings -> SSHCmd -> [Char]
fromSshCmd SshSettings
s SSHCmd
SSH  = SshSettings -> [Char]
ssh SshSettings
s
fromSshCmd SshSettings
s SSHCmd
SCP  = SshSettings -> [Char]
scp SshSettings
s
fromSshCmd SshSettings
s SSHCmd
SFTP = SshSettings -> [Char]
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 ([Char], [[Char]])
getSSH 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 [Char]
"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 ([Char]
sshcmd, [[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 SSHCmd
SSH  [Char]
x = [[Char]
"-p", [Char]
x]
    portFlag SSHCmd
SCP  [Char]
x = [[Char]
"-P", [Char]
x]
    portFlag SSHCmd
SFTP [Char]
x = [[Char]
"-oPort=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
x]
    breakCommand :: [Char] -> ([Char], [[Char]])
breakCommand [Char]
s =
      case [Char] -> [[Char]]
words [Char]
s of
        ([Char]
arg0:[[Char]]
args) -> ([Char]
arg0, [[Char]]
args)
        [] -> ([Char]
s, [])

environmentHelpSsh :: ([String], [String])
environmentHelpSsh :: ([[Char]], [[Char]])
environmentHelpSsh = ([[Char]
"DARCS_SSH"], [
    [Char]
"Repositories of the form [user@]host:[dir] are taken to be remote",
    [Char]
"repositories, which Darcs accesses with the external program ssh(1).",
    [Char]
"",
    [Char]
"The environment variable $DARCS_SSH can be used to specify an",
    [Char]
"alternative SSH client.  Arguments may be included, separated by",
    [Char]
"whitespace.  The value is not interpreted by a shell, so shell",
    [Char]
"constructs cannot be used; in particular, it is not possible for the",
    [Char]
"program name to contain whitespace by using quoting or escaping."])


environmentHelpScp :: ([String], [String])
environmentHelpScp :: ([[Char]], [[Char]])
environmentHelpScp = ([[Char]
"DARCS_SCP", [Char]
"DARCS_SFTP"], [
    [Char]
"When reading from a remote repository, Darcs will attempt to run",
    [Char]
"`darcs transfer-mode` on the remote host.  This will fail if the",
    [Char]
"remote host only has Darcs 1 installed, doesn't have Darcs installed",
    [Char]
"at all, or only allows SFTP.",
    [Char]
"",
    [Char]
"If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",
    [Char]
"The commands invoked can be customized with the environment variables",
    [Char]
"$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",
    [Char]
"If the remote end allows only sftp, try setting DARCS_SCP=sftp."])


environmentHelpSshPort :: ([String], [String])
environmentHelpSshPort :: ([[Char]], [[Char]])
environmentHelpSshPort = ([[Char]
"SSH_PORT"], [
    [Char]
"If this environment variable is set, it will be used as the port",
    [Char]
"number for all SSH calls made by Darcs (when accessing remote",
    [Char]
"repositories over SSH).  This is useful if your SSH server does not",
    [Char]
"run on the default port, and your SSH client does not support",
    [Char]
"ssh_config(5).  OpenSSH users will probably prefer to put something",
    [Char]
"like `Host *.example.net Port 443` into their ~/.ssh/config file."])