├── .gitignore ├── .travis.yml ├── README.md ├── cabal.project ├── libssh2-conduit ├── LICENSE ├── Makefile ├── Network │ └── SSH │ │ └── Client │ │ └── LibSSH2 │ │ └── Conduit.hs ├── Setup.hs ├── hs-ssh-forwarder.hs ├── libssh2-conduit.cabal └── ssh-client.hs ├── libssh2 ├── LICENSE ├── Makefile ├── Setup.hs ├── include │ ├── gcrypt-fix.h │ └── libssh2_local.h ├── libssh2.cabal ├── src │ └── Network │ │ └── SSH │ │ └── Client │ │ ├── LibSSH2.hs │ │ └── LibSSH2 │ │ ├── Errors.chs │ │ ├── FFI │ │ └── gcrypt-fix.c │ │ ├── Foreign.chs │ │ ├── GCrypt.hs │ │ ├── Types.chs │ │ └── WaitSocket.hs └── ssh-client.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.chi 4 | *.swp 5 | *.chs.h 6 | dist/ 7 | cabal-dev/ 8 | libssh2/Network/SSH/Client/LibSSH2/Foreign.hs 9 | libssh2/Network/SSH/Client/LibSSH2/Types.hs 10 | libssh2/Network/SSH/Client/LibSSH2/Errors.hs 11 | ssh-client 12 | .stack-work/ 13 | libssh2/.ghc.environment.* 14 | libssh2/dist 15 | libssh2/dist-* 16 | libssh2-conduit/.ghc.environment.* 17 | libssh2-conduit/dist 18 | libssh2-conduit/dist-* 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Choose a build environment 12 | dist: xenial 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | - libssh2-1-dev 28 | - alex 29 | - happy 30 | 31 | matrix: 32 | include: 33 | - compiler: ": #stack default with example executables" 34 | env: ARGS="" EXAMPLE=1 35 | 36 | - compiler: ": #stack 8.0.2" 37 | env: ARGS="--resolver lts-9" 38 | 39 | - compiler: ": #stack 8.6.5" 40 | env: ARGS="--resolver lts-13" 41 | 42 | - compiler: ": stack 8.6.5 osx" 43 | env: ARGS="--resolver lts-13" 44 | os: osx 45 | addons: 46 | homebrew: 47 | update: true 48 | packages: 49 | # - openssl 50 | - libssh2 51 | 52 | before_install: 53 | # Download and unpack the stack executable 54 | - mkdir -p ~/.local/bin 55 | - export PATH=$HOME/.local/bin:$PATH 56 | - | 57 | if [ `uname` = "Darwin" ] 58 | then 59 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 60 | else 61 | export LDFLAGS="-L/usr/local/opt/openssl/lib" 62 | export CPPFLAGS="-I/usr/local/opt/openssl/include" 63 | export PKG_CONFIG_PATH="/usr/local/opt/openssl/lib/pkgconfig":$PKG_CONFIG_PATH 64 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 65 | fi 66 | 67 | install: 68 | # Build dependencies 69 | - stack --no-terminal --install-ghc $ARGS test --only-dependencies 70 | 71 | script: 72 | # Build the package, its tests, and its docs and run the tests 73 | - | 74 | if [ `uname` = "Darwin" ] 75 | then 76 | export LDFLAGS="-L/usr/local/opt/openssl/lib" 77 | export CPPFLAGS="-I/usr/local/opt/openssl/include" 78 | export PKG_CONFIG_PATH="/usr/local/opt/openssl/lib/pkgconfig":$PKG_CONFIG_PATH 79 | fi 80 | 81 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 82 | if [ x$EXAMPLE = x1 ] 83 | then stack --no-terminal build --flag libssh2:example-client --flag libssh2-conduit:example-forwarder 84 | fi 85 | 86 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | libssh2-hs README 2 | ================= 3 | 4 | [![Build Status](https://travis-ci.org/portnov/libssh2-hs.svg?branch=master)](https://travis-ci.org/portnov/libssh2-hs) 5 | 6 | This repository contains two closely related packages. 7 | 8 | libssh2 9 | ------- 10 | 11 | This package provides FFI bindings for SSH2 client library named libssh2. 12 | 13 | As of version 0.2 all blocking is handled in Haskell code rather than in C 14 | code. This means that all calls are now interruptable using Haskell 15 | asynchronous exceptions; for instance, it is now possible to use System.Timeout 16 | in combination with "libssh2". 17 | 18 | Note on usage on Windows: On Windows you MUST compile your executable with 19 | -threaded or libssh2 will NOT work. We have tested libssh2 on Windows using 20 | http://mingw.org/, with http://www.openssl.org/ and http://libssh2.org/ 21 | compiled from source (be sure to pass the shared option to the configure script 22 | for openssl to enable the shared libraries). 23 | 24 | libssh2-conduit 25 | --------------- 26 | 27 | This package provides Conduit interface (see conduit package) for libssh2 FFI 28 | bindings (see libssh2 package). This allows one to receive data from SSH 29 | channels lazily, without need to read all channel output to the memory. 30 | 31 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./libssh2 2 | ./libssh2-conduit 3 | -------------------------------------------------------------------------------- /libssh2-conduit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, IlyaPortnov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of IlyaPortnov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /libssh2-conduit/Makefile: -------------------------------------------------------------------------------- 1 | LIBS=-lssh2 2 | GHC=ghc $(LIBS) --make 3 | HSFILES=Network/SSH/Client/LibSSH2/Conduit.hs 4 | 5 | all: ssh-client 6 | 7 | ssh-client: ssh-client.hs $(HSFILES) 8 | $(GHC) $< 9 | 10 | clean: 11 | find . -name \*.hi -delete 12 | find . -name \*.o -delete 13 | rm -f ssh-client 14 | -------------------------------------------------------------------------------- /libssh2-conduit/Network/SSH/Client/LibSSH2/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Network.SSH.Client.LibSSH2.Conduit 3 | (sourceChannel, 4 | sinkChannel, 5 | CommandsHandle, 6 | execCommand, 7 | getReturnCode 8 | ) where 9 | 10 | import Control.Monad 11 | import Control.Monad.IO.Class (MonadIO (..)) 12 | import Control.Monad.Trans.Class (lift) 13 | import Control.Concurrent.STM 14 | import Data.Conduit 15 | import qualified Data.ByteString as B 16 | 17 | import Network.SSH.Client.LibSSH2.Foreign 18 | import Network.SSH.Client.LibSSH2 19 | 20 | -- | Stream data from @Channel@. 21 | sourceChannel :: MonadIO m => Channel -> Source m B.ByteString 22 | sourceChannel ch = src 23 | where 24 | src = do 25 | res <- liftIO $ readChannel ch 0x400 26 | if B.length res > 0 27 | then do 28 | yield res 29 | src 30 | else return () 31 | 32 | -- | Stream data to @Channel@. 33 | sinkChannel :: MonadIO m => Channel -> Sink B.ByteString m () 34 | sinkChannel channel = 35 | loop 36 | where 37 | loop = await >>= maybe (return ()) (\bs -> lift (liftIO $ writeChannel channel bs) >> loop) 38 | 39 | -- | Execute one command and read it's output lazily. 40 | -- If first argument is True, then you *must* get return code 41 | -- using getReturnCode on returned CommandsHandle. Moreover, 42 | -- you *must* guarantee that getReturnCode will be called 43 | -- only when all command output will be read. 44 | execCommand :: MonadIO m 45 | => Bool -- ^ Set to True if you want to get return code when command will terminate. 46 | -> Session 47 | -> String -- ^ Command 48 | -> IO (Maybe CommandsHandle, Source m B.ByteString) 49 | execCommand b s cmd = do 50 | (ch, channel) <- initCH b s 51 | let src = execCommandSrc ch channel cmd 52 | return (if b then Just ch else Nothing, src) 53 | 54 | -- | Handles channel opening and closing. 55 | data CommandsHandle = CommandsHandle { 56 | chReturnCode :: Maybe (TMVar Int), 57 | chChannel :: TMVar Channel, 58 | chChannelClosed :: TVar Bool } 59 | 60 | initCH :: Bool -> Session -> IO (CommandsHandle, Channel) 61 | initCH False s = do 62 | c <- newTVarIO False 63 | ch <- newEmptyTMVarIO 64 | channel <- openCH ch s 65 | return (CommandsHandle Nothing ch c, channel) 66 | initCH True s = do 67 | r <- newEmptyTMVarIO 68 | c <- newTVarIO False 69 | ch <- newEmptyTMVarIO 70 | channel <- openCH ch s 71 | return (CommandsHandle (Just r) ch c, channel) 72 | 73 | openCH :: TMVar Channel -> Session -> IO Channel 74 | openCH var s = do 75 | ch <- openChannelSession s 76 | atomically $ putTMVar var ch 77 | return ch 78 | 79 | -- | Get return code for previously run command. 80 | -- It will fail if command was run using execCommand False. 81 | -- Should be called only when all command output is read. 82 | getReturnCode :: CommandsHandle -> IO Int 83 | getReturnCode ch = do 84 | c <- atomically $ readTVar (chChannelClosed ch) 85 | if c 86 | then do 87 | case chReturnCode ch of 88 | Nothing -> fail "Channel already closed and no exit code return was set up for command." 89 | Just v -> atomically $ takeTMVar v 90 | else do 91 | channel <- atomically $ takeTMVar (chChannel ch) 92 | cleanupChannel ch channel 93 | atomically $ writeTVar (chChannelClosed ch) True 94 | case chReturnCode ch of 95 | Nothing -> fail "No exit code return was set up for commnand." 96 | Just v -> do 97 | rc <- atomically $ takeTMVar v 98 | return rc 99 | 100 | execCommandSrc :: MonadIO m => CommandsHandle -> Channel -> String -> Source m B.ByteString 101 | execCommandSrc var channel command = src 102 | where 103 | src = do 104 | liftIO $ channelExecute channel command 105 | pullAnswer channel 106 | 107 | pullAnswer ch = do 108 | res <- liftIO $ readChannel ch 0x400 109 | if B.length res > 0 110 | then do 111 | yield res 112 | pullAnswer ch 113 | else do 114 | liftIO $ cleanupChannel var ch 115 | return () 116 | 117 | -- | Close Channel and write return code 118 | cleanupChannel :: CommandsHandle -> Channel -> IO () 119 | cleanupChannel ch channel = do 120 | c <- atomically $ readTVar (chChannelClosed ch) 121 | when (not c) $ do 122 | closeChannel channel 123 | case chReturnCode ch of 124 | Nothing -> return () 125 | Just v -> do 126 | exitStatus <- channelExitStatus channel 127 | atomically $ putTMVar v exitStatus 128 | closeChannel channel 129 | freeChannel channel 130 | atomically $ writeTVar (chChannelClosed ch) True 131 | return () 132 | 133 | -------------------------------------------------------------------------------- /libssh2-conduit/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /libssh2-conduit/hs-ssh-forwarder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Conduit 6 | import Control.Concurrent 7 | import Control.Concurrent.Async (concurrently) 8 | import Control.Monad 9 | import Data.Conduit.Network 10 | import System.Environment 11 | import System.FilePath 12 | 13 | import Network.SSH.Client.LibSSH2.Foreign 14 | import Network.SSH.Client.LibSSH2.Conduit 15 | import Network.SSH.Client.LibSSH2 16 | 17 | import Network.Socket hiding (send, sendTo, recv, recvFrom) 18 | 19 | import qualified Control.Exception as E 20 | 21 | main :: IO () 22 | main = do 23 | args <- getArgs 24 | case args of 25 | [user, host, port, srcport, dstport] -> run user host (read port) (read srcport) (read dstport) 26 | _ -> putStrLn "Synopsis: hs-ssh-forwarder USERNAME HOSTNAME SSHPORT SRCPORT DSTPORT" 27 | 28 | run :: String -> String -> PortNumber -> PortNumber -> PortNumber -> IO () 29 | run username host port srcport dstport = do 30 | initialize True 31 | 32 | E.bracket (open srcport) (\s -> close s >> exit) $ \sock -> void . forever $ do 33 | (conn, _) <- accept sock 34 | forkFinally 35 | (handleConn username host port dstport conn) 36 | (const $ close conn) 37 | 38 | open :: PortNumber -> IO Socket 39 | open srcport = do 40 | sock <- socket AF_INET6 Stream defaultProtocol 41 | setSocketOption sock ReuseAddr 1 42 | setSocketOption sock ReusePort 1 43 | bind sock $ SockAddrInet6 srcport 0 iN6ADDR_ANY 0 44 | listen sock 5 45 | return sock 46 | 47 | handleConn :: String -> String -> PortNumber -> PortNumber -> Socket -> IO () 48 | handleConn login host sshport dstport conn = ssh login host (fromIntegral sshport) $ \session -> do 49 | channel <- directTcpIpEx session "localhost" (fromIntegral dstport) host (fromIntegral sshport) 50 | 51 | void $ concurrently 52 | (runConduit $ sourceChannel channel .| sinkSocket conn) 53 | (runConduit $ sourceSocket conn .| sinkChannel channel) 54 | 55 | closeChannel channel 56 | freeChannel channel 57 | 58 | ssh login host port actions = do 59 | home <- getEnv "HOME" 60 | let known_hosts = home ".ssh" "known_hosts" 61 | public = home ".ssh" "id_rsa.pub" 62 | private = home ".ssh" "id_rsa" 63 | withSSH2 known_hosts public private "" login host port $ actions 64 | -------------------------------------------------------------------------------- /libssh2-conduit/libssh2-conduit.cabal: -------------------------------------------------------------------------------- 1 | Name: libssh2-conduit 2 | Version: 0.2.1 3 | 4 | Synopsis: Conduit wrappers for libssh2 FFI bindings (see libssh2 package). 5 | 6 | Description: This package provides Conduit interface (see conduit package) for 7 | libssh2 FFI bindings (see libssh2 package). This allows one to 8 | receive data from SSH channels lazily, without need to read 9 | all channel output to the memory. 10 | 11 | Homepage: https://github.com/portnov/libssh2-hs 12 | 13 | License: BSD3 14 | 15 | License-file: LICENSE 16 | 17 | Author: IlyaPortnov 18 | 19 | Maintainer: portnov84@rambler.ru 20 | 21 | Category: Network 22 | 23 | Build-type: Simple 24 | 25 | Extra-source-files: Makefile, ssh-client.hs 26 | 27 | -- Constraint on the version of Cabal needed to build this package. 28 | Cabal-version: >=1.8 29 | 30 | flag example-client 31 | description: Build the example client 32 | default: False 33 | 34 | flag example-forwarder 35 | description: Build the example SSH forwarder 36 | default: False 37 | 38 | Library 39 | Exposed-modules: Network.SSH.Client.LibSSH2.Conduit 40 | GHC-Options: -fwarn-unused-imports 41 | 42 | Build-depends: base >= 4 && <5, 43 | bytestring >= 0.10, 44 | conduit >= 1.0.7, 45 | libssh2 >= 0.2.0.5, 46 | stm, 47 | transformers 48 | 49 | Executable hs-ssh-client 50 | if flag(example-client) 51 | Build-depends: base, libssh2 >= 0.2.0.5, 52 | stm >= 2.4, 53 | transformers, 54 | libssh2-conduit >= 0.2.1, 55 | conduit >= 1.0.7, 56 | conduit-combinators >= 1.0.3, 57 | text >= 1.2.2.0, 58 | filepath, bytestring 59 | else 60 | buildable: False 61 | Main-Is: ssh-client.hs 62 | Other-modules: Network.SSH.Client.LibSSH2.Conduit 63 | GHC-Options: -threaded -fwarn-unused-imports 64 | 65 | Executable hs-ssh-forwarder 66 | if flag(example-forwarder) 67 | Build-depends: base, libssh2 >= 0.2.0.5, 68 | stm >= 2.4, 69 | transformers, 70 | libssh2-conduit >= 0.2.1, 71 | conduit >= 1.0.7, 72 | conduit-combinators >= 1.0.3, 73 | text >= 1.2.2.0, 74 | filepath, bytestring, 75 | async, network, 76 | conduit-extra 77 | else 78 | buildable: False 79 | Main-Is: hs-ssh-forwarder.hs 80 | Other-modules: Network.SSH.Client.LibSSH2.Conduit 81 | GHC-Options: -threaded -fwarn-unused-imports 82 | 83 | Source-repository head 84 | type: git 85 | location: https://github.com/portnov/libssh2-hs 86 | -------------------------------------------------------------------------------- /libssh2-conduit/ssh-client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | import Data.Conduit 4 | import qualified Data.Conduit.Combinators as C 5 | import qualified Data.Conduit.List as CL 6 | import System.Environment 7 | import System.FilePath 8 | import qualified Data.Text.IO as TIO 9 | import System.IO 10 | 11 | import Network.SSH.Client.LibSSH2.Foreign 12 | import Network.SSH.Client.LibSSH2.Conduit 13 | import Network.SSH.Client.LibSSH2 14 | 15 | main = do 16 | args <- getArgs 17 | case args of 18 | [user, host, port, cmd] -> ssh user host (read port) cmd 19 | _ -> putStrLn "Synopsis: ssh-client USERNAME HOSTNAME PORT COMMAND" 20 | 21 | ssh login host port command = do 22 | initialize True 23 | home <- getEnv "HOME" 24 | let known_hosts = home ".ssh" "known_hosts" 25 | public = home ".ssh" "id_rsa.pub" 26 | private = home ".ssh" "id_rsa" 27 | withSession host port $ \session -> do 28 | r <- checkHost session host port known_hosts [TYPE_MASK] 29 | publicKeyAuthFile session login public private "" 30 | (Just ch, !src) <- execCommand True session command 31 | hSetBuffering stdout NoBuffering 32 | src =$= C.decodeUtf8 =$= C.linesUnbounded $$ CL.mapM_ TIO.putStrLn 33 | rc <- getReturnCode ch 34 | putStrLn $ "Exit code: " ++ show rc 35 | exit 36 | 37 | returnStrict !x = return x 38 | -------------------------------------------------------------------------------- /libssh2/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, IlyaPortnov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of IlyaPortnov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /libssh2/Makefile: -------------------------------------------------------------------------------- 1 | LIBS=-lssh2 2 | GHC=ghc $(LIBS) -isrc/ --make 3 | C2HS=c2hs -C"-Iinclude/" 4 | HSFILES=src/Network/SSH/Client/LibSSH2.hs src/Network/SSH/Client/LibSSH2/Types.hs src/Network/SSH/Client/LibSSH2/Errors.hs src/Network/SSH/Client/LibSSH2/Foreign.hs 5 | 6 | all: ssh-client 7 | 8 | ssh-client: ssh-client.hs $(HSFILES) 9 | $(GHC) $< 10 | 11 | %.hs: %.chs 12 | $(C2HS) $< 13 | 14 | clean: 15 | find . -name \*.hi -delete 16 | find . -name \*.chi -delete 17 | find . -name \*.o -delete 18 | find . -name \*.chs.h -delete 19 | rm -f ssh-client 20 | -------------------------------------------------------------------------------- /libssh2/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /libssh2/include/gcrypt-fix.h: -------------------------------------------------------------------------------- 1 | #ifndef GCRYPT_FIX_H 2 | #define GCRYPT_FIX_H 3 | 4 | void gcrypt_fix(); 5 | 6 | #endif 7 | -------------------------------------------------------------------------------- /libssh2/include/libssh2_local.h: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | 4 | // This definition is used to determine sizeof(struct stat), 5 | // because c2hs lacks support for such case. 6 | typedef struct stat stat_t; 7 | 8 | -------------------------------------------------------------------------------- /libssh2/libssh2.cabal: -------------------------------------------------------------------------------- 1 | Name: libssh2 2 | 3 | Version: 0.2.0.9 4 | 5 | Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) 6 | 7 | Description: This package provides FFI bindings for SSH2 client library named libssh2. 8 | . 9 | As of version 0.2 all blocking is handled in Haskell code 10 | rather than in C code. This means that all calls are now 11 | interruptable using Haskell asynchronous exceptions; for 12 | instance, it is now possible to use "System.Timeout" in 13 | combination with "libssh2". 14 | . 15 | /Note on usage on Windows/: On Windows you MUST compile 16 | your executable with @-threaded@ or 'libssh2' will NOT 17 | work. We have tested 'libssh2' on Windows using 18 | , with and 19 | compiled from source (be sure to pass 20 | the 'shared' option to the configure script for 'openssl' 21 | to enable the shared libraries). 22 | 23 | Homepage: https://github.com/portnov/libssh2-hs 24 | 25 | License: BSD3 26 | 27 | License-file: LICENSE 28 | 29 | Author: IlyaPortnov 30 | 31 | Maintainer: portnov84@rambler.ru 32 | 33 | -- A copyright notice. 34 | -- Copyright: 35 | 36 | Category: Network 37 | 38 | Build-type: Simple 39 | 40 | Extra-source-files: ssh-client.hs, Makefile, include/libssh2_local.h 41 | 42 | -- Constraint on the version of Cabal needed to build this package. 43 | Cabal-version: >=1.10 44 | 45 | flag gcrypt 46 | description: add hack that allows to run threaded program when libssh2 is built against gcrypt 47 | default: False 48 | 49 | flag example-client 50 | description: Build the example client 51 | default: False 52 | 53 | Library 54 | Exposed-modules: Network.SSH.Client.LibSSH2.Types 55 | Network.SSH.Client.LibSSH2.Foreign 56 | Network.SSH.Client.LibSSH2.Errors 57 | Network.SSH.Client.LibSSH2.WaitSocket 58 | Network.SSH.Client.LibSSH2 59 | 60 | Include-dirs: include 61 | Includes: include/libssh2_local.h 62 | if os(mingw32) && arch(x86_64) 63 | cpp-options: -Dx86_64_HOST_ARCH 64 | 65 | -- Everything else is some form of Unix 66 | if !os(mingw32) 67 | build-depends: unix 68 | 69 | Build-depends: base >= 4 && < 5, 70 | network >= 2.3 && < 3.3, 71 | syb >= 0.3.3, time >= 1.2, 72 | bytestring >= 0.9 73 | 74 | Extra-libraries: "ssh2" 75 | pkgconfig-depends: libssh2 >= 1.2.8 76 | GHC-Options: -Wall 77 | Default-Language: Haskell2010 78 | 79 | -- Other-modules: 80 | 81 | Build-tools: c2hs 82 | HS-Source-Dirs: src 83 | 84 | if flag(gcrypt) 85 | c-sources: src/Network/SSH/Client/LibSSH2/FFI/gcrypt-fix.c 86 | Includes: gcrypt-fix.h 87 | Exposed-modules: Network.SSH.Client.LibSSH2.GCrypt 88 | Cpp-options: -DGCRYPT 89 | 90 | Executable hs-ssh-client 91 | if flag(example-client) 92 | Build-depends: base, utf8-string, syb, network, filepath, bytestring, time, libssh2 93 | else 94 | buildable: False 95 | Main-Is: ssh-client.hs 96 | GHC-Options: -threaded 97 | Default-Language: Haskell2010 98 | 99 | Source-repository head 100 | type: git 101 | location: https://github.com/portnov/libssh2-hs 102 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Network.SSH.Client.LibSSH2 3 | (-- * Types 4 | Session, Channel, KnownHosts, Sftp, SftpHandle, 5 | SftpAttributes, SftpList, SftpFileTransferFlags, 6 | 7 | -- * Functions 8 | withSSH2, 9 | withSSH2User, 10 | withSSH2Agent, 11 | withSession, 12 | withChannel, 13 | withChannelBy, 14 | checkHost, 15 | readAllChannel, 16 | writeAllChannel, 17 | scpSendFile, 18 | scpReceiveFile, 19 | runShellCommands, 20 | execCommands, 21 | directTcpIpEx, 22 | 23 | -- * Sftp Functions 24 | withSFTP, 25 | withSFTPUser, 26 | withSftpSession, 27 | sftpListDir, 28 | sftpRenameFile, 29 | sftpSendFile, sftpSendFromHandle, 30 | sftpSendBytes, 31 | sftpReceiveFile, sftpReadFileToHandler, 32 | sftpFstat, 33 | sftpDeleteFile, 34 | 35 | -- * Utilities 36 | socketConnect, 37 | sessionInit, 38 | sessionClose, 39 | ) where 40 | 41 | import Control.Monad 42 | import Control.Exception as E 43 | import Network.Socket 44 | import System.IO 45 | import qualified Data.ByteString as BSS 46 | import qualified Data.ByteString.Char8 as BSSC 47 | import qualified Data.ByteString.Lazy as BSL 48 | 49 | import Network.SSH.Client.LibSSH2.Types 50 | import Network.SSH.Client.LibSSH2.Foreign 51 | import Network.SSH.Client.LibSSH2.Errors (ErrorCode) 52 | 53 | -- | Similar to Network.connectTo, but does not socketToHandle. 54 | socketConnect :: String -> Int -> IO Socket 55 | socketConnect hostname port = do 56 | let hints = defaultHints { addrSocketType = Stream } 57 | addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port) 58 | bracketOnError 59 | (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) 60 | (close) 61 | (\sock -> do 62 | connect sock $ addrAddress addr 63 | return sock) 64 | 65 | -- | Execute some actions within SSH2 connection. 66 | -- Uses public key authentication. 67 | withSSH2 :: FilePath -- ^ Path to known_hosts file 68 | -> FilePath -- ^ Path to public key file 69 | -> FilePath -- ^ Path to private key file 70 | -> String -- ^ Passphrase 71 | -> String -- ^ Remote user name 72 | -> String -- ^ Remote host name 73 | -> Int -- ^ Remote port number (usually 22) 74 | -> (Session -> IO a) -- ^ Actions to perform on session 75 | -> IO a 76 | withSSH2 known_hosts public private passphrase login hostname port fn = 77 | withSession hostname port $ \s -> do 78 | r <- checkHost s hostname port known_hosts [TYPE_MASK] 79 | when (r == MISMATCH) $ 80 | error $ "Host key mismatch for host " ++ hostname 81 | publicKeyAuthFile s login public private passphrase 82 | fn s 83 | 84 | -- | Execute some actions within SSH2 connection. 85 | -- Uses agent based public key authentication. 86 | withSSH2Agent :: String -- ^ Path to known_hosts file 87 | -> String -- ^ Remote user name 88 | -> String -- ^ Remote host name 89 | -> Int -- ^ Remote port number (usually 22) 90 | -> (Session -> IO a) -- ^ Actions to perform on session 91 | -> IO a 92 | withSSH2Agent known_hosts login hostname port fn = 93 | withSession hostname port $ \s -> do 94 | r <- checkHost s hostname port known_hosts [TYPE_MASK] 95 | when (r == MISMATCH) $ 96 | error $ "host key mismatch for host " ++ hostname 97 | E.bracket (agentInit s) agentFree $ \a -> 98 | E.bracket_ (agentConnect a) (agentDisconnect a) (act s login a fn) 99 | where 100 | act s u a f = do 101 | agentListIdentities a 102 | agentAuthenticate u a 103 | f s 104 | 105 | -- | Execute some actions within SSH2 connection. 106 | -- Uses username/password authentication. 107 | withSSH2User :: FilePath -- ^ Path to known_hosts file 108 | -> String -- ^ Remote user name 109 | -> String -- ^ Remote password 110 | -> String -- ^ Remote host name 111 | -> Int -- ^ Remote port number (usually 22) 112 | -> (Session -> IO a) -- ^ Actions to perform on session 113 | -> IO a 114 | withSSH2User known_hosts login password hostname port fn = 115 | withSession hostname port $ \s -> do 116 | r <- checkHost s hostname port known_hosts [TYPE_MASK] 117 | when (r == MISMATCH) $ 118 | error $ "Host key mismatch for host " ++ hostname 119 | usernamePasswordAuth s login password 120 | fn s 121 | 122 | -- | Execute some actions within SSH2 session 123 | withSession :: String -- ^ Remote host name 124 | -> Int -- ^ Remote port number (usually 22) 125 | -> (Session -> IO a) -- ^ Actions to perform on handle and session 126 | -> IO a 127 | withSession hostname port = E.bracket (sessionInit hostname port) sessionClose 128 | 129 | -- | Initialize session to the gived host 130 | sessionInit :: String -> Int -> IO Session 131 | sessionInit hostname port = do 132 | sock <- socketConnect hostname port 133 | session <- initSession 134 | setBlocking session False 135 | hs <- E.try (handshake session sock) 136 | case hs of 137 | Right () -> pure session 138 | Left e -> sessionClose session >> E.throw (e :: ErrorCode) 139 | 140 | -- | Close active session 141 | sessionClose :: Session -> IO () 142 | sessionClose session = disconnectSession session "Done." `E.finally` do 143 | sessionGetSocket session >>= maybe (pure ()) close 144 | freeSession session 145 | 146 | 147 | 148 | -- | Check remote host against known hosts list 149 | checkHost :: Session 150 | -> String -- ^ Remote host name 151 | -> Int -- ^ Remote port number (usually 22) 152 | -> FilePath -- ^ Path to known_hosts file 153 | -> [KnownHostType] -- ^ Flags specifying what format the host name is, what format the key is and what key type it is 154 | -> IO KnownHostResult 155 | checkHost s host port path flags = bracket 156 | (initKnownHosts s) 157 | freeKnownHosts 158 | (\kh -> do 159 | _numKnownHosts <- knownHostsReadFile kh path 160 | (hostkey, _keytype) <- getHostKey s 161 | checkKnownHost kh host port hostkey flags 162 | ) 163 | 164 | -- | Execute some actions withing SSH2 channel 165 | withChannel :: Session -> (Channel -> IO a) -> IO (Int, a) 166 | withChannel s = withChannelBy (openChannelSession s) id 167 | 168 | -- | Read all data from the channel 169 | -- 170 | -- Although this function returns a lazy bytestring, the data is /not/ read 171 | -- lazily. 172 | readAllChannel :: Channel -> IO BSL.ByteString 173 | readAllChannel ch = go [] 174 | where 175 | go :: [BSS.ByteString] -> IO BSL.ByteString 176 | go acc = do 177 | bs <- readChannel ch 0x400 178 | if BSS.length bs > 0 179 | then go (bs : acc) 180 | else return (BSL.fromChunks $ reverse acc) 181 | 182 | readAllChannelNonBlocking :: Channel -> IO BSL.ByteString 183 | readAllChannelNonBlocking ch = go [] 184 | where 185 | go :: [BSS.ByteString] -> IO BSL.ByteString 186 | go acc = do 187 | bs <- do readable <- pollChannelRead ch 188 | if readable 189 | then readChannel ch 0x400 190 | else return BSS.empty 191 | if BSS.length bs > 0 192 | then go (bs : acc) 193 | else return (BSL.fromChunks $ reverse acc) 194 | 195 | -- | Write a lazy bytestring to the channel 196 | writeAllChannel :: Channel -> BSL.ByteString -> IO () 197 | writeAllChannel ch = mapM_ (writeChannel ch) . BSL.toChunks 198 | 199 | runShellCommands :: Session -> [String] -> IO (Int, [BSL.ByteString]) 200 | runShellCommands s commands = withChannel s $ \ch -> do 201 | requestPTY ch "linux" 202 | channelShell ch 203 | _hello <- readAllChannelNonBlocking ch 204 | out <- forM commands $ \cmd -> do 205 | writeChannel ch (BSSC.pack $ cmd ++ "\n") 206 | r <- readAllChannelNonBlocking ch 207 | return r 208 | channelSendEOF ch 209 | return out 210 | 211 | execCommands :: Session -> [String] -> IO (Int, [BSL.ByteString]) 212 | execCommands s commands = withChannel s $ \ch -> 213 | forM commands $ \cmd -> do 214 | channelExecute ch cmd 215 | readAllChannel ch 216 | 217 | -- | Send a file to remote host via SCP. 218 | -- Returns size of sent data. 219 | scpSendFile :: Session 220 | -> Int -- ^ File creation mode (0o777, for example) 221 | -> FilePath -- ^ Path to local file 222 | -> FilePath -- ^ Remote file path 223 | -> IO Integer 224 | scpSendFile s mode local remote = do 225 | h <- openFile local ReadMode 226 | size <- hFileSize h 227 | (_, result) <- withChannelBy (scpSendChannel s remote mode (fromIntegral size) 0 0) id $ \ch -> do 228 | written <- writeChannelFromHandle ch h 229 | channelSendEOF ch 230 | channelWaitEOF ch 231 | return written 232 | hClose h 233 | return result 234 | 235 | -- | Receive file from remote host via SCP. 236 | -- Returns size of received data. 237 | scpReceiveFile :: Session -- 238 | -> FilePath -- ^ Remote file path 239 | -> FilePath -- ^ Path to local file 240 | -> IO Integer 241 | scpReceiveFile s remote local = do 242 | h <- openFile local WriteMode 243 | (_, result) <- withChannelBy (scpReceiveChannel s remote) fst $ \(ch, fileSize) -> do 244 | readChannelToHandle ch h fileSize 245 | hClose h 246 | return result 247 | 248 | -- | Generalization of 'withChannel' 249 | withChannelBy :: IO a -- ^ Create a channel (and possibly other stuff) 250 | -> (a -> Channel) -- ^ Extract the channel from "other stuff" 251 | -> (a -> IO b) -- ^ Actions to execute on the channel 252 | -> IO (Int, b) -- ^ Channel exit status and return value 253 | withChannelBy createChannel extractChannel actions = 254 | bracket createChannel (freeChannel . extractChannel) $ \stuff -> do 255 | let ch = extractChannel stuff 256 | result <- actions stuff 257 | closeChannel ch 258 | exitStatus <- channelExitStatus ch 259 | return (exitStatus, result) 260 | 261 | -- | Execute some actions within SFTP connection. 262 | -- Uses public key authentication. 263 | withSFTP :: FilePath -- ^ Path to known_hosts file 264 | -> FilePath -- ^ Path to public key file 265 | -> FilePath -- ^ Path to private key file 266 | -> String -- ^ Passphrase 267 | -> String -- ^ Remote user name 268 | -> String -- ^ Remote host name 269 | -> Int -- ^ Remote port number (usually 22) 270 | -> (Sftp -> IO a) -- ^ Actions to perform on sftp session 271 | -> IO a 272 | withSFTP known_hosts public private passphrase login hostname port fn = 273 | withSession hostname port $ \s -> do 274 | r <- checkHost s hostname port known_hosts [TYPE_MASK] 275 | when (r == MISMATCH) $ 276 | error $ "Host key mismatch for host " ++ hostname 277 | publicKeyAuthFile s login public private passphrase 278 | withSftpSession s fn 279 | 280 | -- | Execute some actions within SFTP connection. 281 | -- Uses username/password authentication. 282 | withSFTPUser :: FilePath -- ^ Path to known_hosts file 283 | -> String -- ^ Remote user name 284 | -> String -- ^ Remote password 285 | -> String -- ^ Remote host name 286 | -> Int -- ^ Remote port number (usually 22) 287 | -> (Sftp -> IO a) -- ^ Actions to perform on sftp session 288 | -> IO a 289 | withSFTPUser known_hosts login password hostname port fn = 290 | withSession hostname port $ \s -> do 291 | r <- checkHost s hostname port known_hosts [TYPE_MASK] 292 | when (r == MISMATCH) $ 293 | error $ "Host key mismatch for host " ++ hostname 294 | usernamePasswordAuth s login password 295 | withSftpSession s fn 296 | 297 | -- | Execute some actions within SFTP session 298 | withSftpSession :: Session -- ^ Remote host name 299 | -> (Sftp -> IO a) -- ^ Actions to perform on sftp session 300 | -> IO a 301 | withSftpSession session = 302 | E.bracket (sftpInit session) sftpShutdown 303 | 304 | type SftpList = [(BSS.ByteString, SftpAttributes)] 305 | 306 | -- | Reads directory information 307 | -- Returns the list of files with attributes, directory . and .. 308 | -- are not excluded 309 | sftpListDir :: Sftp -- ^ Opened sftp session 310 | -> FilePath -- ^ Remote directory to read 311 | -> IO SftpList 312 | sftpListDir sftp path = 313 | let 314 | collectFiles :: SftpHandle -> SftpList -> IO SftpList 315 | collectFiles h acc = do 316 | v <- sftpReadDir h 317 | case v of 318 | Nothing -> return acc 319 | Just r -> collectFiles h (r : acc) 320 | in 321 | withDirList sftp path $ \h -> 322 | collectFiles h [] 323 | 324 | withDirList :: Sftp 325 | -> FilePath 326 | -> (SftpHandle -> IO a) 327 | -> IO a 328 | withDirList sftp path = E.bracket (sftpOpenDir sftp path) sftpCloseHandle 329 | 330 | 331 | -- | Send a file to remote host via SFTP 332 | -- Returns size of sent data. 333 | sftpSendFile :: Sftp -- ^ Opened sftp session 334 | -> FilePath -- ^ Path to local file 335 | -> FilePath -- ^ Remote file path 336 | -> Int -- ^ File creation mode (0o777, for example) 337 | -> IO Integer 338 | sftpSendFile sftp local remote mode = 339 | withFile local ReadMode $ \fh -> 340 | sftpSendFromHandle sftp fh remote mode 341 | 342 | -- | Send a file to remote host via SFTP 343 | -- Returns size of sent data. 344 | sftpSendFromHandle :: Sftp -- ^ Opened sftp session 345 | -> Handle -- ^ Handle to read from 346 | -> FilePath -- ^ Remote file path 347 | -> Int -- ^ File creation mode (0o777, for example) 348 | -> IO Integer 349 | sftpSendFromHandle sftp fh remote mode = do 350 | let flags = [FXF_WRITE, FXF_CREAT, FXF_TRUNC, FXF_EXCL] 351 | withOpenSftpFile sftp remote mode flags $ \sftph -> 352 | sftpWriteFileFromHandler sftph fh 353 | 354 | -- | Send bytes to a remote host via SFTP 355 | -- Returns the size of sent data. 356 | sftpSendBytes :: Sftp -- ^ Opened sftp session 357 | -> BSS.ByteString -- ^ Bytes to write 358 | -> FilePath -- ^ Remote file path 359 | -> Int -- ^ File creation mode (0o777, for example) 360 | -> IO Integer 361 | sftpSendBytes sftp bytes remote mode = do 362 | let flags = [FXF_WRITE, FXF_CREAT, FXF_TRUNC, FXF_EXCL] 363 | withOpenSftpFile sftp remote mode flags $ \sftph -> 364 | sftpWriteFileFromBytes sftph bytes 365 | 366 | -- | Received a file from remote host via SFTP 367 | -- Returns size of received data. 368 | sftpReceiveFile :: Sftp -- ^ Opened sftp session 369 | -> FilePath -- ^ Path to local file 370 | -> FilePath -- ^ Remote file path 371 | -> IO Integer 372 | sftpReceiveFile sftp local remote = 373 | withFile local WriteMode $ \fh -> 374 | sftpReceiveToHandle sftp remote fh 375 | 376 | -- | Received a file from remote host via SFTP 377 | -- Returns size of received data. 378 | sftpReceiveToHandle :: Sftp -- ^ Opened sftp session 379 | -> FilePath -- ^ Path to remote file 380 | -> Handle -- ^ Open handle to write to 381 | -> IO Integer 382 | sftpReceiveToHandle sftp remote fh = do 383 | result <- withOpenSftpFile sftp remote 0 [FXF_READ] $ \sftph -> do 384 | fstat <- sftpFstat sftph 385 | sftpReadFileToHandler sftph fh (fromIntegral $ saFileSize fstat) 386 | return $ fromIntegral result 387 | 388 | withOpenSftpFile :: Sftp 389 | -> FilePath 390 | -> Int 391 | -> [SftpFileTransferFlags] 392 | -> (SftpHandle -> IO a) 393 | -> IO a 394 | withOpenSftpFile sftp path mode flags = 395 | E.bracket (sftpOpenFile sftp path mode flags) sftpCloseHandle 396 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/Errors.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, FlexibleInstances #-} 2 | 3 | #ifdef __APPLE__ 4 | #define _ANSI_SOURCE 5 | #define __OSX_AVAILABLE_STARTING(_mac, _iphone) 6 | #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) 7 | #endif 8 | 9 | #include 10 | #include 11 | 12 | {# context lib="ssh2" prefix="libssh2" #} 13 | 14 | module Network.SSH.Client.LibSSH2.Errors 15 | (-- * Types 16 | ErrorCode (..), 17 | SftpErrorCode (..), 18 | NULL_POINTER, 19 | 20 | -- * Utilities 21 | IntResult (..), 22 | 23 | -- * Functions 24 | getLastError, 25 | getLastSftpError, 26 | handleInt, 27 | handleBool, 28 | handleNullPtr, 29 | int2error, error2int, 30 | int2sftperror, sftperror2int, 31 | blockedDirections, 32 | threadWaitSession 33 | ) where 34 | 35 | import Control.Exception 36 | import Data.Generics 37 | import Foreign 38 | import Foreign.C.Types 39 | 40 | import Network.SSH.Client.LibSSH2.Types 41 | import Network.SSH.Client.LibSSH2.WaitSocket 42 | 43 | -- | Error codes returned by libssh2. 44 | data ErrorCode = 45 | NONE 46 | | SOCKET_NONE 47 | | BANNER_RECV 48 | | BANNER_SEND 49 | | INVALID_MAC 50 | | KEX_FALIURE 51 | | ALLOC 52 | | SOCKET_SEND 53 | | KEY_EXCHANGE_FAILURE 54 | | TIMEOUT 55 | | HOSTKEY_INIT 56 | | HOSTKEY_SIGN 57 | | DECRYPT 58 | | SOCKET_DISCONNECT 59 | | PROTO 60 | | PASSWORD_EXPIRED 61 | | FILE 62 | | METHOD_NONE 63 | | AUTHENTICATION_FAILED 64 | | PUBLICKEY_UNVERIFIED 65 | | CHANNEL_OUTOFORDER 66 | | CHANNEL_FAILURE 67 | | CHANNEL_REQUEST_DENIED 68 | | CHANNEL_UNKNOWN 69 | | CHANNEL_WINDOW_EXCEEDED 70 | | CHANNEL_PACKET_EXCEEDED 71 | | CHANNEL_CLOSED 72 | | CHANNEL_EOF_SENT 73 | | SCP_PROTOCOL 74 | | ZLIB 75 | | SOCKET_TIMEOUT 76 | | SFTP_PROTOCOL 77 | | REQUEST_DENIED 78 | | METHOD_NOT_SUPPORTED 79 | | INVAL 80 | | INVALID_POLL_TYPE 81 | | PUBLICKEY_PROTOCOL 82 | | EAGAIN 83 | | BUFFER_TOO_SMALL 84 | | BAD_USE 85 | | COMPRESS 86 | | OUT_OF_BOUNDARY 87 | | AGENT_PROTOCOL 88 | | SOCKET_RECV 89 | | ENCRYPT 90 | | BAD_SOCKET 91 | | ERROR_KNOWN_HOSTS 92 | deriving (Eq, Show, Ord, Enum, Data, Typeable) 93 | 94 | instance Exception ErrorCode 95 | 96 | error2int :: (Num i) => ErrorCode -> i 97 | error2int = fromIntegral . negate . fromEnum 98 | 99 | int2error :: (Integral i) => i -> ErrorCode 100 | int2error = toEnum . negate . fromIntegral 101 | 102 | -- | Exception to throw when null pointer received 103 | -- from libssh2. 104 | data NULL_POINTER = NULL_POINTER 105 | deriving (Eq, Show, Data, Typeable) 106 | 107 | instance Exception NULL_POINTER 108 | 109 | class IntResult a where 110 | intResult :: a -> Int 111 | 112 | instance IntResult Int where 113 | intResult = id 114 | 115 | instance IntResult (Int, a) where 116 | intResult = fst 117 | 118 | instance IntResult (Int, a, b) where 119 | intResult = \(i, _, _) -> i 120 | 121 | instance IntResult (Int, a, b, c) where 122 | intResult = \(i, _, _, _) -> i 123 | 124 | instance IntResult CInt where 125 | intResult = fromIntegral 126 | 127 | instance IntResult CLong where 128 | intResult = fromIntegral 129 | 130 | instance IntResult CLLong where 131 | intResult = fromIntegral 132 | 133 | {# fun session_last_error as getLastError_ 134 | { toPointer `Session', 135 | alloca- `String' peekCStringPtr*, 136 | castPtr `Ptr Int', 137 | `Int' } -> `Int' #} 138 | 139 | -- | Get last error information. 140 | getLastError :: Session -> IO (Int, String) 141 | getLastError s = getLastError_ s nullPtr 0 142 | 143 | -- | Throw an exception if negative value passed, 144 | -- or return unchanged value. 145 | handleInt :: (IntResult a, SshCtx ctx) => Maybe ctx -> IO a -> IO a 146 | handleInt s io = do 147 | x <- io 148 | let r = intResult x 149 | if r < 0 150 | then case int2error r of 151 | EAGAIN -> threadWaitSession s >> handleInt s io 152 | err -> 153 | case s of 154 | Nothing -> throw err 155 | Just ctx -> throwCtxSpecificError ctx err 156 | else return x 157 | 158 | handleBool :: CInt -> IO Bool 159 | handleBool x 160 | | x == 0 = return False 161 | | x > 0 = return True 162 | | otherwise = throw (int2error x) 163 | 164 | -- | Throw an exception if null pointer passed, 165 | -- or return it casted to right type. 166 | handleNullPtr :: (SshCtx c) => Maybe c -> (Ptr () -> IO a) -> IO (Ptr ()) -> IO a 167 | handleNullPtr m_ctx fromPointer io = do 168 | ptr <- io 169 | if ptr == nullPtr 170 | then case m_ctx of 171 | Nothing -> throw NULL_POINTER 172 | Just ctx -> do 173 | let session = getSession ctx 174 | (r, _) <- getLastError session 175 | case int2error r of 176 | EAGAIN -> threadWaitSession (Just session) >> handleNullPtr m_ctx fromPointer io 177 | err -> throwCtxSpecificError ctx err 178 | else fromPointer ptr 179 | 180 | -- | Get currently blocked directions 181 | {# fun session_block_directions as blockedDirections 182 | { toPointer `Session' } -> `[Direction]' int2dir #} 183 | 184 | threadWaitSession :: (SshCtx ctx) => Maybe ctx -> IO () 185 | threadWaitSession Nothing = error "EAGAIN thrown without session present" 186 | threadWaitSession (Just ctx) = do 187 | let s = getSession ctx 188 | mSocket <- sessionGetSocket s 189 | case mSocket of 190 | Nothing -> error "EAGAIN thrown on session without socket" 191 | Just socket -> do 192 | dirs <- blockedDirections s 193 | case dirs of 194 | [] -> pure () 195 | _ -> 196 | if (OUTBOUND `elem` dirs) 197 | then threadWaitWrite socket 198 | else threadWaitRead socket 199 | 200 | -- | Sftp 201 | 202 | {# fun sftp_last_error as getLastSftpError_ 203 | {toPointer `Sftp'} -> `Int' #} 204 | 205 | -- | Get last sftp related error. 206 | getLastSftpError :: Sftp -> IO Int 207 | getLastSftpError sftp = getLastSftpError_ sftp 208 | 209 | sftperror2int :: (Num i) => SftpErrorCode -> i 210 | sftperror2int = fromIntegral . fromEnum 211 | 212 | int2sftperror :: (Integral i) => i -> SftpErrorCode 213 | int2sftperror = toEnum . fromIntegral 214 | 215 | -- | Sftp error code returning from libssh2 216 | data SftpErrorCode = 217 | FX_OK 218 | | FX_EOF 219 | | FX_NO_SUCH_FILE 220 | | FX_PERMISSION_DENIED 221 | | FX_FAILURE 222 | | FX_BAD_MESSAGE 223 | | FX_NO_CONNECTION 224 | | FX_CONNECTION_LOST 225 | | FX_OP_UNSUPPORTED 226 | | FX_INVALID_HANDLE 227 | | FX_NO_SUCH_PATH 228 | | FX_FILE_ALREADY_EXISTS 229 | | FX_WRITE_PROTECT 230 | | FX_NO_MEDIA 231 | | FX_NO_SPACE_ON_FILESYSTEM 232 | | FX_QUOTA_EXCEEDED 233 | | FX_UNKNOWN_PRINCIPAL 234 | | FX_LOCK_CONFLICT 235 | | FX_DIR_NOT_EMPTY 236 | | FX_NOT_A_DIRECTORY 237 | | FX_INVALID_FILENAME 238 | | FX_LINK_LOOP 239 | deriving (Eq, Show, Ord, Enum, Data, Typeable) 240 | 241 | instance Exception SftpErrorCode 242 | 243 | 244 | class SshCtx a where 245 | getSession :: a -> Session 246 | throwCtxSpecificError :: a -> ErrorCode -> IO b 247 | 248 | instance SshCtx Session where 249 | getSession = id 250 | throwCtxSpecificError _ er = throw er 251 | 252 | instance SshCtx Sftp where 253 | getSession = sftpSession 254 | 255 | throwCtxSpecificError ctx SFTP_PROTOCOL = do 256 | er <- getLastSftpError ctx 257 | throw (int2sftperror er) 258 | throwCtxSpecificError _ er = throw er 259 | 260 | instance SshCtx SftpHandle where 261 | getSession = getSession . sftpHandleSession 262 | 263 | throwCtxSpecificError ctx = 264 | throwCtxSpecificError (sftpHandleSession ctx) 265 | 266 | instance SshCtx Agent where 267 | getSession = getSession . agentSession 268 | throwCtxSpecificError _ er = throw er -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/FFI/gcrypt-fix.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "gcrypt-fix.h" 6 | 7 | GCRY_THREAD_OPTION_PTHREAD_IMPL; 8 | 9 | void gcrypt_fix() { 10 | gcry_control (GCRYCTL_SET_THREAD_CBS, &gcry_threads_pthread); 11 | } 12 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/Foreign.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 | 3 | #ifdef __APPLE__ 4 | #define _ANSI_SOURCE 5 | #define __OSX_AVAILABLE_STARTING(_mac, _iphone) 6 | #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) 7 | #endif 8 | 9 | #include "libssh2_local.h" 10 | #include 11 | #include 12 | 13 | {# context lib="ssh2" prefix="libssh2" #} 14 | 15 | module Network.SSH.Client.LibSSH2.Foreign 16 | (-- * Types 17 | KnownHosts, KnownHostResult (..), KnownHostType (..), KnownHost (..), 18 | 19 | -- * Session functions 20 | initialize, exit, 21 | initSession, freeSession, disconnectSession, 22 | keepaliveConfig, 23 | handshake, 24 | setBlocking, 25 | 26 | -- * Known hosts functions 27 | initKnownHosts, freeKnownHosts, knownHostsReadFile, 28 | getHostKey, checkKnownHost, 29 | 30 | -- * Authentication 31 | publicKeyAuthFile, 32 | usernamePasswordAuth, 33 | 34 | -- * Channel functions 35 | openChannelSession, closeChannel, freeChannel, 36 | channelSendEOF, channelWaitEOF, channelIsEOF, 37 | readChannel, readChannelStderr, writeChannel, 38 | writeChannelFromHandle, readChannelToHandle, 39 | channelProcess, channelExecute, channelShell, 40 | requestPTY, requestPTYEx, 41 | directTcpIpEx, 42 | channelExitStatus, channelExitSignal, 43 | scpSendChannel, scpReceiveChannel, pollChannelRead, 44 | 45 | -- * SFTP functions 46 | sftpInit, sftpShutdown, 47 | sftpOpenDir, sftpReadDir, sftpCloseHandle, 48 | sftpOpenFile, 49 | sftpRenameFile, sftpRenameFileEx, 50 | sftpWriteFileFromHandler, sftpWriteFileFromBytes, 51 | sftpReadFileToHandler, sftpFstat, sftpDeleteFile, 52 | 53 | RenameFlag (..), SftpFileTransferFlags (..), 54 | SftpAttributes (..), 55 | 56 | -- * SSH Agent functions 57 | Agent (..), AgentPublicKey, 58 | agentInit, 59 | agentConnect, agentDisconnect, 60 | agentListIdentities, 61 | agentGetIdentity, 62 | agentGetIdentities, 63 | agentFree, 64 | agentPublicKeyComment, 65 | agentPublicKeyBlob, 66 | agentUserAuth, 67 | agentAuthenticate, 68 | 69 | -- * Debug 70 | TraceFlag (..), setTraceMode 71 | ) where 72 | 73 | import Control.Exception (throw, tryJust) 74 | import Control.Monad (void) 75 | import Data.Time.Clock.POSIX 76 | import Foreign hiding (void) 77 | import Foreign.C.Types 78 | import Foreign.C.String 79 | import System.IO 80 | #if MIN_VERSION_network(3,0,0) 81 | import Network.Socket (Socket, withFdSocket) 82 | #else 83 | import Network.Socket (Socket(MkSocket), isReadable) 84 | #endif 85 | import qualified Data.ByteString as BSS 86 | import qualified Data.ByteString.Unsafe as BSS 87 | 88 | import Network.SSH.Client.LibSSH2.Types 89 | import Network.SSH.Client.LibSSH2.Errors 90 | 91 | 92 | #ifdef GCRYPT 93 | import Network.SSH.Client.LibSSH2.GCrypt 94 | #endif 95 | 96 | -- What machine type represents a Socket in this OS. 97 | #ifdef mingw32_HOST_OS 98 | #ifdef x86_64_HOST_ARCH 99 | type MachineSock = CULLong 100 | #else /* x86_64_HOST_ARCH */ 101 | type MachineSock = CUInt 102 | #endif 103 | #else /* mingw32_HOST_OS */ 104 | type MachineSock = CInt 105 | #endif 106 | 107 | -- Known host flags. See libssh2 documentation. 108 | data KnownHostType = 109 | TYPE_MASK 110 | | TYPE_PLAIN 111 | | TYPE_SHA1 112 | | TYPE_CUSTOM 113 | | KEYENC_MASK 114 | | KEYENC_RAW 115 | | KEYENC_BASE64 116 | | KEY_MASK 117 | | KEY_SHIFT 118 | | KEY_RSA1 119 | | KEY_SSHRSA 120 | | KEY_SSHDSS 121 | | KEY_ECDSA_256 122 | | KEY_ECDSA_384 123 | | KEY_ECDSA_521 124 | | KEY_ED25519 125 | | KEY_UNKNOWN 126 | deriving (Eq, Show) 127 | 128 | kht2int :: KnownHostType -> CInt 129 | kht2int TYPE_MASK = 0xffff 130 | kht2int TYPE_PLAIN = 1 131 | kht2int TYPE_SHA1 = 2 132 | kht2int TYPE_CUSTOM = 3 133 | kht2int KEYENC_MASK = 3 `shiftL` 16 134 | kht2int KEYENC_RAW = 1 `shiftL` 16 135 | kht2int KEYENC_BASE64 = 2 `shiftL` 16 136 | kht2int KEY_MASK = 15 `shiftL` 18 137 | kht2int KEY_SHIFT = 18 138 | kht2int KEY_RSA1 = 1 `shiftL` 18 139 | kht2int KEY_SSHRSA = 2 `shiftL` 18 140 | kht2int KEY_SSHDSS = 3 `shiftL` 18 141 | kht2int KEY_ECDSA_256 = 4 `shiftL` 18 142 | kht2int KEY_ECDSA_384 = 5 `shiftL` 18 143 | kht2int KEY_ECDSA_521 = 6 `shiftL` 18 144 | kht2int KEY_ED25519 = 7 `shiftL` 18 145 | kht2int KEY_UNKNOWN = 15 `shiftL` 18 146 | 147 | int2kht :: CInt -> KnownHostType 148 | int2kht 0xffff = TYPE_MASK 149 | int2kht 1 = TYPE_PLAIN 150 | int2kht 2 = TYPE_SHA1 151 | int2kht 3 = TYPE_CUSTOM 152 | int2kht 18 = KEY_SHIFT 153 | int2kht i 154 | | i == 3 `shiftL` 16 = KEYENC_MASK 155 | | i == 1 `shiftL` 16 = KEYENC_RAW 156 | | i == 2 `shiftL` 16 = KEYENC_BASE64 157 | | i == 15 `shiftL` 18 = KEY_MASK 158 | | i == 1 `shiftL` 18 = KEY_RSA1 159 | | i == 2 `shiftL` 18 = KEY_SSHRSA 160 | | i == 3 `shiftL` 18 = KEY_SSHDSS 161 | | i == 4 `shiftL` 18 = KEY_ECDSA_256 162 | | i == 5 `shiftL` 18 = KEY_ECDSA_384 163 | | i == 6 `shiftL` 18 = KEY_ECDSA_521 164 | | i == 7 `shiftL` 18 = KEY_ED25519 165 | | i == 15 `shiftL` 18 = KEY_UNKNOWN 166 | | otherwise = error $ "Unsupported known host type: " ++ show i 167 | 168 | typemask2int :: [KnownHostType] -> CInt 169 | typemask2int list = foldr (.|.) 0 (map kht2int list) 170 | 171 | -- | Host key types. See libssh2 documentation. 172 | data HostKeyType = 173 | UNKNOWN 174 | | RSA 175 | | DSS 176 | | ECDSA_256 177 | | ECDSA_384 178 | | ECDSA_521 179 | | ED25519 180 | deriving (Enum, Eq, Ord) 181 | 182 | instance Show HostKeyType where 183 | show UNKNOWN = "unknown" 184 | show RSA = "ssh-rsa" 185 | show DSS = "ssh-dss" 186 | show ECDSA_256 = "ecdsa-sha2-nistp256" 187 | show ECDSA_384 = "ecdsa-sha2-nistp384" 188 | show ECDSA_521 = "ecdsa-sha2-nistp521" 189 | show ED25519 = "ssh-ed25519" 190 | 191 | int2hkt :: Integral n => n -> HostKeyType 192 | int2hkt = toEnum . fromIntegral 193 | 194 | -- Result of matching host against known_hosts. 195 | data KnownHostResult = 196 | MATCH 197 | | MISMATCH 198 | | NOTFOUND 199 | | FAILURE 200 | deriving (Eq, Show, Ord, Enum) 201 | 202 | int2khresult :: CInt -> KnownHostResult 203 | int2khresult = toEnum . fromIntegral 204 | 205 | data KnownHost = KnownHost { 206 | khMagic :: CUInt, 207 | khNode :: Ptr (), 208 | khName :: String, 209 | khKey :: String, 210 | khTypeMask :: [KnownHostType] } 211 | deriving (Eq, Show) 212 | 213 | init_crypto :: Bool -> CInt 214 | init_crypto False = 1 215 | init_crypto True = 0 216 | 217 | #if MIN_VERSION_network(3,0,0) 218 | ssh2socket :: Socket -> IO MachineSock 219 | ssh2socket s = 220 | #ifdef mingw32_HOST_OS 221 | fromIntegral <$> withFdSocket s pure 222 | #else 223 | withFdSocket s pure 224 | #endif 225 | #else 226 | ssh2socket :: Socket -> MachineSock 227 | ssh2socket (MkSocket s _ _ _ _) = 228 | #ifdef mingw32_HOST_OS 229 | (fromIntegral s) 230 | #else 231 | s 232 | #endif 233 | 234 | #endif /* MIN_VERSION_network(3,0,0) */ 235 | 236 | {# fun init as initialize_ 237 | { init_crypto `Bool' } -> `Int' #} 238 | 239 | -- | Initialize libssh2. Pass True to enable encryption 240 | -- or False to disable it. 241 | initialize :: Bool -> IO () 242 | #ifdef GCRYPT 243 | initialize flags = void . handleInt (Nothing :: Maybe Session) $ gcryptFix >> initialize_ flags 244 | #else 245 | initialize flags = void . handleInt (Nothing :: Maybe Session) $ initialize_ flags 246 | #endif 247 | 248 | -- | Deinitialize libssh2. 249 | #ifdef mingw32_HOST_OS 250 | foreign import ccall safe "libssh2_exit" 251 | exit:: IO () 252 | #else 253 | {# fun exit as exit { } -> `()' #} 254 | #endif 255 | 256 | -- | Create Session object 257 | initSession :: IO Session 258 | initSession = handleNullPtr (Nothing :: Maybe Session) sessionFromPointer $ 259 | {# call session_init_ex #} nullFunPtr nullFunPtr nullFunPtr nullPtr 260 | 261 | {# fun session_free as freeSession_ 262 | { toPointer `Session' } -> `Int' #} 263 | 264 | -- | Free Session object's memory 265 | freeSession :: Session -> IO () 266 | freeSession session = void . handleInt (Just session) $ freeSession_ session 267 | 268 | {# fun session_disconnect_ex as disconnectSessionEx 269 | { toPointer `Session', `Int', `String', `String' } -> `Int' #} 270 | 271 | -- | Disconnect session (but do not free memory) 272 | disconnectSession :: Session 273 | -> String -- ^ Goodbye message 274 | -> IO () 275 | disconnectSession s msg = void . handleInt (Just s) $ disconnectSessionEx s 11 msg "" 276 | 277 | {# fun keepalive_config as keepaliveConfig 278 | { toPointer `Session', bool2int `Bool', `Int' } -> `()' #} 279 | 280 | {# fun session_set_blocking as setBlocking 281 | { toPointer `Session', bool2int `Bool' } -> `()' #} 282 | 283 | bool2int :: Bool -> CInt 284 | bool2int True = 1 285 | bool2int False = 0 286 | 287 | #if MIN_VERSION_network(3,0,0) 288 | -- We use the id function for marshalling because c2hs can't convert type aliases, 289 | -- but the id function can 290 | {# fun session_handshake 291 | { `Ptr ()', id `MachineSock' } -> `Int' #} 292 | 293 | handshake_ :: Session -> Socket -> IO Int 294 | handshake_ session socket = do 295 | session_handshake (toPointer session) =<< ssh2socket socket 296 | #else 297 | {# fun session_handshake as handshake_ 298 | { toPointer `Session', ssh2socket `Socket' } -> `Int' #} 299 | #endif 300 | 301 | -- | Run SSH handshake on network socket. 302 | handshake :: Session -> Socket -> IO () 303 | handshake session socket = do 304 | sessionSetSocket session (Just socket) 305 | void $ handleInt (Just session) 306 | $ handshake_ session socket 307 | 308 | {# fun knownhost_init as initKnownHosts_ 309 | { toPointer `Session' } -> `Ptr ()' id #} 310 | 311 | -- | Create KnownHosts object for given session. 312 | initKnownHosts :: Session -> IO KnownHosts 313 | initKnownHosts session = handleNullPtr (Nothing :: Maybe Session) knownHostsFromPointer $ initKnownHosts_ session 314 | 315 | -- | Free KnownHosts object's memory 316 | {# fun knownhost_free as freeKnownHosts 317 | { toPointer `KnownHosts' } -> `()' #} 318 | 319 | {# fun knownhost_readfile as knownHostsReadFile_ 320 | { toPointer `KnownHosts', `String', id `CInt' } -> `Int' #} 321 | 322 | -- | Read known hosts from file 323 | knownHostsReadFile :: KnownHosts 324 | -> FilePath -- ^ Path to known_hosts file 325 | -> IO Int 326 | knownHostsReadFile kh path = handleInt (Nothing :: Maybe Session) $ knownHostsReadFile_ kh path 1 327 | 328 | {# fun session_hostkey as getHostKey_ 329 | { toPointer `Session', alloca- `Size' peek*, alloca- `CInt' peek* } -> `Ptr CChar' id #} 330 | 331 | -- | Get remote host public key and its type 332 | getHostKey :: Session -> IO (BSS.ByteString, HostKeyType) 333 | getHostKey session = do 334 | (keyPtr, keySize, keyType) <- getHostKey_ session 335 | key <- BSS.packCStringLen (keyPtr, fromIntegral keySize) 336 | pure (key, int2hkt keyType) 337 | 338 | {# fun knownhost_checkp as checkKnownHost_ 339 | { toPointer `KnownHosts', 340 | `String', 341 | `Int', 342 | id `Ptr CChar', 343 | `Int', 344 | typemask2int `[KnownHostType]', 345 | castPtr `Ptr ()' } -> `KnownHostResult' int2khresult #} 346 | 347 | -- | Check host data against known hosts. 348 | checkKnownHost :: KnownHosts -- 349 | -> String -- ^ Host name 350 | -> Int -- ^ Port number (usually 22) 351 | -> BSS.ByteString -- ^ Host public key 352 | -> [KnownHostType] -- ^ Host flags (see libssh2 documentation) 353 | -> IO KnownHostResult 354 | checkKnownHost kh host port key flags = BSS.useAsCStringLen key $ \(keyPtr, keySize) -> do 355 | checkKnownHost_ kh host port keyPtr keySize flags nullPtr 356 | 357 | -- TODO: I don't see the '&' in the libssh2 docs? 358 | {# fun userauth_publickey_fromfile_ex as publicKeyAuthFile_ 359 | { toPointer `Session', 360 | `String' &, 361 | `String', 362 | `String', 363 | `String' } -> `Int' #} 364 | 365 | -- | Perform public key authentication. 366 | publicKeyAuthFile :: Session -- ^ Session 367 | -> String -- ^ Username 368 | -> String -- ^ Path to public key 369 | -> String -- ^ Path to private key 370 | -> String -- ^ Passphrase 371 | -> IO () 372 | publicKeyAuthFile session username public private passphrase = void . handleInt (Just session) $ 373 | publicKeyAuthFile_ session username public private passphrase 374 | 375 | -- | Perform username/password authentication. 376 | usernamePasswordAuth :: Session -- ^ Session 377 | -> String -- ^ Username 378 | -> String -- ^ Password 379 | -> IO () 380 | usernamePasswordAuth session username password = 381 | withCString username $ \usernameptr -> do 382 | withCString password $ \passwordptr -> do 383 | void . handleInt (Just session) $ 384 | {# call userauth_password_ex #} (toPointer session) usernameptr (toEnum $ length username) passwordptr (toEnum $ length password) nullFunPtr 385 | 386 | {# fun channel_open_ex as openSessionChannelEx 387 | { toPointer `Session', 388 | `String' &, 389 | `Int', `Int', 390 | `String' & } -> `Ptr ()' id #} 391 | 392 | {# fun channel_direct_tcpip_ex as directTcpIpEx_ 393 | { toPointer `Session', 394 | `String', 395 | `Int', 396 | `String', 397 | `Int' } -> `Ptr ()' id #} 398 | 399 | directTcpIpEx :: Session -> String -> Int -> String -> Int -> IO Channel 400 | directTcpIpEx s host port shost sport = handleNullPtr (Just s) (channelFromPointer s) $ directTcpIpEx_ s host port shost sport 401 | 402 | -- | Open a channel for session. 403 | openChannelSession :: Session -> IO Channel 404 | openChannelSession s = handleNullPtr (Just s) (channelFromPointer s) $ 405 | openSessionChannelEx s "session" 65536 32768 "" 406 | 407 | channelProcess :: Channel -> String -> String -> IO () 408 | channelProcess ch kind command = void . handleInt (Just $ channelSession ch) $ 409 | channelProcessStartup_ ch kind command 410 | 411 | -- | Execute command 412 | channelExecute :: Channel -> String -> IO () 413 | channelExecute c command = channelProcess c "exec" command 414 | 415 | {# fun channel_process_startup as channelProcessStartup_ 416 | { toPointer `Channel', 417 | `String' &, 418 | `String' & } -> `Int' #} 419 | 420 | -- | Execute shell command 421 | channelShell :: Channel -> IO () 422 | channelShell c = void . handleInt (Just $ channelSession c) $ do 423 | withCStringLen "shell" $ \(s,l) -> do 424 | res <- channelProcessStartup_'_ (toPointer c) s (fromIntegral l) nullPtr 0 425 | return $ (res :: CInt) 426 | 427 | {# fun channel_request_pty_ex as requestPTYEx 428 | { toPointer `Channel', 429 | `String' &, 430 | `String' &, 431 | `Int', `Int', 432 | `Int', `Int' } -> `Int' #} 433 | 434 | requestPTY :: Channel -> String -> IO () 435 | requestPTY ch term = void . handleInt (Just $ channelSession ch) $ requestPTYEx ch term "" 0 0 0 0 436 | 437 | readChannelEx :: Channel -> Int -> Size -> IO BSS.ByteString 438 | readChannelEx ch i size = do 439 | allocaBytes (fromIntegral size) $ \buffer -> do 440 | rc <- handleInt (Just $ channelSession ch) $ {# call channel_read_ex #} (toPointer ch) (fromIntegral i) buffer size 441 | BSS.packCStringLen (buffer, fromIntegral rc) 442 | 443 | -- | Read data from channel. 444 | readChannel :: Channel -- 445 | -> Size -- ^ Amount of data to read 446 | -> IO BSS.ByteString 447 | readChannel c sz = readChannelEx c 0 sz 448 | 449 | -- | Read data from channel. 450 | readChannelStderr :: Channel -- 451 | -> Size -- ^ Amount of data to read 452 | -> IO BSS.ByteString 453 | readChannelStderr c sz = readChannelEx c {#const SSH_EXTENDED_DATA_STDERR#} sz 454 | 455 | -- | Write data to channel. 456 | writeChannel :: Channel -> BSS.ByteString -> IO () 457 | writeChannel ch bs = 458 | BSS.unsafeUseAsCString bs $ go 0 (fromIntegral $ BSS.length bs) 459 | where 460 | go :: Int -> CULong -> CString -> IO () 461 | go offset len cstr = do 462 | written <- handleInt (Just $ channelSession ch) 463 | $ {# call channel_write_ex #} (toPointer ch) 464 | 0 465 | (cstr `plusPtr` offset) 466 | (fromIntegral len) 467 | if fromIntegral written < len 468 | then go (offset + fromIntegral written) (len - fromIntegral written) cstr 469 | else return () 470 | 471 | {# fun channel_send_eof as channelSendEOF_ 472 | { toPointer `Channel' } -> `Int' #} 473 | 474 | channelSendEOF :: Channel -> IO () 475 | channelSendEOF channel = void . handleInt (Just $ channelSession channel) $ channelSendEOF_ channel 476 | 477 | {# fun channel_wait_eof as channelWaitEOF_ 478 | { toPointer `Channel' } -> `Int' #} 479 | 480 | channelWaitEOF :: Channel -> IO () 481 | channelWaitEOF channel = void . handleInt (Just $ channelSession channel) $ channelWaitEOF_ channel 482 | 483 | data TraceFlag = 484 | T_TRANS 485 | | T_KEX 486 | | T_AUTH 487 | | T_CONN 488 | | T_SCP 489 | | T_SFTP 490 | | T_ERROR 491 | | T_PUBLICKEY 492 | | T_SOCKET 493 | deriving (Eq, Show) 494 | 495 | tf2int :: TraceFlag -> CInt 496 | tf2int T_TRANS = 1 `shiftL` 1 497 | tf2int T_KEX = 1 `shiftL` 2 498 | tf2int T_AUTH = 1 `shiftL` 3 499 | tf2int T_CONN = 1 `shiftL` 4 500 | tf2int T_SCP = 1 `shiftL` 5 501 | tf2int T_SFTP = 1 `shiftL` 6 502 | tf2int T_ERROR = 1 `shiftL` 7 503 | tf2int T_PUBLICKEY = 1 `shiftL` 8 504 | tf2int T_SOCKET = 1 `shiftL` 9 505 | 506 | trace2int :: [TraceFlag] -> CInt 507 | trace2int flags = foldr (.|.) 0 (map tf2int flags) 508 | 509 | {# fun trace as setTraceMode 510 | { toPointer `Session', trace2int `[TraceFlag]' } -> `()' #} 511 | 512 | -- | Write all data to channel from handle. 513 | -- Returns amount of transferred data. 514 | writeChannelFromHandle :: Channel -> Handle -> IO Integer 515 | writeChannelFromHandle ch h = 516 | let 517 | go :: Integer -> Ptr a -> IO Integer 518 | go done buffer = do 519 | sz <- hGetBuf h buffer bufferSize 520 | send 0 (fromIntegral sz) buffer 521 | let newDone = done + fromIntegral sz 522 | if sz < bufferSize 523 | then return newDone 524 | else go newDone buffer 525 | 526 | send :: Int -> CLong -> Ptr a -> IO () 527 | send _ 0 _ = return () 528 | send written size buffer = do 529 | sent <- handleInt (Just $ channelSession ch) $ 530 | {# call channel_write_ex #} 531 | (toPointer ch) 532 | 0 533 | (plusPtr buffer written) 534 | (fromIntegral size) 535 | send (written + fromIntegral sent) (size - fromIntegral sent) buffer 536 | 537 | bufferSize = 0x100000 538 | 539 | in allocaBytes bufferSize $ go 0 540 | 541 | -- | Read all data from channel to handle. 542 | -- Returns amount of transferred data. 543 | readChannelToHandle :: Channel -> Handle -> Offset -> IO Integer 544 | readChannelToHandle ch h fileSize = do 545 | allocaBytes bufferSize $ \buffer -> 546 | readChannelCB ch buffer bufferSize fileSize callback 547 | where 548 | callback buffer size = hPutBuf h buffer size 549 | 550 | bufferSize :: Int 551 | bufferSize = 0x100000 552 | 553 | readChannelCB :: Channel -> CString -> Int -> Offset -> (CString -> Int -> IO ()) -> IO Integer 554 | readChannelCB ch buffer bufferSize fileSize callback = 555 | let go got = do 556 | let toRead = min (fromIntegral fileSize - got) (fromIntegral bufferSize) 557 | sz <- handleInt (Just $ channelSession ch) $ 558 | {# call channel_read_ex #} 559 | (toPointer ch) 560 | 0 561 | buffer 562 | (fromIntegral toRead) 563 | let isz :: Integer 564 | isz = fromIntegral sz 565 | callback buffer (fromIntegral sz) 566 | eof <- {# call channel_eof #} (toPointer ch) 567 | let newGot = got + fromIntegral sz 568 | if (eof == 1) || (newGot == fromIntegral fileSize) 569 | then do 570 | return isz 571 | else do 572 | rest <- go newGot 573 | return $ isz + rest 574 | in go (0 :: Integer) 575 | 576 | {# fun channel_eof as channelIsEOF 577 | { toPointer `Channel' } -> `Bool' handleBool* #} 578 | 579 | {# fun channel_close as closeChannel_ 580 | { toPointer `Channel' } -> `Int' #} 581 | 582 | -- | Close channel (but do not free memory) 583 | closeChannel :: Channel -> IO () 584 | closeChannel channel = void . handleInt (Just $ channelSession channel) $ closeChannel_ channel 585 | 586 | {# fun channel_free as freeChannel_ 587 | { toPointer `Channel' } -> `Int' #} 588 | 589 | -- | Free channel object's memory 590 | freeChannel :: Channel -> IO () 591 | freeChannel channel = void . handleInt (Just $ channelSession channel) $ freeChannel_ channel 592 | 593 | -- | Get channel exit status 594 | {# fun channel_get_exit_status as channelExitStatus 595 | { toPointer `Channel' } -> `Int' #} 596 | 597 | {# fun channel_get_exit_signal as channelExitSignal_ 598 | { toPointer `Channel', 599 | alloca- `String' peekCStringPtr*, 600 | castPtr `Ptr Int', 601 | alloca- `Maybe String' peekMaybeCStringPtr*, 602 | castPtr `Ptr Int', 603 | alloca- `Maybe String' peekMaybeCStringPtr*, 604 | castPtr `Ptr Int' } -> `Int' #} 605 | 606 | -- | Get channel exit signal. Returns: 607 | -- (possibly error code, exit signal name, possibly error message, possibly language code). 608 | channelExitSignal :: Channel -> IO (Int, String, Maybe String, Maybe String) 609 | channelExitSignal ch = handleInt (Just $ channelSession ch) $ channelExitSignal_ ch nullPtr nullPtr nullPtr 610 | 611 | {# fun scp_send64 as scpSendChannel_ 612 | { toPointer `Session', 613 | `String', 614 | `Int', 615 | `Int64', 616 | round `POSIXTime', 617 | round `POSIXTime' } -> `Ptr ()' id #} 618 | 619 | -- | Create SCP file send channel. 620 | scpSendChannel :: Session -> String -> Int -> Int64 -> POSIXTime -> POSIXTime -> IO Channel 621 | scpSendChannel session remotePath mode size mtime atime = handleNullPtr (Just session) (channelFromPointer session) $ 622 | scpSendChannel_ session remotePath mode size mtime atime 623 | 624 | type Offset = {# type off_t #} 625 | 626 | -- {# pointer *stat_t as Stat newtype #} 627 | 628 | -- | Create SCP file receive channel. 629 | -- TODO: receive struct stat also. 630 | scpReceiveChannel :: Session -> FilePath -> IO (Channel, Offset) 631 | scpReceiveChannel s path = do 632 | withCString path $ \pathptr -> 633 | allocaBytes {# sizeof stat_t #} $ \statptr -> do 634 | channel <- handleNullPtr (Just s) (channelFromPointer s) $ {# call scp_recv #} (toPointer s) pathptr statptr 635 | size <- {# get stat_t->st_size #} statptr 636 | return (channel, size) 637 | 638 | -- {# fun poll_channel_read as pollChannelRead_ 639 | -- { toPointer `Channel' } -> `Int' #} 640 | 641 | pollChannelRead :: Channel -> IO Bool 642 | pollChannelRead ch = do 643 | mbSocket <- sessionGetSocket (channelSession ch) 644 | case mbSocket of 645 | Nothing -> error "pollChannelRead without socket present" 646 | #if MIN_VERSION_network(3,0,0) 647 | Just _ -> pure True 648 | #else 649 | Just socket -> isReadable socket 650 | #endif 651 | 652 | -- 653 | -- | Sftp support 654 | -- 655 | 656 | -- SFTP File Transfer Flags. See libssh2 documentation 657 | data SftpFileTransferFlags = 658 | FXF_READ 659 | | FXF_WRITE 660 | | FXF_APPEND 661 | | FXF_CREAT 662 | | FXF_TRUNC 663 | | FXF_EXCL 664 | deriving (Eq, Show) 665 | 666 | ftf2int :: SftpFileTransferFlags -> CULong 667 | ftf2int FXF_READ = 0x00000001 668 | ftf2int FXF_WRITE = 0x00000002 669 | ftf2int FXF_APPEND = 0x00000004 670 | ftf2int FXF_CREAT = 0x00000008 671 | ftf2int FXF_TRUNC = 0x00000010 672 | ftf2int FXF_EXCL = 0x00000020 673 | 674 | ftransferflags2int :: [SftpFileTransferFlags] -> CULong 675 | ftransferflags2int list = foldr (.|.) 0 (map ftf2int list) 676 | 677 | -- | Flags for open_ex() 678 | data OpenExFlags = OpenFile 679 | | OpenDir 680 | deriving (Eq, Show) 681 | 682 | oef2int :: (Num a) => OpenExFlags -> a 683 | oef2int OpenFile = 0 684 | oef2int OpenDir = 1 685 | 686 | sftpInit :: Session -> IO Sftp 687 | sftpInit s = handleNullPtr (Just s) (sftpFromPointer s) $ 688 | sftpInit_ s 689 | 690 | sftpShutdown :: Sftp -> IO () 691 | sftpShutdown sftp = 692 | void . handleInt (Just sftp) $ sftpShutdown_ sftp 693 | 694 | {# fun sftp_init as sftpInit_ 695 | { toPointer `Session' } -> `Ptr ()' id #} 696 | 697 | {# fun sftp_shutdown as sftpShutdown_ 698 | { toPointer `Sftp' } -> `Int' #} 699 | 700 | -- | Open regular file handler 701 | sftpOpenFile :: Sftp -> String -> Int -> [SftpFileTransferFlags] -> IO SftpHandle 702 | sftpOpenFile sftp path mode flags = 703 | handleNullPtr (Just sftp) ( sftpHandleFromPointer sftp ) $ 704 | sftpOpen_ sftp path (toEnum mode) flags (oef2int OpenFile) 705 | 706 | -- | Open directory file handler 707 | sftpOpenDir :: Sftp -> String -> IO SftpHandle 708 | sftpOpenDir sftp path = 709 | handleNullPtr (Just sftp) ( sftpHandleFromPointer sftp ) $ 710 | sftpOpen_ sftp path 0 [] (oef2int OpenDir) 711 | 712 | sftpOpen_ :: Sftp -> String -> CLong -> [SftpFileTransferFlags] -> CInt -> IO (Ptr ()) 713 | sftpOpen_ sftp path mode fl open_type = 714 | let flags = ftransferflags2int fl 715 | in 716 | withCStringLen path $ \(pathP, pathL) -> do 717 | {# call sftp_open_ex #} (toPointer sftp) pathP (toEnum pathL) flags mode open_type 718 | 719 | -- | Read directory from file handler 720 | sftpReadDir :: SftpHandle -> IO (Maybe (BSS.ByteString, SftpAttributes)) 721 | sftpReadDir sftph = do 722 | let bufflen = 512 723 | allocaBytes bufflen $ \bufptr -> do 724 | allocaBytes {# sizeof _LIBSSH2_SFTP_ATTRIBUTES #} $ \sftpattrptr -> do 725 | rc <- handleInt (Just sftph) $ 726 | {# call sftp_readdir_ex #} (toPointer sftph) bufptr (fromIntegral bufflen) nullPtr 0 sftpattrptr 727 | case rc == 0 of 728 | False -> do 729 | fstat <- parseSftpAttributes sftpattrptr 730 | filename <- BSS.packCStringLen (bufptr, intResult rc) 731 | return $ Just (filename, fstat) 732 | True -> 733 | return Nothing 734 | 735 | -- | Close file handle 736 | sftpCloseHandle :: SftpHandle -> IO () 737 | sftpCloseHandle sftph = 738 | void . handleInt (Just $ sftpHandleSession sftph) $ 739 | {# call sftp_close_handle #} (toPointer sftph) 740 | 741 | data RenameFlag = 742 | RENAME_OVERWRITE 743 | | RENAME_ATOMIC 744 | | RENAME_NATIVE 745 | deriving (Eq, Show) 746 | 747 | rf2long :: RenameFlag -> CLong 748 | rf2long RENAME_OVERWRITE = 0x00000001 749 | rf2long RENAME_ATOMIC = 0x00000002 750 | rf2long RENAME_NATIVE = 0x00000004 751 | 752 | renameFlag2int :: [RenameFlag] -> CLong 753 | renameFlag2int flags = foldr (.|.) 0 (map rf2long flags) 754 | 755 | -- | Rename a file on the sftp server 756 | sftpRenameFile :: Sftp -- ^ Opened sftp session 757 | -> FilePath -- ^ Old file name 758 | -> FilePath -- ^ New file name 759 | -> IO () 760 | sftpRenameFile sftp src dest = 761 | sftpRenameFileEx sftp src dest [ RENAME_NATIVE, RENAME_ATOMIC, RENAME_OVERWRITE] 762 | 763 | -- | Rename a file on the sftp server 764 | sftpRenameFileEx :: Sftp -- ^ Opened sftp session 765 | -> FilePath -- ^ Old file name 766 | -> FilePath -- ^ New file name 767 | -> [RenameFlag] -- ^ Rename flags 768 | -> IO () 769 | sftpRenameFileEx sftp src dest flags = 770 | withCStringLen src $ \(srcP, srcL) -> 771 | withCStringLen dest $ \(destP, destL) -> 772 | void . handleInt (Just $ sftpSession sftp) $ 773 | {# call sftp_rename_ex #} (toPointer sftp) srcP (toEnum srcL) destP (toEnum destL) (renameFlag2int flags ) 774 | 775 | -- | Download file from the sftp server 776 | sftpReadFileToHandler :: SftpHandle -> Handle -> Int -> IO Int 777 | sftpReadFileToHandler sftph fh fileSize = 778 | let 779 | go :: Int -> Ptr a -> IO Int 780 | go received buffer = do 781 | let toRead :: Int 782 | toRead = min (fromIntegral fileSize - received) bufferSize 783 | sz <- receive toRead buffer 0 784 | _ <- hPutBuf fh buffer sz 785 | let newreceived :: Int 786 | newreceived = (received + fromIntegral sz) 787 | if newreceived < fromIntegral fileSize 788 | then go newreceived buffer 789 | else return $ fromIntegral newreceived 790 | 791 | receive :: Int -> Ptr a -> Int -> IO Int 792 | receive 0 _ read_sz = return read_sz 793 | receive toread buf alreadyread = do 794 | received <- handleInt (Just sftph) 795 | $ {# call sftp_read #} (toPointer sftph) 796 | (buf `plusPtr` alreadyread) 797 | (fromIntegral toread) 798 | receive (toread - fromIntegral received) buf (alreadyread + fromIntegral received) 799 | 800 | bufferSize = 0x100000 801 | 802 | in allocaBytes bufferSize $ go 0 803 | 804 | -- | Upload file to the sftp server 805 | sftpWriteFileFromHandler :: SftpHandle -> Handle -> IO Integer 806 | sftpWriteFileFromHandler sftph fh = 807 | let 808 | go :: Integer -> Ptr a -> IO Integer 809 | go done buffer = do 810 | sz <- hGetBuf fh buffer bufferSize 811 | send 0 (fromIntegral sz) buffer 812 | let newDone = done + fromIntegral sz 813 | if sz < bufferSize 814 | then return newDone 815 | else go newDone buffer 816 | 817 | send :: Int -> CLong -> Ptr a -> IO () 818 | send _ 0 _ = return () 819 | send written size buf = do 820 | sent <- handleInt (Just sftph) 821 | $ {# call sftp_write #} (toPointer sftph) 822 | (buf `plusPtr` written) 823 | (fromIntegral size) 824 | send (written + fromIntegral sent) (size - fromIntegral sent) buf 825 | 826 | bufferSize :: Int 827 | bufferSize = 0x100000 828 | 829 | in allocaBytes bufferSize $ go 0 830 | 831 | -- | Upload bytes to the sftp server 832 | -- Returns size of sent data. 833 | sftpWriteFileFromBytes :: SftpHandle -> BSS.ByteString -> IO Integer 834 | sftpWriteFileFromBytes sftph bs = BSS.useAsCStringLen bs (uncurry (send 0)) 835 | where 836 | send :: Int -> Ptr CChar -> Int -> IO Integer 837 | send written _ 0 = pure (toInteger written) 838 | send written src len = do 839 | let nBytes = min len bufferSize 840 | sent <- fmap fromIntegral . handleInt (Just sftph) 841 | $ {# call sftp_write #} (toPointer sftph) 842 | src 843 | (fromIntegral nBytes) 844 | send (written + sent) (src `plusPtr` sent) (len - sent) 845 | 846 | bufferSize :: Int 847 | bufferSize = 0x100000 848 | 849 | data SftpAttributes = SftpAttributes { 850 | saFlags :: CULong, 851 | saFileSize :: CULLong, 852 | saUid :: CULong, 853 | saGid :: CULong, 854 | saPermissions :: CULong, 855 | saAtime :: CULong, 856 | saMtime :: CULong 857 | } deriving (Show, Eq) 858 | 859 | -- | Get sftp attributes from the sftp handler 860 | sftpFstat :: SftpHandle 861 | -> IO (SftpAttributes) 862 | sftpFstat sftph = do 863 | allocaBytes {# sizeof _LIBSSH2_SFTP_ATTRIBUTES #} $ \sftpattrptr -> do 864 | _ <- handleInt (Just sftph) $ 865 | {# call sftp_fstat_ex #} (toPointer sftph) sftpattrptr 0 866 | parseSftpAttributes sftpattrptr 867 | 868 | parseSftpAttributes :: Ptr a -> IO SftpAttributes -- TODO why not storable? 869 | parseSftpAttributes sftpattrptr = do 870 | flags<- {# get _LIBSSH2_SFTP_ATTRIBUTES->flags #} sftpattrptr 871 | size <- {# get _LIBSSH2_SFTP_ATTRIBUTES->filesize #} sftpattrptr 872 | uid <- {# get _LIBSSH2_SFTP_ATTRIBUTES->uid #} sftpattrptr 873 | gid <- {# get _LIBSSH2_SFTP_ATTRIBUTES->gid #} sftpattrptr 874 | perm <- {# get _LIBSSH2_SFTP_ATTRIBUTES->permissions #} sftpattrptr 875 | atime<- {# get _LIBSSH2_SFTP_ATTRIBUTES->atime #} sftpattrptr 876 | mtime<- {# get _LIBSSH2_SFTP_ATTRIBUTES->mtime #} sftpattrptr 877 | 878 | return $ SftpAttributes flags size uid gid perm atime mtime 879 | 880 | -- | Delete file from SFTP server 881 | sftpDeleteFile :: Sftp -- ^ Opened sftp session 882 | -> FilePath -- ^ Path to the file to be deleted 883 | -> IO () 884 | sftpDeleteFile sftp path = do 885 | withCStringLen path $ \(str,len) -> do 886 | void . handleInt (Just sftp) $ 887 | {# call sftp_unlink_ex #} (toPointer sftp) str (toEnum len) 888 | 889 | 890 | -- 891 | -- | Agent support 892 | -- 893 | 894 | -- | Initialize a new ssh agent handle. 895 | agentInit :: Session -> IO Agent 896 | agentInit s = handleNullPtr (Just s) (agentFromPointer s) $ agentInit_ s 897 | 898 | {# fun agent_init as agentInit_ { toPointer `Session' } -> `Ptr ()' id #} 899 | 900 | {# fun agent_free as agentFree 901 | { toPointer `Agent' } -> `()' #} 902 | 903 | -- | Attempt to establish a connection to an ssh agent process. 904 | -- | The environment variable @SSH_AUTH_SOCK@ is used to determine where to connect on unix. 905 | agentConnect :: Agent -> IO () 906 | agentConnect agent = void . handleInt (Just agent) $ agentConnect_ agent 907 | 908 | {# fun agent_connect as agentConnect_ { toPointer `Agent' } -> `Int' #} 909 | 910 | -- | Get or update the list of known identities. Must be called at least once. 911 | agentListIdentities :: Agent -> IO () 912 | agentListIdentities agent = void . handleInt (Just agent) $ agentListIdentities_ agent 913 | 914 | {# fun agent_list_identities as agentListIdentities_ { toPointer `Agent' } -> `Int' #} 915 | 916 | -- | Cleans up a connection to an ssh agent. 917 | agentDisconnect :: Agent -> IO () 918 | agentDisconnect agent = void . handleInt (Just agent) $ agentDisconnect_ agent 919 | 920 | {# fun agent_disconnect as agentDisconnect_ { toPointer `Agent' } -> `Int' #} 921 | 922 | -- | Copies all the keys from the agent to the local process. 923 | agentGetIdentities :: Agent -> IO [AgentPublicKey] 924 | agentGetIdentities agent = agentGetIdentities_ agent [] 925 | where 926 | agentGetIdentities_ :: Agent -> [AgentPublicKey] -> IO [AgentPublicKey] 927 | agentGetIdentities_ agent' acc@[] = do 928 | k <- agentGetIdentity agent' Nothing 929 | case k of 930 | Just aKey -> agentGetIdentities_ agent' [aKey] 931 | Nothing -> return acc 932 | agentGetIdentities_ agent' acc = do 933 | k <- agentGetIdentity agent' $ Just $ head acc 934 | case k of 935 | Just aKey -> agentGetIdentities_ agent' (aKey:acc) 936 | Nothing -> return acc 937 | 938 | agentNullPublicKey :: IO AgentPublicKey 939 | agentNullPublicKey = agentPublicKeyFromPointer nullPtr 940 | 941 | -- | Copies one identity from the agent to the local process. 942 | agentGetIdentity :: Agent -- ^ Agent handle. 943 | -> Maybe AgentPublicKey -- ^ Previous key returned. 944 | -> IO (Maybe AgentPublicKey) 945 | agentGetIdentity agent Nothing = do 946 | nullKey <- agentNullPublicKey 947 | agentGetIdentity agent (Just nullKey) 948 | agentGetIdentity agent (Just key) = do 949 | agentGetIdentity_ agent key 950 | 951 | agentGetIdentity_ :: Agent -> AgentPublicKey -> IO (Maybe AgentPublicKey) 952 | agentGetIdentity_ a pk = do 953 | withAgentPublicKey pk $ \pkPtr -> do 954 | alloca $ \ptr -> do 955 | (res, pptr) <- with ptr $ \pkStore -> do 956 | x <- {# call agent_get_identity #} (toPointer a) pkStore (castPtr pkPtr) 957 | pptr <- peek pkStore 958 | return (x, pptr) 959 | void $ handleInt (Just a) (return res) 960 | if res == 0 961 | then do 962 | resPkPtr <- agentPublicKeyFromPointer pptr 963 | return $ Just resPkPtr 964 | else return Nothing 965 | 966 | -- | Return the comment from the given agent public key. 967 | agentPublicKeyComment :: AgentPublicKey -> IO BSS.ByteString 968 | agentPublicKeyComment pk = do 969 | withAgentPublicKey pk $ \pkPtr -> do 970 | c <- {# get struct agent_publickey->comment #} pkPtr 971 | BSS.packCString c 972 | 973 | -- | Return the bytes of the given agent public key. 974 | agentPublicKeyBlob :: AgentPublicKey -> IO BSS.ByteString 975 | agentPublicKeyBlob pk = do 976 | withAgentPublicKey pk $ \pkPtr -> do 977 | blobPtr <- {# get struct agent_publickey->blob #} pkPtr 978 | blobLen <- {# get struct agent_publickey->blob_len #} pkPtr 979 | BSS.packCStringLen (castPtr blobPtr, fromEnum blobLen) 980 | 981 | -- | Perform agent based public key authentication. 982 | -- You almost certainly want @agentAuthenticate instead of this, since this 983 | -- only does one round of authentication with the agent. 984 | agentUserAuth :: Agent -- ^ Agent handle. 985 | -> String -- ^ Username to authenticate with. 986 | -> AgentPublicKey -- ^ Public key to use from the agent. 987 | -> IO () 988 | agentUserAuth agent username key = void . handleInt (Just agent) $ agentUserAuth_ agent username key 989 | 990 | {# fun agent_userauth as agentUserAuth_ { toPointer `Agent' 991 | , `String' 992 | , withAgentPublicKeyVoidPtr* `AgentPublicKey' 993 | } -> `Int' #} 994 | 995 | -- | Authenticate with an ssh agent. 996 | -- Takes a user and an agent and tries each key from the agent in succession. 997 | -- Throws AUTHENTICATION_FAILED if it's unable to authenticate. 998 | -- If you call this, you need to call @agentListIdentities at least once. 999 | agentAuthenticate :: String -- ^ Remote user name. 1000 | -> Agent -- ^ Connection to an agent. 1001 | -> IO () 1002 | agentAuthenticate login agent = do 1003 | firstKey <- agentGetIdentity agent Nothing 1004 | agentAuthenticate' login agent firstKey 1005 | where 1006 | agentAuthenticate' _ _ Nothing = throw AUTHENTICATION_FAILED 1007 | agentAuthenticate' u a (Just k) = do 1008 | r <- tryJust isAuthenticationFailed (agentUserAuth a u k) 1009 | case r of 1010 | Left _ -> do 1011 | nextKey <- agentGetIdentity a $ Just k 1012 | agentAuthenticate' u a nextKey 1013 | Right _ -> return () 1014 | isAuthenticationFailed AUTHENTICATION_FAILED = Just () 1015 | isAuthenticationFailed _ = Nothing 1016 | 1017 | withAgentPublicKeyVoidPtr :: AgentPublicKey -> (Ptr () -> IO a) -> IO a 1018 | withAgentPublicKeyVoidPtr p f = withAgentPublicKey p $ \pp -> f (castPtr pp) 1019 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/GCrypt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | module Network.SSH.Client.LibSSH2.GCrypt 3 | ( gcryptFix ) 4 | where 5 | 6 | foreign import ccall "gcrypt_fix" gcryptFix :: IO () 7 | 8 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/Types.chs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, StandaloneDeriving #-} 2 | 3 | #ifdef __APPLE__ 4 | #define _ANSI_SOURCE 5 | #define __OSX_AVAILABLE_STARTING(_mac, _iphone) 6 | #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) 7 | #endif 8 | 9 | #include 10 | #include 11 | 12 | {# context lib="ssh2" prefix="libssh2" #} 13 | 14 | module Network.SSH.Client.LibSSH2.Types 15 | (Session, 16 | KnownHosts, 17 | Channel, 18 | Sftp, 19 | SftpHandle, 20 | Agent, 21 | AgentPublicKey, 22 | ToPointer (..), 23 | Direction (..), 24 | int2dir, 25 | CStringCLen, 26 | Size, SSize, 27 | withCStringLenIntConv, 28 | peekCStringPtr, 29 | peekMaybeCStringPtr, 30 | channelFromPointer, 31 | knownHostsFromPointer, 32 | sessionFromPointer, 33 | sessionGetSocket, 34 | sessionSetSocket, 35 | channelSession, 36 | sftpFromPointer, 37 | sftpSession, 38 | sftpHandlePtr, 39 | sftpHandleFromPointer, 40 | sftpHandleSession, 41 | agentFromPointer, 42 | agentSession, 43 | agentPublicKeyFromPointer, 44 | withAgentPublicKey 45 | ) where 46 | 47 | import Foreign 48 | import Foreign.C.String 49 | import Data.Generics 50 | import Data.IORef 51 | import Network.Socket 52 | 53 | type Size = {# type size_t #} 54 | 55 | type SSize = {# type ssize_t #} 56 | 57 | type CStringCLen i = (CString, i) 58 | 59 | withCStringLenIntConv :: (Integral i) => String -> (CStringCLen i -> IO a) -> IO a 60 | withCStringLenIntConv str fn = 61 | withCStringLen str (\(ptr, len) -> fn (ptr, fromIntegral len)) 62 | 63 | peekCStringPtr :: Ptr CString -> IO String 64 | peekCStringPtr ptr = peekCAString =<< peek ptr 65 | 66 | peekMaybeCStringPtr :: Ptr CString -> IO (Maybe String) 67 | peekMaybeCStringPtr ptr = do 68 | strPtr <- peek ptr 69 | if strPtr == nullPtr 70 | then return Nothing 71 | else Just `fmap` peekCAString strPtr 72 | 73 | 74 | class ToPointer p where 75 | toPointer :: p -> Ptr () 76 | 77 | {# pointer *SESSION as CSession #} 78 | 79 | data Session = Session { sessionPtr :: CSession 80 | , sessionSocketRef :: IORef (Maybe Socket) 81 | } 82 | 83 | sessionFromPointer :: Ptr () -> IO Session 84 | sessionFromPointer ptr = do 85 | socketRef <- newIORef Nothing 86 | return $ Session (castPtr ptr) socketRef 87 | 88 | sessionGetSocket :: Session -> IO (Maybe Socket) 89 | sessionGetSocket = readIORef . sessionSocketRef 90 | 91 | sessionSetSocket :: Session -> Maybe Socket -> IO () 92 | sessionSetSocket session = writeIORef (sessionSocketRef session) 93 | 94 | deriving instance Eq Session 95 | deriving instance Data Session 96 | deriving instance Typeable Session 97 | 98 | instance Show Session where 99 | show session = "" 100 | 101 | instance ToPointer Session where 102 | toPointer = castPtr . sessionPtr 103 | 104 | {# pointer *KNOWNHOSTS as KnownHosts newtype #} 105 | 106 | knownHostsFromPointer :: Ptr () -> IO KnownHosts 107 | knownHostsFromPointer ptr = return $ KnownHosts (castPtr ptr) 108 | 109 | deriving instance Eq KnownHosts 110 | deriving instance Data KnownHosts 111 | deriving instance Typeable KnownHosts 112 | 113 | instance Show KnownHosts where 114 | show (KnownHosts p) = "" 115 | 116 | instance ToPointer KnownHosts where 117 | toPointer (KnownHosts p) = castPtr p 118 | 119 | {# pointer *CHANNEL as CChannel #} 120 | 121 | data Channel = Channel { channelPtr :: CChannel 122 | , channelSession :: Session 123 | } 124 | 125 | channelFromPointer :: Session -> Ptr () -> IO Channel 126 | channelFromPointer session ptr = return $ Channel (castPtr ptr) session 127 | 128 | deriving instance Eq Channel 129 | deriving instance Data Channel 130 | deriving instance Typeable Channel 131 | 132 | instance Show Channel where 133 | show channel = "" 134 | 135 | instance ToPointer Channel where 136 | toPointer = castPtr . channelPtr 137 | 138 | -- | Session directions 139 | data Direction = INBOUND | OUTBOUND 140 | deriving (Eq, Show) 141 | 142 | int2dir :: (Eq a, Num a, Show a) => a -> [Direction] 143 | int2dir 0 = [] 144 | int2dir 1 = [INBOUND] 145 | int2dir 2 = [OUTBOUND] 146 | int2dir 3 = [INBOUND, OUTBOUND] 147 | int2dir x = error $ "Unknown direction: " ++ show x 148 | 149 | -- 150 | -- | Sftp support 151 | -- 152 | 153 | sftpFromPointer :: Session -> Ptr () -> IO Sftp 154 | sftpFromPointer session ptr = return $ Sftp (castPtr ptr) session 155 | 156 | {# pointer *SFTP as CSftp #} 157 | 158 | data Sftp = Sftp { sftpPtr :: CSftp 159 | , sftpSession :: Session 160 | } 161 | 162 | instance Show Sftp where 163 | show sftp = "" 164 | 165 | instance ToPointer Sftp where 166 | toPointer = castPtr . sftpPtr 167 | 168 | sftpHandleFromPointer :: Sftp -> Ptr () -> IO SftpHandle 169 | sftpHandleFromPointer sftp ptr = return $ SftpHandle (castPtr ptr) sftp 170 | 171 | {# pointer *SFTP_HANDLE as CSftpHandle #} 172 | 173 | data SftpHandle = SftpHandle { sftpHandlePtr :: CSftpHandle 174 | , sftpHandleSession :: Sftp 175 | } 176 | 177 | instance Show SftpHandle where 178 | show handle = "" 179 | 180 | instance ToPointer SftpHandle where 181 | toPointer = castPtr . sftpHandlePtr 182 | 183 | 184 | -- 185 | -- | Agent support 186 | -- 187 | 188 | agentFromPointer :: Session -> Ptr () -> IO Agent 189 | agentFromPointer session ptr = return $ Agent (castPtr ptr) session 190 | 191 | {# pointer *AGENT as CAgent #} 192 | 193 | data Agent = Agent { agentPtr :: CAgent, agentSession :: Session } 194 | 195 | instance Show Agent where 196 | show agent = "" 197 | 198 | instance ToPointer Agent where 199 | toPointer = castPtr . agentPtr 200 | 201 | {# pointer *agent_publickey as AgentPublicKey foreign newtype #} 202 | 203 | agentPublicKeyFromPointer :: Ptr () -> IO AgentPublicKey 204 | agentPublicKeyFromPointer ptr = do 205 | newPtr <- newForeignPtr_ ptr 206 | return $ AgentPublicKey $ castForeignPtr newPtr 207 | 208 | deriving instance Eq AgentPublicKey 209 | deriving instance Data AgentPublicKey 210 | deriving instance Typeable AgentPublicKey 211 | 212 | instance Show AgentPublicKey where 213 | show (AgentPublicKey p) = "" 214 | -------------------------------------------------------------------------------- /libssh2/src/Network/SSH/Client/LibSSH2/WaitSocket.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ForeignFunctionInterface #-} 2 | -- | Block until a read or write operation on a socket would succeed 3 | -- 4 | -- On most platforms this uses 'Control.Concurrent.threadWaitRead' or 5 | -- 'Conctrol.Concurrent.threadWaitWrite', but on Windows we need to do 6 | -- something different. 7 | -- 8 | -- See . 9 | module Network.SSH.Client.LibSSH2.WaitSocket 10 | ( threadWaitRead 11 | , threadWaitWrite 12 | ) where 13 | 14 | import Network.Socket(Socket) 15 | #if MIN_VERSION_network(3,0,0) 16 | import Network.Socket(withFdSocket) 17 | #else 18 | import Network.Socket(fdSocket) 19 | #endif 20 | 21 | import System.Posix.Types(Fd(Fd)) 22 | 23 | #ifdef mingw32_HOST_OS 24 | import Control.Concurrent(forkIO,newEmptyMVar,putMVar,takeMVar) 25 | import Control.Exception(IOException,throwIO,try) 26 | import Control.Exception.Base(mask_) 27 | import Foreign.C.Error(throwErrnoIfMinus1_) 28 | import Foreign.C.Types(CInt(CInt)) 29 | import System.IO(hWaitForInput,stdin) 30 | #else 31 | import qualified GHC.Conc (threadWaitRead, threadWaitWrite) 32 | #endif 33 | 34 | threadWaitRead :: Socket -> IO () 35 | #if MIN_VERSION_network(3,0,0) 36 | threadWaitRead = flip withFdSocket (threadWaitRead_ . Fd) 37 | #else 38 | threadWaitRead = threadWaitRead_ . Fd . fdSocket 39 | #endif 40 | 41 | threadWaitWrite :: Socket -> IO () 42 | #if MIN_VERSION_network(3,0,0) 43 | threadWaitWrite = flip withFdSocket (threadWaitWrite_ . Fd) 44 | #else 45 | threadWaitWrite = threadWaitWrite_ . Fd . fdSocket 46 | #endif 47 | 48 | -- | Block the current thread until data is available to read on the 49 | -- given file descriptor (GHC only). 50 | -- 51 | -- This will throw an 'IOError' if the file descriptor was closed 52 | -- while this thread was blocked. To safely close a file descriptor 53 | -- that has been used with 'threadWaitRead', use 54 | -- 'GHC.Conc.closeFdWith'. 55 | threadWaitRead_ :: Fd -> IO () 56 | threadWaitRead_ fd 57 | #ifdef mingw32_HOST_OS 58 | -- We have no IO manager implementing threadWaitRead on Windows. 59 | -- fdReady does the right thing, but we have to call it in a 60 | -- separate thread, otherwise threadWaitRead won't be interruptible, 61 | -- and this only works with -threaded. 62 | | threaded = withThread (waitFd fd 0) 63 | | otherwise = case fd of 64 | 0 -> do 65 | -- hWaitForInput does work properly, but we can only 66 | -- do this for stdin since we know its FD. 67 | _ <- hWaitForInput stdin (-1) 68 | return () 69 | _ -> 70 | error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" 71 | #else 72 | = GHC.Conc.threadWaitRead fd 73 | #endif 74 | 75 | -- | Block the current thread until data can be written to the 76 | -- given file descriptor (GHC only). 77 | -- This will throw an 'IOError' if the file descriptor was closed 78 | -- while this thread was blocked. To safely close a file descriptor 79 | -- that has been used with 'threadWaitWrite', use 80 | -- 'GHC.Conc.closeFdWith'. 81 | threadWaitWrite_ :: Fd -> IO () 82 | threadWaitWrite_ fd 83 | #ifdef mingw32_HOST_OS 84 | | threaded = withThread (waitFd fd 1) 85 | | otherwise = error "threadWaitWrite requires -threaded on Windows" 86 | #else 87 | = GHC.Conc.threadWaitWrite fd 88 | #endif 89 | 90 | #ifdef mingw32_HOST_OS 91 | foreign import ccall unsafe "rtsSupportsBoundThreads" threaded:: Bool 92 | 93 | withThread :: IO a -> IO a 94 | withThread io = do 95 | m <- newEmptyMVar 96 | _ <- mask_ $ forkIO $ try io >>= putMVar m 97 | x <- takeMVar m 98 | case x of 99 | Right a -> return a 100 | Left e -> throwIO (e :: IOException) 101 | 102 | -- The last argument can be 1 (true) because this will only be applied to 103 | -- sockets 104 | waitFd :: Fd -> CInt -> IO () 105 | waitFd fd write = 106 | throwErrnoIfMinus1_ "fdReady" $ fdReady (fromIntegral fd) write iNFINITE 1 107 | where 108 | iNFINITE :: CInt 109 | iNFINITE = 0xFFFFFFFF -- urgh 110 | 111 | foreign import ccall safe "fdReady" 112 | fdReady:: CInt -- ^ fd 113 | -> CInt -- ^ write 114 | -> CInt -- ^ msecs 115 | -> CInt -- ^ isSock 116 | -> IO CInt 117 | #endif 118 | -------------------------------------------------------------------------------- /libssh2/ssh-client.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.ByteString.Lazy as BSL 2 | import System.Environment 3 | import System.FilePath 4 | import Codec.Binary.UTF8.String 5 | 6 | import Network.SSH.Client.LibSSH2.Foreign 7 | import Network.SSH.Client.LibSSH2 8 | 9 | main = do 10 | args <- getArgs 11 | case args of 12 | ["command", user, host, port, cmd] -> runCommand user host (read port) cmd 13 | ["send", user, host, port, path] -> sendFile user host (read port) path 14 | ["receive", user, host, port, path] -> receiveFile user host (read port) path 15 | _ -> putStrLn "Synopsis: ssh-client ACTION USERNAME HOSTNAME PORT ARG" 16 | 17 | runCommand login host port command = 18 | ssh login host port $ \s -> 19 | withChannel s $ \ch -> do 20 | channelExecute ch command 21 | result <- readAllChannel ch 22 | BSL.putStr result 23 | 24 | sendFile login host port path = 25 | ssh login host port $ \s -> do 26 | sz <- scpSendFile s 0o644 path (takeFileName path) 27 | putStrLn $ "Sent: " ++ show sz ++ " bytes." 28 | 29 | receiveFile login host port path = 30 | ssh login host port $ \s -> do 31 | sz <- scpReceiveFile s (takeFileName path) path 32 | putStrLn $ "Received: " ++ show sz ++ " bytes." 33 | 34 | ssh login host port actions = do 35 | initialize True 36 | home <- getEnv "HOME" 37 | let known_hosts = home ".ssh" "known_hosts" 38 | public = home ".ssh" "id_rsa.pub" 39 | private = home ".ssh" "id_rsa" 40 | withSSH2 known_hosts public private "" login host port $ actions 41 | exit 42 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | packages: 3 | - libssh2/ 4 | - libssh2-conduit/ 5 | 6 | flags: 7 | libssh2: 8 | example-client: false 9 | gcrypt: false 10 | 11 | libssh2-conduit: 12 | example-forwarder: false 13 | --------------------------------------------------------------------------------