diff --git a/Network/SSH/Client/LibSSH2.hs b/Network/SSH/Client/LibSSH2.hs deleted file mode 100644 --- a/Network/SSH/Client/LibSSH2.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Network.SSH.Client.LibSSH2 - (-- * Types - Session, Channel, KnownHosts, - - -- * Functions - withSSH2, - withSession, - withSessionBlocking, - withChannel, - checkHost, - readAllChannel, - retryIfNeeded, - scpSendFile, - scpReceiveFile, - runShellCommands, - execCommands, - - -- * Utilities - socketConnect - ) where - -import Control.Monad -import Control.Exception as E -import Network -import Network.BSD -import Network.Socket -import System.IO - -import Network.SSH.Client.LibSSH2.Types -import Network.SSH.Client.LibSSH2.Errors -import Network.SSH.Client.LibSSH2.Foreign - --- | Check if handle is ready for reading in 10 seconds. -waitSocket :: Handle -> Session -> IO Bool -waitSocket h s = do - dirs <- blockedDirections s - if INBOUND `elem` dirs - then hWaitForInput h (10*1000) - else return True - --- | Similar to Network.connectTo, but does not socketToHandle. -socketConnect :: String -> Int -> IO Socket -socketConnect hostname port = do - proto <- getProtocolNumber "tcp" - bracketOnError (socket AF_INET Stream proto) (sClose) - (\sock -> do - he <- getHostByName hostname - connect sock (SockAddrInet (fromIntegral port) (hostAddress he)) - return sock) - --- | Execute some actions within SSH2 connection. --- Uses public key authentication. -withSSH2 :: FilePath -- ^ Path to known_hosts file - -> FilePath -- ^ Path to public key file - -> FilePath -- ^ Path to private key file - -> String -- ^ Remote user name - -> String -- ^ Remote host name - -> Int -- ^ Remote port number (usually 22) - -> (Channel -> IO a) -- ^ Actions to perform on channel - -> IO (Int, a) -withSSH2 known_hosts public private login hostname port fn = - withSessionBlocking hostname port $ \s -> do - r <- checkHost s hostname port known_hosts - publicKeyAuthFile s login public private "" - withChannel s $ fn - --- | Execute some actions within SSH2 session -withSession :: String -- ^ Remote host name - -> Int -- ^ Remote port number (usually 22) - -> (Handle -> Session -> IO a) -- ^ Actions to perform on handle and session - -> IO a -withSession hostname port fn = do - sock <- socketConnect hostname port - handle <- socketToHandle sock ReadWriteMode - session <- initSession - handshake session sock - result <- fn handle session - disconnectSession session "Done." - freeSession session - hClose handle - return result - --- | Execute some actions within SSH2 session -withSessionBlocking :: String -- ^ Remote host name - -> Int -- ^ Remote port number (usually 22) - -> (Session -> IO a) -- ^ Actions to perform on handle and session - -> IO a -withSessionBlocking hostname port fn = do - sock <- socketConnect hostname port - session <- initSession - handshake session sock - result <- fn session - disconnectSession session "Done." - freeSession session - return result - --- | Check remote host against known hosts list -checkHost :: Session - -> String -- ^ Remote host name - -> Int -- ^ Remote port number (usually 22) - -> FilePath -- ^ Path to known_hosts file - -> IO KnownHostResult -checkHost s host port path = do - kh <- initKnownHosts s - knownHostsReadFile kh path - (hostkey, keylen, keytype) <- getHostKey s - result <- checkKnownHost kh host port hostkey [TYPE_PLAIN, KEYENC_RAW] - freeKnownHosts kh - return result - --- | Execute some actions withing SSH2 channel -withChannel :: Session -> (Channel -> IO a) -> IO (Int, a) -withChannel s fn = do - ch <- openChannelSession s - -- waitSocket sock s - result <- fn ch - closeChannel ch - exitStatus <- channelExitStatus ch - freeChannel ch - return (exitStatus, result) - --- | Read all data from the channel -readAllChannel :: Channel -> IO String -readAllChannel ch = do - (sz, res) <- readChannel ch 0x400 - if sz > 0 - then do - rest <- readAllChannel ch - return $ res ++ rest - else return "" - -runShellCommands :: Session -> [String] -> IO (Int, [String]) -runShellCommands s commands = do - ch <- openChannelSession s - requestPTY ch "linux" - channelShell ch - hello <- readAllChannel ch - out <- forM commands $ \cmd -> do - writeChannel ch (cmd ++ "\n") - r <- readAllChannel ch - return r - channelSendEOF ch - closeChannel ch - exitStatus <- channelExitStatus ch - freeChannel ch - return (exitStatus, out) - -execCommands :: Session -> [String] -> IO (Int, [String]) -execCommands s commands = do - ch <- openChannelSession s - out <- forM commands $ \cmd -> do - channelExecute ch cmd - readAllChannel ch - closeChannel ch - exitStatus <- channelExitStatus ch - freeChannel ch - return (exitStatus, out) - - --- | Send a file to remote host via SCP. --- Returns size of sent data. -scpSendFile :: Session - -> Int -- ^ File creation mode (0o777, for example) - -> FilePath -- ^ Path to local file - -> FilePath -- ^ Remote file path - -> IO Integer -scpSendFile s mode local remote = do - h <- openFile local ReadMode - size <- hFileSize h - ch <- scpSendChannel s remote mode (fromIntegral size) 0 0 - result <- writeChannelFromHandle s ch h - hClose h - closeChannel ch - freeChannel ch - return result - --- | Receive file from remote host via SCP. --- Returns size of received data. -scpReceiveFile :: Session -- - -> FilePath -- ^ Remote file path - -> FilePath -- ^ Path to local file - -> IO Integer -scpReceiveFile s remote local = do - h <- openFile local WriteMode - (ch, fileSize) <- scpReceiveChannel s remote - result <- readChannelToHandle ch h fileSize - hClose h - closeChannel ch - freeChannel ch - return result - --- | Retry the action repeatedly, while it fails with EAGAIN. --- This does matter if using nonblocking mode. -retryIfNeeded :: Handle -> Session -> IO a -> IO a -retryIfNeeded handle session action = - action `E.catch` (\(e :: ErrorCode) -> - if e == EAGAIN - then do - waitSocket handle session - retryIfNeeded handle session action - else throw e ) - diff --git a/Network/SSH/Client/LibSSH2/Errors.chs b/Network/SSH/Client/LibSSH2/Errors.chs deleted file mode 100644 --- a/Network/SSH/Client/LibSSH2/Errors.chs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-} - -#include - -{# context lib="ssh2" prefix="libssh2" #} - -module Network.SSH.Client.LibSSH2.Errors - (-- * Types - ErrorCode (..), - NULL_POINTER, - - -- * Utilities - CIntResult (..), - - -- * Functions - getLastError, - handleInt, - handleBool, - handleNullPtr, - int2error - ) where - -import Control.Exception -import Data.Generics -import Foreign -import Foreign.Ptr -import Foreign.C.Types - -import Network.SSH.Client.LibSSH2.Types - --- | Error codes returned by libssh2. -data ErrorCode = - NONE - | SOCKET_NONE - | BANNER_RECV - | BANNER_SEND - | INVALID_MAC - | KEX_FALIURE - | ALLOC - | SOCKET_SEND - | KEY_EXCHANGE_FAILURE - | TIMEOUT - | HOSTKEY_INIT - | HOSTKEY_SIGN - | DECRYPT - | SOCKET_DISCONNECT - | PROTO - | PASSWORD_EXPIRED - | FILE - | METHOD_NONE - | AUTHENTICATION_FAILED - | PUBLICKEY_UNVERIFIED - | CHANNEL_OUTOFORDER - | CHANNEL_FAILURE - | CHANNEL_REQUEST_DENIED - | CHANNEL_UNKNOWN - | CHANNEL_WINDOW_EXCEEDED - | CHANNEL_PACKET_EXCEEDED - | CHANNEL_CLOSED - | CHANNEL_EOF_SENT - | SCP_PROTOCOL - | ZLIB - | SOCKET_TIMEOUT - | SFTP_PROTOCOL - | REQUEST_DENIED - | METHOD_NOT_SUPPORTED - | INVAL - | INVALID_POLL_TYPE - | PUBLICKEY_PROTOCOL - | EAGAIN - | BUFFER_TOO_SMALL - | BAD_USE - | COMPRESS - | OUT_OF_BOUNDARY - | AGENT_PROTOCOL - | SOCKET_RECV - | ENCRYPT - | BAD_SOCKET - deriving (Eq, Show, Ord, Enum, Data, Typeable) - -instance Exception ErrorCode - -error2int :: (Num i) => ErrorCode -> i -error2int = fromIntegral . negate . fromEnum - -int2error :: (Integral i) => i -> ErrorCode -int2error = toEnum . negate . fromIntegral - --- | Exception to throw when null pointer received --- from libssh2. -data NULL_POINTER = NULL_POINTER - deriving (Eq, Show, Data, Typeable) - -instance Exception NULL_POINTER - -class HasCInt a where - intResult :: a -> CInt - -class (HasCInt a) => CIntResult a b where - fromCInt :: a -> b - -instance HasCInt CInt where - intResult = id - -instance (Num b) => CIntResult CInt b where - fromCInt = fromIntegral - -instance HasCInt CLong where - intResult = fromIntegral - -instance (Num b) => CIntResult CLong b where - fromCInt = fromIntegral - -instance (Integral i) => HasCInt (i, a) where - intResult (i, _) = fromIntegral i - -instance (Integral i, Num b) => CIntResult (i, a) (b, a) where - fromCInt (i, a) = (fromIntegral i, a) - -instance HasCInt (CInt, a, b) where - intResult (i, _, _) = i - -instance (Num j) => CIntResult (CInt, a, b) (j, a, b) where - fromCInt (i, a, b) = (fromIntegral i, a, b) - -instance HasCInt (CInt, a, b, c) where - intResult (i, _, _, _) = i - -instance (Num j) => CIntResult (CInt, a, b, c) (j, a, b, c) where - fromCInt (i, a, b, c) = (fromIntegral i, a, b, c) - -{# fun session_last_error as getLastError_ - { toPointer `Session', - alloca- `String' peekCStringPtr*, - castPtr `Ptr Int', - `Int' } -> `Int' #} - --- | Get last error information. -getLastError :: Session -> IO (Int, String) -getLastError s = getLastError_ s nullPtr 0 - --- | Throw an exception if negative value passed, --- or return unchanged value. -handleInt :: (CIntResult a b) => a -> IO b -handleInt x = - let r = intResult x - in if r < 0 - then throw (int2error r) - else return (fromCInt x) - -handleBool :: CInt -> IO Bool -handleBool x - | x == 0 = return False - | x > 0 = return True - | otherwise = throw (int2error x) - --- | Throw an exception if null pointer passed, --- or return it casted to right type. -handleNullPtr :: (IsPointer a) => Ptr () -> IO a -handleNullPtr p - | p == nullPtr = throw NULL_POINTER - | otherwise = return (fromPointer p) - diff --git a/Network/SSH/Client/LibSSH2/Foreign.chs b/Network/SSH/Client/LibSSH2/Foreign.chs deleted file mode 100644 --- a/Network/SSH/Client/LibSSH2/Foreign.chs +++ /dev/null @@ -1,444 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -#include "libssh2_local.h" -#include - -{# context lib="ssh2" prefix="libssh2" #} - -module Network.SSH.Client.LibSSH2.Foreign - (-- * Types - KnownHosts, KnownHostResult (..), KnownHostType (..), - Direction (..), - - -- * Session functions - initialize, exit, - initSession, freeSession, disconnectSession, - handshake, - blockedDirections, - setBlocking, - - -- * Known hosts functions - initKnownHosts, freeKnownHosts, knownHostsReadFile, - getHostKey, checkKnownHost, - - -- * Authentication - publicKeyAuthFile, - - -- * Channel functions - openChannelSession, closeChannel, freeChannel, - channelSendEOF, - readChannel, writeChannel, - writeChannelFromHandle, readChannelToHandle, - channelProcess, channelExecute, channelShell, - requestPTY, requestPTYEx, - channelExitStatus, channelExitSignal, - scpSendChannel, scpReceiveChannel, - - -- * Debug - TraceFlag (..), setTraceMode - ) where - -import Control.Exception -import Control.Monad -import Foreign -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import System.IO -import Network.Socket -import Data.Bits -import Data.Int -import Data.Time.Clock.POSIX -import Text.Printf - -import Network.SSH.Client.LibSSH2.Types -import Network.SSH.Client.LibSSH2.Errors - --- Known host flags. See libssh2 documentation. -data KnownHostType = - TYPE_MASK - | TYPE_PLAIN - | TYPE_SHA1 - | TYPE_CUSTOM - | KEYENC_MASK - | KEYENC_RAW - | KEYENC_BASE64 - | KEY_MASK - | KEY_SHIFT - | KEY_RSA1 - | KEY_SSHRSA - | KEY_SSHDSS - deriving (Eq, Show) - -kht2int :: KnownHostType -> CInt -kht2int TYPE_MASK = 0xffff -kht2int TYPE_PLAIN = 1 -kht2int TYPE_SHA1 = 2 -kht2int TYPE_CUSTOM = 3 -kht2int KEYENC_MASK = 3 `shiftL` 16 -kht2int KEYENC_RAW = 1 `shiftL` 16 -kht2int KEYENC_BASE64 = 2 `shiftL` 16 -kht2int KEY_MASK = 3 `shiftL` 18 -kht2int KEY_SHIFT = 18 -kht2int KEY_RSA1 = 1 `shiftL` 18 -kht2int KEY_SSHRSA = 2 `shiftL` 18 -kht2int KEY_SSHDSS = 3 `shiftL` 18 - -typemask2int :: [KnownHostType] -> CInt -typemask2int list = foldr (.|.) 0 (map kht2int list) - --- Result of matching host against known_hosts. -data KnownHostResult = - MATCH - | MISMATCH - | NOTFOUND - | FAILURE - deriving (Eq, Show, Ord, Enum) - -int2khresult :: CInt -> KnownHostResult -int2khresult = toEnum . fromIntegral - -data KnownHost = KnownHost { - khMagic :: CUInt, - khNode :: Ptr (), - khName :: String, - khKey :: String, - khTypeMask :: [KnownHostType] } - deriving (Eq, Show) - --- | Session directions -data Direction = INBOUND | OUTBOUND - deriving (Eq, Show) - -int2dir 1 = [INBOUND] -int2dir 2 = [OUTBOUND] -int2dir 3 = [INBOUND, OUTBOUND] -int2dir x = error $ "Unknown direction: " ++ show x - -init_crypto :: Bool -> CInt -init_crypto False = 1 -init_crypto True = 0 - -ssh2socket :: Socket -> CInt -ssh2socket (MkSocket s _ _ _ _) = s - --- | Initialize libssh2. Pass True to enable encryption --- or False to disable it. -{# fun init as initialize - { init_crypto `Bool' } -> `Int' handleInt* #} - --- | Deinitialize libssh2. -{# fun exit as exit { } -> `()' #} - --- | Create Session object -initSession :: IO Session -initSession = do - ptr <- {# call session_init_ex #} nullFunPtr nullFunPtr nullFunPtr nullPtr - handleNullPtr ptr - --- | Free Session object's memory -{# fun session_free as freeSession - { toPointer `Session' } -> `Int' handleInt* #} - -{# fun session_disconnect_ex as disconnectSessionEx - { toPointer `Session', `Int', `String', `String' } -> `Int' handleInt* #} - --- | Disconnect session (but do not free memory) -disconnectSession :: Session - -> String -- ^ Goodbye message - -> IO Int -disconnectSession s msg = disconnectSessionEx s 11 msg "" - -{# fun session_set_blocking as setBlocking - { toPointer `Session', bool2int `Bool' } -> `()' #} - -bool2int :: Bool -> CInt -bool2int True = 1 -bool2int False = 0 - --- | Run SSH handshake on network socket. -{# fun session_handshake as handshake - { toPointer `Session', ssh2socket `Socket' } -> `Int' handleInt* #} - --- | Create KnownHosts object for given session. -{# fun knownhost_init as initKnownHosts - { toPointer `Session' } -> `KnownHosts' handleNullPtr* #} - --- | Free KnownHosts object's memory -{# fun knownhost_free as freeKnownHosts - { toPointer `KnownHosts' } -> `()' #} - -{# fun knownhost_readfile as knownHostsReadFile_ - { toPointer `KnownHosts', `String', id `CInt' } -> `Int' handleInt* #} - --- | Read known hosts from file -knownHostsReadFile :: KnownHosts - -> FilePath -- ^ Path to known_hosts file - -> IO Int -knownHostsReadFile kh path = knownHostsReadFile_ kh path 1 - --- | Get remote host public key -{# fun session_hostkey as getHostKey - { toPointer `Session', alloca- `Size' peek*, alloca- `CInt' peek* } -> `String' #} - -{# fun knownhost_checkp as checkKnownHost_ - { toPointer `KnownHosts', - `String', - `Int', - `String', - `Int', - typemask2int `[KnownHostType]', - castPtr `Ptr ()' } -> `KnownHostResult' int2khresult #} - --- | Check host data against known hosts. -checkKnownHost :: KnownHosts -- - -> String -- ^ Host name - -> Int -- ^ Port number (usually 22) - -> String -- ^ Host public key - -> [KnownHostType] -- ^ Host flags (see libssh2 documentation) - -> IO KnownHostResult -checkKnownHost kh host port key mask = checkKnownHost_ kh host port key (length key) mask nullPtr - --- | Perform public key authentication. --- Arguments are: session, username, path to public key file, --- path to private key file, passphrase. -{# fun userauth_publickey_fromfile_ex as publicKeyAuthFile - { toPointer `Session', - `String' &, - `String', - `String', - `String' } -> `Int' handleInt* #} - -{# fun channel_open_ex as openSessionChannelEx - { toPointer `Session', - `String' &, - `Int', `Int', - `String' & } -> `Channel' handleNullPtr* #} - --- | Open a channel for session. -openChannelSession :: Session -> IO Channel -openChannelSession s = openSessionChannelEx s "session" 65536 32768 "" - -channelProcess :: Channel -> String -> String -> IO Int -channelProcess ch kind command = do - withCStringLenIntConv kind $ \(kindptr, kindlen) -> - withCStringLenIntConv command $ \(commandptr, commandlen) -> - {# call channel_process_startup #} - (toPointer ch) - kindptr kindlen - commandptr commandlen >>= handleInt - --- | Execute command -channelExecute :: Channel -> String -> IO Int -channelExecute c command = channelProcess c "exec" command - --- | Execute shell command -channelShell :: Channel -> IO Int -channelShell c = do - withCStringLenIntConv "shell" $ \(kindptr, kindlen) -> - {# call channel_process_startup #} - (toPointer c) - kindptr - kindlen - nullPtr 0 >>= handleInt - -{# fun channel_request_pty_ex as requestPTYEx - { toPointer `Channel', - `String' &, - `String' &, - `Int', `Int', - `Int', `Int' } -> `Int' handleInt* #} - -requestPTY :: Channel -> String -> IO Int -requestPTY ch term = requestPTYEx ch term "" 0 0 0 0 - -readChannelEx :: Channel -> Int -> Size -> IO (SSize, String) -readChannelEx ch i size = - allocaBytes (fromIntegral size) $ \buffer -> do - rc <- {# call channel_read_ex #} (toPointer ch) (fromIntegral i) buffer size - when (rc < 0) $ - throw (int2error rc) - str <- peekCAStringLen (buffer, fromIntegral rc) - return (rc, str) - --- | Read data from channel. --- Returns amount of given data and data itself. --- NOTE: returns bytes sequence, i.e. not Unicode. -readChannel :: Channel -- - -> Size -- ^ Amount of data to read - -> IO (SSize, String) -readChannel c sz = readChannelEx c 0 sz - -{# fun channel_write_ex as writeChannelEx - { toPointer `Channel', - `Int', - withCStringLenIntConv* `String' & } -> `Int' handleInt* #} - --- | Write data to channel. --- Returns amount of written data. -writeChannel :: Channel -> String -> IO Int -writeChannel ch str = writeChannelEx ch 0 str - -{# fun channel_send_eof as channelSendEOF - { toPointer `Channel' } -> `Int' handleInt* #} - -data TraceFlag = - T_TRANS - | T_KEX - | T_AUTH - | T_CONN - | T_SCP - | T_SFTP - | T_ERROR - | T_PUBLICKEY - | T_SOCKET - deriving (Eq, Show) - -tf2int :: TraceFlag -> CInt -tf2int T_TRANS = 1 `shiftL` 1 -tf2int T_KEX = 1 `shiftL` 2 -tf2int T_AUTH = 1 `shiftL` 3 -tf2int T_CONN = 1 `shiftL` 4 -tf2int T_SCP = 1 `shiftL` 5 -tf2int T_SFTP = 1 `shiftL` 6 -tf2int T_ERROR = 1 `shiftL` 7 -tf2int T_PUBLICKEY = 1 `shiftL` 8 -tf2int T_SOCKET = 1 `shiftL` 9 - -trace2int :: [TraceFlag] -> CInt -trace2int flags = foldr (.|.) 0 (map tf2int flags) - -{# fun trace as setTraceMode - { toPointer `Session', trace2int `[TraceFlag]' } -> `Int' handleInt* #} - --- | Write all data to channel from handle. --- Returns amount of transferred data. ---writeChannelFromHandle :: Channel -> Handle -> IO Integer -writeChannelFromHandle session ch handle = - let - go h done fileSize buffer = do - sz <- hGetBuf h buffer bufferSize - sent <- send 0 (fromIntegral sz) buffer - let newDone = done + sent - if sz < bufferSize - then do - --channelSendEOF ch - return $ fromIntegral sz - else do - rest <- go h newDone fileSize buffer - return $ fromIntegral sz + rest - - send written 0 _ = return written - send written size buffer = do - sent <- {# call channel_write_ex #} - (toPointer ch) - 0 - (plusPtr buffer written) - (fromIntegral size) - when (sent < 0) $ do - throw (int2error sent) - send (written + fromIntegral sent) (size - sent) buffer - - bufferSize = 0x100000 - - in do - fileSize <- hFileSize handle - {# call trace #} (toPointer session) (512) - allocaBytes bufferSize $ \buffer -> - go handle 0 fileSize buffer - --- | Read all data from channel to handle. --- Returns amount of transferred data. -readChannelToHandle :: Channel -> Handle -> Offset -> IO Integer -readChannelToHandle ch handle fileSize = do - allocaBytes bufferSize $ \buffer -> - readChannelCB ch buffer bufferSize fileSize callback - where - callback buffer size = hPutBuf handle buffer size - - bufferSize :: Int - bufferSize = 0x100000 - -readChannelCB :: Channel -> CString -> Int -> Offset -> (CString -> Int -> IO a) -> IO Integer -readChannelCB ch buffer bufferSize fileSize callback = - let go got = do - let toRead = min (fromIntegral fileSize - got) (fromIntegral bufferSize) - sz <- {# call channel_read_ex #} - (toPointer ch) - 0 - buffer - (fromIntegral toRead) - when (sz < 0) $ - throw (int2error sz) - let isz :: Integer - isz = fromIntegral sz - callback buffer (fromIntegral sz) - eof <- {# call channel_eof #} (toPointer ch) - let newGot = got + fromIntegral sz - if (eof == 1) || (newGot == fromIntegral fileSize) - then do - return isz - else do - rest <- go newGot - return $ isz + rest - in go 0 - -{# fun channel_eof as channelIsEOF - { toPointer `Channel' } -> `Bool' handleBool* #} - --- | Close channel (but do not free memory) -{# fun channel_close as closeChannel - { toPointer `Channel' } -> `Int' handleInt* #} - --- | Free channel object's memory -{# fun channel_free as freeChannel - { toPointer `Channel' } -> `Int' handleInt* #} - --- | Get currently blocked directions -{# fun session_block_directions as blockedDirections - { toPointer `Session' } -> `[Direction]' int2dir #} - --- | Get channel exit status -{# fun channel_get_exit_status as channelExitStatus - { toPointer `Channel' } -> `Int' handleInt* #} - -{# fun channel_get_exit_signal as channelExitSignal_ - { toPointer `Channel', - alloca- `String' peekCStringPtr*, - castPtr `Ptr Int', - alloca- `Maybe String' peekMaybeCStringPtr*, - castPtr `Ptr Int', - alloca- `Maybe String' peekMaybeCStringPtr*, - castPtr `Ptr Int' } -> `Int' handleInt* #} - --- | Get channel exit signal. Returns: --- (possibly error code, exit signal name, possibly error message, possibly language code). -channelExitSignal :: Channel -> IO (Int, String, Maybe String, Maybe String) -channelExitSignal ch = channelExitSignal_ ch nullPtr nullPtr nullPtr - --- | Create SCP file send channel. -{# fun scp_send64 as scpSendChannel - { toPointer `Session', - `String', - `Int', - `Int64', - round `POSIXTime', - round `POSIXTime' } -> `Channel' handleNullPtr* #} - -type Offset = {# type off_t #} - -{# pointer *stat_t as Stat newtype #} - --- | Create SCP file receive channel. --- TODO: receive struct stat also. -scpReceiveChannel :: Session -> FilePath -> IO (Channel, Offset) -scpReceiveChannel s path = do - (ptr, sz) <- withCString path $ \pathptr -> - allocaBytes {# sizeof stat_t #} $ \statptr -> do - p <- {# call scp_recv #} (toPointer s) pathptr statptr - size <- {# get stat_t->st_size #} statptr - return (p, size) - channel <- handleNullPtr ptr - return (channel, sz) - - diff --git a/Network/SSH/Client/LibSSH2/Types.chs b/Network/SSH/Client/LibSSH2/Types.chs deleted file mode 100644 --- a/Network/SSH/Client/LibSSH2/Types.chs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, StandaloneDeriving #-} - -#include - -{# context lib="ssh2" prefix="libssh2" #} - -module Network.SSH.Client.LibSSH2.Types - (Session, - KnownHosts, - Channel, - IsPointer (..), - CStringCLen, - Size, SSize, - withCStringLenIntConv, - peekCStringPtr, - peekMaybeCStringPtr - ) where - -import Foreign -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import Data.Generics - -type Size = {# type size_t #} - -type SSize = {# type ssize_t #} - -type CStringCLen i = (CString, i) - -withCStringLenIntConv :: (Integral i) => String -> (CStringCLen i -> IO a) -> IO a -withCStringLenIntConv str fn = - withCStringLen str (\(ptr, len) -> fn (ptr, fromIntegral len)) - -peekCStringPtr :: Ptr CString -> IO String -peekCStringPtr ptr = peekCAString =<< peek ptr - -peekMaybeCStringPtr :: Ptr CString -> IO (Maybe String) -peekMaybeCStringPtr ptr = do - strPtr <- peek ptr - if strPtr == nullPtr - then return Nothing - else Just `fmap` peekCAString strPtr - -class IsPointer p where - fromPointer :: Ptr () -> p - toPointer :: p -> Ptr () - -{# pointer *SESSION as Session newtype #} - -deriving instance Eq Session -deriving instance Data Session -deriving instance Typeable Session - -instance Show Session where - show (Session p) = "" - -instance IsPointer Session where - fromPointer p = Session (castPtr p) - toPointer (Session p) = castPtr p - -{# pointer *KNOWNHOSTS as KnownHosts newtype #} - -deriving instance Eq KnownHosts -deriving instance Data KnownHosts -deriving instance Typeable KnownHosts - -instance Show KnownHosts where - show (KnownHosts p) = "" - -instance IsPointer KnownHosts where - fromPointer p = KnownHosts (castPtr p) - toPointer (KnownHosts p) = castPtr p - -{# pointer *CHANNEL as Channel newtype #} - -deriving instance Eq Channel -deriving instance Data Channel -deriving instance Typeable Channel - -instance Show Channel where - show (Channel p) = "" - -instance IsPointer Channel where - fromPointer p = Channel (castPtr p) - toPointer (Channel p) = castPtr p - diff --git a/libssh2.cabal b/libssh2.cabal --- a/libssh2.cabal +++ b/libssh2.cabal @@ -1,12 +1,26 @@ Name: libssh2 -Version: 0.1 +Version: 0.2 Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) Description: This package provides FFI bindings for SSH2 client library named libssh2. + . + As of version 0.2 all blocking is handled in Haskell code + rather than in C code. This means that all calls are now + interruptable using Haskell asynchronous exceptions; for + instance, it is now possible to use "System.Timeout" in + combination with "libssh2". + . + /Note on usage on Windows/: On Windows you MUST compile + your executable with @-threaded@ or 'libssh2' will NOT + work. We have tested 'libssh2' on Windows using + , with and + compiled from source (be sure to pass + the 'shared' option to the configure script for 'openssl' + to enable the shared libraries). -Homepage: http://redmine.iportnov.ru/projects/libssh2-hs +Homepage: https://github.com/portnov/libssh2-hs License: BSD3 @@ -26,24 +40,38 @@ Extra-source-files: ssh-client.hs, Makefile, include/libssh2_local.h -- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.6 +Cabal-version: >=1.8 +flag example-client + description: Build the example client + default: False Library Exposed-modules: Network.SSH.Client.LibSSH2.Types Network.SSH.Client.LibSSH2.Foreign Network.SSH.Client.LibSSH2.Errors + Network.SSH.Client.LibSSH2.WaitSocket Network.SSH.Client.LibSSH2 Include-dirs: include Includes: include/libssh2_local.h Build-depends: base >= 4 && < 5, network >= 2.3, - syb >= 0.3.3, time >= 1.2 + syb >= 0.3.3, time >= 1.2, + bytestring >= 0.9 Extra-libraries: "ssh2" + GHC-Options: -Wall -- Other-modules: Build-tools: c2hs + HS-Source-Dirs: src +Executable hs-ssh-client + if flag(example-client) + Build-depends: base, utf8-string, libssh2 >= 0.2, syb, network, filepath, bytestring + else + buildable: False + Main-Is: ssh-client.hs + GHC-Options: -threaded diff --git a/src/Network/SSH/Client/LibSSH2.hs b/src/Network/SSH/Client/LibSSH2.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client/LibSSH2.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Network.SSH.Client.LibSSH2 + (-- * Types + Session, Channel, KnownHosts, + + -- * Functions + withSSH2, + withSession, + withChannel, + withChannelBy, + checkHost, + readAllChannel, + writeAllChannel, + scpSendFile, + scpReceiveFile, + runShellCommands, + execCommands, + + -- * Utilities + socketConnect + ) where + +import Control.Monad +import Control.Exception as E +import Network +import Network.BSD +import Network.Socket +import System.IO +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Char8 as BSSC +import qualified Data.ByteString.Lazy as BSL + +import Network.SSH.Client.LibSSH2.Types +import Network.SSH.Client.LibSSH2.Foreign + +-- | Similar to Network.connectTo, but does not socketToHandle. +socketConnect :: String -> Int -> IO Socket +socketConnect hostname port = do + proto <- getProtocolNumber "tcp" + bracketOnError (socket AF_INET Stream proto) (sClose) + (\sock -> do + he <- getHostByName hostname + connect sock (SockAddrInet (fromIntegral port) (hostAddress he)) + return sock) + +-- | Execute some actions within SSH2 connection. +-- Uses public key authentication. +withSSH2 :: FilePath -- ^ Path to known_hosts file + -> FilePath -- ^ Path to public key file + -> FilePath -- ^ Path to private key file + -> String -- ^ Passphrase + -> String -- ^ Remote user name + -> String -- ^ Remote host name + -> Int -- ^ Remote port number (usually 22) + -> (Session -> IO a) -- ^ Actions to perform on session + -> IO a +withSSH2 known_hosts public private passphrase login hostname port fn = + withSession hostname port $ \s -> do + r <- checkHost s hostname port known_hosts + when (r == MISMATCH) $ + error $ "Host key mismatch for host " ++ hostname + publicKeyAuthFile s login public private passphrase + fn s + +-- | Execute some actions within SSH2 session +withSession :: String -- ^ Remote host name + -> Int -- ^ Remote port number (usually 22) + -> (Session -> IO a) -- ^ Actions to perform on handle and session + -> IO a +withSession hostname port fn = do + sock <- socketConnect hostname port + session <- initSession + setBlocking session False + handshake session sock + result <- fn session + disconnectSession session "Done." + freeSession session + return result + +-- | Check remote host against known hosts list +checkHost :: Session + -> String -- ^ Remote host name + -> Int -- ^ Remote port number (usually 22) + -> FilePath -- ^ Path to known_hosts file + -> IO KnownHostResult +checkHost s host port path = do + kh <- initKnownHosts s + _numKnownHosts <- knownHostsReadFile kh path + (hostkey, _keylen, _keytype) <- getHostKey s + result <- checkKnownHost kh host port hostkey [TYPE_PLAIN, KEYENC_RAW] + freeKnownHosts kh + return result + +-- | Execute some actions withing SSH2 channel +withChannel :: Session -> (Channel -> IO a) -> IO (Int, a) +withChannel s = withChannelBy (openChannelSession s) id + +-- | Read all data from the channel +-- +-- Although this function returns a lazy bytestring, the data is /not/ read +-- lazily. +readAllChannel :: Channel -> IO BSL.ByteString +readAllChannel ch = go [] + where + go :: [BSS.ByteString] -> IO BSL.ByteString + go acc = do + bs <- readChannel ch 0x400 + if BSS.length bs > 0 + then go (bs : acc) + else return (BSL.fromChunks $ reverse acc) + +-- | Write a lazy bytestring to the channel +writeAllChannel :: Channel -> BSL.ByteString -> IO () +writeAllChannel ch = mapM_ (writeChannel ch) . BSL.toChunks + +runShellCommands :: Session -> [String] -> IO (Int, [BSL.ByteString]) +runShellCommands s commands = withChannel s $ \ch -> do + requestPTY ch "linux" + channelShell ch + _hello <- readAllChannel ch + out <- forM commands $ \cmd -> do + writeChannel ch (BSSC.pack $ cmd ++ "\n") + r <- readAllChannel ch + return r + channelSendEOF ch + return out + +execCommands :: Session -> [String] -> IO (Int, [BSL.ByteString]) +execCommands s commands = withChannel s $ \ch -> + forM commands $ \cmd -> do + channelExecute ch cmd + readAllChannel ch + +-- | Send a file to remote host via SCP. +-- Returns size of sent data. +scpSendFile :: Session + -> Int -- ^ File creation mode (0o777, for example) + -> FilePath -- ^ Path to local file + -> FilePath -- ^ Remote file path + -> IO Integer +scpSendFile s mode local remote = do + h <- openFile local ReadMode + size <- hFileSize h + (_, result) <- withChannelBy (scpSendChannel s remote mode (fromIntegral size) 0 0) id $ \ch -> do + written <- writeChannelFromHandle ch h + channelSendEOF ch + channelWaitEOF ch + return written + hClose h + return result + +-- | Receive file from remote host via SCP. +-- Returns size of received data. +scpReceiveFile :: Session -- + -> FilePath -- ^ Remote file path + -> FilePath -- ^ Path to local file + -> IO Integer +scpReceiveFile s remote local = do + h <- openFile local WriteMode + (_, result) <- withChannelBy (scpReceiveChannel s remote) fst $ \(ch, fileSize) -> do + readChannelToHandle ch h fileSize + hClose h + return result + +-- | Generalization of 'withChannel' +withChannelBy :: IO a -- ^ Create a channel (and possibly other stuff) + -> (a -> Channel) -- ^ Extract the channel from "other stuff" + -> (a -> IO b) -- ^ Actions to execute on the channel + -> IO (Int, b) -- ^ Channel exit status and return value +withChannelBy createChannel extractChannel actions = do + stuff <- createChannel + let ch = extractChannel stuff + result <- actions stuff + closeChannel ch + exitStatus <- channelExitStatus ch + freeChannel ch + return (exitStatus, result) + diff --git a/src/Network/SSH/Client/LibSSH2/Errors.chs b/src/Network/SSH/Client/LibSSH2/Errors.chs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client/LibSSH2/Errors.chs @@ -0,0 +1,173 @@ +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances #-} + +#include + +{# context lib="ssh2" prefix="libssh2" #} + +module Network.SSH.Client.LibSSH2.Errors + (-- * Types + ErrorCode (..), + NULL_POINTER, + + -- * Utilities + IntResult (..), + + -- * Functions + getLastError, + handleInt, + handleBool, + handleNullPtr, + int2error, error2int, + blockedDirections, + threadWaitSession + ) where + +import Control.Exception +import Data.Generics +import Foreign +import Foreign.C.Types +import Control.Monad (when) + +import Network.SSH.Client.LibSSH2.Types +import Network.SSH.Client.LibSSH2.WaitSocket + +-- | Error codes returned by libssh2. +data ErrorCode = + NONE + | SOCKET_NONE + | BANNER_RECV + | BANNER_SEND + | INVALID_MAC + | KEX_FALIURE + | ALLOC + | SOCKET_SEND + | KEY_EXCHANGE_FAILURE + | TIMEOUT + | HOSTKEY_INIT + | HOSTKEY_SIGN + | DECRYPT + | SOCKET_DISCONNECT + | PROTO + | PASSWORD_EXPIRED + | FILE + | METHOD_NONE + | AUTHENTICATION_FAILED + | PUBLICKEY_UNVERIFIED + | CHANNEL_OUTOFORDER + | CHANNEL_FAILURE + | CHANNEL_REQUEST_DENIED + | CHANNEL_UNKNOWN + | CHANNEL_WINDOW_EXCEEDED + | CHANNEL_PACKET_EXCEEDED + | CHANNEL_CLOSED + | CHANNEL_EOF_SENT + | SCP_PROTOCOL + | ZLIB + | SOCKET_TIMEOUT + | SFTP_PROTOCOL + | REQUEST_DENIED + | METHOD_NOT_SUPPORTED + | INVAL + | INVALID_POLL_TYPE + | PUBLICKEY_PROTOCOL + | EAGAIN + | BUFFER_TOO_SMALL + | BAD_USE + | COMPRESS + | OUT_OF_BOUNDARY + | AGENT_PROTOCOL + | SOCKET_RECV + | ENCRYPT + | BAD_SOCKET + deriving (Eq, Show, Ord, Enum, Data, Typeable) + +instance Exception ErrorCode + +error2int :: (Num i) => ErrorCode -> i +error2int = fromIntegral . negate . fromEnum + +int2error :: (Integral i) => i -> ErrorCode +int2error = toEnum . negate . fromIntegral + +-- | Exception to throw when null pointer received +-- from libssh2. +data NULL_POINTER = NULL_POINTER + deriving (Eq, Show, Data, Typeable) + +instance Exception NULL_POINTER + +class IntResult a where + intResult :: a -> Int + +instance IntResult Int where + intResult = id + +instance IntResult (Int, a) where + intResult = fst + +instance IntResult (Int, a, b) where + intResult = \(i, _, _) -> i + +instance IntResult (Int, a, b, c) where + intResult = \(i, _, _, _) -> i + +instance IntResult CLong where + intResult = fromIntegral + +{# fun session_last_error as getLastError_ + { toPointer `Session', + alloca- `String' peekCStringPtr*, + castPtr `Ptr Int', + `Int' } -> `Int' #} + +-- | Get last error information. +getLastError :: Session -> IO (Int, String) +getLastError s = getLastError_ s nullPtr 0 + +-- | Throw an exception if negative value passed, +-- or return unchanged value. +handleInt :: (IntResult a) => Maybe Session -> IO a -> IO a +handleInt s io = do + x <- io + let r = intResult x + if r < 0 + then case int2error r of + EAGAIN -> threadWaitSession s >> handleInt s io + err -> throwIO err + else return x + +handleBool :: CInt -> IO Bool +handleBool x + | x == 0 = return False + | x > 0 = return True + | otherwise = throw (int2error x) + +-- | Throw an exception if null pointer passed, +-- or return it casted to right type. +handleNullPtr :: Maybe Session -> (Ptr () -> IO a) -> IO (Ptr ()) -> IO a +handleNullPtr s fromPointer io = do + p <- io + if p == nullPtr + then case s of + Nothing -> throw NULL_POINTER + Just session -> do + (r, _) <- getLastError session + case int2error r of + EAGAIN -> threadWaitSession (Just session) >> handleNullPtr s fromPointer io + _ -> throw NULL_POINTER -- TODO: should we throw the error instead? + else fromPointer p + +-- | Get currently blocked directions +{# fun session_block_directions as blockedDirections + { toPointer `Session' } -> `[Direction]' int2dir #} + +threadWaitSession :: Maybe Session -> IO () +threadWaitSession Nothing = error "EAGAIN thrown without session present" +threadWaitSession (Just s) = do + mSocket <- sessionGetSocket s + case mSocket of + Nothing -> error "EAGAIN thrown on session without socket" + Just socket -> do + dirs <- blockedDirections s + when (INBOUND `elem` dirs) $ threadWaitRead socket + when (OUTBOUND `elem` dirs) $ threadWaitWrite socket diff --git a/src/Network/SSH/Client/LibSSH2/Foreign.chs b/src/Network/SSH/Client/LibSSH2/Foreign.chs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client/LibSSH2/Foreign.chs @@ -0,0 +1,468 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +#include "libssh2_local.h" +#include + +{# context lib="ssh2" prefix="libssh2" #} + +module Network.SSH.Client.LibSSH2.Foreign + (-- * Types + KnownHosts, KnownHostResult (..), KnownHostType (..), KnownHost (..), + + -- * Session functions + initialize, exit, + initSession, freeSession, disconnectSession, + handshake, + setBlocking, + + -- * Known hosts functions + initKnownHosts, freeKnownHosts, knownHostsReadFile, + getHostKey, checkKnownHost, + + -- * Authentication + publicKeyAuthFile, + + -- * Channel functions + openChannelSession, closeChannel, freeChannel, + channelSendEOF, channelWaitEOF, channelIsEOF, + readChannel, writeChannel, + writeChannelFromHandle, readChannelToHandle, + channelProcess, channelExecute, channelShell, + requestPTY, requestPTYEx, + channelExitStatus, channelExitSignal, + scpSendChannel, scpReceiveChannel, + + -- * Debug + TraceFlag (..), setTraceMode + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import System.IO +import Network.Socket (Socket(MkSocket)) +import Data.Time.Clock.POSIX +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Unsafe as BSS + +import Network.SSH.Client.LibSSH2.Types +import Network.SSH.Client.LibSSH2.Errors + +-- Known host flags. See libssh2 documentation. +data KnownHostType = + TYPE_MASK + | TYPE_PLAIN + | TYPE_SHA1 + | TYPE_CUSTOM + | KEYENC_MASK + | KEYENC_RAW + | KEYENC_BASE64 + | KEY_MASK + | KEY_SHIFT + | KEY_RSA1 + | KEY_SSHRSA + | KEY_SSHDSS + deriving (Eq, Show) + +kht2int :: KnownHostType -> CInt +kht2int TYPE_MASK = 0xffff +kht2int TYPE_PLAIN = 1 +kht2int TYPE_SHA1 = 2 +kht2int TYPE_CUSTOM = 3 +kht2int KEYENC_MASK = 3 `shiftL` 16 +kht2int KEYENC_RAW = 1 `shiftL` 16 +kht2int KEYENC_BASE64 = 2 `shiftL` 16 +kht2int KEY_MASK = 3 `shiftL` 18 +kht2int KEY_SHIFT = 18 +kht2int KEY_RSA1 = 1 `shiftL` 18 +kht2int KEY_SSHRSA = 2 `shiftL` 18 +kht2int KEY_SSHDSS = 3 `shiftL` 18 + +typemask2int :: [KnownHostType] -> CInt +typemask2int list = foldr (.|.) 0 (map kht2int list) + +-- Result of matching host against known_hosts. +data KnownHostResult = + MATCH + | MISMATCH + | NOTFOUND + | FAILURE + deriving (Eq, Show, Ord, Enum) + +int2khresult :: CInt -> KnownHostResult +int2khresult = toEnum . fromIntegral + +data KnownHost = KnownHost { + khMagic :: CUInt, + khNode :: Ptr (), + khName :: String, + khKey :: String, + khTypeMask :: [KnownHostType] } + deriving (Eq, Show) + +init_crypto :: Bool -> CInt +init_crypto False = 1 +init_crypto True = 0 + +ssh2socket :: Socket +#ifdef mingw32_HOST_OS + -> CUInt +#else + -> CInt +#endif +ssh2socket (MkSocket s _ _ _ _) = +#ifdef mingw32_HOST_OS + (fromIntegral s) +#else + s +#endif + +{# fun init as initialize_ + { init_crypto `Bool' } -> `Int' #} + +-- | Initialize libssh2. Pass True to enable encryption +-- or False to disable it. +initialize :: Bool -> IO () +initialize flags = void . handleInt Nothing $ initialize_ flags + +-- | Deinitialize libssh2. +#ifdef mingw32_HOST_OS +foreign import ccall safe "libssh2_exit" + exit:: IO () +#else +{# fun exit as exit { } -> `()' #} +#endif + +-- | Create Session object +initSession :: IO Session +initSession = handleNullPtr Nothing sessionFromPointer $ + {# call session_init_ex #} nullFunPtr nullFunPtr nullFunPtr nullPtr + +{# fun session_free as freeSession_ + { toPointer `Session' } -> `Int' #} + +-- | Free Session object's memory +freeSession :: Session -> IO () +freeSession session = void . handleInt (Just session) $ freeSession_ session + +{# fun session_disconnect_ex as disconnectSessionEx + { toPointer `Session', `Int', `String', `String' } -> `Int' #} + +-- | Disconnect session (but do not free memory) +disconnectSession :: Session + -> String -- ^ Goodbye message + -> IO () +disconnectSession s msg = void . handleInt (Just s) $ disconnectSessionEx s 11 msg "" + +{# fun session_set_blocking as setBlocking + { toPointer `Session', bool2int `Bool' } -> `()' #} + +bool2int :: Bool -> CInt +bool2int True = 1 +bool2int False = 0 + +{# fun session_handshake as handshake_ + { toPointer `Session', ssh2socket `Socket' } -> `Int' #} + +-- | Run SSH handshake on network socket. +handshake :: Session -> Socket -> IO () +handshake session socket = do + sessionSetSocket session (Just socket) + void . handleInt (Just session) $ handshake_ session socket + +{# fun knownhost_init as initKnownHosts_ + { toPointer `Session' } -> `Ptr ()' id #} + +-- | Create KnownHosts object for given session. +initKnownHosts :: Session -> IO KnownHosts +initKnownHosts session = handleNullPtr Nothing knownHostsFromPointer $ initKnownHosts_ session + +-- | Free KnownHosts object's memory +{# fun knownhost_free as freeKnownHosts + { toPointer `KnownHosts' } -> `()' #} + +{# fun knownhost_readfile as knownHostsReadFile_ + { toPointer `KnownHosts', `String', id `CInt' } -> `Int' #} + +-- | Read known hosts from file +knownHostsReadFile :: KnownHosts + -> FilePath -- ^ Path to known_hosts file + -> IO Int +knownHostsReadFile kh path = handleInt Nothing $ knownHostsReadFile_ kh path 1 + +-- | Get remote host public key +{# fun session_hostkey as getHostKey + { toPointer `Session', alloca- `Size' peek*, alloca- `CInt' peek* } -> `String' #} + +{# fun knownhost_checkp as checkKnownHost_ + { toPointer `KnownHosts', + `String', + `Int', + `String', + `Int', + typemask2int `[KnownHostType]', + castPtr `Ptr ()' } -> `KnownHostResult' int2khresult #} + +-- | Check host data against known hosts. +checkKnownHost :: KnownHosts -- + -> String -- ^ Host name + -> Int -- ^ Port number (usually 22) + -> String -- ^ Host public key + -> [KnownHostType] -- ^ Host flags (see libssh2 documentation) + -> IO KnownHostResult +checkKnownHost kh host port key flags = checkKnownHost_ kh host port key (length key) flags nullPtr + +-- TODO: I don't see the '&' in the libssh2 docs? +{# fun userauth_publickey_fromfile_ex as publicKeyAuthFile_ + { toPointer `Session', + `String' &, + `String', + `String', + `String' } -> `Int' #} + +-- | Perform public key authentication. +publicKeyAuthFile :: Session -- ^ Session + -> String -- ^ Username + -> String -- ^ Path to public key + -> String -- ^ Path to private key + -> String -- ^ Passphrase + -> IO () +publicKeyAuthFile session username public private passphrase = void . handleInt (Just session) $ + publicKeyAuthFile_ session username public private passphrase + +{# fun channel_open_ex as openSessionChannelEx + { toPointer `Session', + `String' &, + `Int', `Int', + `String' & } -> `Ptr ()' id #} + +-- | Open a channel for session. +openChannelSession :: Session -> IO Channel +openChannelSession s = handleNullPtr (Just s) (channelFromPointer s) $ + openSessionChannelEx s "session" 65536 32768 "" + +channelProcess :: Channel -> String -> String -> IO () +channelProcess ch kind command = void . handleInt (Just $ channelSession ch) $ + channelProcessStartup_ ch kind command + +-- | Execute command +channelExecute :: Channel -> String -> IO () +channelExecute c command = channelProcess c "exec" command + +{# fun channel_process_startup as channelProcessStartup_ + { toPointer `Channel', + `String' &, + `String' & } -> `Int' #} + +-- | Execute shell command +channelShell :: Channel -> IO () +channelShell c = void . handleInt (Just $ channelSession c) $ channelProcessStartup_ c "shell" "" + +{# fun channel_request_pty_ex as requestPTYEx + { toPointer `Channel', + `String' &, + `String' &, + `Int', `Int', + `Int', `Int' } -> `Int' #} + +requestPTY :: Channel -> String -> IO () +requestPTY ch term = void . handleInt (Just $ channelSession ch) $ requestPTYEx ch term "" 0 0 0 0 + +readChannelEx :: Channel -> Int -> Size -> IO BSS.ByteString +readChannelEx ch i size = + allocaBytes (fromIntegral size) $ \buffer -> do + rc <- handleInt (Just $ channelSession ch) $ {# call channel_read_ex #} (toPointer ch) (fromIntegral i) buffer size + BSS.packCStringLen (buffer, fromIntegral rc) + +-- | Read data from channel. +readChannel :: Channel -- + -> Size -- ^ Amount of data to read + -> IO BSS.ByteString +readChannel c sz = readChannelEx c 0 sz + +-- | Write data to channel. +writeChannel :: Channel -> BSS.ByteString -> IO () +writeChannel ch bs = + BSS.unsafeUseAsCString bs $ go 0 (fromIntegral $ BSS.length bs) + where + go :: Int -> CULong -> CString -> IO () + go offset len cstr = do + written <- handleInt (Just $ channelSession ch) + $ {# call channel_write_ex #} (toPointer ch) + 0 + (cstr `plusPtr` offset) +#ifdef mingw32_HOST_OS + (fromIntegral len) +#else + len +#endif + if fromIntegral written < len + then go (offset + fromIntegral written) (len - fromIntegral written) cstr + else return () + +{# fun channel_send_eof as channelSendEOF_ + { toPointer `Channel' } -> `Int' #} + +channelSendEOF :: Channel -> IO () +channelSendEOF channel = void . handleInt (Just $ channelSession channel) $ channelSendEOF_ channel + +{# fun channel_wait_eof as channelWaitEOF_ + { toPointer `Channel' } -> `Int' #} + +channelWaitEOF :: Channel -> IO () +channelWaitEOF channel = void . handleInt (Just $ channelSession channel) $ channelWaitEOF_ channel + +data TraceFlag = + T_TRANS + | T_KEX + | T_AUTH + | T_CONN + | T_SCP + | T_SFTP + | T_ERROR + | T_PUBLICKEY + | T_SOCKET + deriving (Eq, Show) + +tf2int :: TraceFlag -> CInt +tf2int T_TRANS = 1 `shiftL` 1 +tf2int T_KEX = 1 `shiftL` 2 +tf2int T_AUTH = 1 `shiftL` 3 +tf2int T_CONN = 1 `shiftL` 4 +tf2int T_SCP = 1 `shiftL` 5 +tf2int T_SFTP = 1 `shiftL` 6 +tf2int T_ERROR = 1 `shiftL` 7 +tf2int T_PUBLICKEY = 1 `shiftL` 8 +tf2int T_SOCKET = 1 `shiftL` 9 + +trace2int :: [TraceFlag] -> CInt +trace2int flags = foldr (.|.) 0 (map tf2int flags) + +{# fun trace as setTraceMode + { toPointer `Session', trace2int `[TraceFlag]' } -> `()' #} + +-- | Write all data to channel from handle. +-- Returns amount of transferred data. +writeChannelFromHandle :: Channel -> Handle -> IO Integer +writeChannelFromHandle ch h = + let + go :: Integer -> Ptr a -> IO Integer + go done buffer = do + sz <- hGetBuf h buffer bufferSize + send 0 (fromIntegral sz) buffer + let newDone = done + fromIntegral sz + if sz < bufferSize + then return newDone + else go newDone buffer + + send :: Int -> CLong -> Ptr a -> IO () + send _ 0 _ = return () + send written size buffer = do + sent <- handleInt (Just $ channelSession ch) $ + {# call channel_write_ex #} + (toPointer ch) + 0 + (plusPtr buffer written) + (fromIntegral size) + send (written + fromIntegral sent) (size - sent) buffer + + bufferSize = 0x100000 + + in allocaBytes bufferSize $ go 0 + +-- | Read all data from channel to handle. +-- Returns amount of transferred data. +readChannelToHandle :: Channel -> Handle -> Offset -> IO Integer +readChannelToHandle ch h fileSize = do + allocaBytes bufferSize $ \buffer -> + readChannelCB ch buffer bufferSize fileSize callback + where + callback buffer size = hPutBuf h buffer size + + bufferSize :: Int + bufferSize = 0x100000 + +readChannelCB :: Channel -> CString -> Int -> Offset -> (CString -> Int -> IO ()) -> IO Integer +readChannelCB ch buffer bufferSize fileSize callback = + let go got = do + let toRead = min (fromIntegral fileSize - got) (fromIntegral bufferSize) + sz <- handleInt (Just $ channelSession ch) $ + {# call channel_read_ex #} + (toPointer ch) + 0 + buffer + (fromIntegral toRead) + let isz :: Integer + isz = fromIntegral sz + callback buffer (fromIntegral sz) + eof <- {# call channel_eof #} (toPointer ch) + let newGot = got + fromIntegral sz + if (eof == 1) || (newGot == fromIntegral fileSize) + then do + return isz + else do + rest <- go newGot + return $ isz + rest + in go (0 :: Integer) + +{# fun channel_eof as channelIsEOF + { toPointer `Channel' } -> `Bool' handleBool* #} + +{# fun channel_close as closeChannel_ + { toPointer `Channel' } -> `Int' #} + +-- | Close channel (but do not free memory) +closeChannel :: Channel -> IO () +closeChannel channel = void . handleInt (Just $ channelSession channel) $ closeChannel_ channel + +{# fun channel_free as freeChannel_ + { toPointer `Channel' } -> `Int' #} + +-- | Free channel object's memory +freeChannel :: Channel -> IO () +freeChannel channel = void . handleInt (Just $ channelSession channel) $ freeChannel_ channel + +-- | Get channel exit status +{# fun channel_get_exit_status as channelExitStatus + { toPointer `Channel' } -> `Int' #} + +{# fun channel_get_exit_signal as channelExitSignal_ + { toPointer `Channel', + alloca- `String' peekCStringPtr*, + castPtr `Ptr Int', + alloca- `Maybe String' peekMaybeCStringPtr*, + castPtr `Ptr Int', + alloca- `Maybe String' peekMaybeCStringPtr*, + castPtr `Ptr Int' } -> `Int' #} + +-- | Get channel exit signal. Returns: +-- (possibly error code, exit signal name, possibly error message, possibly language code). +channelExitSignal :: Channel -> IO (Int, String, Maybe String, Maybe String) +channelExitSignal ch = handleInt (Just $ channelSession ch) $ channelExitSignal_ ch nullPtr nullPtr nullPtr + +{# fun scp_send64 as scpSendChannel_ + { toPointer `Session', + `String', + `Int', + `Int64', + round `POSIXTime', + round `POSIXTime' } -> `Ptr ()' id #} + +-- | Create SCP file send channel. +scpSendChannel :: Session -> String -> Int -> Int64 -> POSIXTime -> POSIXTime -> IO Channel +scpSendChannel session remotePath mode size mtime atime = handleNullPtr (Just session) (channelFromPointer session) $ + scpSendChannel_ session remotePath mode size mtime atime + +type Offset = {# type off_t #} + +-- {# pointer *stat_t as Stat newtype #} + +-- | Create SCP file receive channel. +-- TODO: receive struct stat also. +scpReceiveChannel :: Session -> FilePath -> IO (Channel, Offset) +scpReceiveChannel s path = do + withCString path $ \pathptr -> + allocaBytes {# sizeof stat_t #} $ \statptr -> do + channel <- handleNullPtr (Just s) (channelFromPointer s) $ {# call scp_recv #} (toPointer s) pathptr statptr + size <- {# get stat_t->st_size #} statptr + return (channel, size) diff --git a/src/Network/SSH/Client/LibSSH2/Types.chs b/src/Network/SSH/Client/LibSSH2/Types.chs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client/LibSSH2/Types.chs @@ -0,0 +1,126 @@ +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, StandaloneDeriving #-} + +#include + +{# context lib="ssh2" prefix="libssh2" #} + +module Network.SSH.Client.LibSSH2.Types + (Session, + KnownHosts, + Channel, + ToPointer (..), + Direction (..), + int2dir, + CStringCLen, + Size, SSize, + withCStringLenIntConv, + peekCStringPtr, + peekMaybeCStringPtr, + channelFromPointer, + knownHostsFromPointer, + sessionFromPointer, + sessionGetSocket, + sessionSetSocket, + channelSession + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Data.Generics +import Data.IORef +import Network.Socket + +type Size = {# type size_t #} + +type SSize = {# type ssize_t #} + +type CStringCLen i = (CString, i) + +withCStringLenIntConv :: (Integral i) => String -> (CStringCLen i -> IO a) -> IO a +withCStringLenIntConv str fn = + withCStringLen str (\(ptr, len) -> fn (ptr, fromIntegral len)) + +peekCStringPtr :: Ptr CString -> IO String +peekCStringPtr ptr = peekCAString =<< peek ptr + +peekMaybeCStringPtr :: Ptr CString -> IO (Maybe String) +peekMaybeCStringPtr ptr = do + strPtr <- peek ptr + if strPtr == nullPtr + then return Nothing + else Just `fmap` peekCAString strPtr + +class ToPointer p where + toPointer :: p -> Ptr () + +{# pointer *SESSION as CSession #} + +data Session = Session { sessionPtr :: CSession + , sessionSocketRef :: IORef (Maybe Socket) + } + +sessionFromPointer :: Ptr () -> IO Session +sessionFromPointer ptr = do + socketRef <- newIORef Nothing + return $ Session (castPtr ptr) socketRef + +sessionGetSocket :: Session -> IO (Maybe Socket) +sessionGetSocket = readIORef . sessionSocketRef + +sessionSetSocket :: Session -> Maybe Socket -> IO () +sessionSetSocket session = writeIORef (sessionSocketRef session) + +deriving instance Eq Session +deriving instance Data Session +deriving instance Typeable Session + +instance Show Session where + show session = "" + +instance ToPointer Session where + toPointer = castPtr . sessionPtr + +{# pointer *KNOWNHOSTS as KnownHosts newtype #} + +knownHostsFromPointer :: Ptr () -> IO KnownHosts +knownHostsFromPointer ptr = return $ KnownHosts (castPtr ptr) + +deriving instance Eq KnownHosts +deriving instance Data KnownHosts +deriving instance Typeable KnownHosts + +instance Show KnownHosts where + show (KnownHosts p) = "" + +instance ToPointer KnownHosts where + toPointer (KnownHosts p) = castPtr p + +{# pointer *CHANNEL as CChannel #} + +data Channel = Channel { channelPtr :: CChannel + , channelSession :: Session + } + +channelFromPointer :: Session -> Ptr () -> IO Channel +channelFromPointer session ptr = return $ Channel (castPtr ptr) session + +deriving instance Eq Channel +deriving instance Data Channel +deriving instance Typeable Channel + +instance Show Channel where + show channel = "" + +instance ToPointer Channel where + toPointer = castPtr . channelPtr + +-- | Session directions +data Direction = INBOUND | OUTBOUND + deriving (Eq, Show) + +int2dir :: (Eq a, Num a, Show a) => a -> [Direction] +int2dir 1 = [INBOUND] +int2dir 2 = [OUTBOUND] +int2dir 3 = [INBOUND, OUTBOUND] +int2dir x = error $ "Unknown direction: " ++ show x diff --git a/src/Network/SSH/Client/LibSSH2/WaitSocket.hs b/src/Network/SSH/Client/LibSSH2/WaitSocket.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client/LibSSH2/WaitSocket.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +-- | Block until a read or write operation on a socket would succeed +-- +-- On most platforms this uses 'Control.Concurrent.threadWaitRead' or +-- 'Conctrol.Concurrent.threadWaitWrite', but on Windows we need to do +-- something different. +-- +-- See . +module Network.SSH.Client.LibSSH2.WaitSocket + ( threadWaitRead + , threadWaitWrite + ) where + +import Network.Socket(Socket,fdSocket) +import System.Posix.Types(Fd(Fd)) + +#ifdef mingw32_HOST_OS +import Control.Concurrent(forkIO,newEmptyMVar,putMVar,takeMVar) +import Control.Exception(IOException,throwIO,try) +import Control.Exception.Base(mask_) +import Foreign.C.Error(throwErrnoIfMinus1_) +import Foreign.C.Types(CInt(CInt)) +import System.IO(hWaitForInput,stdin) +#else +import qualified GHC.Conc (threadWaitRead, threadWaitWrite) +#endif + +threadWaitRead :: Socket -> IO () +threadWaitRead = threadWaitRead_ . Fd . fdSocket + +threadWaitWrite :: Socket -> IO () +threadWaitWrite = threadWaitWrite_ . Fd . fdSocket + +-- | Block the current thread until data is available to read on the +-- given file descriptor (GHC only). +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitRead', use +-- 'GHC.Conc.closeFdWith'. +threadWaitRead_ :: Fd -> IO () +threadWaitRead_ fd +#ifdef mingw32_HOST_OS + -- We have no IO manager implementing threadWaitRead on Windows. + -- fdReady does the right thing, but we have to call it in a + -- separate thread, otherwise threadWaitRead won't be interruptible, + -- and this only works with -threaded. + | threaded = withThread (waitFd fd 0) + | otherwise = case fd of + 0 -> do + -- hWaitForInput does work properly, but we can only + -- do this for stdin since we know its FD. + _ <- hWaitForInput stdin (-1) + return () + _ -> + error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" +#else + = GHC.Conc.threadWaitRead fd +#endif + +-- | Block the current thread until data can be written to the +-- given file descriptor (GHC only). +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitWrite', use +-- 'GHC.Conc.closeFdWith'. +threadWaitWrite_ :: Fd -> IO () +threadWaitWrite_ fd +#ifdef mingw32_HOST_OS + | threaded = withThread (waitFd fd 1) + | otherwise = error "threadWaitWrite requires -threaded on Windows" +#else + = GHC.Conc.threadWaitWrite fd +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded:: Bool + +withThread :: IO a -> IO a +withThread io = do + m <- newEmptyMVar + _ <- mask_ $ forkIO $ try io >>= putMVar m + x <- takeMVar m + case x of + Right a -> return a + Left e -> throwIO (e :: IOException) + +-- The last argument can be 1 (true) because this will only be applied to +-- sockets +waitFd :: Fd -> CInt -> IO () +waitFd fd write = + throwErrnoIfMinus1_ "fdReady" $ fdReady (fromIntegral fd) write iNFINITE 1 + where + iNFINITE :: CInt + iNFINITE = 0xFFFFFFFF -- urgh + +foreign import ccall safe "fdReady" + fdReady:: CInt -- ^ fd + -> CInt -- ^ write + -> CInt -- ^ msecs + -> CInt -- ^ isSock + -> IO CInt +#endif diff --git a/ssh-client.hs b/ssh-client.hs --- a/ssh-client.hs +++ b/ssh-client.hs @@ -1,4 +1,4 @@ - +import qualified Data.ByteString.Lazy as BSL import System.Environment import System.FilePath import Codec.Binary.UTF8.String @@ -15,43 +15,21 @@ _ -> putStrLn "Synopsis: ssh-client USERNAME HOSTNAME PORT COMMAND" runCommand login host port command = - ssh login host port $ \ch -> do + ssh login host port $ \s -> + withChannel s $ \ch -> do channelExecute ch command result <- readAllChannel ch - let r = decodeString result - print (length result) - print (length r) - putStrLn r - -sendFile login host port path = do - initialize True - home <- getEnv "HOME" - let known_hosts = home ".ssh" "known_hosts" - public = home ".ssh" "id_rsa.pub" - private = home ".ssh" "id_rsa" - - withSession host port $ \_ s -> do - r <- checkHost s host port known_hosts - print r - publicKeyAuthFile s login public private "" - sz <- scpSendFile s 0o644 path (takeFileName path) - putStrLn $ "Sent: " ++ show sz ++ " bytes." - exit + BSL.putStr result -receiveFile login host port path = do - initialize True - home <- getEnv "HOME" - let known_hosts = home ".ssh" "known_hosts" - public = home ".ssh" "id_rsa.pub" - private = home ".ssh" "id_rsa" +sendFile login host port path = + ssh login host port $ \s -> do + sz <- scpSendFile s 0o644 path (takeFileName path) + putStrLn $ "Sent: " ++ show sz ++ " bytes." - withSession host port $ \_ s -> do - r <- checkHost s host port known_hosts - print r - publicKeyAuthFile s login public private "" - sz <- scpReceiveFile s (takeFileName path) path - putStrLn $ "Received: " ++ show sz ++ " bytes." - exit +receiveFile login host port path = + ssh login host port $ \s -> do + sz <- scpReceiveFile s (takeFileName path) path + putStrLn $ "Received: " ++ show sz ++ " bytes." ssh login host port actions = do initialize True @@ -59,5 +37,5 @@ let known_hosts = home ".ssh" "known_hosts" public = home ".ssh" "id_rsa.pub" private = home ".ssh" "id_rsa" - withSSH2 known_hosts public private login host port $ actions + withSSH2 known_hosts public private "" login host port $ actions exit