diff --git a/libssh2.cabal b/libssh2.cabal --- a/libssh2.cabal +++ b/libssh2.cabal @@ -1,6 +1,6 @@ Name: libssh2 -Version: 0.2.0.4 +Version: 0.2.0.5 Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) @@ -62,7 +62,7 @@ Build-depends: base >= 4 && < 5, network >= 2.3, syb >= 0.3.3, time >= 1.2, - bytestring >= 0.9 + bytestring >= 0.9, select >= 0.4 Extra-libraries: "ssh2" pkgconfig-depends: libssh2 >= 1.2.8 diff --git a/src/Network/SSH/Client/LibSSH2.hs b/src/Network/SSH/Client/LibSSH2.hs --- a/src/Network/SSH/Client/LibSSH2.hs +++ b/src/Network/SSH/Client/LibSSH2.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.SSH.Client.LibSSH2 (-- * Types - Session, Channel, KnownHosts, + Session, Channel, KnownHosts, Sftp, SftpHandle, + SftpAttributes, SftpList, SftpFileTransferFlags, -- * Functions withSSH2, @@ -17,6 +18,16 @@ runShellCommands, execCommands, + -- * Sftp Functions + withSFTP, + withSFTPUser, + sftpListDir, + sftpRenameFile, + sftpSendFile, sftpSendFromHandle, + sftpReceiveFile, sftpReadFileToHandler, + sftpFstat, + sftpDeleteFile, + -- * Utilities socketConnect, sessionInit, @@ -143,10 +154,10 @@ where go :: [BSS.ByteString] -> IO BSL.ByteString go acc = do - bs <- do i <- pollChannelRead_ ch - if i == 1 - then readChannel ch 0x400 - else return BSS.empty + bs <- do isReadable <- pollChannelRead ch + if isReadable + then readChannel ch 0x400 + else return BSS.empty if BSS.length bs > 0 then go (bs : acc) else return (BSL.fromChunks $ reverse acc) @@ -218,3 +229,126 @@ freeChannel ch return (exitStatus, result) +-- | Execute some actions within SFTP connection. +-- Uses public key authentication. +withSFTP :: 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) + -> (Sftp -> IO a) -- ^ Actions to perform on sftp session + -> IO a +withSFTP 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 + withSftpSession s fn + +-- | Execute some actions within SFTP connection. +-- Uses username/password authentication. +withSFTPUser :: FilePath -- ^ Path to known_hosts file + -> String -- ^ Remote user name + -> String -- ^ Remote password + -> String -- ^ Remote host name + -> Int -- ^ Remote port number (usually 22) + -> (Sftp -> IO a) -- ^ Actions to perform on sftp session + -> IO a +withSFTPUser known_hosts login password 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 + usernamePasswordAuth s login password + withSftpSession s fn + +-- | Execute some actions within SFTP session +withSftpSession :: Session -- ^ Remote host name + -> (Sftp -> IO a) -- ^ Actions to perform on sftp session + -> IO a +withSftpSession session = + E.bracket (sftpInit session) sftpShutdown + +type SftpList = [(BSS.ByteString, SftpAttributes)] + +-- | Reads directory information +-- Returns the list of files with attributes, directory . and .. +-- are not excluded +sftpListDir :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Remote directory to read + -> IO SftpList +sftpListDir sftp path = + let + collectFiles :: SftpHandle -> SftpList -> IO SftpList + collectFiles h acc = do + v <- sftpReadDir h + case v of + Nothing -> return acc + Just r -> collectFiles h (r : acc) + in + withDirList sftp path $ \h -> + collectFiles h [] + +withDirList :: Sftp + -> FilePath + -> (SftpHandle -> IO a) + -> IO a +withDirList sftp path = E.bracket (sftpOpenDir sftp path) sftpCloseHandle + + +-- | Send a file to remote host via SFTP +-- Returns size of sent data. +sftpSendFile :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Path to local file + -> FilePath -- ^ Remote file path + -> Int -- ^ File creation mode (0o777, for example) + -> IO Integer +sftpSendFile sftp local remote mode = + withFile local ReadMode $ \fh -> + sftpSendFromHandle sftp fh remote mode + +-- | Send a file to remote host via SFTP +-- Returns size of sent data. +sftpSendFromHandle :: Sftp -- ^ Opened sftp session + -> Handle -- ^ Handle to read from + -> FilePath -- ^ Remote file path + -> Int -- ^ File creation mode (0o777, for example) + -> IO Integer +sftpSendFromHandle sftp fh remote mode = do + let flags = [FXF_WRITE, FXF_CREAT, FXF_TRUNC, FXF_EXCL] + withOpenSftpFile sftp remote mode flags $ \sftph -> + sftpWriteFileFromHandler sftph fh + +-- | Received a file from remote host via SFTP +-- Returns size of received data. +sftpReceiveFile :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Path to local file + -> FilePath -- ^ Remote file path + -> IO Integer +sftpReceiveFile sftp local remote = + withFile local WriteMode $ \fh -> + sftpReceiveToHandle sftp remote fh + +-- | Received a file from remote host via SFTP +-- Returns size of received data. +sftpReceiveToHandle :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Path to remote file + -> Handle -- ^ Open handle to write to + -> IO Integer +sftpReceiveToHandle sftp remote fh = do + result <- withOpenSftpFile sftp remote 0 [FXF_READ] $ \sftph -> do + fstat <- sftpFstat sftph + sftpReadFileToHandler sftph fh (fromIntegral $ saFileSize fstat) + return $ fromIntegral result + +withOpenSftpFile :: Sftp + -> FilePath + -> Int + -> [SftpFileTransferFlags] + -> (SftpHandle -> IO a) + -> IO a +withOpenSftpFile sftp path mode flags = + E.bracket (sftpOpenFile sftp path mode flags) sftpCloseHandle diff --git a/src/Network/SSH/Client/LibSSH2/Errors.chs b/src/Network/SSH/Client/LibSSH2/Errors.chs --- a/src/Network/SSH/Client/LibSSH2/Errors.chs +++ b/src/Network/SSH/Client/LibSSH2/Errors.chs @@ -8,12 +8,14 @@ #endif #include +#include {# context lib="ssh2" prefix="libssh2" #} module Network.SSH.Client.LibSSH2.Errors (-- * Types ErrorCode (..), + SftpErrorCode (..), NULL_POINTER, -- * Utilities @@ -21,10 +23,12 @@ -- * Functions getLastError, + getLastSftpError, handleInt, handleBool, handleNullPtr, int2error, error2int, + int2sftperror, sftperror2int, blockedDirections, threadWaitSession ) where @@ -140,15 +144,18 @@ -- | Throw an exception if negative value passed, -- or return unchanged value. -handleInt :: (IntResult a) => Maybe Session -> IO a -> IO a +handleInt :: (IntResult a, SshCtx ctx) => Maybe ctx -> 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 + err -> + case s of + Nothing -> throw err + Just ctx -> throwCtxSpecificError ctx err + else return x handleBool :: CInt -> IO Bool handleBool x @@ -158,32 +165,99 @@ -- | 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 +handleNullPtr :: (SshCtx c) => Maybe c -> (Ptr () -> IO a) -> IO (Ptr ()) -> IO a +handleNullPtr m_ctx fromPointer io = do + ptr <- io + if ptr == nullPtr + then case m_ctx of + Nothing -> throw NULL_POINTER + Just ctx -> do + let session = getSession ctx (r, _) <- getLastError session case int2error r of - EAGAIN -> threadWaitSession (Just session) >> handleNullPtr s fromPointer io - err -> throw err - else fromPointer p + EAGAIN -> threadWaitSession (Just session) >> handleNullPtr m_ctx fromPointer io + err -> throwCtxSpecificError ctx err + else fromPointer ptr -- | Get currently blocked directions {# fun session_block_directions as blockedDirections { toPointer `Session' } -> `[Direction]' int2dir #} -threadWaitSession :: Maybe Session -> IO () +threadWaitSession :: (SshCtx ctx) => Maybe ctx -> IO () threadWaitSession Nothing = error "EAGAIN thrown without session present" -threadWaitSession (Just s) = do +threadWaitSession (Just ctx) = do + let s = getSession ctx mSocket <- sessionGetSocket s case mSocket of Nothing -> error "EAGAIN thrown on session without socket" - Just socket -> do + Just socket -> do dirs <- blockedDirections s if (OUTBOUND `elem` dirs) then threadWaitWrite socket else threadWaitRead socket +-- | Sftp + +{# fun sftp_last_error as getLastSftpError_ + {toPointer `Sftp'} -> `Int' #} + +-- | Get last sftp related error. +getLastSftpError :: Sftp -> IO Int +getLastSftpError sftp = getLastSftpError_ sftp + +sftperror2int :: (Num i) => SftpErrorCode -> i +sftperror2int = fromIntegral . fromEnum + +int2sftperror :: (Integral i) => i -> SftpErrorCode +int2sftperror = toEnum . fromIntegral + +-- | Sftp error code returning from libssh2 +data SftpErrorCode = + FX_OK + | FX_EOF + | FX_NO_SUCH_FILE + | FX_PERMISSION_DENIED + | FX_FAILURE + | FX_BAD_MESSAGE + | FX_NO_CONNECTION + | FX_CONNECTION_LOST + | FX_OP_UNSUPPORTED + | FX_INVALID_HANDLE + | FX_NO_SUCH_PATH + | FX_FILE_ALREADY_EXISTS + | FX_WRITE_PROTECT + | FX_NO_MEDIA + | FX_NO_SPACE_ON_FILESYSTEM + | FX_QUOTA_EXCEEDED + | FX_UNKNOWN_PRINCIPAL + | FX_LOCK_CONFLICT + | FX_DIR_NOT_EMPTY + | FX_NOT_A_DIRECTORY + | FX_INVALID_FILENAME + | FX_LINK_LOOP + deriving (Eq, Show, Ord, Enum, Data, Typeable) + +instance Exception SftpErrorCode + + +class SshCtx a where + getSession :: a -> Session + throwCtxSpecificError :: a -> ErrorCode -> IO b + +instance SshCtx Session where + getSession = id + throwCtxSpecificError _ er = throw er + +instance SshCtx Sftp where + getSession = sftpSession + + throwCtxSpecificError ctx SFTP_PROTOCOL = do + er <- getLastSftpError ctx + throw (int2sftperror er) + throwCtxSpecificError _ er = throw er + +instance SshCtx SftpHandle where + getSession = getSession . sftpHandleSession + + throwCtxSpecificError ctx = + throwCtxSpecificError (sftpHandleSession ctx) diff --git a/src/Network/SSH/Client/LibSSH2/Foreign.chs b/src/Network/SSH/Client/LibSSH2/Foreign.chs --- a/src/Network/SSH/Client/LibSSH2/Foreign.chs +++ b/src/Network/SSH/Client/LibSSH2/Foreign.chs @@ -9,6 +9,7 @@ #include "libssh2_local.h" #include +#include {# context lib="ssh2" prefix="libssh2" #} @@ -38,8 +39,19 @@ channelProcess, channelExecute, channelShell, requestPTY, requestPTYEx, channelExitStatus, channelExitSignal, - scpSendChannel, scpReceiveChannel, pollChannelRead_, + scpSendChannel, scpReceiveChannel, pollChannelRead, + -- * SFTP functions + sftpInit, sftpShutdown, + sftpOpenDir, sftpReadDir, sftpCloseHandle, + sftpOpenFile, + sftpRenameFile, sftpRenameFileEx, + sftpWriteFileFromHandler, sftpReadFileToHandler, + sftpFstat, sftpDeleteFile, + + RenameFlag (..), SftpFileTransferFlags (..), + SftpAttributes (..), + -- * Debug TraceFlag (..), setTraceMode ) where @@ -48,8 +60,11 @@ import Foreign.C.Types import Foreign.C.String import System.IO -import Network.Socket (Socket(MkSocket)) +import Network.Socket (Socket(MkSocket), fdSocket) import Data.Time.Clock.POSIX +import System.Posix.IO.Select +import System.Posix.IO.Select.Types +import System.Posix.Types import qualified Data.ByteString as BSS import qualified Data.ByteString.Unsafe as BSS @@ -139,9 +154,9 @@ -- or False to disable it. initialize :: Bool -> IO () #ifdef GCRYPT -initialize flags = void . handleInt Nothing $ gcryptFix >> initialize_ flags +initialize flags = void . handleInt (Nothing :: Maybe Session) $ gcryptFix >> initialize_ flags #else -initialize flags = void . handleInt Nothing $ initialize_ flags +initialize flags = void . handleInt (Nothing :: Maybe Session) $ initialize_ flags #endif -- | Deinitialize libssh2. @@ -154,7 +169,7 @@ -- | Create Session object initSession :: IO Session -initSession = handleNullPtr Nothing sessionFromPointer $ +initSession = handleNullPtr (Nothing :: Maybe Session) sessionFromPointer $ {# call session_init_ex #} nullFunPtr nullFunPtr nullFunPtr nullPtr {# fun session_free as freeSession_ @@ -194,7 +209,7 @@ -- | Create KnownHosts object for given session. initKnownHosts :: Session -> IO KnownHosts -initKnownHosts session = handleNullPtr Nothing knownHostsFromPointer $ initKnownHosts_ session +initKnownHosts session = handleNullPtr (Nothing :: Maybe Session) knownHostsFromPointer $ initKnownHosts_ session -- | Free KnownHosts object's memory {# fun knownhost_free as freeKnownHosts @@ -207,7 +222,7 @@ knownHostsReadFile :: KnownHosts -> FilePath -- ^ Path to known_hosts file -> IO Int -knownHostsReadFile kh path = handleInt Nothing $ knownHostsReadFile_ kh path 1 +knownHostsReadFile kh path = handleInt (Nothing :: Maybe Session) $ knownHostsReadFile_ kh path 1 -- | Get remote host public key {# fun session_hostkey as getHostKey @@ -496,5 +511,230 @@ size <- {# get stat_t->st_size #} statptr return (channel, size) -{# fun poll_channel_read as pollChannelRead_ - { toPointer `Channel' } -> `Int' #} +-- {# fun poll_channel_read as pollChannelRead_ +-- { toPointer `Channel' } -> `Int' #} + +pollChannelRead :: Channel -> IO Bool +pollChannelRead ch = do + mbSocket <- sessionGetSocket (channelSession ch) + case mbSocket of + Nothing -> error "pollChannelRead without socket present" + Just socket -> (== 1) <$> select'' [Fd $ fdSocket socket] [] [] (finite 0 100) + +-- +-- | Sftp support +-- + +-- SFTP File Transfer Flags. See libssh2 documentation +data SftpFileTransferFlags = + FXF_READ + | FXF_WRITE + | FXF_APPEND + | FXF_CREAT + | FXF_TRUNC + | FXF_EXCL + deriving (Eq, Show) + +ftf2int :: SftpFileTransferFlags -> CULong +ftf2int FXF_READ = 0x00000001 +ftf2int FXF_WRITE = 0x00000002 +ftf2int FXF_APPEND = 0x00000004 +ftf2int FXF_CREAT = 0x00000008 +ftf2int FXF_TRUNC = 0x00000010 +ftf2int FXF_EXCL = 0x00000020 + +ftransferflags2int :: [SftpFileTransferFlags] -> CULong +ftransferflags2int list = foldr (.|.) 0 (map ftf2int list) + +-- | Flags for open_ex() +data OpenExFlags = OpenFile + | OpenDir + deriving (Eq, Show) + +oef2int :: (Num a) => OpenExFlags -> a +oef2int OpenFile = 0 +oef2int OpenDir = 1 + +sftpInit :: Session -> IO Sftp +sftpInit s = handleNullPtr (Just s) (sftpFromPointer s) $ + sftpInit_ s + +sftpShutdown :: Sftp -> IO () +sftpShutdown sftp = + void . handleInt (Just sftp) $ sftpShutdown_ sftp + +{# fun sftp_init as sftpInit_ + { toPointer `Session' } -> `Ptr ()' id #} + +{# fun sftp_shutdown as sftpShutdown_ + { toPointer `Sftp' } -> `Int' #} + +-- | Open regular file handler +sftpOpenFile :: Sftp -> String -> Int -> [SftpFileTransferFlags] -> IO SftpHandle +sftpOpenFile sftp path mode flags = + handleNullPtr (Just sftp) ( sftpHandleFromPointer sftp ) $ + sftpOpen_ sftp path (toEnum mode) flags (oef2int OpenFile) + +-- | Open directory file handler +sftpOpenDir :: Sftp -> String -> IO SftpHandle +sftpOpenDir sftp path = + handleNullPtr (Just sftp) ( sftpHandleFromPointer sftp ) $ + sftpOpen_ sftp path 0 [] (oef2int OpenDir) + +sftpOpen_ :: Sftp -> String -> CLong -> [SftpFileTransferFlags] -> CInt -> IO (Ptr ()) +sftpOpen_ sftp path mode fl open_type = + let flags = ftransferflags2int fl + in + withCStringLen path $ \(pathP, pathL) -> do + {# call sftp_open_ex #} (toPointer sftp) pathP (toEnum pathL) flags mode open_type + +-- | Read directory from file handler +sftpReadDir :: SftpHandle -> IO (Maybe (BSS.ByteString, SftpAttributes)) +sftpReadDir sftph = do + let bufflen = 512 + allocaBytes bufflen $ \bufptr -> do + allocaBytes {# sizeof _LIBSSH2_SFTP_ATTRIBUTES #} $ \sftpattrptr -> do + rc <- handleInt (Just sftph) $ + {# call sftp_readdir_ex #} (toPointer sftph) bufptr (fromIntegral bufflen) nullPtr 0 sftpattrptr + case rc == 0 of + False -> do + fstat <- parseSftpAttributes sftpattrptr + filename <- BSS.packCStringLen (bufptr, intResult rc) + return $ Just (filename, fstat) + True -> + return Nothing + +-- | Close file handle +sftpCloseHandle :: SftpHandle -> IO () +sftpCloseHandle sftph = + void . handleInt (Just $ sftpHandleSession sftph) $ + {# call sftp_close_handle #} (toPointer sftph) + +data RenameFlag = + RENAME_OVERWRITE + | RENAME_ATOMIC + | RENAME_NATIVE + deriving (Eq, Show) + +rf2long :: RenameFlag -> CLong +rf2long RENAME_OVERWRITE = 0x00000001 +rf2long RENAME_ATOMIC = 0x00000002 +rf2long RENAME_NATIVE = 0x00000004 + +renameFlag2int :: [RenameFlag] -> CLong +renameFlag2int flags = foldr (.|.) 0 (map rf2long flags) + +-- | Rename a file on the sftp server +sftpRenameFile :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Old file name + -> FilePath -- ^ New file name + -> IO () +sftpRenameFile sftp src dest = + sftpRenameFileEx sftp src dest [ RENAME_NATIVE, RENAME_ATOMIC, RENAME_OVERWRITE] + +-- | Rename a file on the sftp server +sftpRenameFileEx :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Old file name + -> FilePath -- ^ New file name + -> [RenameFlag] -- ^ Rename flags + -> IO () +sftpRenameFileEx sftp src dest flags = + withCStringLen src $ \(srcP, srcL) -> + withCStringLen dest $ \(destP, destL) -> + void . handleInt (Just $ sftpSession sftp) $ + {# call sftp_rename_ex #} (toPointer sftp) srcP (toEnum srcL) destP (toEnum destL) (renameFlag2int flags ) + +-- | Download file from the sftp server +sftpReadFileToHandler :: SftpHandle -> Handle -> Int -> IO Int +sftpReadFileToHandler sftph fh fileSize = + let + go :: Int -> Ptr a -> IO Int + go received buffer = do + let toRead :: Int + toRead = min (fromIntegral fileSize - received) bufferSize + sz <- receive toRead buffer 0 + _ <- hPutBuf fh buffer sz + let newreceived :: Int + newreceived = (received + fromIntegral sz) + if newreceived < fromIntegral fileSize + then go newreceived buffer + else return $ fromIntegral newreceived + + receive :: Int -> Ptr a -> Int -> IO Int + receive 0 _ read_sz = return read_sz + receive toread buf alreadyread = do + received <- handleInt (Just sftph) + $ {# call sftp_read #} (toPointer sftph) + (buf `plusPtr` alreadyread) + (fromIntegral toread) + receive (toread - fromIntegral received) buf (alreadyread + fromIntegral received) + + bufferSize = 0x100000 + + in allocaBytes bufferSize $ go 0 + +-- | Upload file to the sftp server +sftpWriteFileFromHandler :: SftpHandle -> Handle -> IO Integer +sftpWriteFileFromHandler sftph fh = + let + go :: Integer -> Ptr a -> IO Integer + go done buffer = do + sz <- hGetBuf fh 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 buf = do + sent <- handleInt (Just sftph) + $ {# call sftp_write #} (toPointer sftph) + (buf `plusPtr` written) + (fromIntegral size) + send (written + fromIntegral sent) (size - fromIntegral sent) buf + + bufferSize :: Int + bufferSize = 0x100000 + + in allocaBytes bufferSize $ go 0 + +data SftpAttributes = SftpAttributes { + saFlags :: CULong, + saFileSize :: CULLong, + saUid :: CULong, + saGid :: CULong, + saPermissions :: CULong, + saAtime :: CULong, + saMtime :: CULong + } deriving (Show, Eq) + +-- | Get sftp attributes from the sftp handler +sftpFstat :: SftpHandle + -> IO (SftpAttributes) +sftpFstat sftph = do + allocaBytes {# sizeof _LIBSSH2_SFTP_ATTRIBUTES #} $ \sftpattrptr -> do + _ <- handleInt (Just sftph) $ + {# call sftp_fstat_ex #} (toPointer sftph) sftpattrptr 0 + parseSftpAttributes sftpattrptr + +parseSftpAttributes sftpattrptr = do + flags<- {# get _LIBSSH2_SFTP_ATTRIBUTES->flags #} sftpattrptr + size <- {# get _LIBSSH2_SFTP_ATTRIBUTES->filesize #} sftpattrptr + uid <- {# get _LIBSSH2_SFTP_ATTRIBUTES->uid #} sftpattrptr + gid <- {# get _LIBSSH2_SFTP_ATTRIBUTES->gid #} sftpattrptr + perm <- {# get _LIBSSH2_SFTP_ATTRIBUTES->permissions #} sftpattrptr + atime<- {# get _LIBSSH2_SFTP_ATTRIBUTES->atime #} sftpattrptr + mtime<- {# get _LIBSSH2_SFTP_ATTRIBUTES->mtime #} sftpattrptr + + return $ SftpAttributes flags size uid gid perm atime mtime + +-- | Delete file from SFTP server +sftpDeleteFile :: Sftp -- ^ Opened sftp session + -> FilePath -- ^ Path to the file to be deleted + -> IO () +sftpDeleteFile sftp path = do + withCStringLen path $ \(str,len) -> do + void . handleInt (Just sftp) $ + {# call sftp_unlink_ex #} (toPointer sftp) str (toEnum len) diff --git a/src/Network/SSH/Client/LibSSH2/Foreign.hs b/src/Network/SSH/Client/LibSSH2/Foreign.hs deleted file mode 100644 --- a/src/Network/SSH/Client/LibSSH2/Foreign.hs +++ /dev/null @@ -1,693 +0,0 @@ --- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell) --- Edit the ORIGNAL .chs file instead! - - -{-# LINE 1 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-}{-# LANGUAGE CPP, ForeignFunctionInterface #-} - - - -{-# LINE 6 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -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, - usernamePasswordAuth, - - -- * 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 - -> CInt -ssh2socket (MkSocket s _ _ _ _) = - s - -initialize_ :: Bool -> IO (Int) -initialize_ a1 = - let {a1' = init_crypto a1} in - initialize_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 125 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Initialize libssh2. Pass True to enable encryption --- or False to disable it. -initialize :: Bool -> IO () -initialize flags = void . handleInt Nothing $ initialize_ flags - --- | Deinitialize libssh2. -exit :: IO () -exit = - exit'_ >>= \res -> - return () -{-# LINE 142 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Create Session object -initSession :: IO Session -initSession = handleNullPtr Nothing sessionFromPointer $ - libssh2_session_init_ex nullFunPtr nullFunPtr nullFunPtr nullPtr - -freeSession_ :: Session -> IO (Int) -freeSession_ a1 = - let {a1' = toPointer a1} in - freeSession_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 150 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Free Session object's memory -freeSession :: Session -> IO () -freeSession session = void . handleInt (Just session) $ freeSession_ session - -disconnectSessionEx :: Session -> Int -> String -> String -> IO (Int) -disconnectSessionEx a1 a2 a3 a4 = - let {a1' = toPointer a1} in - let {a2' = fromIntegral a2} in - withCString a3 $ \a3' -> - withCString a4 $ \a4' -> - disconnectSessionEx'_ a1' a2' a3' a4' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 157 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Disconnect session (but do not free memory) -disconnectSession :: Session - -> String -- ^ Goodbye message - -> IO () -disconnectSession s msg = void . handleInt (Just s) $ disconnectSessionEx s 11 msg "" - -setBlocking :: Session -> Bool -> IO () -setBlocking a1 a2 = - let {a1' = toPointer a1} in - let {a2' = bool2int a2} in - setBlocking'_ a1' a2' >>= \res -> - return () -{-# LINE 166 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -bool2int :: Bool -> CInt -bool2int True = 1 -bool2int False = 0 - -handshake_ :: Session -> Socket -> IO (Int) -handshake_ a1 a2 = - let {a1' = toPointer a1} in - let {a2' = ssh2socket a2} in - handshake_'_ a1' a2' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 173 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 - -initKnownHosts_ :: Session -> IO (Ptr ()) -initKnownHosts_ a1 = - let {a1' = toPointer a1} in - initKnownHosts_'_ a1' >>= \res -> - let {res' = id res} in - return (res') -{-# LINE 182 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Create KnownHosts object for given session. -initKnownHosts :: Session -> IO KnownHosts -initKnownHosts session = handleNullPtr Nothing knownHostsFromPointer $ initKnownHosts_ session - --- | Free KnownHosts object's memory -freeKnownHosts :: KnownHosts -> IO () -freeKnownHosts a1 = - let {a1' = toPointer a1} in - freeKnownHosts'_ a1' >>= \res -> - return () -{-# LINE 190 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -knownHostsReadFile_ :: KnownHosts -> String -> CInt -> IO (Int) -knownHostsReadFile_ a1 a2 a3 = - let {a1' = toPointer a1} in - withCString a2 $ \a2' -> - let {a3' = id a3} in - knownHostsReadFile_'_ a1' a2' a3' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 193 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 -getHostKey :: Session -> IO (String, Size, CInt) -getHostKey a1 = - let {a1' = toPointer a1} in - alloca $ \a2' -> - alloca $ \a3' -> - getHostKey'_ a1' a2' a3' >>= \res -> - peek a2'>>= \a2'' -> - peek a3'>>= \a3'' -> - peekCString res >>= \res' -> - return (res', a2'', a3'') -{-# LINE 203 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -checkKnownHost_ :: KnownHosts -> String -> Int -> String -> Int -> [KnownHostType] -> Ptr () -> IO (KnownHostResult) -checkKnownHost_ a1 a2 a3 a4 a5 a6 a7 = - let {a1' = toPointer a1} in - withCString a2 $ \a2' -> - let {a3' = fromIntegral a3} in - withCString a4 $ \a4' -> - let {a5' = fromIntegral a5} in - let {a6' = typemask2int a6} in - let {a7' = castPtr a7} in - checkKnownHost_'_ a1' a2' a3' a4' a5' a6' a7' >>= \res -> - let {res' = int2khresult res} in - return (res') -{-# LINE 212 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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? -publicKeyAuthFile_ :: Session -> String -> String -> String -> String -> IO (Int) -publicKeyAuthFile_ a1 a2 a3 a4 a5 = - let {a1' = toPointer a1} in - withCStringLenIntConv a2 $ \(a2'1, a2'2) -> - withCString a3 $ \a3' -> - withCString a4 $ \a4' -> - withCString a5 $ \a5' -> - publicKeyAuthFile_'_ a1' a2'1 a2'2 a3' a4' a5' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 229 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 - --- | Perform username/password authentication. -usernamePasswordAuth :: Session -- ^ Session - -> String -- ^ Username - -> String -- ^ Password - -> IO () -usernamePasswordAuth session username password = - withCString username $ \usernameptr -> do - withCString password $ \passwordptr -> do - void . handleInt (Just session) $ - libssh2_userauth_password_ex (toPointer session) usernameptr (toEnum $ length username) passwordptr (toEnum $ length password) nullFunPtr - -openSessionChannelEx :: Session -> String -> Int -> Int -> String -> IO (Ptr ()) -openSessionChannelEx a1 a2 a3 a4 a5 = - let {a1' = toPointer a1} in - withCStringLenIntConv a2 $ \(a2'1, a2'2) -> - let {a3' = fromIntegral a3} in - let {a4' = fromIntegral a4} in - withCStringLenIntConv a5 $ \(a5'1, a5'2) -> - openSessionChannelEx'_ a1' a2'1 a2'2 a3' a4' a5'1 a5'2 >>= \res -> - let {res' = id res} in - return (res') -{-# LINE 256 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 - -channelProcessStartup_ :: Channel -> String -> String -> IO (Int) -channelProcessStartup_ a1 a2 a3 = - let {a1' = toPointer a1} in - withCStringLenIntConv a2 $ \(a2'1, a2'2) -> - withCStringLenIntConv a3 $ \(a3'1, a3'2) -> - channelProcessStartup_'_ a1' a2'1 a2'2 a3'1 a3'2 >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 274 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Execute shell command -channelShell :: Channel -> IO () -channelShell c = void . handleInt (Just $ channelSession c) $ channelProcessStartup_ c "shell" "" - -requestPTYEx :: Channel -> String -> String -> Int -> Int -> Int -> Int -> IO (Int) -requestPTYEx a1 a2 a3 a4 a5 a6 a7 = - let {a1' = toPointer a1} in - withCStringLenIntConv a2 $ \(a2'1, a2'2) -> - withCStringLenIntConv a3 $ \(a3'1, a3'2) -> - let {a4' = fromIntegral a4} in - let {a5' = fromIntegral a5} in - let {a6' = fromIntegral a6} in - let {a7' = fromIntegral a7} in - requestPTYEx'_ a1' a2'1 a2'2 a3'1 a3'2 a4' a5' a6' a7' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 285 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -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) $ libssh2_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) - $ libssh2_channel_write_ex (toPointer ch) - 0 - (cstr `plusPtr` offset) - (fromIntegral len) - if fromIntegral written < len - then go (offset + fromIntegral written) (len - fromIntegral written) cstr - else return () - -channelSendEOF_ :: Channel -> IO (Int) -channelSendEOF_ a1 = - let {a1' = toPointer a1} in - channelSendEOF_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 319 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -channelSendEOF :: Channel -> IO () -channelSendEOF channel = void . handleInt (Just $ channelSession channel) $ channelSendEOF_ channel - -channelWaitEOF_ :: Channel -> IO (Int) -channelWaitEOF_ a1 = - let {a1' = toPointer a1} in - channelWaitEOF_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 325 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -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) - -setTraceMode :: Session -> [TraceFlag] -> IO () -setTraceMode a1 a2 = - let {a1' = toPointer a1} in - let {a2' = trace2int a2} in - setTraceMode'_ a1' a2' >>= \res -> - return () -{-# LINE 357 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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) $ - libssh2_channel_write_ex -{-# LINE 377 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - (toPointer ch) - 0 - (plusPtr buffer written) - (fromIntegral size) - send (written + fromIntegral sent) (size - fromIntegral 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) $ - libssh2_channel_read_ex -{-# LINE 405 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - (toPointer ch) - 0 - buffer - (fromIntegral toRead) - let isz :: Integer - isz = fromIntegral sz - callback buffer (fromIntegral sz) - eof <- libssh2_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) - -channelIsEOF :: Channel -> IO (Bool) -channelIsEOF a1 = - let {a1' = toPointer a1} in - channelIsEOF'_ a1' >>= \res -> - handleBool res >>= \res' -> - return (res') -{-# LINE 424 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -closeChannel_ :: Channel -> IO (Int) -closeChannel_ a1 = - let {a1' = toPointer a1} in - closeChannel_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 427 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Close channel (but do not free memory) -closeChannel :: Channel -> IO () -closeChannel channel = void . handleInt (Just $ channelSession channel) $ closeChannel_ channel - -freeChannel_ :: Channel -> IO (Int) -freeChannel_ a1 = - let {a1' = toPointer a1} in - freeChannel_'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 434 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | Free channel object's memory -freeChannel :: Channel -> IO () -freeChannel channel = void . handleInt (Just $ channelSession channel) $ freeChannel_ channel - --- | Get channel exit status -channelExitStatus :: Channel -> IO (Int) -channelExitStatus a1 = - let {a1' = toPointer a1} in - channelExitStatus'_ a1' >>= \res -> - let {res' = fromIntegral res} in - return (res') -{-# LINE 442 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - -channelExitSignal_ :: Channel -> Ptr Int -> Ptr Int -> Ptr Int -> IO (Int, String, Maybe String, Maybe String) -channelExitSignal_ a1 a3 a5 a7 = - let {a1' = toPointer a1} in - alloca $ \a2' -> - let {a3' = castPtr a3} in - alloca $ \a4' -> - let {a5' = castPtr a5} in - alloca $ \a6' -> - let {a7' = castPtr a7} in - channelExitSignal_'_ a1' a2' a3' a4' a5' a6' a7' >>= \res -> - peekCStringPtr a2'>>= \a2'' -> - peekMaybeCStringPtr a4'>>= \a4'' -> - peekMaybeCStringPtr a6'>>= \a6'' -> - let {res' = fromIntegral res} in - return (res', a2'', a4'', a6'') -{-# LINE 451 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 - -scpSendChannel_ :: Session -> String -> Int -> Int64 -> POSIXTime -> POSIXTime -> IO (Ptr ()) -scpSendChannel_ a1 a2 a3 a4 a5 a6 = - let {a1' = toPointer a1} in - withCString a2 $ \a2' -> - let {a3' = fromIntegral a3} in - let {a4' = fromIntegral a4} in - let {a5' = round a5} in - let {a6' = round a6} in - scpSendChannel_'_ a1' a2' a3' a4' a5' a6' >>= \res -> - let {res' = id res} in - return (res') -{-# LINE 464 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- | 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 = (CLong) -{-# LINE 471 "src/Network/SSH/Client/LibSSH2/Foreign.chs" #-} - --- {# 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 144 $ \statptr -> do - channel <- handleNullPtr (Just s) (channelFromPointer s) $ libssh2_scp_recv (toPointer s) pathptr statptr - size <- (\ptr -> do {peekByteOff ptr 48 ::IO CLong}) statptr - return (channel, size) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_init" - initialize_'_ :: (CInt -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_exit" - exit'_ :: (IO ()) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_init_ex" - libssh2_session_init_ex :: ((FunPtr (CULong -> ((Ptr (Ptr ())) -> (IO (Ptr ()))))) -> ((FunPtr ((Ptr ()) -> ((Ptr (Ptr ())) -> (IO ())))) -> ((FunPtr ((Ptr ()) -> (CULong -> ((Ptr (Ptr ())) -> (IO (Ptr ())))))) -> ((Ptr ()) -> (IO (Ptr ())))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_free" - freeSession_'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_disconnect_ex" - disconnectSessionEx'_ :: ((Ptr ()) -> (CInt -> ((Ptr CChar) -> ((Ptr CChar) -> (IO CInt))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_set_blocking" - setBlocking'_ :: ((Ptr ()) -> (CInt -> (IO ()))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_handshake" - handshake_'_ :: ((Ptr ()) -> (CInt -> (IO CInt))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_knownhost_init" - initKnownHosts_'_ :: ((Ptr ()) -> (IO (Ptr ()))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_knownhost_free" - freeKnownHosts'_ :: ((Ptr ()) -> (IO ())) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_knownhost_readfile" - knownHostsReadFile_'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO CInt)))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_session_hostkey" - getHostKey'_ :: ((Ptr ()) -> ((Ptr CULong) -> ((Ptr CInt) -> (IO (Ptr CChar))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_knownhost_checkp" - checkKnownHost_'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> ((Ptr CChar) -> (CULong -> (CInt -> ((Ptr (Ptr ())) -> (IO CInt)))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_userauth_publickey_fromfile_ex" - publicKeyAuthFile_'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> ((Ptr CChar) -> ((Ptr CChar) -> ((Ptr CChar) -> (IO CInt))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_userauth_password_ex" - libssh2_userauth_password_ex :: ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> ((Ptr CChar) -> (CUInt -> ((FunPtr ((Ptr ()) -> ((Ptr (Ptr CChar)) -> ((Ptr CInt) -> ((Ptr (Ptr ())) -> (IO ())))))) -> (IO CInt))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_open_ex" - openSessionChannelEx'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> (CUInt -> (CUInt -> ((Ptr CChar) -> (CUInt -> (IO (Ptr ()))))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_process_startup" - channelProcessStartup_'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> ((Ptr CChar) -> (CUInt -> (IO CInt)))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_request_pty_ex" - requestPTYEx'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CUInt -> ((Ptr CChar) -> (CUInt -> (CInt -> (CInt -> (CInt -> (CInt -> (IO CInt)))))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_read_ex" - libssh2_channel_read_ex :: ((Ptr ()) -> (CInt -> ((Ptr CChar) -> (CULong -> (IO CLong))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_write_ex" - libssh2_channel_write_ex :: ((Ptr ()) -> (CInt -> ((Ptr CChar) -> (CULong -> (IO CLong))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_send_eof" - channelSendEOF_'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_wait_eof" - channelWaitEOF_'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_trace" - setTraceMode'_ :: ((Ptr ()) -> (CInt -> (IO CInt))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_eof" - libssh2_channel_eof :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_eof" - channelIsEOF'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_close" - closeChannel_'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_free" - freeChannel_'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_get_exit_status" - channelExitStatus'_ :: ((Ptr ()) -> (IO CInt)) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_channel_get_exit_signal" - channelExitSignal_'_ :: ((Ptr ()) -> ((Ptr (Ptr CChar)) -> ((Ptr CULong) -> ((Ptr (Ptr CChar)) -> ((Ptr CULong) -> ((Ptr (Ptr CChar)) -> ((Ptr CULong) -> (IO CInt)))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_scp_send64" - scpSendChannel_'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CLLong -> (CLong -> (CLong -> (IO (Ptr ())))))))) - -foreign import ccall safe "src/Network/SSH/Client/LibSSH2/Foreign.chs.h libssh2_scp_recv" - libssh2_scp_recv :: ((Ptr ()) -> ((Ptr CChar) -> ((Ptr ()) -> (IO (Ptr ()))))) diff --git a/src/Network/SSH/Client/LibSSH2/Types.chs b/src/Network/SSH/Client/LibSSH2/Types.chs --- a/src/Network/SSH/Client/LibSSH2/Types.chs +++ b/src/Network/SSH/Client/LibSSH2/Types.chs @@ -8,6 +8,7 @@ #endif #include +#include {# context lib="ssh2" prefix="libssh2" #} @@ -15,6 +16,8 @@ (Session, KnownHosts, Channel, + Sftp, + SftpHandle, ToPointer (..), Direction (..), int2dir, @@ -28,7 +31,12 @@ sessionFromPointer, sessionGetSocket, sessionSetSocket, - channelSession + channelSession, + sftpFromPointer, + sftpSession, + sftpHandlePtr, + sftpHandleFromPointer, + sftpHandleSession ) where import Foreign @@ -131,3 +139,37 @@ int2dir 2 = [OUTBOUND] int2dir 3 = [INBOUND, OUTBOUND] int2dir x = error $ "Unknown direction: " ++ show x + +-- +-- | Sftp support +-- + +sftpFromPointer :: Session -> Ptr () -> IO Sftp +sftpFromPointer session ptr = return $ Sftp (castPtr ptr) session + +{# pointer *SFTP as CSftp #} + +data Sftp = Sftp { sftpPtr :: CSftp + , sftpSession :: Session + } + +instance Show Sftp where + show sftp = "" + +instance ToPointer Sftp where + toPointer = castPtr . sftpPtr + +sftpHandleFromPointer :: Sftp -> Ptr () -> IO SftpHandle +sftpHandleFromPointer sftp ptr = return $ SftpHandle (castPtr ptr) sftp + +{# pointer *SFTP_HANDLE as CSftpHandle #} + +data SftpHandle = SftpHandle { sftpHandlePtr :: CSftpHandle + , sftpHandleSession :: Sftp + } + +instance Show SftpHandle where + show handle = "" + +instance ToPointer SftpHandle where + toPointer = castPtr . sftpHandlePtr