diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, IlyaPortnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of IlyaPortnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,19 @@ +LIBS=-lssh2 +GHC=ghc $(LIBS) --make +C2HS=c2hs -C"-Iinclude/" +HSFILES=Network/SSH/Client/LibSSH2.hs Network/SSH/Client/LibSSH2/Types.hs Network/SSH/Client/LibSSH2/Errors.hs Network/SSH/Client/LibSSH2/Foreign.hs + +all: ssh-client + +ssh-client: ssh-client.hs $(HSFILES) + $(GHC) $< + +%.hs: %.chs + $(C2HS) $< + +clean: + find . -name \*.hi -delete + find . -name \*.chi -delete + find . -name \*.o -delete + find . -name \*.chs.h -delete + rm -f ssh-client diff --git a/Network/SSH/Client/LibSSH2.hs b/Network/SSH/Client/LibSSH2.hs new file mode 100644 --- /dev/null +++ b/Network/SSH/Client/LibSSH2.hs @@ -0,0 +1,203 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Network/SSH/Client/LibSSH2/Errors.chs @@ -0,0 +1,163 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Network/SSH/Client/LibSSH2/Foreign.chs @@ -0,0 +1,444 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Network/SSH/Client/LibSSH2/Types.chs @@ -0,0 +1,87 @@ +{-# 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/include/libssh2_local.h b/include/libssh2_local.h new file mode 100644 --- /dev/null +++ b/include/libssh2_local.h @@ -0,0 +1,7 @@ + +#include + +// This definition is used to determine sizeof(struct stat), +// because c2hs lacks support for such case. +typedef struct stat stat_t; + diff --git a/libssh2.cabal b/libssh2.cabal new file mode 100644 --- /dev/null +++ b/libssh2.cabal @@ -0,0 +1,49 @@ +Name: libssh2 + +Version: 0.1 + +Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) + +Description: This package provides FFI bindings for SSH2 client library named libssh2. + +Homepage: http://redmine.iportnov.ru/projects/libssh2-hs + +License: BSD3 + +License-file: LICENSE + +Author: IlyaPortnov + +Maintainer: portnov84@rambler.ru + +-- A copyright notice. +-- Copyright: + +Category: Network + +Build-type: Simple + +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 + + +Library + Exposed-modules: Network.SSH.Client.LibSSH2.Types + Network.SSH.Client.LibSSH2.Foreign + Network.SSH.Client.LibSSH2.Errors + 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 + + Extra-libraries: "ssh2" + + -- Other-modules: + + Build-tools: c2hs + diff --git a/ssh-client.hs b/ssh-client.hs new file mode 100644 --- /dev/null +++ b/ssh-client.hs @@ -0,0 +1,63 @@ + +import System.Environment +import System.FilePath +import Codec.Binary.UTF8.String + +import Network.SSH.Client.LibSSH2.Foreign +import Network.SSH.Client.LibSSH2 + +main = do + args <- getArgs + case args of + ["command", user, host, port, cmd] -> runCommand user host (read port) cmd + ["send", user, host, port, path] -> sendFile user host (read port) path + ["receive", user, host, port, path] -> receiveFile user host (read port) path + _ -> putStrLn "Synopsis: ssh-client USERNAME HOSTNAME PORT COMMAND" + +runCommand login host port command = + ssh login host port $ \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 + +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" + + 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 + +ssh login host port actions = do + initialize True + home <- getEnv "HOME" + 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 + exit