diff --git a/libssh2.cabal b/libssh2.cabal --- a/libssh2.cabal +++ b/libssh2.cabal @@ -1,6 +1,6 @@ Name: libssh2 -Version: 0.2.0.7 +Version: 0.2.0.8 Synopsis: FFI bindings to libssh2 SSH2 client library (http://libssh2.org/) @@ -40,7 +40,7 @@ Extra-source-files: ssh-client.hs, Makefile, include/libssh2_local.h -- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.8 +Cabal-version: >=1.10 flag gcrypt description: add hack that allows to run threaded program when libssh2 is built against gcrypt @@ -60,7 +60,8 @@ Include-dirs: include Includes: include/libssh2_local.h - Build-depends: base >= 4 && < 5, network >= 2.3, + Build-depends: base >= 4 && < 5, + network >= 2.3 && < 3.2, syb >= 0.3.3, time >= 1.2, bytestring >= 0.9, unix @@ -68,6 +69,7 @@ Extra-libraries: "ssh2" pkgconfig-depends: libssh2 >= 1.2.8 GHC-Options: -Wall + Default-Language: Haskell2010 -- Other-modules: @@ -82,11 +84,12 @@ Executable hs-ssh-client if flag(example-client) - Build-depends: base, utf8-string, syb, network, filepath, bytestring, time + Build-depends: base, utf8-string, syb, network, filepath, bytestring, time, libssh2 else buildable: False Main-Is: ssh-client.hs GHC-Options: -threaded + Default-Language: Haskell2010 Source-repository head type: git diff --git a/src/Network/SSH/Client/LibSSH2.hs b/src/Network/SSH/Client/LibSSH2.hs --- a/src/Network/SSH/Client/LibSSH2.hs +++ b/src/Network/SSH/Client/LibSSH2.hs @@ -7,6 +7,7 @@ -- * Functions withSSH2, withSSH2User, + withSSH2Agent, withSession, withChannel, withChannelBy, @@ -17,10 +18,12 @@ scpReceiveFile, runShellCommands, execCommands, + directTcpIpEx, -- * Sftp Functions withSFTP, withSFTPUser, + withSftpSession, sftpListDir, sftpRenameFile, sftpSendFile, sftpSendFromHandle, @@ -36,8 +39,6 @@ import Control.Monad import Control.Exception as E -import Network hiding (sClose) -import Network.BSD import Network.Socket import System.IO import qualified Data.ByteString as BSS @@ -50,12 +51,14 @@ -- | Similar to Network.connectTo, but does not socketToHandle. socketConnect :: String -> Int -> IO Socket socketConnect hostname port = do - proto <- getProtocolNumber "tcp" - bracketOnError (socket AF_INET Stream proto) (close) - (\sock -> do - he <- getHostByName hostname - connect sock (SockAddrInet (fromIntegral port) (hostAddress he)) - return sock) + let hints = defaultHints { addrSocketType = Stream } + addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port) + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (close) + (\sock -> do + connect sock $ addrAddress addr + return sock) -- | Execute some actions within SSH2 connection. -- Uses public key authentication. @@ -75,6 +78,27 @@ error $ "Host key mismatch for host " ++ hostname publicKeyAuthFile s login public private passphrase fn s + +-- | Execute some actions within SSH2 connection. +-- Uses agent based public key authentication. +withSSH2Agent :: String -- ^ Path to known_hosts file + -> String -- ^ Remote user name + -> String -- ^ Remote host name + -> Int -- ^ Remote port number (usually 22) + -> (Session -> IO a) -- ^ Actions to perform on session + -> IO a +withSSH2Agent known_hosts login hostname port fn = + withSession hostname port $ \s -> do + r <- checkHost s hostname port known_hosts + when (r == MISMATCH) $ + error $ "host key mismatch for host " ++ hostname + E.bracket (agentInit s) agentFree $ \a -> + E.bracket_ (agentConnect a) (agentDisconnect a) (act s login a fn) + where + act s u a f = do + agentListIdentities a + agentAuthenticate u a + f s -- | Execute some actions within SSH2 connection. -- Uses username/password authentication. diff --git a/src/Network/SSH/Client/LibSSH2/Errors.chs b/src/Network/SSH/Client/LibSSH2/Errors.chs --- a/src/Network/SSH/Client/LibSSH2/Errors.chs +++ b/src/Network/SSH/Client/LibSSH2/Errors.chs @@ -259,3 +259,7 @@ throwCtxSpecificError ctx = throwCtxSpecificError (sftpHandleSession ctx) + +instance SshCtx Agent where + getSession = getSession . agentSession + throwCtxSpecificError _ er = throw er diff --git a/src/Network/SSH/Client/LibSSH2/Foreign.chs b/src/Network/SSH/Client/LibSSH2/Foreign.chs --- a/src/Network/SSH/Client/LibSSH2/Foreign.chs +++ b/src/Network/SSH/Client/LibSSH2/Foreign.chs @@ -37,6 +37,7 @@ writeChannelFromHandle, readChannelToHandle, channelProcess, channelExecute, channelShell, requestPTY, requestPTYEx, + directTcpIpEx, channelExitStatus, channelExitSignal, scpSendChannel, scpReceiveChannel, pollChannelRead, @@ -51,17 +52,35 @@ RenameFlag (..), SftpFileTransferFlags (..), SftpAttributes (..), + -- * SSH Agent functions + Agent (..), AgentPublicKey, + agentInit, + agentConnect, agentDisconnect, + agentListIdentities, + agentGetIdentity, + agentGetIdentities, + agentFree, + agentPublicKeyComment, + agentPublicKeyBlob, + agentUserAuth, + agentAuthenticate, + -- * Debug TraceFlag (..), setTraceMode ) where +import Control.Exception (throw, tryJust) import Control.Monad (void) import Data.Time.Clock.POSIX import Foreign hiding (void) import Foreign.C.Types import Foreign.C.String import System.IO +#if MIN_VERSION_network(3,0,0) +import Network.Socket (Socket, withFdSocket) +#else import Network.Socket (Socket(MkSocket), isReadable) +#endif import qualified Data.ByteString as BSS import qualified Data.ByteString.Unsafe as BSS @@ -129,16 +148,34 @@ init_crypto False = 1 init_crypto True = 0 +#if MIN_VERSION_network(3,0,0) ssh2socket :: Socket #ifdef mingw32_HOST_OS #ifdef x86_64_HOST_ARCH -> CULLong #else + -> IO CUInt + #endif +#else + -> IO CInt +#endif +ssh2socket s = +#ifdef mingw32_HOST_OS + fromIntegral <$> withFdSocket s pure +#else + withFdSocket s pure +#endif +#else +ssh2socket :: Socket +#ifdef mingw32_HOST_OS + #ifdef x86_64_HOST_ARCH + -> CULLong + #else -> CUInt #endif #else -> CInt -#endif +#endif /* mingw32_HOST_OS */ ssh2socket (MkSocket s _ _ _ _) = #ifdef mingw32_HOST_OS (fromIntegral s) @@ -146,6 +183,8 @@ s #endif +#endif /* MIN_VERSION_network(3,0,0) */ + {# fun init as initialize_ { init_crypto `Bool' } -> `Int' #} @@ -194,14 +233,24 @@ bool2int True = 1 bool2int False = 0 +#if MIN_VERSION_network(3,0,0) +{# fun session_handshake + { `Ptr ()', `CInt' } -> `Int' #} + +handshake_ :: Session -> Socket -> IO Int +handshake_ session socket = do + session_handshake (toPointer session) =<< ssh2socket socket +#else {# fun session_handshake as handshake_ { toPointer `Session', ssh2socket `Socket' } -> `Int' #} +#endif -- | Run SSH handshake on network socket. handshake :: Session -> Socket -> IO () handshake session socket = do sessionSetSocket session (Just socket) - void . handleInt (Just session) $ handshake_ session socket + void $ handleInt (Just session) + $ handshake_ session socket {# fun knownhost_init as initKnownHosts_ { toPointer `Session' } -> `Ptr ()' id #} @@ -280,6 +329,16 @@ `Int', `Int', `String' & } -> `Ptr ()' id #} +{# fun channel_direct_tcpip_ex as directTcpIpEx_ + { toPointer `Session', + `String', + `Int', + `String', + `Int' } -> `Ptr ()' id #} + +directTcpIpEx :: Session -> String -> Int -> String -> Int -> IO Channel +directTcpIpEx s host port shost sport = handleNullPtr (Just s) (channelFromPointer s) $ directTcpIpEx_ s host port shost sport + -- | Open a channel for session. openChannelSession :: Session -> IO Channel openChannelSession s = handleNullPtr (Just s) (channelFromPointer s) $ @@ -518,7 +577,11 @@ mbSocket <- sessionGetSocket (channelSession ch) case mbSocket of Nothing -> error "pollChannelRead without socket present" +#if MIN_VERSION_network(3,0,0) + Just _ -> pure True +#else Just socket -> isReadable socket +#endif -- -- | Sftp support @@ -738,3 +801,134 @@ withCStringLen path $ \(str,len) -> do void . handleInt (Just sftp) $ {# call sftp_unlink_ex #} (toPointer sftp) str (toEnum len) + + +-- +-- | Agent support +-- + +-- | Initialize a new ssh agent handle. +agentInit :: Session -> IO Agent +agentInit s = handleNullPtr (Just s) (agentFromPointer s) $ agentInit_ s + +{# fun agent_init as agentInit_ { toPointer `Session' } -> `Ptr ()' id #} + +{# fun agent_free as agentFree + { toPointer `Agent' } -> `()' #} + +-- | Attempt to establish a connection to an ssh agent process. +-- | The environment variable @SSH_AUTH_SOCK@ is used to determine where to connect on unix. +agentConnect :: Agent -> IO () +agentConnect agent = void . handleInt (Just agent) $ agentConnect_ agent + +{# fun agent_connect as agentConnect_ { toPointer `Agent' } -> `Int' #} + +-- | Get or update the list of known identities. Must be called at least once. +agentListIdentities :: Agent -> IO () +agentListIdentities agent = void . handleInt (Just agent) $ agentListIdentities_ agent + +{# fun agent_list_identities as agentListIdentities_ { toPointer `Agent' } -> `Int' #} + +-- | Cleans up a connection to an ssh agent. +agentDisconnect :: Agent -> IO () +agentDisconnect agent = void . handleInt (Just agent) $ agentDisconnect_ agent + +{# fun agent_disconnect as agentDisconnect_ { toPointer `Agent' } -> `Int' #} + +-- | Copies all the keys from the agent to the local process. +agentGetIdentities :: Agent -> IO [AgentPublicKey] +agentGetIdentities agent = agentGetIdentities_ agent [] + where + agentGetIdentities_ :: Agent -> [AgentPublicKey] -> IO [AgentPublicKey] + agentGetIdentities_ agent' acc@[] = do + k <- agentGetIdentity agent' Nothing + case k of + Just aKey -> agentGetIdentities_ agent' [aKey] + Nothing -> return acc + agentGetIdentities_ agent' acc = do + k <- agentGetIdentity agent' $ Just $ head acc + case k of + Just aKey -> agentGetIdentities_ agent' (aKey:acc) + Nothing -> return acc + +agentNullPublicKey :: IO AgentPublicKey +agentNullPublicKey = agentPublicKeyFromPointer nullPtr + +-- | Copies one identity from the agent to the local process. +agentGetIdentity :: Agent -- ^ Agent handle. + -> Maybe AgentPublicKey -- ^ Previous key returned. + -> IO (Maybe AgentPublicKey) +agentGetIdentity agent Nothing = do + nullKey <- agentNullPublicKey + agentGetIdentity agent (Just nullKey) +agentGetIdentity agent (Just key) = do + agentGetIdentity_ agent key + +agentGetIdentity_ :: Agent -> AgentPublicKey -> IO (Maybe AgentPublicKey) +agentGetIdentity_ a pk = do + withAgentPublicKey pk $ \pkPtr -> do + alloca $ \ptr -> do + (res, pptr) <- with ptr $ \pkStore -> do + x <- {# call agent_get_identity #} (toPointer a) pkStore (castPtr pkPtr) + pptr <- peek pkStore + return (x, pptr) + void $ handleInt (Just a) (return res) + if res == 0 + then do + resPkPtr <- agentPublicKeyFromPointer pptr + return $ Just resPkPtr + else return Nothing + +-- | Return the comment from the given agent public key. +agentPublicKeyComment :: AgentPublicKey -> IO BSS.ByteString +agentPublicKeyComment pk = do + withAgentPublicKey pk $ \pkPtr -> do + c <- {# get struct agent_publickey->comment #} pkPtr + BSS.packCString c + +-- | Return the bytes of the given agent public key. +agentPublicKeyBlob :: AgentPublicKey -> IO BSS.ByteString +agentPublicKeyBlob pk = do + withAgentPublicKey pk $ \pkPtr -> do + blobPtr <- {# get struct agent_publickey->blob #} pkPtr + blobLen <- {# get struct agent_publickey->blob_len #} pkPtr + BSS.packCStringLen (castPtr blobPtr, fromEnum blobLen) + +-- | Perform agent based public key authentication. +-- You almost certainly want @agentAuthenticate instead of this, since this +-- only does one round of authentication with the agent. +agentUserAuth :: Agent -- ^ Agent handle. + -> String -- ^ Username to authenticate with. + -> AgentPublicKey -- ^ Public key to use from the agent. + -> IO () +agentUserAuth agent username key = void . handleInt (Just agent) $ agentUserAuth_ agent username key + +{# fun agent_userauth as agentUserAuth_ { toPointer `Agent' + , `String' + , withAgentPublicKeyVoidPtr* `AgentPublicKey' + } -> `Int' #} + +-- | Authenticate with an ssh agent. +-- Takes a user and an agent and tries each key from the agent in succession. +-- Throws AUTHENTICATION_FAILED if it's unable to authenticate. +-- If you call this, you need to call @agentListIdentities at least once. +agentAuthenticate :: String -- ^ Remote user name. + -> Agent -- ^ Connection to an agent. + -> IO () +agentAuthenticate login agent = do + firstKey <- agentGetIdentity agent Nothing + agentAuthenticate' login agent firstKey + where + agentAuthenticate' _ _ Nothing = throw AUTHENTICATION_FAILED + agentAuthenticate' u a (Just k) = do + r <- tryJust isAuthenticationFailed (agentUserAuth a u k) + case r of + Left _ -> do + nextKey <- agentGetIdentity a $ Just k + agentAuthenticate' u a nextKey + Right _ -> return () + isAuthenticationFailed AUTHENTICATION_FAILED = Just () + isAuthenticationFailed _ = Nothing + +withAgentPublicKeyVoidPtr :: AgentPublicKey -> (Ptr () -> IO a) -> IO a +withAgentPublicKeyVoidPtr p f = withAgentPublicKey p $ \pp -> f (castPtr pp) diff --git a/src/Network/SSH/Client/LibSSH2/Types.chs b/src/Network/SSH/Client/LibSSH2/Types.chs --- a/src/Network/SSH/Client/LibSSH2/Types.chs +++ b/src/Network/SSH/Client/LibSSH2/Types.chs @@ -17,6 +17,8 @@ Channel, Sftp, SftpHandle, + Agent, + AgentPublicKey, ToPointer (..), Direction (..), int2dir, @@ -35,11 +37,14 @@ sftpSession, sftpHandlePtr, sftpHandleFromPointer, - sftpHandleSession + sftpHandleSession, + agentFromPointer, + agentSession, + agentPublicKeyFromPointer, + withAgentPublicKey ) where import Foreign -import Foreign.C.Types import Foreign.C.String import Data.Generics import Data.IORef @@ -65,6 +70,7 @@ then return Nothing else Just `fmap` peekCAString strPtr + class ToPointer p where toPointer :: p -> Ptr () @@ -172,3 +178,35 @@ instance ToPointer SftpHandle where toPointer = castPtr . sftpHandlePtr + + +-- +-- | Agent support +-- + +agentFromPointer :: Session -> Ptr () -> IO Agent +agentFromPointer session ptr = return $ Agent (castPtr ptr) session + +{# pointer *AGENT as CAgent #} + +data Agent = Agent { agentPtr :: CAgent, agentSession :: Session } + +instance Show Agent where + show agent = "" + +instance ToPointer Agent where + toPointer = castPtr . agentPtr + +{# pointer *agent_publickey as AgentPublicKey foreign newtype #} + +agentPublicKeyFromPointer :: Ptr () -> IO AgentPublicKey +agentPublicKeyFromPointer ptr = do + newPtr <- newForeignPtr_ ptr + return $ AgentPublicKey $ castForeignPtr newPtr + +deriving instance Eq AgentPublicKey +deriving instance Data AgentPublicKey +deriving instance Typeable AgentPublicKey + +instance Show AgentPublicKey where + show (AgentPublicKey p) = "" diff --git a/src/Network/SSH/Client/LibSSH2/WaitSocket.hs b/src/Network/SSH/Client/LibSSH2/WaitSocket.hs --- a/src/Network/SSH/Client/LibSSH2/WaitSocket.hs +++ b/src/Network/SSH/Client/LibSSH2/WaitSocket.hs @@ -11,7 +11,13 @@ , threadWaitWrite ) where -import Network.Socket(Socket,fdSocket) +import Network.Socket(Socket) +#if MIN_VERSION_network(3,0,0) +import Network.Socket(withFdSocket) +#else +import Network.Socket(fdSocket) +#endif + import System.Posix.Types(Fd(Fd)) #ifdef mingw32_HOST_OS @@ -26,10 +32,18 @@ #endif threadWaitRead :: Socket -> IO () +#if MIN_VERSION_network(3,0,0) +threadWaitRead = flip withFdSocket (threadWaitRead_ . Fd) +#else threadWaitRead = threadWaitRead_ . Fd . fdSocket +#endif threadWaitWrite :: Socket -> IO () +#if MIN_VERSION_network(3,0,0) +threadWaitWrite = flip withFdSocket (threadWaitWrite_ . Fd) +#else threadWaitWrite = threadWaitWrite_ . Fd . fdSocket +#endif -- | Block the current thread until data is available to read on the -- given file descriptor (GHC only).