{-# LANGUAGE ScopedTypeVariables #-}
module Network.SSH.Client.LibSSH2
(
Session, Channel, KnownHosts, Sftp, SftpHandle,
SftpAttributes, SftpList, SftpFileTransferFlags,
withSSH2,
withSSH2User,
withSession,
withChannel,
withChannelBy,
checkHost,
readAllChannel,
writeAllChannel,
scpSendFile,
scpReceiveFile,
runShellCommands,
execCommands,
withSFTP,
withSFTPUser,
sftpListDir,
sftpRenameFile,
sftpSendFile, sftpSendFromHandle,
sftpReceiveFile, sftpReadFileToHandler,
sftpFstat,
sftpDeleteFile,
socketConnect,
sessionInit,
sessionClose,
) where
import Control.Monad
import Control.Exception as E
import Network hiding (sClose)
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
socketConnect :: String -> Int -> IO Socket
socketConnect hostname port = do
proto <- getProtocolNumber "tcp"
bracketOnError (socket AF_INET Stream proto) (close)
(\sock -> do
he <- getHostByName hostname
connect sock (SockAddrInet (fromIntegral port) (hostAddress he))
return sock)
withSSH2 :: FilePath
-> FilePath
-> FilePath
-> String
-> String
-> String
-> Int
-> (Session -> IO a)
-> 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
withSSH2User :: FilePath
-> String
-> String
-> String
-> Int
-> (Session -> IO a)
-> IO a
withSSH2User 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
fn s
withSession :: String
-> Int
-> (Session -> IO a)
-> IO a
withSession hostname port = E.bracket (sessionInit hostname port) sessionClose
sessionInit :: String -> Int -> IO Session
sessionInit hostname port = do
sock <- socketConnect hostname port
session <- initSession
setBlocking session False
handshake session sock
return session
sessionClose :: Session -> IO ()
sessionClose session = do
disconnectSession session "Done."
sessionGetSocket session >>= maybe (pure ()) close
freeSession session
checkHost :: Session
-> String
-> Int
-> FilePath
-> 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
withChannel :: Session -> (Channel -> IO a) -> IO (Int, a)
withChannel s = withChannelBy (openChannelSession s) id
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)
readAllChannelNonBlocking :: Channel -> IO BSL.ByteString
readAllChannelNonBlocking ch = go []
where
go :: [BSS.ByteString] -> IO BSL.ByteString
go acc = do
bs <- do readable <- pollChannelRead ch
if readable
then readChannel ch 0x400
else return BSS.empty
if BSS.length bs > 0
then go (bs : acc)
else return (BSL.fromChunks $ reverse acc)
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 <- readAllChannelNonBlocking ch
out <- forM commands $ \cmd -> do
writeChannel ch (BSSC.pack $ cmd ++ "\n")
r <- readAllChannelNonBlocking 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
scpSendFile :: Session
-> Int
-> FilePath
-> FilePath
-> 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
scpReceiveFile :: Session
-> FilePath
-> FilePath
-> 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
withChannelBy :: IO a
-> (a -> Channel)
-> (a -> IO b)
-> IO (Int, b)
withChannelBy createChannel extractChannel actions = do
stuff <- createChannel
let ch = extractChannel stuff
result <- actions stuff
closeChannel ch
exitStatus <- channelExitStatus ch
freeChannel ch
return (exitStatus, result)
withSFTP :: FilePath
-> FilePath
-> FilePath
-> String
-> String
-> String
-> Int
-> (Sftp -> IO a)
-> 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
withSFTPUser :: FilePath
-> String
-> String
-> String
-> Int
-> (Sftp -> IO a)
-> 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
withSftpSession :: Session
-> (Sftp -> IO a)
-> IO a
withSftpSession session =
E.bracket (sftpInit session) sftpShutdown
type SftpList = [(BSS.ByteString, SftpAttributes)]
sftpListDir :: Sftp
-> FilePath
-> 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
sftpSendFile :: Sftp
-> FilePath
-> FilePath
-> Int
-> IO Integer
sftpSendFile sftp local remote mode =
withFile local ReadMode $ \fh ->
sftpSendFromHandle sftp fh remote mode
sftpSendFromHandle :: Sftp
-> Handle
-> FilePath
-> Int
-> 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
sftpReceiveFile :: Sftp
-> FilePath
-> FilePath
-> IO Integer
sftpReceiveFile sftp local remote =
withFile local WriteMode $ \fh ->
sftpReceiveToHandle sftp remote fh
sftpReceiveToHandle :: Sftp
-> FilePath
-> Handle
-> 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