diff --git a/libssh2.cabal b/libssh2.cabal --- a/libssh2.cabal +++ b/libssh2.cabal @@ -1,6 +1,6 @@ Name: libssh2 -Version: 0.2.0.8 +Version: 0.2.0.9 Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) 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 @@ -27,6 +27,7 @@ sftpListDir, sftpRenameFile, sftpSendFile, sftpSendFromHandle, + sftpSendBytes, sftpReceiveFile, sftpReadFileToHandler, sftpFstat, sftpDeleteFile, @@ -73,7 +74,7 @@ -> IO a withSSH2 known_hosts public private passphrase login hostname port fn = withSession hostname port $ \s -> do - r <- checkHost s hostname port known_hosts + r <- checkHost s hostname port known_hosts [TYPE_MASK] when (r == MISMATCH) $ error $ "Host key mismatch for host " ++ hostname publicKeyAuthFile s login public private passphrase @@ -89,7 +90,7 @@ -> IO a withSSH2Agent known_hosts login hostname port fn = withSession hostname port $ \s -> do - r <- checkHost s hostname port known_hosts + r <- checkHost s hostname port known_hosts [TYPE_MASK] when (r == MISMATCH) $ error $ "host key mismatch for host " ++ hostname E.bracket (agentInit s) agentFree $ \a -> @@ -111,7 +112,7 @@ -> IO a withSSH2User known_hosts login password hostname port fn = withSession hostname port $ \s -> do - r <- checkHost s hostname port known_hosts + r <- checkHost s hostname port known_hosts [TYPE_MASK] when (r == MISMATCH) $ error $ "Host key mismatch for host " ++ hostname usernamePasswordAuth s login password @@ -147,14 +148,16 @@ -> String -- ^ Remote host name -> Int -- ^ Remote port number (usually 22) -> FilePath -- ^ Path to known_hosts file + -> [KnownHostType] -- ^ Flags specifying what format the host name is, what format the key is and what key type it is -> 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 +checkHost s host port path flags = bracket + (initKnownHosts s) + freeKnownHosts + (\kh -> do + _numKnownHosts <- knownHostsReadFile kh path + (hostkey, _keytype) <- getHostKey s + checkKnownHost kh host port hostkey flags + ) -- | Execute some actions withing SSH2 channel withChannel :: Session -> (Channel -> IO a) -> IO (Int, a) @@ -267,7 +270,7 @@ -> IO a withSFTP known_hosts public private passphrase login hostname port fn = withSession hostname port $ \s -> do - r <- checkHost s hostname port known_hosts + r <- checkHost s hostname port known_hosts [TYPE_MASK] when (r == MISMATCH) $ error $ "Host key mismatch for host " ++ hostname publicKeyAuthFile s login public private passphrase @@ -284,7 +287,7 @@ -> IO a withSFTPUser known_hosts login password hostname port fn = withSession hostname port $ \s -> do - r <- checkHost s hostname port known_hosts + r <- checkHost s hostname port known_hosts [TYPE_MASK] when (r == MISMATCH) $ error $ "Host key mismatch for host " ++ hostname usernamePasswordAuth s login password @@ -346,6 +349,18 @@ let flags = [FXF_WRITE, FXF_CREAT, FXF_TRUNC, FXF_EXCL] withOpenSftpFile sftp remote mode flags $ \sftph -> sftpWriteFileFromHandler sftph fh + +-- | Send bytes to a remote host via SFTP +-- Returns the size of sent data. +sftpSendBytes :: Sftp -- ^ Opened sftp session + -> BSS.ByteString -- ^ Bytes to write + -> FilePath -- ^ Remote file path + -> Int -- ^ File creation mode (0o777, for example) + -> IO Integer +sftpSendBytes sftp bytes remote mode = do + let flags = [FXF_WRITE, FXF_CREAT, FXF_TRUNC, FXF_EXCL] + withOpenSftpFile sftp remote mode flags $ \sftph -> + sftpWriteFileFromBytes sftph bytes -- | Received a file from remote host via SFTP -- Returns size of received data. 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 @@ -190,9 +190,12 @@ Nothing -> error "EAGAIN thrown on session without socket" Just socket -> do dirs <- blockedDirections s - if (OUTBOUND `elem` dirs) - then threadWaitWrite socket - else threadWaitRead socket + case dirs of + [] -> pure () + _ -> + if (OUTBOUND `elem` dirs) + then threadWaitWrite socket + else threadWaitRead socket -- | Sftp 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 @@ -19,6 +19,7 @@ -- * Session functions initialize, exit, initSession, freeSession, disconnectSession, + keepaliveConfig, handshake, setBlocking, @@ -33,7 +34,7 @@ -- * Channel functions openChannelSession, closeChannel, freeChannel, channelSendEOF, channelWaitEOF, channelIsEOF, - readChannel, writeChannel, + readChannel, readChannelStderr, writeChannel, writeChannelFromHandle, readChannelToHandle, channelProcess, channelExecute, channelShell, requestPTY, requestPTYEx, @@ -46,8 +47,8 @@ sftpOpenDir, sftpReadDir, sftpCloseHandle, sftpOpenFile, sftpRenameFile, sftpRenameFileEx, - sftpWriteFileFromHandler, sftpReadFileToHandler, - sftpFstat, sftpDeleteFile, + sftpWriteFileFromHandler, sftpWriteFileFromBytes, + sftpReadFileToHandler, sftpFstat, sftpDeleteFile, RenameFlag (..), SftpFileTransferFlags (..), SftpAttributes (..), @@ -106,25 +107,79 @@ | KEY_RSA1 | KEY_SSHRSA | KEY_SSHDSS + | KEY_ECDSA_256 + | KEY_ECDSA_384 + | KEY_ECDSA_521 + | KEY_ED25519 + | KEY_UNKNOWN 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 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 +kht2int KEY_MASK = 15 `shiftL` 18 +kht2int KEY_SHIFT = 18 +kht2int KEY_RSA1 = 1 `shiftL` 18 +kht2int KEY_SSHRSA = 2 `shiftL` 18 +kht2int KEY_SSHDSS = 3 `shiftL` 18 +kht2int KEY_ECDSA_256 = 4 `shiftL` 18 +kht2int KEY_ECDSA_384 = 5 `shiftL` 18 +kht2int KEY_ECDSA_521 = 6 `shiftL` 18 +kht2int KEY_ED25519 = 7 `shiftL` 18 +kht2int KEY_UNKNOWN = 15 `shiftL` 18 +int2kht :: CInt -> KnownHostType +int2kht 0xffff = TYPE_MASK +int2kht 1 = TYPE_PLAIN +int2kht 2 = TYPE_SHA1 +int2kht 3 = TYPE_CUSTOM +int2kht 18 = KEY_SHIFT +int2kht i + | i == 3 `shiftL` 16 = KEYENC_MASK + | i == 1 `shiftL` 16 = KEYENC_RAW + | i == 2 `shiftL` 16 = KEYENC_BASE64 + | i == 15 `shiftL` 18 = KEY_MASK + | i == 1 `shiftL` 18 = KEY_RSA1 + | i == 2 `shiftL` 18 = KEY_SSHRSA + | i == 3 `shiftL` 18 = KEY_SSHDSS + | i == 4 `shiftL` 18 = KEY_ECDSA_256 + | i == 5 `shiftL` 18 = KEY_ECDSA_384 + | i == 6 `shiftL` 18 = KEY_ECDSA_521 + | i == 7 `shiftL` 18 = KEY_ED25519 + | i == 15 `shiftL` 18 = KEY_UNKNOWN + | otherwise = error $ "Unsupported known host type: " ++ show i + typemask2int :: [KnownHostType] -> CInt typemask2int list = foldr (.|.) 0 (map kht2int list) +-- | Host key types. See libssh2 documentation. +data HostKeyType = + UNKNOWN + | RSA + | DSS + | ECDSA_256 + | ECDSA_384 + | ECDSA_521 + | ED25519 + deriving (Enum, Eq, Ord) + +instance Show HostKeyType where + show UNKNOWN = "unknown" + show RSA = "ssh-rsa" + show DSS = "ssh-dss" + show ECDSA_256 = "ecdsa-sha2-nistp256" + show ECDSA_384 = "ecdsa-sha2-nistp384" + show ECDSA_521 = "ecdsa-sha2-nistp521" + show ED25519 = "ssh-ed25519" + +int2hkt :: Integral n => n -> HostKeyType +int2hkt = toEnum . fromIntegral + -- Result of matching host against known_hosts. data KnownHostResult = MATCH @@ -226,6 +281,9 @@ -> IO () disconnectSession s msg = void . handleInt (Just s) $ disconnectSessionEx s 11 msg "" +{# fun keepalive_config as keepaliveConfig + { toPointer `Session', bool2int `Bool', `Int' } -> `()' #} + {# fun session_set_blocking as setBlocking { toPointer `Session', bool2int `Bool' } -> `()' #} @@ -272,15 +330,21 @@ -> IO Int knownHostsReadFile kh path = handleInt (Nothing :: Maybe Session) $ knownHostsReadFile_ kh path 1 --- | Get remote host public key -{# fun session_hostkey as getHostKey - { toPointer `Session', alloca- `Size' peek*, alloca- `CInt' peek* } -> `String' #} +{# fun session_hostkey as getHostKey_ + { toPointer `Session', alloca- `Size' peek*, alloca- `CInt' peek* } -> `Ptr CChar' id #} +-- | Get remote host public key and its type +getHostKey :: Session -> IO (BSS.ByteString, HostKeyType) +getHostKey session = do + (keyPtr, keySize, keyType) <- getHostKey_ session + key <- BSS.packCStringLen (keyPtr, fromIntegral keySize) + pure (key, int2hkt keyType) + {# fun knownhost_checkp as checkKnownHost_ { toPointer `KnownHosts', `String', `Int', - `String', + id `Ptr CChar', `Int', typemask2int `[KnownHostType]', castPtr `Ptr ()' } -> `KnownHostResult' int2khresult #} @@ -289,10 +353,11 @@ checkKnownHost :: KnownHosts -- -> String -- ^ Host name -> Int -- ^ Port number (usually 22) - -> String -- ^ Host public key + -> BSS.ByteString -- ^ 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 +checkKnownHost kh host port key flags = BSS.useAsCStringLen key $ \(keyPtr, keySize) -> do + checkKnownHost_ kh host port keyPtr keySize flags nullPtr -- TODO: I don't see the '&' in the libssh2 docs? {# fun userauth_publickey_fromfile_ex as publicKeyAuthFile_ @@ -386,6 +451,12 @@ -> IO BSS.ByteString readChannel c sz = readChannelEx c 0 sz +-- | Read data from channel. +readChannelStderr :: Channel -- + -> Size -- ^ Amount of data to read + -> IO BSS.ByteString +readChannelStderr c sz = readChannelEx c {#const SSH_EXTENDED_DATA_STDERR#} sz + -- | Write data to channel. writeChannel :: Channel -> BSS.ByteString -> IO () writeChannel ch bs = @@ -761,6 +832,24 @@ bufferSize = 0x100000 in allocaBytes bufferSize $ go 0 + +-- | Upload bytes to the sftp server +-- Returns size of sent data. +sftpWriteFileFromBytes :: SftpHandle -> BSS.ByteString -> IO Integer +sftpWriteFileFromBytes sftph bs = BSS.useAsCStringLen bs (uncurry (send 0)) + where + send :: Int -> Ptr CChar -> Int -> IO Integer + send written _ 0 = pure (toInteger written) + send written src len = do + let nBytes = min len bufferSize + sent <- fmap fromIntegral . handleInt (Just sftph) + $ {# call sftp_write #} (toPointer sftph) + src + (fromIntegral nBytes) + send (written + sent) (src `plusPtr` written) (len - sent) + + bufferSize :: Int + bufferSize = 0x100000 data SftpAttributes = SftpAttributes { saFlags :: CULong, 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 @@ -140,6 +140,7 @@ deriving (Eq, Show) int2dir :: (Eq a, Num a, Show a) => a -> [Direction] +int2dir 0 = [] int2dir 1 = [INBOUND] int2dir 2 = [OUTBOUND] int2dir 3 = [INBOUND, OUTBOUND]