libssh2 0.1 → 0.2
raw patch · 11 files changed
+1093/−936 lines, 11 filesdep +bytestringdep +filepathdep +libssh2dep ~basedep ~networkdep ~sybnew-component:exe:hs-ssh-client
Dependencies added: bytestring, filepath, libssh2, utf8-string
Dependency ranges changed: base, network, syb
Files
- Network/SSH/Client/LibSSH2.hs +0/−203
- Network/SSH/Client/LibSSH2/Errors.chs +0/−163
- Network/SSH/Client/LibSSH2/Foreign.chs +0/−444
- Network/SSH/Client/LibSSH2/Types.chs +0/−87
- libssh2.cabal +32/−4
- src/Network/SSH/Client/LibSSH2.hs +178/−0
- src/Network/SSH/Client/LibSSH2/Errors.chs +173/−0
- src/Network/SSH/Client/LibSSH2/Foreign.chs +468/−0
- src/Network/SSH/Client/LibSSH2/Types.chs +126/−0
- src/Network/SSH/Client/LibSSH2/WaitSocket.hs +103/−0
- ssh-client.hs +13/−35
− Network/SSH/Client/LibSSH2.hs
@@ -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 )-
− Network/SSH/Client/LibSSH2/Errors.chs
@@ -1,163 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}--#include <libssh2.h>--{# 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)-
− Network/SSH/Client/LibSSH2/Foreign.chs
@@ -1,444 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--#include "libssh2_local.h"-#include <libssh2.h>--{# 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)--
− Network/SSH/Client/LibSSH2/Types.chs
@@ -1,87 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, StandaloneDeriving #-}--#include <libssh2.h>--{# 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) = "<libssh2 session: " ++ show 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) = "<libssh2 known hosts: " ++ show 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) = "<libssh2 channel: " ++ show p ++ ">"--instance IsPointer Channel where- fromPointer p = Channel (castPtr p)- toPointer (Channel p) = castPtr p-
libssh2.cabal view
@@ -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 + <http://mingw.org/>, with <http://www.openssl.org/> and+ <http://libssh2.org/> 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
+ src/Network/SSH/Client/LibSSH2.hs view
@@ -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)+
+ src/Network/SSH/Client/LibSSH2/Errors.chs view
@@ -0,0 +1,173 @@+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances #-}++#include <libssh2.h>++{# 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
+ src/Network/SSH/Client/LibSSH2/Foreign.chs view
@@ -0,0 +1,468 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++#include "libssh2_local.h"+#include <libssh2.h>++{# 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)
+ src/Network/SSH/Client/LibSSH2/Types.chs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, StandaloneDeriving #-}++#include <libssh2.h>++{# 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 = "<libssh2 session: " ++ show (sessionPtr 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) = "<libssh2 known hosts: " ++ show 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 = "<libssh2 channel: " ++ show (channelPtr 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
+ src/Network/SSH/Client/LibSSH2/WaitSocket.hs view
@@ -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 <http://hackage.haskell.org/trac/ghc/ticket/5797>.+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
ssh-client.hs view
@@ -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