hssh (empty) → 0.1.0.0
raw patch · 37 files changed
+6116/−0 lines, 37 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, cereal, containers, cryptonite, data-default, hssh, memory, socket, stm, tasty, tasty-hunit, tasty-quickcheck
Files
- CHANGELOG.md +3/−0
- LICENSE +20/−0
- README.md +146/−0
- Setup.hs +2/−0
- app/Main.hs +98/−0
- hssh.cabal +130/−0
- src/Network/SSH.hs +49/−0
- src/Network/SSH/Algorithms.hs +32/−0
- src/Network/SSH/AuthAgent.hs +34/−0
- src/Network/SSH/Builder.hs +166/−0
- src/Network/SSH/Client.hs +3/−0
- src/Network/SSH/Constants.hs +26/−0
- src/Network/SSH/Encoding.hs +155/−0
- src/Network/SSH/Exception.hs +129/−0
- src/Network/SSH/Internal.hs +25/−0
- src/Network/SSH/Key.hs +230/−0
- src/Network/SSH/Message.hs +895/−0
- src/Network/SSH/Name.hs +14/−0
- src/Network/SSH/Server.hs +120/−0
- src/Network/SSH/Server/Service/Connection.hs +592/−0
- src/Network/SSH/Server/Service/UserAuth.hs +132/−0
- src/Network/SSH/Stream.hs +96/−0
- src/Network/SSH/TStreamingQueue.hs +164/−0
- src/Network/SSH/Transport.hs +517/−0
- src/Network/SSH/Transport/Crypto.hs +237/−0
- src/Network/SSH/Transport/Crypto/ChaCha.hs +55/−0
- src/Network/SSH/Transport/Crypto/Poly1305.hs +43/−0
- test/Spec.hs +22/−0
- test/Spec/Algorithms.hs +79/−0
- test/Spec/Key.hs +97/−0
- test/Spec/Message.hs +334/−0
- test/Spec/Server.hs +7/−0
- test/Spec/Server/Service/Connection.hs +937/−0
- test/Spec/Server/Service/UserAuth.hs +242/−0
- test/Spec/TStreamingQueue.hs +61/−0
- test/Spec/Transport.hs +167/−0
- test/Spec/Util.hs +57/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.1.0.0 Lars Petersen <info@lars-petersen.net> 2018-10-31++ * Initial release.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Lars Petersen++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,146 @@+# hssh++## Introduction++This library is a pure-Haskell implementation of the SSH2 protocol.++## Features++By now, only the server part has been implemented. It can be used+to embed SSH servers into Haskell applications.++Transport layer:++- `ssh-ed25519` host keys.+- Key exchange using the `curve25519-sha256@libssh.org` algorithm.+- Encryption using the `chacha20-poly1305@openssh.com` algorithm.+- Rekeying fully supported and compatible with OpenSSH.++Authentication layer:++- User authentication with `ssh-ed25519` public keys.++Connection layer:++- Connection multiplexing.+- Serving session requests (shell and exec) with user-supplied handlers.+- Serving direct-tcpip requests with user-supplied handlers.++Misc:++- SSH private key file import (not encrypted yet).++## Dependencies++- async+- base+- bytestring+- cereal+- containers+- cryptonite+- memory+- stm+- data-default++## Example server application++```hs+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent ( forkFinally+ )+import Control.Exception ( bracket+ , bracketOnError+ , handle+ , throwIO+ )+import Control.Monad ( forever+ , void+ )+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import Data.Default+import System.Exit++import qualified System.Socket as S+import qualified System.Socket.Family.Inet6 as S+import qualified System.Socket.Protocol.Default as S+import qualified System.Socket.Type.Stream as S+import qualified System.Socket.Unsafe as S++import Network.SSH+import qualified Network.SSH.Server as Server++main :: IO ()+main = do+ file <- BS.readFile "./resources/id_ed25519"+ (privateKey, _) : _ <- decodePrivateKeyFile BS.empty file :: IO [(KeyPair, BA.Bytes)]+ bracket open close (accept config privateKey)+ where+ config = def+ { Server.transportConfig = def+ , Server.userAuthConfig = def+ { Server.onAuthRequest = \username _ _ -> pure (Just username)+ }+ , Server.connectionConfig = def+ { Server.onSessionRequest = handleSessionRequest+ , Server.onDirectTcpIpRequest = handleDirectTcpIpRequest+ }+ }+ open = S.socket :: IO (S.Socket S.Inet6 S.Stream S.Default)+ close = S.close+ accept config agent s = do+ S.setSocketOption s (S.ReuseAddress True)+ S.setSocketOption s (S.V6Only False)+ S.bind s (S.SocketAddressInet6 S.inet6Any 22 0 0)+ S.listen s 5+ forever $ bracketOnError (S.accept s) (S.close . fst) $ \(stream, peer) -> do+ putStrLn $ "Connection from " ++ show peer+ void $ forkFinally+ (Server.serve config agent stream >>= print)+ (const $ S.close stream)++handleDirectTcpIpRequest :: identity -> Server.DirectTcpIpRequest -> IO (Maybe Server.DirectTcpIpHandler)+handleDirectTcpIpRequest idnt req = pure $ Just $ Server.DirectTcpIpHandler $ \stream-> do+ bs <- receive stream 4096+ sendAll stream "HTTP/1.1 200 OK\n"+ sendAll stream "Content-Type: text/plain\n\n"+ sendAll stream $! BS.pack $ fmap (fromIntegral . fromEnum) $ show req+ sendAll stream "\n\n"+ sendAll stream bs+ print bs++handleSessionRequest :: identity -> Server.SessionRequest -> IO (Maybe Server.SessionHandler)+handleSessionRequest idnt req = pure $ Just $ Server.SessionHandler $ \_ _ _ _ stdout _ -> do+ sendAll stdout "Hello world!\n"+ pure ExitSuccess++-------------------------------------------------------------------------------+-- Instances for use with the socket library+-------------------------------------------------------------------------------++instance DuplexStream (S.Socket f S.Stream p) where++instance OutputStream (S.Socket f S.Stream p) where+ send stream bytes =+ handle f $ S.send stream bytes S.msgNoSignal+ where+ f e+ | e == S.ePipe = pure 0+ | otherwise = throwIO e+ sendUnsafe stream (BA.MemView ptr n) = fromIntegral <$>+ handle f (S.unsafeSend stream ptr (fromIntegral n) S.msgNoSignal)+ where+ f e+ | e == S.ePipe = pure 0+ | otherwise = throwIO e++instance InputStream (S.Socket f S.Stream p) where+ peek stream len = S.receive stream len (S.msgNoSignal <> S.msgPeek)+ receive stream len = S.receive stream len S.msgNoSignal+ receiveUnsafe stream (BA.MemView ptr n) = fromIntegral <$>+ S.unsafeReceive stream ptr (fromIntegral n) S.msgNoSignal+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent ( forkFinally+ )+import Control.Exception ( bracket+ , bracketOnError+ , handle+ , throwIO+ )+import Control.Monad ( forever+ , void+ )+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import Data.Default+import System.Exit++import qualified System.Socket as S+import qualified System.Socket.Family.Inet6 as S+import qualified System.Socket.Protocol.Default as S+import qualified System.Socket.Type.Stream as S+import qualified System.Socket.Unsafe as S++import Network.SSH+import qualified Network.SSH.Server as Server++main :: IO ()+main = do+ file <- BS.readFile "./resources/id_ed25519"+ (privateKey, _) : _ <- decodePrivateKeyFile BS.empty file :: IO [(KeyPair, BA.Bytes)]+ bracket open close (accept config privateKey)+ where+ config = def+ { Server.transportConfig = def+ , Server.userAuthConfig = def+ { Server.onAuthRequest = \username _ _ -> pure (Just username)+ }+ , Server.connectionConfig = def+ { Server.onSessionRequest = handleSessionRequest+ , Server.onDirectTcpIpRequest = handleDirectTcpIpRequest+ }+ }+ open = S.socket :: IO (S.Socket S.Inet6 S.Stream S.Default)+ close = S.close+ accept config agent s = do+ S.setSocketOption s (S.ReuseAddress True)+ S.setSocketOption s (S.V6Only False)+ S.bind s (S.SocketAddressInet6 S.inet6Any 22 0 0)+ S.listen s 5+ forever $ bracketOnError (S.accept s) (S.close . fst) $ \(stream, peer) -> do+ putStrLn $ "Connection from " ++ show peer+ void $ forkFinally+ (Server.serve config agent stream >>= print)+ (const $ S.close stream)++handleDirectTcpIpRequest :: identity -> Server.DirectTcpIpRequest -> IO (Maybe Server.DirectTcpIpHandler)+handleDirectTcpIpRequest idnt req = pure $ Just $ Server.DirectTcpIpHandler $ \stream-> do+ bs <- receive stream 4096+ sendAll stream "HTTP/1.1 200 OK\n"+ sendAll stream "Content-Type: text/plain\n\n"+ sendAll stream $! BS.pack $ fmap (fromIntegral . fromEnum) $ show req+ sendAll stream "\n\n"+ sendAll stream bs+ print bs++handleSessionRequest :: identity -> Server.SessionRequest -> IO (Maybe Server.SessionHandler)+handleSessionRequest idnt req = pure $ Just $ Server.SessionHandler $ \_ _ _ _ stdout _ -> do+ sendAll stdout "Hello world!\n"+ pure ExitSuccess++-------------------------------------------------------------------------------+-- Instances for use with the socket library+-------------------------------------------------------------------------------++instance DuplexStream (S.Socket f S.Stream p) where++instance OutputStream (S.Socket f S.Stream p) where+ send stream bytes =+ handle f $ S.send stream bytes S.msgNoSignal+ where+ f e+ | e == S.ePipe = pure 0+ | otherwise = throwIO e+ sendUnsafe stream (BA.MemView ptr n) = fromIntegral <$>+ handle f (S.unsafeSend stream ptr (fromIntegral n) S.msgNoSignal)+ where+ f e+ | e == S.ePipe = pure 0+ | otherwise = throwIO e++instance InputStream (S.Socket f S.Stream p) where+ peek stream len = S.receive stream len (S.msgNoSignal <> S.msgPeek)+ receive stream len = S.receive stream len S.msgNoSignal+ receiveUnsafe stream (BA.MemView ptr n) = fromIntegral <$>+ S.unsafeReceive stream ptr (fromIntegral n) S.msgNoSignal
+ hssh.cabal view
@@ -0,0 +1,130 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 308fede7a07bceb4ca92e125acf95561b26d29d16c4b65955db9bd656575292b++name: hssh+version: 0.1.0.0+synopsis: SSH protocol implementation+description: Please see the README on Github at <https://github.com/lpeterse/haskell-ssh#readme>+category: Network+homepage: https://github.com/lpeterse/haskell-ssh#readme+bug-reports: https://github.com/lpeterse/haskell-ssh/issues+author: Lars Petersen+maintainer: info@lars-petersen.net+copyright: 2017 Lars Petersen+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/lpeterse/haskell-ssh++flag demo+ description: Build server demo executable hssh-demo+ manual: True+ default: False++library+ exposed-modules:+ Network.SSH+ Network.SSH.Server+ Network.SSH.Client+ Network.SSH.Internal+ other-modules:+ Network.SSH.Algorithms+ Network.SSH.AuthAgent+ Network.SSH.Builder+ Network.SSH.Constants+ Network.SSH.Encoding+ Network.SSH.Exception+ Network.SSH.Key+ Network.SSH.Message+ Network.SSH.Name+ Network.SSH.Server.Service.Connection+ Network.SSH.Server.Service.UserAuth+ Network.SSH.Stream+ Network.SSH.Transport+ Network.SSH.Transport.Crypto+ Network.SSH.Transport.Crypto.ChaCha+ Network.SSH.Transport.Crypto.Poly1305+ Network.SSH.TStreamingQueue+ Paths_hssh+ hs-source-dirs:+ src+ ghc-options: -Wall -fno-warn-orphans+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , cereal+ , containers+ , cryptonite+ , data-default+ , memory+ , stm+ default-language: Haskell2010++executable hssh-demo+ main-is: Main.hs+ other-modules:+ Paths_hssh+ hs-source-dirs:+ app+ ghc-options: -rtsopts+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , cereal+ , containers+ , cryptonite+ , data-default+ , hssh+ , memory+ , socket >=0.8.2.0+ , stm+ if flag(demo)+ buildable: True+ else+ buildable: False+ default-language: Haskell2010++test-suite hssh-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Spec.Algorithms+ Spec.Key+ Spec.Message+ Spec.Server+ Spec.Server.Service.Connection+ Spec.Server.Service.UserAuth+ Spec.Transport+ Spec.TStreamingQueue+ Spec.Util+ Paths_hssh+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , cereal+ , containers+ , cryptonite+ , data-default+ , hssh+ , memory+ , stm+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ default-language: Haskell2010
+ src/Network/SSH.hs view
@@ -0,0 +1,49 @@+module Network.SSH + ( -- * Authentication & Identity+ -- ** AuthAgent+ AuthAgent (..)+ , KeyPair (..)+ -- ** newKeyPair+ , newKeyPair+ -- ** decodePrivateKeyFile+ , decodePrivateKeyFile+ -- * Input / Output+ , DuplexStream+ -- ** receive, receiveAll+ , InputStream (..)+ , receiveAll+ -- ** send, sendAll+ , OutputStream (..)+ , sendAll+ -- * Transport+ , TransportConfig (..)+ -- * Misc+ -- ** Disconnect+ , Disconnect (..)+ , DisconnectParty (..)+ , DisconnectReason (..)+ , DisconnectMessage (..)+ -- ** Name+ , Name ()+ , UserName+ , ServiceName+ , HasName (..)+ -- ** Algorithms+ , HostKeyAlgorithm (..)+ , KeyExchangeAlgorithm (..)+ , EncryptionAlgorithm (..)+ , CompressionAlgorithm (..)+ -- ** PublicKey+ , PublicKey (..)+ -- ** Signature+ , Signature (..)+ ) where++import Network.SSH.Algorithms+import Network.SSH.AuthAgent+import Network.SSH.Exception+import Network.SSH.Key+import Network.SSH.Message+import Network.SSH.Name+import Network.SSH.Stream+import Network.SSH.Transport
+ src/Network/SSH/Algorithms.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.SSH.Algorithms where++import Network.SSH.Name++data HostKeyAlgorithm+ = SshEd25519+ deriving (Eq, Show)++data KeyExchangeAlgorithm+ = Curve25519Sha256AtLibsshDotOrg+ deriving (Eq, Show)++data EncryptionAlgorithm+ = Chacha20Poly1305AtOpensshDotCom+ deriving (Eq, Show)++data CompressionAlgorithm+ = None+ deriving (Eq, Show)++instance HasName HostKeyAlgorithm where+ name SshEd25519 = Name "ssh-ed25519"++instance HasName KeyExchangeAlgorithm where+ name Curve25519Sha256AtLibsshDotOrg = Name "curve25519-sha256@libssh.org"++instance HasName EncryptionAlgorithm where+ name Chacha20Poly1305AtOpensshDotCom = Name "chacha20-poly1305@openssh.com"++instance HasName CompressionAlgorithm where+ name None = Name "none"
+ src/Network/SSH/AuthAgent.hs view
@@ -0,0 +1,34 @@+module Network.SSH.AuthAgent where++import qualified Data.ByteArray as BA+import qualified Crypto.PubKey.Ed25519 as Ed25519++import Network.SSH.Message+import Network.SSH.Key++-- | An `AuthAgent` is something that is capable of cryptographic signing+-- using a public key algorithm like Ed25519 or RSA.+--+-- Currently, `KeyPair` is the only instance, but the method+-- signatures have been designed with other mechanisms like HSM's+-- or agent-forwarding in mind.+class AuthAgent agent where+ -- | Get a list of public keys for which the agent holds the corresponding+ -- private keys.+ --+ -- The list contents may change when called subsequently.+ getPublicKeys :: agent -> IO [PublicKey]+ -- | Sign the given hash with the requested public key.+ --+ -- The signature may be denied in case the key is no longer available.+ -- This method shall not throw exceptions, but rather return `Nothing` if possible.+ getSignature :: BA.ByteArrayAccess hash => agent -> PublicKey -> hash -> IO (Maybe Signature)++instance AuthAgent KeyPair where+ getPublicKeys kp = case kp of+ KeyPairEd25519 pk _ -> pure [PublicKeyEd25519 pk]++ getSignature kp pk0 hash = case kp of+ KeyPairEd25519 pk sk+ | pk0 == PublicKeyEd25519 pk -> pure $ Just $ SignatureEd25519 $ Ed25519.sign sk pk hash+ | otherwise -> pure Nothing
+ src/Network/SSH/Builder.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+module Network.SSH.Builder where++import Control.Monad ( void )+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Internal+ as SBS+import qualified Data.ByteArray as BA+import Foreign.Ptr+import Foreign.Storable+import Data.Memory.PtrMethods+import Data.Word+import Data.Semigroup+import Data.List.NonEmpty ( NonEmpty((:|)) )+import Prelude hiding ( length )++class Monoid a => Builder a where+ word8 :: Word8 -> a+ word16BE :: Word16 -> a+ word16BE x = word8 (fromIntegral $ x `unsafeShiftR` 8)+ <> word8 (fromIntegral x)+ word32BE :: Word32 -> a+ word32BE x = word8 (fromIntegral $ x `unsafeShiftR` 24)+ <> word8 (fromIntegral $ x `unsafeShiftR` 16)+ <> word8 (fromIntegral $ x `unsafeShiftR` 8)+ <> word8 (fromIntegral x)+ word64BE :: Word64 -> a+ word64BE x = word8 (fromIntegral $ x `unsafeShiftR` 56)+ <> word8 (fromIntegral $ x `unsafeShiftR` 48)+ <> word8 (fromIntegral $ x `unsafeShiftR` 40)+ <> word8 (fromIntegral $ x `unsafeShiftR` 32)+ <> word8 (fromIntegral $ x `unsafeShiftR` 24)+ <> word8 (fromIntegral $ x `unsafeShiftR` 16)+ <> word8 (fromIntegral $ x `unsafeShiftR` 8)+ <> word8 (fromIntegral x)+ byteArray :: forall ba. BA.ByteArrayAccess ba => ba -> a+ byteArray x =+ foldl (\acc i-> acc <> word8 (BA.index x i)) mempty [0.. BA.length x - 1]+ byteString :: BS.ByteString -> a+ byteString = byteArray+ shortByteString :: SBS.ShortByteString -> a+ shortByteString x =+ foldl (\acc i-> acc <> word8 (SBS.index x i)) mempty [0.. SBS.length x - 1]+ zeroes :: Int -> a+ zeroes i = mconcat $ fmap (const $ word8 0) [1..i]+ {-# MINIMAL word8 #-}++newtype Length = Length { length :: Int }+ deriving (Eq, Ord, Show, Num)++newtype PtrWriter = PtrWriter { runPtrWriter :: Ptr Word8 -> IO (Ptr Word8) }++instance Semigroup Length where+ Length i <> Length j = Length (i + j)+ sconcat (Length i :| is) = Length (f is i)+ where+ f [] acc = acc+ f (Length j:js) acc = f js $! acc + j++instance Monoid Length where+ mempty = 0+ mconcat is = Length (f is 0)+ where+ f [] acc = acc+ f (Length j:js) acc = f js $! acc + j++instance Builder Length where+ word8 = const 1+ word16BE = const 2+ word32BE = const 4+ word64BE = const 8+ byteArray = Length. BA.length+ byteString = Length . BS.length+ shortByteString = Length . SBS.length+ zeroes = Length+{-# SPECIALIZE word8 :: Word8 -> Length #-}+{-# SPECIALIZE word16BE :: Word16 -> Length #-}+{-# SPECIALIZE word32BE :: Word32 -> Length #-}+{-# SPECIALIZE word64BE :: Word64 -> Length #-}+{-# SPECIALIZE byteArray :: byteArray -> Length #-}+{-# SPECIALIZE byteString :: byteString -> Length #-}+{-# SPECIALIZE shortByteString :: shortByteString -> Length #-}++instance Semigroup PtrWriter where+ PtrWriter f <> PtrWriter g = PtrWriter $ \ptr -> f ptr >>= g++instance Monoid PtrWriter where+ mempty = PtrWriter pure++instance Builder PtrWriter where+ word8 x = PtrWriter $ \ptr -> do+ poke ptr x+ pure (plusPtr ptr 1)+ word32BE x = PtrWriter $ \ptr -> do+ pokeByteOff ptr 0 (fromIntegral $ x `unsafeShiftR` 24 :: Word8)+ pokeByteOff ptr 1 (fromIntegral $ x `unsafeShiftR` 16 :: Word8)+ pokeByteOff ptr 2 (fromIntegral $ x `unsafeShiftR` 8 :: Word8)+ pokeByteOff ptr 3 (fromIntegral x :: Word8)+ pure (plusPtr ptr 4)+ word64BE x = PtrWriter $ \ptr -> do+ pokeByteOff ptr 0 (fromIntegral $ x `unsafeShiftR` 56 :: Word8)+ pokeByteOff ptr 1 (fromIntegral $ x `unsafeShiftR` 48 :: Word8)+ pokeByteOff ptr 2 (fromIntegral $ x `unsafeShiftR` 40 :: Word8)+ pokeByteOff ptr 3 (fromIntegral $ x `unsafeShiftR` 32 :: Word8)+ pokeByteOff ptr 4 (fromIntegral $ x `unsafeShiftR` 24 :: Word8)+ pokeByteOff ptr 5 (fromIntegral $ x `unsafeShiftR` 16 :: Word8)+ pokeByteOff ptr 6 (fromIntegral $ x `unsafeShiftR` 8 :: Word8)+ pokeByteOff ptr 7 (fromIntegral x :: Word8)+ pure (plusPtr ptr 8)+ byteArray x = PtrWriter $ \ptr -> do+ BA.copyByteArrayToPtr x ptr+ pure (plusPtr ptr $ BA.length x)+ byteString x = PtrWriter $ \ptr -> do+ BA.copyByteArrayToPtr x ptr+ pure (plusPtr ptr $ BA.length x)+ shortByteString x = PtrWriter $ \ptr -> do+ let l = SBS.length x+ SBS.copyToPtr x 0 ptr l+ pure (plusPtr ptr l)+ zeroes n = PtrWriter $ \ptr -> do+ memSet ptr 0 n+ pure (plusPtr ptr n)+{-# SPECIALIZE word8 :: Word8 -> PtrWriter #-}+{-# SPECIALIZE word16BE :: Word16 -> PtrWriter #-}+{-# SPECIALIZE word32BE :: Word32 -> PtrWriter #-}+{-# SPECIALIZE word64BE :: Word64 -> PtrWriter #-}+{-# SPECIALIZE byteArray :: BA.ByteArray ba => ba -> PtrWriter #-}+{-# SPECIALIZE byteString :: BS.ByteString -> PtrWriter #-}+{-# SPECIALIZE shortByteString :: SBS.ShortByteString -> PtrWriter #-}+{-# SPECIALIZE zeroes :: Int -> PtrWriter #-}++data ByteArrayBuilder = ByteArrayBuilder Int PtrWriter++instance Semigroup ByteArrayBuilder where+ ByteArrayBuilder c0 w0 <> ByteArrayBuilder c1 w1 =+ c `seq` w `seq` ByteArrayBuilder c w+ where+ c = c0 + c1+ w = w0 <> w1++instance Monoid ByteArrayBuilder where+ mempty = ByteArrayBuilder 0 mempty++instance Builder ByteArrayBuilder where+ word8 x = ByteArrayBuilder 1 (word8 x)+ word16BE x = ByteArrayBuilder 2 (word16BE x)+ word32BE x = ByteArrayBuilder 4 (word32BE x)+ word64BE x = ByteArrayBuilder 8 (word64BE x)+ byteArray x = ByteArrayBuilder (BA.length x) (byteArray x)+ byteString x = ByteArrayBuilder (BS.length x) (byteString x)+ shortByteString x = ByteArrayBuilder (SBS.length x) (shortByteString x)+ zeroes n = ByteArrayBuilder n (zeroes n)++toByteArray :: BA.ByteArray ba => ByteArrayBuilder -> ba+toByteArray (ByteArrayBuilder n w) =+ BA.allocAndFreeze n $ void . runPtrWriter w++copyToPtr :: ByteArrayBuilder -> Ptr Word8 -> IO ()+copyToPtr (ByteArrayBuilder _ b) = void . runPtrWriter b++babLength :: ByteArrayBuilder -> Int+babLength (ByteArrayBuilder n _) = n
+ src/Network/SSH/Client.hs view
@@ -0,0 +1,3 @@+module Network.SSH.Client where++-- Nothing there yet.
+ src/Network/SSH/Constants.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.SSH.Constants where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.Version as V+import Data.Word+import Data.Monoid ( (<>) )++import Network.SSH.Message++import qualified Paths_hssh as Library++version :: Version+version = Version ("SSH-2.0-hssh_" <> v)+ where+ v = SBS.toShort $ BS.pack $ fmap (fromIntegral . fromEnum) (V.showVersion Library.version)++maxPacketLength :: Word32+maxPacketLength = 35000++maxBoundIntWord32 :: Num a => a+maxBoundIntWord32 = fromIntegral $ min maxBoundInt maxBoundWord32+ where+ maxBoundInt = fromIntegral (maxBound :: Int) :: Word64+ maxBoundWord32 = fromIntegral (maxBound :: Word32) :: Word64
+ src/Network/SSH/Encoding.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE LambdaCase, RankNTypes #-}+module Network.SSH.Encoding where++import Control.Applicative+import Control.Monad ( when )+import qualified Control.Monad.Fail as Fail+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.Serialize.Get as G+import Data.Word+import System.Exit++import qualified Network.SSH.Builder as B+import Network.SSH.Name++type Get = G.Get++class Encoding a where+ put :: forall b. B.Builder b => a -> b+ get :: Get a++runPut :: B.ByteArrayBuilder -> BS.ByteString+runPut = B.toByteArray+{-# INLINEABLE runPut #-}++runGet :: (Fail.MonadFail m, Encoding a) => BS.ByteString -> m a+runGet bs = case G.runGet get bs of+ Left e -> Fail.fail e+ Right a -> pure a+{-# INLINEABLE runGet #-}++putExitCode :: B.Builder b => ExitCode -> b+putExitCode = \case+ ExitSuccess -> B.word32BE 0+ ExitFailure x -> B.word32BE (fromIntegral x)+{-# INLINEABLE putExitCode #-}++getExitCode :: Get ExitCode+getExitCode = getWord32 >>= \case+ 0 -> pure ExitSuccess+ x -> pure (ExitFailure $ fromIntegral x)+{-# INLINEABLE getExitCode #-}++getFramed :: Get a -> Get a+getFramed g = do+ w <- getWord32+ G.isolate (fromIntegral w) g+{-# INLINEABLE getFramed #-}++putWord8 :: B.Builder b => Word8 -> b+putWord8 = B.word8+{-# INLINEABLE putWord8 #-}++getWord8 :: Get Word8+getWord8 = G.getWord8+{-# INLINEABLE getWord8 #-}++expectWord8 :: Word8 -> Get ()+expectWord8 i = do+ i' <- getWord8+ when (i /= i') (fail mempty)+{-# INLINEABLE expectWord8 #-}++getWord32 :: Get Word32+getWord32 = G.getWord32be+{-# INLINEABLE getWord32 #-}++putBytes :: B.Builder b => BA.ByteArrayAccess ba => ba -> b+putBytes = B.byteArray+{-# INLINEABLE putBytes #-}++getBytes :: BA.ByteArray ba => Word32 -> Get ba+getBytes i = BA.convert <$> G.getByteString (fromIntegral i)+{-# INLINEABLE getBytes #-}++lenByteString :: BS.ByteString -> Word32+lenByteString = fromIntegral . BA.length+{-# INLINEABLE lenByteString #-}++putByteString :: B.Builder b => BS.ByteString -> b+putByteString = B.byteString+{-# INLINEABLE putByteString #-}++getByteString :: Word32 -> Get BS.ByteString+getByteString = G.getByteString . fromIntegral+{-# INLINEABLE getByteString #-}++getRemainingByteString :: Get BS.ByteString+getRemainingByteString = G.remaining >>= G.getBytes+{-# INLINEABLE getRemainingByteString #-}++putString :: (B.Builder b, BA.ByteArrayAccess ba) => ba -> b+putString ba = B.word32BE (fromIntegral $ BA.length ba) <> putBytes ba+{-# INLINEABLE putString #-}++putShortString :: B.Builder b => SBS.ShortByteString -> b+putShortString bs = B.word32BE (fromIntegral $ SBS.length bs) <> B.shortByteString bs+{-# INLINEABLE putShortString #-}++getShortString :: Get SBS.ShortByteString+getShortString = SBS.toShort <$> getString+{-# INLINEABLE getShortString #-}++getString :: BA.ByteArray ba => Get ba+getString = getWord32 >>= getBytes+{-# INLINEABLE getString #-}++getName :: Get Name+getName = Name <$> getShortString+{-# INLINEABLE getName #-}++putName :: B.Builder b => Name -> b+putName (Name n) = putShortString n+{-# INLINEABLE putName #-}++putBool :: B.Builder b => Bool -> b+putBool False = putWord8 0+putBool True = putWord8 1+{-# INLINEABLE putBool #-}++getBool :: Get Bool+getBool = (expectWord8 0 >> pure False) <|> (expectWord8 1 >> pure True)+{-# INLINEABLE getBool #-}++getTrue :: Get ()+getTrue = expectWord8 1+{-# INLINEABLE getTrue #-}++getFalse :: Get ()+getFalse = expectWord8 0+{-# INLINEABLE getFalse #-}++putAsMPInt :: (B.Builder b, BA.ByteArrayAccess ba) => ba -> b+putAsMPInt ba = f 0+ where+ baLen = BA.length ba+ f i | i >= baLen =+ mempty+ | BA.index ba i == 0 =+ f (i + 1)+ | BA.index ba i >= 128 =+ B.word32BE (fromIntegral $ baLen - i + 1) <>+ putWord8 0 <>+ putWord8 (BA.index ba i) <>+ g (i + 1)+ | otherwise =+ B.word32BE (fromIntegral $ baLen - i) <>+ putWord8 (BA.index ba i) <>+ g (i + 1)+ g i | i >= baLen =+ mempty+ | otherwise =+ putWord8 (BA.index ba i) <>+ g (i + 1)
+ src/Network/SSH/Exception.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.SSH.Exception where++import Control.Exception ( Exception )+import qualified Data.ByteString as BS+import Data.String+import Data.Word++data Disconnect = Disconnect DisconnectParty DisconnectReason DisconnectMessage+ deriving (Eq, Ord, Show)++data DisconnectParty = Local | Remote+ deriving (Eq, Ord, Show)++data DisconnectReason+ = DisconnectHostNotAllowedToConnect+ | DisconnectProtocolError+ | DisconnectKeyExchangeFailed+ | DisconnectReserved+ | DisconnectMacError+ | DisconnectCompressionError+ | DisconnectServiceNotAvailable+ | DisconnectProtocolVersionNotSupported+ | DisconnectHostKeyNotVerifiable+ | DisconnectConnectionLost+ | DisconnectByApplication+ | DisconnectTooManyConnection+ | DisconnectAuthCancelledByUser+ | DisconnectNoMoreAuthMethodsAvailable+ | DisconnectIllegalUsername+ | DisconnectOtherReason Word32+ deriving (Eq, Ord, Show)++newtype DisconnectMessage = DisconnectMessage BS.ByteString+ deriving (Eq, Ord, Show, Semigroup, Monoid, IsString)++instance Exception Disconnect where++exceptionProtocolVersionNotSupported :: Disconnect+exceptionProtocolVersionNotSupported =+ Disconnect Local DisconnectProtocolVersionNotSupported mempty++exceptionConnectionLost :: Disconnect+exceptionConnectionLost =+ Disconnect Local DisconnectConnectionLost mempty++exceptionKexInvalidTransition :: Disconnect+exceptionKexInvalidTransition =+ Disconnect Local DisconnectKeyExchangeFailed "invalid transition"++exceptionKexInvalidSignature :: Disconnect+exceptionKexInvalidSignature =+ Disconnect Local DisconnectKeyExchangeFailed "invalid signature"++exceptionKexNoSignature :: Disconnect+exceptionKexNoSignature =+ Disconnect Local DisconnectKeyExchangeFailed "no signature"++exceptionKexNoCommonKexAlgorithm :: Disconnect+exceptionKexNoCommonKexAlgorithm = + Disconnect Local DisconnectKeyExchangeFailed "no common kex algorithm"++exceptionKexNoCommonEncryptionAlgorithm :: Disconnect+exceptionKexNoCommonEncryptionAlgorithm = + Disconnect Local DisconnectKeyExchangeFailed "no common encryption algorithm"++exceptionMacError :: Disconnect+exceptionMacError =+ Disconnect Local DisconnectMacError mempty++exceptionInvalidPacket :: Disconnect+exceptionInvalidPacket =+ Disconnect Local DisconnectProtocolError "invalid packet"++exceptionPacketLengthExceeded :: Disconnect+exceptionPacketLengthExceeded =+ Disconnect Local DisconnectProtocolError "packet length exceeded"++exceptionAuthenticationTimeout :: Disconnect+exceptionAuthenticationTimeout =+ Disconnect Local DisconnectByApplication "authentication timeout"++exceptionAuthenticationLimitExceeded :: Disconnect+exceptionAuthenticationLimitExceeded =+ Disconnect Local DisconnectByApplication "authentication limit exceeded"++exceptionServiceNotAvailable :: Disconnect+exceptionServiceNotAvailable =+ Disconnect Local DisconnectServiceNotAvailable mempty++exceptionInvalidChannelId :: Disconnect+exceptionInvalidChannelId =+ Disconnect Local DisconnectProtocolError "invalid channel id"++exceptionInvalidChannelRequest :: Disconnect+exceptionInvalidChannelRequest =+ Disconnect Local DisconnectProtocolError "invalid channel request"++exceptionWindowSizeOverflow :: Disconnect+exceptionWindowSizeOverflow =+ Disconnect Local DisconnectProtocolError "window size overflow"+ +exceptionWindowSizeUnderrun :: Disconnect+exceptionWindowSizeUnderrun =+ Disconnect Local DisconnectProtocolError "window size underrun"++exceptionPacketSizeExceeded :: Disconnect+exceptionPacketSizeExceeded =+ Disconnect Local DisconnectProtocolError "packet size exceeded"++exceptionDataAfterEof :: Disconnect+exceptionDataAfterEof =+ Disconnect Local DisconnectProtocolError "data after eof"++exceptionAlreadyExecuting :: Disconnect+exceptionAlreadyExecuting =+ Disconnect Local DisconnectProtocolError "already executing"++exceptionUnexpectedMessage :: BS.ByteString -> Disconnect+exceptionUnexpectedMessage raw+ | BS.null raw = Disconnect Local DisconnectProtocolError "empty message"+ | otherwise = Disconnect Local DisconnectProtocolError msg+ where+ x = BS.head raw+ x0 = (x `div` 100) + 48+ x1 = ((x `div` 10) `mod` 10) + 48+ x2 = (x `mod` 10) + 48+ msg = DisconnectMessage $ "unexpected message type " <> BS.pack [x0,x1,x2]
+ src/Network/SSH/Internal.hs view
@@ -0,0 +1,25 @@+module Network.SSH.Internal+ ( module Network.SSH.Algorithms+ , module Network.SSH.Encoding+ , module Network.SSH.Exception+ , module Network.SSH.Key+ , module Network.SSH.Message+ , module Network.SSH.Name+ , module Network.SSH.Server.Service.Connection+ , module Network.SSH.Server.Service.UserAuth+ , module Network.SSH.Stream+ , module Network.SSH.Transport+ , module Network.SSH.TStreamingQueue+ ) where++import Network.SSH.Algorithms+import Network.SSH.Encoding+import Network.SSH.Exception+import Network.SSH.Key+import Network.SSH.Message+import Network.SSH.Name+import Network.SSH.Server.Service.Connection+import Network.SSH.Server.Service.UserAuth+import Network.SSH.Stream+import Network.SSH.Transport+import Network.SSH.TStreamingQueue
+ src/Network/SSH/Key.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Network.SSH.Key+ ( KeyPair (..)+ , newKeyPair+ , PublicKey (..)+ , decodePrivateKeyFile+ , toPublicKey+ ) where++import Control.Applicative (many, (<|>))+import Control.Monad (replicateM, void, when)+import Control.Monad.Fail (MonadFail)+import qualified Crypto.Cipher.AES as Cipher+import qualified Crypto.Cipher.Types as Cipher+import Crypto.Error+-- import qualified Crypto.KDF.BCryptPBKDF as BCryptPBKDF+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.RSA as RSA+import Data.Bits+import qualified Data.ByteArray as BA+import qualified Data.ByteArray.Parse as BP+import qualified Data.ByteString as BS+import Data.String+import Data.Word++import Network.SSH.Name++data KeyPair+ = KeyPairEd25519 Ed25519.PublicKey Ed25519.SecretKey+ deriving (Eq, Show)++data PublicKey+ = PublicKeyEd25519 Ed25519.PublicKey+ | PublicKeyRSA RSA.PublicKey+ | PublicKeyOther Name+ deriving (Eq, Show)++instance HasName PublicKey where+ name PublicKeyEd25519 {} = Name "ssh-ed25519"+ name PublicKeyRSA {} = Name "ssh-rsa"+ name (PublicKeyOther n) = n++newKeyPair :: IO KeyPair+newKeyPair = + (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey++toPublicKey :: KeyPair -> PublicKey+toPublicKey (KeyPairEd25519 pk _) = PublicKeyEd25519 pk++decodePrivateKeyFile ::+ ( MonadFail m, BA.ByteArray input, BA.ByteArrayAccess passphrase, BA.ByteArray comment )+ => passphrase -> input -> m [(KeyPair, comment)]+decodePrivateKeyFile passphrase = f . BP.parse (parsePrivateKeyFile passphrase) . BA.convert+ where+ f (BP.ParseOK _ a) = pure a+ f (BP.ParseFail e) = fail e+ f (BP.ParseMore c) = f (c Nothing)++parsePrivateKeyFile ::+ ( BA.ByteArrayAccess passphrase, BA.ByteArray comment )+ => passphrase -> BP.Parser BS.ByteString [(KeyPair, comment)]+parsePrivateKeyFile _passphrase = do+ BP.bytes "-----BEGIN OPENSSH PRIVATE KEY-----"+ void $ many space+ bs <- parseBase64+ void $ many space+ BP.bytes "-----END OPENSSH PRIVATE KEY-----"+ void $ many space+ BP.hasMore >>= flip when syntaxError+ case BP.parse parseKeys bs of+ BP.ParseOK _ keys -> pure keys+ BP.ParseFail e -> fail e+ BP.ParseMore _ -> syntaxError+ where+ syntaxError :: BP.Parser ba a+ syntaxError = fail "Syntax error"++ parseBase64 :: (BA.ByteArray ba) => BP.Parser ba ba+ parseBase64 = s0 []+ where+ -- Initial state and final state.+ s0 xs = (char >>= s1 xs) <|> (space1 >> s0 xs)+ <|> pure (BA.pack $ reverse xs)+ -- One character read (i). Three more characters or whitespace expected.+ s1 xs i = (char >>= s2 xs i) <|> (space1 >> s1 xs i)+ -- Two characters read (i and j). Either '==' or space or two more character expected.+ s2 xs i j = r2 xs i j <|> (char >>= s3 xs i j) <|> (space1 >> s2 xs i j)+ -- Three characters read (i, j and k). Either a '=' or space or one more character expected.+ s3 xs i j k = r3 xs i j k <|> (char >>= s4 xs i j k) <|> (space1 >> s3 xs i j k)+ -- Four characters read (i, j, k and l). Computation of result and transition back to s0.+ s4 xs i j k l = s0 $ byte3 : byte2 : byte1: xs+ where+ byte1 = ( i `shiftL` 2) + (j `shiftR` 4)+ byte2 = ((j .&. 15) `shiftL` 4) + (k `shiftR` 2)+ byte3 = ((k .&. 3) `shiftL` 6) + l+ -- Read two '=' chars as finalizer. Only valid from state s2.+ r2 xs i j = padding >> padding >> pure (BA.pack $ reverse $ byte1 : xs)+ where+ byte1 = (i `shiftL` 2) + (j `shiftR` 4)+ -- Read one '=' char as finalizer. Only valid from state s1.+ r3 xs i j k = padding >> pure (BA.pack $ reverse $ byte2 : byte1 : xs)+ where+ byte1 = (i `shiftL` 2) + (j `shiftR` 4)+ byte2 = ((j .&. 15) `shiftL` 4) + (k `shiftR` 2)++ char :: (BA.ByteArray ba) => BP.Parser ba Word8+ char = BP.anyByte >>= \c-> if+ | c >= fe 'A' && c <= fe 'Z' -> pure (c - fe 'A')+ | c >= fe 'a' && c <= fe 'z' -> pure (c - fe 'a' + 26)+ | c >= fe '0' && c <= fe '9' -> pure (c - fe '0' + 52)+ | c == fe '+' -> pure 62+ | c == fe '/' -> pure 63+ | otherwise -> fail ""++ padding :: (BA.ByteArray ba) => BP.Parser ba ()+ padding = BP.byte 61 -- 61 == fromEnum '='++ fe :: Char -> Word8+ fe = fromIntegral . fromEnum++ space :: (BA.ByteArray ba) => BP.Parser ba ()+ space = BP.anyByte >>= \c-> if+ | c == fe ' ' -> pure ()+ | c == fe '\n' -> pure ()+ | c == fe '\r' -> pure ()+ | c == fe '\t' -> pure ()+ | otherwise -> fail ""++ space1 :: (BA.ByteArray ba) => BP.Parser ba ()+ space1 = space >> many space >> pure ()++ getWord32be :: BA.ByteArray ba => BP.Parser ba Word32+ getWord32be = do+ x0 <- fromIntegral <$> BP.anyByte+ x1 <- fromIntegral <$> BP.anyByte+ x2 <- fromIntegral <$> BP.anyByte+ x3 <- fromIntegral <$> BP.anyByte+ pure $ shiftR x0 24 .|. shiftR x1 16 .|. shiftR x2 8 .|. x3++ getString :: BA.ByteArray ba => BP.Parser ba ba+ getString = BP.take =<< (fromIntegral <$> getWord32be)++ parseKeys :: (BA.ByteArray input, IsString input, Show input, BA.ByteArray comment)+ => BP.Parser input [(KeyPair, comment)]+ parseKeys = do+ BP.bytes "openssh-key-v1\NUL"+ cipherAlgo <- getString+ kdfAlgo <- getString+ BP.skip 4 -- size of the kdf section+ deriveKey <- case kdfAlgo of+ "none" ->+ pure $ \_-> CryptoFailed CryptoError_KeySizeInvalid+{-+ -- This is currently not included in cryptonite.+ -- Re-enable if my PR has been merged.+ "bcrypt" -> do+ salt <- getString+ rounds <- fromIntegral <$> getWord32be+ pure $ \case+ Cipher.KeySizeFixed len ->+ CryptoPassed $ BCryptPBKDF.generate (BCryptPBKDF.Parameters rounds len) (BA.convert passphrase :: BA.Bytes) salt+ _ -> undefined -- impossible+-}+ _ -> fail $ "Unsupported key derivation function " ++ show (BA.convert kdfAlgo :: BA.Bytes)++ numberOfKeys <- fromIntegral <$> getWord32be+ _publicKeysRaw <- getString -- not used+ privateKeysRawEncrypted <- getString+ privateKeysRawDecrypted <- BA.convert <$> case cipherAlgo of+ "none" -> pure privateKeysRawEncrypted+ "aes256-cbc" -> do+ let result = do+ let Cipher.KeySizeFixed keySize = Cipher.cipherKeySize (undefined :: Cipher.AES256)+ ivSize = Cipher.blockSize (undefined :: Cipher.AES256)+ keyIV <- deriveKey $ Cipher.KeySizeFixed (keySize + ivSize)+ let key = BA.take keySize keyIV :: BA.ScrubbedBytes+ case Cipher.makeIV (BA.drop keySize keyIV) of+ Nothing -> CryptoFailed CryptoError_IvSizeInvalid+ Just iv -> do+ cipher <- Cipher.cipherInit key :: CryptoFailable Cipher.AES256+ pure $ Cipher.cbcDecrypt cipher iv privateKeysRawEncrypted+ case result of+ CryptoPassed a -> pure a+ CryptoFailed e -> fail (show e)+ "aes256-ctr" -> do+ let result = do+ let Cipher.KeySizeFixed keySize = Cipher.cipherKeySize (undefined :: Cipher.AES256)+ let ivSize = Cipher.blockSize (undefined :: Cipher.AES256)+ keyIV <- deriveKey $ Cipher.KeySizeFixed (keySize + ivSize)+ let key = BA.take keySize keyIV :: BA.ScrubbedBytes+ case Cipher.makeIV (BA.drop keySize keyIV) of+ Nothing -> CryptoFailed CryptoError_IvSizeInvalid+ Just iv -> do+ cipher <- Cipher.cipherInit key :: CryptoFailable Cipher.AES256+ pure $ Cipher.ctrCombine cipher iv privateKeysRawEncrypted+ case result of+ CryptoPassed a -> pure a+ CryptoFailed e -> fail (show e)+ _ -> fail $ "Unsupported cipher " ++ show cipherAlgo+ case BP.parse (parsePrivateKeys numberOfKeys) privateKeysRawDecrypted of+ BP.ParseOK _ keys -> pure keys+ BP.ParseFail e -> fail e+ BP.ParseMore _ -> syntaxError++ parsePrivateKeys :: (BA.ByteArray comment) => Int -> BP.Parser BA.ScrubbedBytes [(KeyPair, comment)]+ parsePrivateKeys count = do+ check1 <- getWord32be+ check2 <- getWord32be+ when (check1 /= check2) (fail "Unsuccessful decryption")+ replicateM count $ do+ key <- getString >>= \algo-> case algo of+ "ssh-ed25519" -> do+ BP.skip 3+ BP.byte 32 -- length field (is always 32 for ssh-ed25519)+ BP.skip Ed25519.publicKeySize+ BP.skip 3+ BP.byte 64 -- length field (is always 64 for ssh-ed25519)+ secretKeyRaw <- BP.take 32+ publicKeyRaw <- BP.take 32+ let key = KeyPairEd25519+ <$> Ed25519.publicKey publicKeyRaw+ <*> Ed25519.secretKey secretKeyRaw+ case key of+ CryptoPassed a -> pure a+ CryptoFailed _ -> fail $ "Invalid " ++ show (BA.convert algo :: BA.Bytes) ++ " key"+ _ -> fail $ "Unsupported algorithm " ++ show (BA.convert algo :: BA.Bytes)+ comment <- BA.convert <$> getString+ pure (key, comment)
+ src/Network/SSH/Message.hs view
@@ -0,0 +1,895 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.SSH.Message+ ( -- * Message+ Message (..)+ , MessageStream (..)+ -- ** Disconnected (1)+ , Disconnected (..)+ , DisconnectReason (..)+ -- ** Ignore (2)+ , Ignore (..)+ -- ** Unimplemented (3)+ , Unimplemented (..)+ -- ** Debug (4)+ , Debug (..)+ -- ** ServiceRequest (5)+ , ServiceRequest (..)+ -- ** ServiceAccept (6)+ , ServiceAccept (..)+ -- ** KexInit (20)+ , KexInit (..)+ -- ** KexNewKeys (21)+ , KexNewKeys (..)+ -- ** KexEcdhInit (30)+ , KexEcdhInit (..)+ -- ** KexEcdhReply (31)+ , KexEcdhReply (..)+ -- ** UserAuthRequest (50)+ , UserAuthRequest (..)+ -- ** UserAuthFailure (51)+ , UserAuthFailure (..)+ -- ** UserAuthSuccess (52)+ , UserAuthSuccess (..)+ -- ** UserAuthBanner (53)+ , UserAuthBanner (..)+ -- ** UserAuthPublicKeyOk (60)+ , UserAuthPublicKeyOk (..)+ -- ** ChannelOpen (90)+ , ChannelOpen (..)+ , ChannelOpenType (..)+ -- ** ChannelOpenConfirmation (91)+ , ChannelOpenConfirmation (..)+ -- ** ChannelOpenFailure (92)+ , ChannelOpenFailure (..)+ , ChannelOpenFailureReason (..)+ -- ** ChannelWindowAdjust (93)+ , ChannelWindowAdjust (..)+ -- ** ChannelData (94)+ , ChannelData (..)+ -- ** ChannelExtendedData (95)+ , ChannelExtendedData (..)+ -- ** ChannelEof (96)+ , ChannelEof (..)+ -- ** ChannelClose (97)+ , ChannelClose (..)+ -- ** ChannelRequest (98)+ , ChannelRequest (..)+ , ChannelRequestEnv (..)+ , ChannelRequestPty (..)+ , ChannelRequestWindowChange (..)+ , ChannelRequestShell (..)+ , ChannelRequestExec (..)+ , ChannelRequestSignal (..)+ , ChannelRequestExitStatus (..)+ , ChannelRequestExitSignal (..)+ -- ** ChannelSuccess (99)+ , ChannelSuccess (..)+ -- ** ChannelFailure (100)+ , ChannelFailure (..)++ -- * Misc+ , AuthMethod (..)+ , ChannelId (..)+ , ChannelType (..)+ , ChannelPacketSize+ , ChannelWindowSize+ , Cookie (), newCookie, nilCookie+ , Password (..)+ , PtySettings (..)+ , PublicKey (..)+ , SessionId (..)+ , Signature (..)+ , Version (..)+ , ServiceName+ , UserName+ ) where++import Control.Applicative+import Control.Monad (void)+import Crypto.Error+import qualified Crypto.PubKey.Curve25519 as Curve25519+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.RSA as RSA+import Crypto.Random+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import Data.Foldable+import Data.Typeable+import Data.Word+import System.Exit++import qualified Network.SSH.Builder as B+import Network.SSH.Exception+import Network.SSH.Encoding+import Network.SSH.Key+import Network.SSH.Name++class MessageStream a where+ sendMessage :: forall msg. Encoding msg => a -> msg -> IO ()+ receiveMessage :: forall msg. Encoding msg => a -> IO msg++data Message+ = MsgDisconnect Disconnected+ | MsgIgnore Ignore+ | MsgUnimplemented Unimplemented+ | MsgDebug Debug+ | MsgServiceRequest ServiceRequest+ | MsgServiceAccept ServiceAccept+ | MsgKexInit KexInit+ | MsgKexNewKeys KexNewKeys+ | MsgKexEcdhInit KexEcdhInit+ | MsgKexEcdhReply KexEcdhReply+ | MsgUserAuthRequest UserAuthRequest+ | MsgUserAuthFailure UserAuthFailure+ | MsgUserAuthSuccess UserAuthSuccess+ | MsgUserAuthBanner UserAuthBanner+ | MsgUserAuthPublicKeyOk UserAuthPublicKeyOk+ | MsgChannelOpen ChannelOpen+ | MsgChannelOpenConfirmation ChannelOpenConfirmation+ | MsgChannelOpenFailure ChannelOpenFailure+ | MsgChannelWindowAdjust ChannelWindowAdjust+ | MsgChannelData ChannelData+ | MsgChannelExtendedData ChannelExtendedData+ | MsgChannelEof ChannelEof+ | MsgChannelClose ChannelClose+ | MsgChannelRequest ChannelRequest+ | MsgChannelSuccess ChannelSuccess+ | MsgChannelFailure ChannelFailure+ | MsgUnknown Word8+ deriving (Eq, Show)++data Disconnected+ = Disconnected+ { disconnectedReason :: DisconnectReason+ , disconnectedDescription :: SBS.ShortByteString+ , disconnectedLanguageTag :: SBS.ShortByteString+ }+ deriving (Eq, Show, Typeable)++data Ignore+ = Ignore+ deriving (Eq, Show)++data Unimplemented+ = Unimplemented Word32+ deriving (Eq, Show)++data Debug+ = Debug+ { debugAlwaysDisplay :: Bool+ , debugMessage :: SBS.ShortByteString+ , debugLanguageTag :: SBS.ShortByteString+ }+ deriving (Eq, Show)++data ServiceRequest+ = ServiceRequest ServiceName+ deriving (Eq, Show)++data ServiceAccept+ = ServiceAccept ServiceName+ deriving (Eq, Show)++data KexInit+ = KexInit+ { kexCookie :: Cookie+ , kexKexAlgorithms :: [Name]+ , kexServerHostKeyAlgorithms :: [Name]+ , kexEncryptionAlgorithmsClientToServer :: [Name]+ , kexEncryptionAlgorithmsServerToClient :: [Name]+ , kexMacAlgorithmsClientToServer :: [Name]+ , kexMacAlgorithmsServerToClient :: [Name]+ , kexCompressionAlgorithmsClientToServer :: [Name]+ , kexCompressionAlgorithmsServerToClient :: [Name]+ , kexLanguagesClientToServer :: [Name]+ , kexLanguagesServerToClient :: [Name]+ , kexFirstPacketFollows :: Bool+ } deriving (Eq, Show)++data KexNewKeys+ = KexNewKeys+ deriving (Eq, Show)++data KexEcdhInit+ = KexEcdhInit+ { kexClientEphemeralKey :: Curve25519.PublicKey+ }+ deriving (Eq, Show)++data KexEcdhReply+ = KexEcdhReply+ { kexServerHostKey :: PublicKey+ , kexServerEphemeralKey :: Curve25519.PublicKey+ , kexHashSignature :: Signature+ }+ deriving (Eq, Show)++data UserAuthRequest+ = UserAuthRequest UserName ServiceName AuthMethod+ deriving (Eq, Show)++data UserAuthFailure+ = UserAuthFailure [Name] Bool+ deriving (Eq, Show)++data UserAuthSuccess+ = UserAuthSuccess+ deriving (Eq, Show)++data UserAuthBanner+ = UserAuthBanner SBS.ShortByteString SBS.ShortByteString+ deriving (Eq, Show)++data UserAuthPublicKeyOk+ = UserAuthPublicKeyOk PublicKey+ deriving (Eq, Show)++data ChannelOpen+ = ChannelOpen ChannelId ChannelWindowSize ChannelPacketSize ChannelOpenType+ deriving (Eq, Show)++data ChannelOpenType+ = ChannelOpenSession+ | ChannelOpenDirectTcpIp+ { coDestinationAddress :: SBS.ShortByteString+ , coDestinationPort :: Word32+ , coSourceAddress :: SBS.ShortByteString+ , coSourcePort :: Word32+ }+ | ChannelOpenOther ChannelType+ deriving (Eq, Show)++data ChannelOpenConfirmation+ = ChannelOpenConfirmation ChannelId ChannelId ChannelWindowSize ChannelPacketSize+ deriving (Eq, Show)++data ChannelOpenFailure+ = ChannelOpenFailure ChannelId ChannelOpenFailureReason SBS.ShortByteString SBS.ShortByteString+ deriving (Eq, Show)++data ChannelOpenFailureReason+ = ChannelOpenAdministrativelyProhibited+ | ChannelOpenConnectFailed+ | ChannelOpenUnknownChannelType+ | ChannelOpenResourceShortage+ | ChannelOpenOtherFailure Word32+ deriving (Eq, Show)++data ChannelWindowAdjust+ = ChannelWindowAdjust ChannelId ChannelWindowSize+ deriving (Eq, Show)++data ChannelData+ = ChannelData ChannelId SBS.ShortByteString+ deriving (Eq, Show)++data ChannelExtendedData+ = ChannelExtendedData ChannelId Word32 SBS.ShortByteString+ deriving (Eq, Show)++data ChannelEof+ = ChannelEof ChannelId+ deriving (Eq, Show)++data ChannelClose+ = ChannelClose ChannelId+ deriving (Eq, Show)++data ChannelRequest+ = ChannelRequest+ { crChannel :: ChannelId+ , crType :: SBS.ShortByteString+ , crWantReply :: Bool+ , crData :: BS.ByteString+ } deriving (Eq, Show)++data ChannelRequestEnv+ = ChannelRequestEnv+ { crVariableName :: SBS.ShortByteString+ , crVariableValue :: SBS.ShortByteString+ } deriving (Eq, Show)++data ChannelRequestPty+ = ChannelRequestPty+ { crPtySettings :: PtySettings+ } deriving (Eq, Show)++data ChannelRequestWindowChange+ = ChannelRequestWindowChange+ { crWidth :: Word32+ , crHeight :: Word32+ , crWidthPixels :: Word32+ , crHeightPixels :: Word32+ } deriving (Eq, Show)++data ChannelRequestShell+ = ChannelRequestShell+ deriving (Eq, Show)++data ChannelRequestExec+ = ChannelRequestExec+ { crCommand :: SBS.ShortByteString+ } deriving (Eq, Show)++data ChannelRequestSignal+ = ChannelRequestSignal+ { crSignal :: SBS.ShortByteString+ } deriving (Eq, Show)++data ChannelRequestExitStatus+ = ChannelRequestExitStatus+ { crExitStatus :: ExitCode+ } deriving (Eq, Show)++data ChannelRequestExitSignal+ = ChannelRequestExitSignal+ { crSignalName :: SBS.ShortByteString+ , crCodeDumped :: Bool+ , crErrorMessage :: SBS.ShortByteString+ , crLanguageTag :: SBS.ShortByteString+ } deriving (Eq, Show)++data ChannelSuccess+ = ChannelSuccess ChannelId+ deriving (Eq, Show)++data ChannelFailure+ = ChannelFailure ChannelId+ deriving (Eq, Show)++data AuthMethod+ = AuthNone+ | AuthHostBased+ | AuthPassword Password+ | AuthPublicKey PublicKey (Maybe Signature)+ | AuthOther Name+ deriving (Eq, Show)++instance HasName AuthMethod where+ name AuthNone = Name "none"+ name AuthHostBased = Name "hostbased"+ name AuthPassword {} = Name "password"+ name AuthPublicKey {} = Name "publickey"+ name (AuthOther n) = n++data Signature+ = SignatureEd25519 Ed25519.Signature+ | SignatureRSA BS.ByteString+ | SignatureOther Name+ deriving (Eq, Show)++instance HasName Signature where+ name SignatureEd25519 {} = Name "ssh-ed25519"+ name SignatureRSA {} = Name "ssh-rsa"+ name (SignatureOther n) = n++data PtySettings+ = PtySettings+ { ptyEnv :: SBS.ShortByteString+ , ptyWidthCols :: Word32+ , ptyHeightRows :: Word32+ , ptyWidthPixels :: Word32+ , ptyHeightPixels :: Word32+ , ptyModes :: SBS.ShortByteString+ } deriving (Eq, Show)+++type ChannelWindowSize = Word32+type ChannelPacketSize = Word32++type UserName = Name+type ServiceName = Name++newtype Cookie = Cookie SBS.ShortByteString+ deriving (Eq, Ord, Show)++newtype Version = Version SBS.ShortByteString+ deriving (Eq, Ord, Show)++newtype Password = Password SBS.ShortByteString+ deriving (Eq, Ord, Show)++newtype SessionId = SessionId SBS.ShortByteString+ deriving (Eq, Ord, Show)++newtype ChannelType = ChannelType SBS.ShortByteString+ deriving (Eq, Ord, Show)++newtype ChannelId = ChannelId Word32+ deriving (Eq, Ord, Show)++newCookie :: MonadRandom m => m Cookie+newCookie = Cookie . SBS.toShort <$> getRandomBytes 16++nilCookie :: Cookie+nilCookie = Cookie $ SBS.toShort $ BS.replicate 16 0++-------------------------------------------------------------------------------+-- Encoding instances+-------------------------------------------------------------------------------++instance Encoding Message where+ put = \case+ MsgDisconnect x -> put x+ MsgIgnore x -> put x+ MsgUnimplemented x -> put x+ MsgDebug x -> put x+ MsgServiceRequest x -> put x+ MsgServiceAccept x -> put x+ MsgKexInit x -> put x+ MsgKexNewKeys x -> put x+ MsgKexEcdhInit x -> put x+ MsgKexEcdhReply x -> put x+ MsgUserAuthRequest x -> put x+ MsgUserAuthFailure x -> put x+ MsgUserAuthSuccess x -> put x+ MsgUserAuthBanner x -> put x+ MsgUserAuthPublicKeyOk x -> put x+ MsgChannelOpen x -> put x+ MsgChannelOpenConfirmation x -> put x+ MsgChannelOpenFailure x -> put x+ MsgChannelWindowAdjust x -> put x+ MsgChannelData x -> put x+ MsgChannelExtendedData x -> put x+ MsgChannelEof x -> put x+ MsgChannelClose x -> put x+ MsgChannelRequest x -> put x+ MsgChannelSuccess x -> put x+ MsgChannelFailure x -> put x+ MsgUnknown x -> putWord8 x+ get =+ MsgDisconnect <$> get <|>+ MsgIgnore <$> get <|>+ MsgUnimplemented <$> get <|>+ MsgDebug <$> get <|>+ MsgServiceRequest <$> get <|>+ MsgServiceAccept <$> get <|>+ MsgKexInit <$> get <|>+ MsgKexNewKeys <$> get <|>+ MsgKexEcdhInit <$> get <|>+ MsgKexEcdhReply <$> get <|>+ MsgUserAuthRequest <$> get <|>+ MsgUserAuthFailure <$> get <|>+ MsgUserAuthSuccess <$> get <|>+ MsgUserAuthBanner <$> get <|>+ MsgUserAuthPublicKeyOk <$> get <|>+ MsgChannelOpen <$> get <|>+ MsgChannelOpenConfirmation <$> get <|>+ MsgChannelOpenFailure <$> get <|>+ MsgChannelWindowAdjust <$> get <|>+ MsgChannelData <$> get <|>+ MsgChannelExtendedData <$> get <|>+ MsgChannelEof <$> get <|>+ MsgChannelClose <$> get <|>+ MsgChannelRequest <$> get <|>+ MsgChannelSuccess <$> get <|>+ MsgChannelFailure <$> get <|> (MsgUnknown <$> getWord8)++instance Encoding Disconnected where+ put (Disconnected r d l) =+ putWord8 1 <>+ put r <>+ putShortString d <>+ putShortString l+ get = do+ expectWord8 1+ Disconnected <$> get <*> getShortString <*> getShortString++instance Encoding DisconnectReason where+ put r = B.word32BE $ case r of+ DisconnectHostNotAllowedToConnect -> 1+ DisconnectProtocolError -> 2+ DisconnectKeyExchangeFailed -> 3+ DisconnectReserved -> 4+ DisconnectMacError -> 5+ DisconnectCompressionError -> 6+ DisconnectServiceNotAvailable -> 7+ DisconnectProtocolVersionNotSupported -> 8+ DisconnectHostKeyNotVerifiable -> 9+ DisconnectConnectionLost -> 10+ DisconnectByApplication -> 11+ DisconnectTooManyConnection -> 12+ DisconnectAuthCancelledByUser -> 13+ DisconnectNoMoreAuthMethodsAvailable -> 14+ DisconnectIllegalUsername -> 15+ DisconnectOtherReason n -> n+ get = (<$> getWord32) $ \case+ 1 -> DisconnectHostNotAllowedToConnect+ 2 -> DisconnectProtocolError+ 3 -> DisconnectKeyExchangeFailed+ 4 -> DisconnectReserved+ 5 -> DisconnectMacError+ 6 -> DisconnectCompressionError+ 7 -> DisconnectServiceNotAvailable+ 8 -> DisconnectProtocolVersionNotSupported+ 9 -> DisconnectHostKeyNotVerifiable+ 10 -> DisconnectConnectionLost+ 11 -> DisconnectByApplication+ 12 -> DisconnectTooManyConnection+ 13 -> DisconnectAuthCancelledByUser+ 14 -> DisconnectNoMoreAuthMethodsAvailable+ 15 -> DisconnectIllegalUsername+ r -> DisconnectOtherReason r++instance Encoding Ignore where+ put _ = putWord8 2+ get = expectWord8 2 >> pure Ignore++instance Encoding Unimplemented where+ put (Unimplemented w) = putWord8 3 <> B.word32BE w+ get = expectWord8 3 >> Unimplemented <$> getWord32++instance Encoding Debug where+ put (Debug ad msg lang) = putWord8 4 <> putBool ad <> putShortString msg <> putShortString lang+ get = expectWord8 4 >> Debug <$> getBool <*> getShortString <*> getShortString++instance Encoding ServiceRequest where+ put (ServiceRequest n) = putWord8 5 <> putName n+ get = expectWord8 5 >> ServiceRequest <$> getName++instance Encoding ServiceAccept where+ put (ServiceAccept n) = putWord8 6 <> putName n+ get = expectWord8 6 >> ServiceAccept <$> getName++instance Encoding KexInit where+ put kex =+ putWord8 20 <>+ put (kexCookie kex) <>+ putNameList (kexKexAlgorithms kex) <>+ putNameList (kexServerHostKeyAlgorithms kex) <>+ putNameList (kexEncryptionAlgorithmsClientToServer kex) <>+ putNameList (kexEncryptionAlgorithmsServerToClient kex) <>+ putNameList (kexMacAlgorithmsClientToServer kex) <>+ putNameList (kexMacAlgorithmsServerToClient kex) <>+ putNameList (kexCompressionAlgorithmsClientToServer kex) <>+ putNameList (kexCompressionAlgorithmsServerToClient kex) <>+ putNameList (kexLanguagesClientToServer kex) <>+ putNameList (kexLanguagesServerToClient kex) <>+ putBool (kexFirstPacketFollows kex) <>+ B.word32BE 0 -- reserved for future extensions+ get = do+ expectWord8 20+ kex <- KexInit <$> get+ <*> getNameList <*> getNameList <*> getNameList <*> getNameList+ <*> getNameList <*> getNameList <*> getNameList <*> getNameList+ <*> getNameList <*> getNameList <*> getBool+ void getWord32 -- reserved for future extensions+ pure kex++instance Encoding KexNewKeys where+ put _ = putWord8 21+ get = expectWord8 21 >> pure KexNewKeys++instance Encoding KexEcdhInit where+ put (KexEcdhInit key) = putWord8 30 <> put key+ get = expectWord8 30 >> KexEcdhInit <$> get++instance Encoding KexEcdhReply where+ put (KexEcdhReply hkey ekey sig) = putWord8 31 <> put hkey <> put ekey <> put sig+ get = expectWord8 31 >> KexEcdhReply <$> get <*> get <*> get++instance Encoding UserAuthRequest where+ put (UserAuthRequest un sn am) = putWord8 50 <> putName un <> putName sn <> put am+ get = expectWord8 50 >> UserAuthRequest <$> getName <*> getName <*> get++instance Encoding UserAuthFailure where+ put (UserAuthFailure ms ps) =+ putWord8 51 <>+ putNameList ms <>+ putBool ps+ get = do+ expectWord8 51+ UserAuthFailure <$> getNameList <*> getBool++instance Encoding UserAuthSuccess where+ put UserAuthSuccess = putWord8 52+ get = expectWord8 52 >> pure UserAuthSuccess++instance Encoding UserAuthBanner where+ put (UserAuthBanner x y) = putWord8 53 <> putShortString x <> putShortString y+ get = expectWord8 53 >> UserAuthBanner <$> getShortString <*> getShortString++instance Encoding UserAuthPublicKeyOk where+ put (UserAuthPublicKeyOk pk) = putWord8 60 <> putName (name pk) <> put pk+ get = expectWord8 60 >> getName >> UserAuthPublicKeyOk <$> get++instance Encoding ChannelOpen where+ put (ChannelOpen rc rw rp ct) =+ putWord8 90 <>+ (case ct of+ ChannelOpenSession {} -> put (ChannelType "session")+ ChannelOpenDirectTcpIp {} -> put (ChannelType "direct-tcpip")+ ChannelOpenOther t -> put t ) <>+ put rc <>+ B.word32BE rw <>+ B.word32BE rp <>+ case ct of+ ChannelOpenSession {} -> mempty+ ChannelOpenDirectTcpIp da dp sa sp ->+ putShortString da <>+ B.word32BE dp <>+ putShortString sa <>+ B.word32BE sp+ ChannelOpenOther {} -> mempty+ get = do+ expectWord8 90+ ct <- get+ rc <- get+ rw <- getWord32+ rp <- getWord32+ ChannelOpen rc rw rp <$> case ct of+ ChannelType "session" ->+ pure ChannelOpenSession+ ChannelType "direct-tcpip" ->+ ChannelOpenDirectTcpIp+ <$> getShortString+ <*> getWord32+ <*> getShortString+ <*> getWord32+ other ->+ pure $ ChannelOpenOther other++instance Encoding ChannelOpenConfirmation where+ put (ChannelOpenConfirmation a b ws ps) =+ putWord8 91 <>+ put a <>+ put b <>+ B.word32BE ws <>+ B.word32BE ps+ get = do+ expectWord8 91+ ChannelOpenConfirmation+ <$> get+ <*> get+ <*> getWord32+ <*> getWord32++instance Encoding ChannelOpenFailure where+ put (ChannelOpenFailure cid reason descr lang) =+ putWord8 92 <>+ put cid <>+ put reason <>+ putShortString descr <>+ putShortString lang+ get = do+ expectWord8 92+ ChannelOpenFailure <$> get <*> get <*> getShortString <*> getShortString++instance Encoding ChannelOpenFailureReason where+ put r = B.word32BE $ case r of+ ChannelOpenAdministrativelyProhibited -> 1+ ChannelOpenConnectFailed -> 2+ ChannelOpenUnknownChannelType -> 3+ ChannelOpenResourceShortage -> 4+ ChannelOpenOtherFailure w32 -> w32+ get = (<$> getWord32) $ \case+ 1 -> ChannelOpenAdministrativelyProhibited+ 2 -> ChannelOpenConnectFailed+ 3 -> ChannelOpenUnknownChannelType+ 4 -> ChannelOpenResourceShortage+ w32 -> ChannelOpenOtherFailure w32++instance Encoding ChannelWindowAdjust where+ put (ChannelWindowAdjust cid ws) = putWord8 93 <> put cid <> B.word32BE ws+ get = expectWord8 93 >> ChannelWindowAdjust <$> get <*> getWord32++instance Encoding ChannelData where+ put (ChannelData cid ba) = putWord8 94 <> put cid <> putShortString ba+ get = expectWord8 94 >> ChannelData <$> get <*> getShortString++instance Encoding ChannelExtendedData where+ put (ChannelExtendedData cid x ba) = putWord8 95 <> put cid <> B.word32BE x <> putShortString ba+ get = expectWord8 95 >> ChannelExtendedData <$> get <*> getWord32 <*> getShortString++instance Encoding ChannelEof where+ put (ChannelEof cid) = putWord8 96 <> put cid+ get = expectWord8 96 >> ChannelEof <$> get++instance Encoding ChannelClose where+ put (ChannelClose cid) = putWord8 97 <> put cid+ get = expectWord8 97 >> ChannelClose <$> get++instance Encoding ChannelRequest where+ put (ChannelRequest cid typ reply dat) = putWord8 98 <> put cid <> putShortString typ <> putBool reply <> putByteString dat+ get = expectWord8 98 >> ChannelRequest <$> get <*> getShortString <*> getBool <*> getRemainingByteString++instance Encoding ChannelRequestEnv where+ put (ChannelRequestEnv key value) = putShortString key <> putShortString value+ get = ChannelRequestEnv <$> getShortString <*> getShortString++instance Encoding ChannelRequestPty where+ put (ChannelRequestPty settings) = put settings+ get = ChannelRequestPty <$> get++instance Encoding ChannelRequestWindowChange where+ put (ChannelRequestWindowChange x0 x1 x2 x3) = B.word32BE x0 <> B.word32BE x1 <> B.word32BE x2 <> B.word32BE x3+ get = ChannelRequestWindowChange <$> getWord32 <*> getWord32 <*> getWord32 <*> getWord32++instance Encoding ChannelRequestShell where+ put _ = mempty+ get = pure ChannelRequestShell++instance Encoding ChannelRequestExec where+ put (ChannelRequestExec c) = putShortString c+ get = ChannelRequestExec <$> getShortString++instance Encoding ChannelRequestSignal where+ put (ChannelRequestSignal signame) = putShortString signame+ get = ChannelRequestSignal <$> getShortString++instance Encoding ChannelRequestExitStatus where+ put (ChannelRequestExitStatus code) = putExitCode code+ get = ChannelRequestExitStatus <$> getExitCode++instance Encoding ChannelRequestExitSignal where+ put (ChannelRequestExitSignal signame core msg lang) = putShortString signame <> putBool core <> putShortString msg <> putShortString lang+ get = ChannelRequestExitSignal <$> getShortString <*> getBool <*> getShortString <*> getShortString++instance Encoding ChannelSuccess where+ put (ChannelSuccess cid) = putWord8 99 <> put cid+ get = expectWord8 99 >> (ChannelSuccess <$> get)++instance Encoding ChannelFailure where+ put (ChannelFailure cid) = putWord8 100 <> put cid+ get = expectWord8 100 >> (ChannelFailure <$> get)++instance Encoding Cookie where+ put (Cookie s) = B.shortByteString s+ get = Cookie . SBS.toShort <$> getBytes 16++instance Encoding ChannelId where+ put (ChannelId x) = B.word32BE x+ get = ChannelId <$> getWord32++instance Encoding ChannelType where+ put (ChannelType x) = putShortString x+ get = ChannelType <$> getShortString++instance Encoding SessionId where+ put (SessionId x) = putShortString x+ get = SessionId <$> getShortString++instance Encoding Version where+ put (Version x) =+ B.shortByteString x <>+ putWord8 0x0d <>+ putWord8 0x0a+ get = do+ mapM_ expectWord8 magic+ untilCRLF 0 (reverse magic)+ where+ magic :: [Word8]+ magic = [0x53,0x53,0x48,0x2d,0x32,0x2e,0x30,0x2d]+ untilCRLF !i !xs+ | i >= (246 :: Int) = fail mempty+ | otherwise = getWord8 >>= \case+ 0x0d -> getWord8 >>= \case+ 0x0a -> pure (Version $ SBS.toShort $ BS.pack $ reverse xs)+ _ -> fail mempty+ x -> untilCRLF (i+1) (x:xs)++instance Encoding AuthMethod where+ put m = putName (name m) <> case m of+ AuthNone -> mempty+ AuthHostBased -> mempty+ AuthPassword (Password pw) ->+ putBool False <> putShortString pw+ AuthPublicKey pk msig -> case msig of+ Nothing -> putBool False <> putName (name pk) <> put pk+ Just sig -> putBool True <> putName (name pk) <> put pk <> put sig+ AuthOther {} -> mempty+ get = getName >>= \case+ Name "none" ->+ pure AuthNone+ Name "hostbased" ->+ pure AuthHostBased+ Name "password" ->+ void getBool >> AuthPassword <$> (Password <$> getShortString)+ Name "publickey" -> do+ signed <- getBool+ void getShortString -- is redundant, ignore!+ key <- get+ msig <- if signed then Just <$> get else pure Nothing+ pure (AuthPublicKey key msig)+ other -> pure (AuthOther other)++instance Encoding PublicKey where+ put k = B.word32BE (len k - 4) <> putName (name k) <> case k of+ PublicKeyEd25519 key -> put key+ PublicKeyRSA key -> putRsaPublicKey key+ PublicKeyOther {} -> mempty+ where+ len = fromIntegral . B.length . put -- FIXME+ get = getFramed $ getName >>= \case+ Name "ssh-ed25519" -> PublicKeyEd25519 <$> get+ Name "ssh-rsa" -> PublicKeyRSA <$> getRsaPublicKey+ other -> PublicKeyOther <$> pure other++instance Encoding Signature where+ put s = B.word32BE (len s - 4) <> putName (name s) <> case s of+ SignatureEd25519 sig -> put sig+ SignatureRSA sig -> putString sig -- FIXME+ SignatureOther {} -> mempty+ where+ len = fromIntegral . B.length . put -- FIXME+ get = getFramed $ getName >>= \case+ Name "ssh-ed25519" -> SignatureEd25519 <$> get+ Name "ssh-rsa" -> SignatureRSA <$> getString --FIXME+ other -> SignatureOther <$> pure other++instance Encoding PtySettings where+ put (PtySettings env wc hc wp hp modes) =+ putShortString env <> B.word32BE wc <> B.word32BE hc <> B.word32BE wp <> B.word32BE hp <> putShortString modes+ get =+ PtySettings <$> getShortString <*> getWord32 <*> getWord32 <*> getWord32 <*> getWord32 <*> getShortString++-------------------------------------------------------------------------------+-- Util functions+-------------------------------------------------------------------------------++putNameList :: (B.Builder b) => [Name] -> b+putNameList xs = B.word32BE (fromIntegral $ g xs) <> h xs+ where+ g [] = 0+ g ys = sum ((\(Name y) -> SBS.length y) <$> ys) + length ys - 1+ h [] = mempty+ h [Name y] = B.shortByteString y+ h (Name y:ys) = B.shortByteString y <> B.word8 0x2c <> h ys++getNameList :: Get [Name]+getNameList = do+ s <- getString :: Get BS.ByteString+ pure $ Name . SBS.toShort <$> BS.split 0x2c s++instance Encoding Curve25519.PublicKey where+ put = putString+ get = getString >>= \s-> case Curve25519.publicKey (s :: BA.Bytes) of+ CryptoPassed k -> pure k+ CryptoFailed _ -> fail ""++instance Encoding Ed25519.PublicKey where+ put = putString+ get = getString >>= \s-> case Ed25519.publicKey (s :: BA.Bytes) of+ CryptoPassed k -> pure k+ CryptoFailed _ -> fail ""++instance Encoding Ed25519.Signature where+ put = putString+ get = getString >>= \s-> case Ed25519.signature (s :: BA.Bytes) of+ CryptoPassed k -> pure k+ CryptoFailed _ -> fail ""++putRsaPublicKey :: B.Builder b => RSA.PublicKey -> b+putRsaPublicKey (RSA.PublicKey _ n e) =+ putInteger n <>+ putInteger e+ where+ putInteger x = putString bs+ where+ bs = BA.pack $ g $ f x [] :: BS.ByteString+ f 0 acc = acc+ f i acc = let (q,r) = quotRem i 256+ in f q (fromIntegral r : acc)+ g [] = []+ g yys@(y:_) | y > 128 = 0:yys+ | otherwise = yys++getRsaPublicKey :: Get RSA.PublicKey+getRsaPublicKey = do+ (n,_) <- getIntegerAndSize+ (e,s) <- getIntegerAndSize+ pure $ RSA.PublicKey s n e+ where+ -- Observing the encoded length is far cheaper than calculating the+ -- log2 of the resulting integer.+ getIntegerAndSize :: Get (Integer, Int)+ getIntegerAndSize = do+ ws <- dropWhile (== 0) . (BA.unpack :: BS.ByteString -> [Word8]) <$> getString -- eventually remove leading 0 byte+ pure (foldl' (\acc w8-> acc * 256 + fromIntegral w8) 0 ws, length ws * 8)
+ src/Network/SSH/Name.hs view
@@ -0,0 +1,14 @@+module Network.SSH.Name where++import qualified Data.ByteArray as BA+import qualified Data.ByteString.Short as SBS+import Data.String++newtype Name = Name SBS.ShortByteString+ deriving (Eq, Ord, Show)++instance IsString Name where+ fromString = Name . SBS.toShort . BA.pack . fmap (fromIntegral . fromEnum)++class HasName a where+ name :: a -> Name
+ src/Network/SSH/Server.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+module Network.SSH.Server (+ -- * Server+ serve+ , Config (..)+ -- * Authentication Layer+ , UserAuthConfig (..)+ -- * Connection Layer+ , ConnectionConfig (..)+ -- ** Session+ -- *** Request & Handler+ , SessionRequest (..)+ , SessionHandler (..)+ -- *** Environment+ , Environment (..)+ -- *** TermInfo+ , TermInfo ()+ -- *** Command+ , Command (..)+ -- ** Direct TCP/IP+ -- *** Request & Handler+ , DirectTcpIpRequest (..)+ , DirectTcpIpHandler (..)+ ) where++import Data.Default++import Network.SSH.AuthAgent+import Network.SSH.Exception+import Network.SSH.Name+import Network.SSH.Server.Service.Connection+import Network.SSH.Server.Service.UserAuth+import Network.SSH.Stream+import Network.SSH.Transport++-- | Serve a single connection represented by a `DuplexStream`.+--+-- (1) The actual server behaviour is only determined by its configuration.+-- The default configuration rejects all authentication and service requests,+-- so you will need to adapt it to your use-case.+-- (2) The `AuthAgent` will be used to authenticate to the client.+-- It is usually sufficient to use a `Network.SSH.KeyPair` as agent.+-- (3) This operation does not return unless the other side either gracefully+-- closes the connection or an error occurs (like connection loss).+-- All expected exceptional conditions get caught and are reflected in the return+-- value.+-- (4) If the connection needs to be terminated by the server, this can be achieved by+-- throwing an asynchronous exception to the executing thread. All depdendant+-- threads and resources will be properly freed and a disconnect message will+-- be delivered to the client (if possible). It is a good idea to run `serve`+-- within an `Control.Concurrent.Async.Async` which can be canceled on demand.+--+-- Example:+--+-- @+-- runServer :: Socket -> IO ()+-- runServer sock = do+-- keyPair <- `Network.SSH.newKeyPair`+-- `serve` conf keyPair sock+-- where+-- conf = `def` { userAuthConfig = `def` { `onAuthRequest` = handleAuthRequest }+-- , connectionConfig = `def` { `onSessionRequest` = handleSessionRequest+-- , `onDirectTcpIpRequest` = handleDirectTcpIpRequest+-- }+-- }+--+-- handleAuthRequest :: `Network.SSH.UserName` -> `Network.SSH.ServiceName` -> `Network.SSH.PublicKey` -> IO (Maybe `Network.SSH.UserName`)+-- handleAuthRequest user service pubkey = case user of+-- "simon" -> pure (Just user)+-- _ -> pure Nothing+--+-- handleSessionRequest :: identity -> `SessionRequest` -> IO (Maybe `SessionHandler`)+-- handleSessionRequest _ _ = pure $ Just $ SessionHandler $ \env mterm mcmd stdin stdout stderr -> do+-- `sendAll` stdout "Hello, world!\\n"+-- pure `System.Exit.ExitSuccess`+--+-- handleDirectTcpIpRequest :: identity -> `DirectTcpIpRequest` -> IO (Maybe DirectTcpIpHandler)+-- handleDirectTcpIpRequest _ req =+-- | port (dstPort req) == 80 = pure $ Just $ DirectTcpIpHandler $ \stream -> do+-- bs <- `receive` stream 4096+-- `sendAll` stream "HTTP/1.1 200 OK\\n"+-- sendAll stream "Content-Type: text/plain\\n\\n"+-- sendAll stream "Hello, world!\\n"+-- sendAll stream "\\n"+-- sendAll stream bs+-- pure ()+-- | otherwise = pure Nothing+-- @+serve :: (DuplexStream stream, AuthAgent agent) => Config identity -> agent -> stream -> IO Disconnect+serve config agent stream = run >>= \case+ Left d -> pure d+ Right () -> pure $ Disconnect Local DisconnectByApplication mempty+ where+ run =+ withTransport (transportConfig config) (Just agent) stream $ \transport session ->+ withAuthentication (userAuthConfig config) transport session $ \case+ Name "ssh-connection" ->+ Just $ serveConnection (connectionConfig config) transport+ _ -> Nothing++-- | The server configuration.+--+-- * The type variable `identity` represents the return type of+-- the user authentication process. It may be chosen freely.+-- The identity object will be supplied to all subsequent+-- service handler functions and can be used as connection state.+data Config identity+ = Config+ { transportConfig :: TransportConfig+ , userAuthConfig :: UserAuthConfig identity+ , connectionConfig :: ConnectionConfig identity+ }++instance Default (Config identity) where+ def = Config+ { transportConfig = def+ , userAuthConfig = def+ , connectionConfig = def+ }
+ src/Network/SSH/Server/Service/Connection.hs view
@@ -0,0 +1,592 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.SSH.Server.Service.Connection+ ( Connection ()+ , ConnectionConfig (..)+ , SessionRequest (..)+ , SessionHandler (..)+ , Environment (..)+ , TermInfo (..)+ , Command (..)+ , DirectTcpIpRequest (..)+ , DirectTcpIpHandler (..)+ , ConnectionMsg (..)+ , serveConnection+ ) where++import Control.Applicative+import qualified Control.Concurrent.Async as Async+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TMVar+import Control.Monad (join, when, forever, unless)+import Control.Monad.STM (STM, atomically, check, throwSTM)+import Control.Exception (bracket, bracketOnError)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import Data.Default+import qualified Data.Map.Strict as M+import Data.Word+import Data.String+import System.Exit++import Network.SSH.Encoding+import Network.SSH.Exception+import Network.SSH.Constants+import Network.SSH.Message+import qualified Network.SSH.Stream as S+import qualified Network.SSH.TStreamingQueue as Q++data ConnectionConfig identity+ = ConnectionConfig+ { onSessionRequest :: identity -> SessionRequest -> IO (Maybe SessionHandler)+ -- ^ This callback will be executed for every session request.+ --+ -- Return a `SessionHandler` or `Nothing` to reject the request (default).+ , onDirectTcpIpRequest :: identity -> DirectTcpIpRequest -> IO (Maybe DirectTcpIpHandler)+ -- ^ This callback will be executed for every direct-tcpip request.+ --+ -- Return a `DirectTcpIpHandler` or `Nothing` to reject the request (default).+ , channelMaxCount :: Word16+ -- ^ The maximum number of channels that may be active simultaneously (default: 256).+ --+ -- Any requests that would exceed the limit will be rejected.+ -- Setting the limit to high values might expose the server to denial+ -- of service issues!+ , channelMaxQueueSize :: Word32+ -- ^ The maximum size of the internal buffers in bytes (also+ -- limits the maximum window size, default: 32 kB)+ --+ -- Increasing this value might help with performance issues+ -- (if connection delay is in a bad ration with the available bandwidth the window+ -- resizing might cause unncessary throttling).+ , channelMaxPacketSize :: Word32+ -- ^ The maximum size of inbound channel data payload (default: 32 kB)+ --+ -- Values that are larger than `channelMaxQueueSize` or the+ -- maximum message size (35000 bytes) will be automatically adjusted+ -- to the maximum possible value.+ }++instance Default (ConnectionConfig identity) where+ def = ConnectionConfig+ { onSessionRequest = \_ _ -> pure Nothing+ , onDirectTcpIpRequest = \_ _ -> pure Nothing+ , channelMaxCount = 256+ , channelMaxQueueSize = 32 * 1024+ , channelMaxPacketSize = 32 * 1024+ }++-- | Information associated with the session request.+--+-- Might be exteded in the future.+data SessionRequest+ = SessionRequest+ deriving (Eq, Ord, Show)++-- | The session handler contains the application logic that serves a client's+-- shell or exec request.+--+-- * The `Command` parameter will be present if this is an exec request and absent+-- for shell requests.+-- * The `TermInfo` parameter will be present if the client requested a pty.+-- * The `Environment` parameter contains the set of all env requests+-- the client issued before the actual shell or exec request.+-- * @stdin@, @stdout@ and @stderr@ are streams. The former can only be read+-- from while the latter can only be written to.+-- After the handler has gracefully terminated, the implementation assures+-- that all bytes will be sent before sending an eof and actually closing the+-- channel.+-- has gracefully terminated. The client will then receive an eof and close.+-- * A @SIGILL@ exit signal will be sent if the handler terminates with an exception.+-- Otherwise the client will receive the returned exit code.+--+-- @+-- handler :: SessionHandler+-- handler = SessionHandler $ \\env mterm mcmd stdin stdout stderr -> case mcmd of+-- Just "echo" -> do+-- bs <- `receive` stdin 1024+-- `sendAll` stdout bs+-- pure `ExitSuccess`+-- Nothing ->+-- pure (`ExitFailure` 1)+-- @+newtype SessionHandler =+ SessionHandler (forall stdin stdout stderr. (S.InputStream stdin, S.OutputStream stdout, S.OutputStream stderr)+ => Environment -> Maybe TermInfo -> Maybe Command -> stdin -> stdout -> stderr -> IO ExitCode)++-- | The `Environment` is list of key-value pairs.+--+-- > Environment [ ("LC_ALL", "en_US.UTF-8") ]+newtype Environment = Environment [(BS.ByteString, BS.ByteString)]+ deriving (Eq, Ord, Show)++-- | The `TermInfo` describes the client's terminal settings if it requested a pty.+--+-- NOTE: This will follow in a future release. You may access the constructor+-- through the `Network.SSH.Internal` module, but should not rely on it yet.+data TermInfo = TermInfo PtySettings++-- | The `Command` is what the client wants to execute when making an exec request+-- (shell requests don't have a command).+newtype Command = Command BS.ByteString+ deriving (Eq, Ord, Show, IsString)++-- | When the client makes a `DirectTcpIpRequest` it requests a TCP port forwarding.+data DirectTcpIpRequest+ = DirectTcpIpRequest+ { dstAddress :: BS.ByteString+ -- ^ The destination address.+ , dstPort :: Word32+ -- ^ The destination port.+ , srcAddress :: BS.ByteString+ -- ^ The source address (usually the IP the client will bind the local listening socket to).+ , srcPort :: Word32+ -- ^ The source port (usually the port the client will bind the local listening socket).+ } deriving (Eq, Ord, Show)++-- | The `DirectTcpIpHandler` contains the application logic+-- that handles port forwarding requests.+--+-- There is of course no need to actually do a real forwarding - this+-- mechanism might also be used to give access to process internal services+-- like integrated web servers etc.+--+-- * When the handler exits gracefully, the implementation assures that+-- all bytes will be sent to the client before terminating the stream+-- with an eof and actually closing the channel.+newtype DirectTcpIpHandler =+ DirectTcpIpHandler (forall stream. S.DuplexStream stream => stream -> IO ())++data Connection identity+ = Connection+ { connConfig :: ConnectionConfig identity+ , connIdentity :: identity+ , connChannels :: TVar (M.Map ChannelId Channel)+ }++data Channel+ = Channel+ { chanApplication :: ChannelApplication+ , chanIdLocal :: ChannelId+ , chanIdRemote :: ChannelId+ , chanMaxPacketSizeRemote :: Word32+ , chanClosed :: TVar Bool+ , chanThread :: TMVar (Async.Async ())+ }++data ChannelApplication+ = ChannelApplicationSession SessionState+ | ChannelApplicationDirectTcpIp DirectTcpIpState++data SessionState+ = SessionState+ { sessHandler :: SessionHandler+ , sessEnvironment :: TVar Environment+ , sessPtySettings :: TVar (Maybe PtySettings)+ , sessStdin :: Q.TStreamingQueue+ , sessStdout :: Q.TStreamingQueue+ , sessStderr :: Q.TStreamingQueue+ }++data DirectTcpIpState+ = DirectTcpIpState+ { dtiStreamIn :: Q.TStreamingQueue+ , dtiStreamOut :: Q.TStreamingQueue+ }++instance S.InputStream DirectTcpIpState where+ peek x = S.peek (dtiStreamIn x)+ receive x = S.receive (dtiStreamIn x)++instance S.OutputStream DirectTcpIpState where+ send x = S.send (dtiStreamOut x)++instance S.DuplexStream DirectTcpIpState where++data ConnectionMsg+ = ConnectionChannelOpen ChannelOpen+ | ConnectionChannelClose ChannelClose+ | ConnectionChannelEof ChannelEof+ | ConnectionChannelData ChannelData+ | ConnectionChannelRequest ChannelRequest+ | ConnectionChannelWindowAdjust ChannelWindowAdjust+ deriving (Eq, Show)++instance Encoding ConnectionMsg where+ put (ConnectionChannelOpen x) = put x+ put (ConnectionChannelClose x) = put x+ put (ConnectionChannelEof x) = put x+ put (ConnectionChannelData x) = put x+ put (ConnectionChannelRequest x) = put x+ put (ConnectionChannelWindowAdjust x) = put x+ get = ConnectionChannelOpen <$> get+ <|> ConnectionChannelClose <$> get+ <|> ConnectionChannelEof <$> get+ <|> ConnectionChannelData <$> get+ <|> ConnectionChannelRequest <$> get+ <|> ConnectionChannelWindowAdjust <$> get++serveConnection :: forall stream identity. MessageStream stream =>+ ConnectionConfig identity -> stream -> identity -> IO ()+serveConnection config stream idnt = bracket open close $ \connection ->+ forever $ receiveMessage stream >>= \case+ ConnectionChannelOpen req -> connectionChannelOpen connection stream req+ ConnectionChannelClose req -> connectionChannelClose connection stream req+ ConnectionChannelEof req -> connectionChannelEof connection req+ ConnectionChannelData req -> connectionChannelData connection req+ ConnectionChannelRequest req -> connectionChannelRequest connection stream req+ ConnectionChannelWindowAdjust req -> connectionChannelWindowAdjust connection req+ where+ open :: IO (Connection identity)+ open = Connection+ <$> pure config+ <*> pure idnt+ <*> newTVarIO mempty++ close :: Connection identity -> IO ()+ close connection = do+ channels <- readTVarIO (connChannels connection)+ mapM_ terminate (M.elems channels)+ where+ terminate channel =+ maybe (pure ()) Async.cancel =<< atomically (tryReadTMVar $ chanThread channel)++connectionChannelOpen :: forall stream identity. MessageStream stream =>+ Connection identity -> stream -> ChannelOpen -> IO ()+connectionChannelOpen connection stream (ChannelOpen remoteChannelId remoteWindowSize remotePacketSize channelType) =+ case channelType of+ ChannelOpenSession ->+ onSessionRequest (connConfig connection) (connIdentity connection) SessionRequest >>= \case+ Nothing ->+ sendMessage stream $ openFailure ChannelOpenAdministrativelyProhibited+ Just handler -> do+ env <- newTVarIO (Environment [])+ pty <- newTVarIO Nothing+ wsLocal <- newTVarIO maxQueueSize+ wsRemote <- newTVarIO remoteWindowSize+ stdIn <- atomically $ Q.newTStreamingQueue maxQueueSize wsLocal+ stdOut <- atomically $ Q.newTStreamingQueue maxQueueSize wsRemote+ stdErr <- atomically $ Q.newTStreamingQueue maxQueueSize wsRemote+ let app = ChannelApplicationSession SessionState+ { sessHandler = handler+ , sessEnvironment = env+ , sessPtySettings = pty+ , sessStdin = stdIn+ , sessStdout = stdOut+ , sessStderr = stdErr+ }+ atomically (openApplicationChannel app) >>= \case+ Left failure -> sendMessage stream failure+ Right (_,confirmation) -> sendMessage stream confirmation+ ChannelOpenDirectTcpIp da dp oa op -> do+ let req = DirectTcpIpRequest (SBS.fromShort da) dp (SBS.fromShort oa) op+ onDirectTcpIpRequest (connConfig connection) (connIdentity connection) req >>= \case+ Nothing ->+ sendMessage stream $ openFailure ChannelOpenAdministrativelyProhibited+ Just (DirectTcpIpHandler handler) -> do+ wsLocal <- newTVarIO maxQueueSize+ wsRemote <- newTVarIO remoteWindowSize+ streamIn <- atomically $ Q.newTStreamingQueue maxQueueSize wsLocal+ streamOut <- atomically $ Q.newTStreamingQueue maxQueueSize wsRemote+ let st = DirectTcpIpState+ { dtiStreamIn = streamIn+ , dtiStreamOut = streamOut+ }+ let app = ChannelApplicationDirectTcpIp st+ atomically (openApplicationChannel app) >>= \case+ Left failure -> sendMessage stream failure+ Right (c,confirmation) -> do+ forkDirectTcpIpHandler stream c st (handler st)+ sendMessage stream confirmation+ ChannelOpenOther {} ->+ sendMessage stream $ openFailure ChannelOpenUnknownChannelType+ where+ openFailure :: ChannelOpenFailureReason -> ChannelOpenFailure+ openFailure reason = ChannelOpenFailure remoteChannelId reason mempty mempty++ openApplicationChannel :: ChannelApplication -> STM (Either ChannelOpenFailure (Channel, ChannelOpenConfirmation))+ openApplicationChannel application = tryRegisterChannel $ \localChannelId -> do+ closed <- newTVar False+ thread <- newEmptyTMVar+ pure Channel+ { chanApplication = application+ , chanIdLocal = localChannelId+ , chanIdRemote = remoteChannelId+ , chanMaxPacketSizeRemote = remotePacketSize+ , chanClosed = closed+ , chanThread = thread+ }++ tryRegisterChannel :: (ChannelId -> STM Channel) -> STM (Either ChannelOpenFailure (Channel, ChannelOpenConfirmation))+ tryRegisterChannel createChannel = do+ channels <- readTVar (connChannels connection)+ case selectFreeLocalChannelId channels of+ Nothing -> pure $ Left $ openFailure ChannelOpenResourceShortage+ Just localChannelId -> do+ channel <- createChannel localChannelId+ writeTVar (connChannels connection) $! M.insert localChannelId channel channels+ pure $ Right $ (channel,) $ ChannelOpenConfirmation+ remoteChannelId+ localChannelId+ maxQueueSize+ maxPacketSize++ -- The maxQueueSize must at least be one (even if 0 in the config)+ -- and must not exceed the range of Int (might happen on 32bit systems+ -- as Int's guaranteed upper bound is only 2^29 -1).+ -- The value is adjusted silently as this won't be a problem+ -- for real use cases and is just the safest thing to do.+ maxQueueSize :: Word32+ maxQueueSize = max 1 $ fromIntegral $ min maxBoundIntWord32+ (channelMaxQueueSize $ connConfig connection)++ maxPacketSize :: Word32+ maxPacketSize = max 1 $ fromIntegral $ min maxBoundIntWord32+ (channelMaxPacketSize $ connConfig connection)++ selectFreeLocalChannelId :: M.Map ChannelId a -> Maybe ChannelId+ selectFreeLocalChannelId m+ | M.size m >= fromIntegral maxCount = Nothing+ | otherwise = f (ChannelId 0) $ M.keys m+ where+ f i [] = Just i+ f (ChannelId i) (ChannelId k:ks)+ | i == k = f (ChannelId $ i+1) ks+ | otherwise = Just (ChannelId i)+ maxCount = channelMaxCount (connConfig connection)++connectionChannelEof ::+ Connection identity -> ChannelEof -> IO ()+connectionChannelEof connection (ChannelEof localChannelId) = atomically $ do+ channel <- getChannelSTM connection localChannelId+ let queue = case chanApplication channel of+ ChannelApplicationSession st -> sessStdin st+ ChannelApplicationDirectTcpIp st -> dtiStreamIn st+ Q.terminate queue++connectionChannelClose :: forall stream identity. MessageStream stream =>+ Connection identity -> stream -> ChannelClose -> IO ()+connectionChannelClose connection stream (ChannelClose localChannelId) = do+ channel <- atomically $ getChannelSTM connection localChannelId+ maybe (pure ()) Async.cancel =<< atomically (tryReadTMVar $ chanThread channel)+ atomically $ do+ channels <- readTVar (connChannels connection)+ writeTVar (connChannels connection) $! M.delete localChannelId channels+ -- When the channel is not marked as already closed then the close+ -- must have been initiated by the client and the server needs to send+ -- a confirmation (both sides may issue close messages simultaneously+ -- and receive them afterwards).+ closeAlreadySent <- readTVarIO (chanClosed channel)+ unless closeAlreadySent $+ sendMessage stream $ ChannelClose $ chanIdRemote channel++connectionChannelData ::+ Connection identity -> ChannelData -> IO ()+connectionChannelData connection (ChannelData localChannelId packet) = atomically $ do+ when (packetSize > maxPacketSize) (throwSTM exceptionPacketSizeExceeded)+ channel <- getChannelSTM connection localChannelId+ let queue = case chanApplication channel of+ ChannelApplicationSession st -> sessStdin st+ ChannelApplicationDirectTcpIp st -> dtiStreamIn st+ i <- Q.enqueue queue (SBS.fromShort packet) <|> throwSTM exceptionWindowSizeUnderrun+ when (i == 0) (throwSTM exceptionDataAfterEof)+ when (i /= packetSize) (throwSTM exceptionWindowSizeUnderrun)+ where+ packetSize :: Word32+ packetSize = fromIntegral $ SBS.length packet++ maxPacketSize :: Word32+ maxPacketSize = max 1 $ fromIntegral $ min maxBoundIntWord32+ (channelMaxPacketSize $ connConfig connection)++connectionChannelWindowAdjust ::+ Connection identity -> ChannelWindowAdjust -> IO ()+connectionChannelWindowAdjust connection (ChannelWindowAdjust channelId increment) = atomically $ do+ channel <- getChannelSTM connection channelId+ let queue = case chanApplication channel of+ ChannelApplicationSession st -> sessStdout st+ ChannelApplicationDirectTcpIp st -> dtiStreamOut st+ Q.addWindowSpace queue increment <|> throwSTM exceptionWindowSizeOverflow++connectionChannelRequest :: forall identity stream. MessageStream stream =>+ Connection identity -> stream -> ChannelRequest -> IO ()+connectionChannelRequest connection stream (ChannelRequest channelId typ wantReply dat) = join $ atomically $ do+ channel <- getChannelSTM connection channelId+ case chanApplication channel of+ ChannelApplicationSession sessionState -> case typ of+ "env" -> interpret $ \(ChannelRequestEnv name value) -> do+ Environment env <- readTVar (sessEnvironment sessionState)+ writeTVar (sessEnvironment sessionState) $! Environment $ (SBS.fromShort name, SBS.fromShort value):env+ pure $ success channel+ "pty-req" -> interpret $ \(ChannelRequestPty settings) -> do+ writeTVar (sessPtySettings sessionState) (Just settings)+ pure $ success channel+ "shell" -> interpret $ \ChannelRequestShell -> do+ env <- readTVar (sessEnvironment sessionState)+ pty <- readTVar (sessPtySettings sessionState)+ stdin <- pure (sessStdin sessionState)+ stdout <- pure (sessStdout sessionState)+ stderr <- pure (sessStderr sessionState)+ let SessionHandler handler = sessHandler sessionState+ pure $ do+ forkSessionHandler stream channel stdin stdout stderr $+ handler env (TermInfo <$> pty) Nothing stdin stdout stderr+ success channel+ "exec" -> interpret $ \(ChannelRequestExec command) -> do+ env <- readTVar (sessEnvironment sessionState)+ pty <- readTVar (sessPtySettings sessionState)+ stdin <- pure (sessStdin sessionState)+ stdout <- pure (sessStdout sessionState)+ stderr <- pure (sessStderr sessionState)+ let SessionHandler handler = sessHandler sessionState+ pure $ do+ forkSessionHandler stream channel stdin stdout stderr $+ handler env (TermInfo <$> pty) (Just (Command $ SBS.fromShort command)) stdin stdout stderr+ success channel+ -- "signal" ->+ -- "exit-status" ->+ -- "exit-signal" ->+ -- "window-change" ->+ _ -> pure $ failure channel+ ChannelApplicationDirectTcpIp {} -> pure $ failure channel+ where+ interpret f = maybe (throwSTM exceptionInvalidChannelRequest) f (runGet dat)+ success channel+ | wantReply = sendMessage stream $ ChannelSuccess (chanIdRemote channel)+ | otherwise = pure ()+ failure channel+ | wantReply = sendMessage stream $ ChannelFailure (chanIdRemote channel)+ | otherwise = pure ()++forkDirectTcpIpHandler :: forall stream. MessageStream stream =>+ stream -> Channel -> DirectTcpIpState -> IO () -> IO ()+forkDirectTcpIpHandler stream channel st handle = do+ registerThread channel handle supervise+ where+ supervise :: Async.Async () -> IO ()+ supervise thread = do+ continue <- join $ atomically+ $ waitOutput+ <|> waitExit thread+ <|> waitLocalWindowAdjust+ when continue $ supervise thread++ waitExit :: Async.Async () -> STM (IO Bool)+ waitExit thread = do+ eof <- Async.waitCatchSTM thread >>= \case+ Right _ -> pure True+ Left _ -> pure False+ writeTVar (chanClosed channel) True+ pure $ do+ when eof $ sendMessage stream $ ChannelEof (chanIdRemote channel)+ sendMessage stream $ ChannelClose (chanIdRemote channel)+ pure False++ waitOutput :: STM (IO Bool)+ waitOutput = do+ bs <- Q.dequeueShort (dtiStreamOut st) (chanMaxPacketSizeRemote channel)+ pure $ do+ sendMessage stream $ ChannelData (chanIdRemote channel) bs+ pure True++ waitLocalWindowAdjust :: STM (IO Bool)+ waitLocalWindowAdjust = do+ check =<< Q.askWindowSpaceAdjustRecommended (dtiStreamIn st)+ increaseBy <- Q.fillWindowSpace (dtiStreamIn st)+ pure $ do+ sendMessage stream $ ChannelWindowAdjust (chanIdRemote channel) increaseBy+ pure True++forkSessionHandler :: forall stream. MessageStream stream =>+ stream -> Channel -> Q.TStreamingQueue -> Q.TStreamingQueue -> Q.TStreamingQueue -> IO ExitCode -> IO ()+forkSessionHandler stream channel stdin stdout stderr run = do+ registerThread channel run supervise+ where+ -- The supervisor thread waits for several event sources simultaneously,+ -- handles them and loops until the session thread has terminated and exit+ -- has been signaled or the channel/connection got closed.+ supervise :: Async.Async ExitCode -> IO ()+ supervise thread = do+ continue <- join $ atomically $+ -- NB: The order is critical: Another order would cause a close+ -- or eof to be sent before all data has been flushed.+ waitStdout+ <|> waitStderr+ <|> waitExit thread+ <|> waitLocalWindowAdjust+ when continue $ supervise thread++ waitExit :: Async.Async ExitCode -> STM (IO Bool)+ waitExit thread = do+ exitMessage <- Async.waitCatchSTM thread >>= \case+ Right c -> pure $ req "exit-status" $ runPut $ put $ ChannelRequestExitStatus c+ Left _ -> pure $ req "exit-signal" $ runPut $ put $ ChannelRequestExitSignal "ILL" False "" ""+ writeTVar (chanClosed channel) True+ pure $ do+ sendMessage stream eofMessage+ sendMessage stream exitMessage+ sendMessage stream closeMessage+ pure False+ where+ req t = ChannelRequest (chanIdRemote channel) t False+ eofMessage = ChannelEof (chanIdRemote channel)+ closeMessage = ChannelClose (chanIdRemote channel)++ waitStdout :: STM (IO Bool)+ waitStdout = do+ bs <- Q.dequeueShort stdout (chanMaxPacketSizeRemote channel)+ pure $ do+ sendMessage stream $ ChannelData (chanIdRemote channel) bs+ pure True++ waitStderr :: STM (IO Bool)+ waitStderr = do+ bs <- Q.dequeueShort stderr (chanMaxPacketSizeRemote channel)+ pure $ do+ sendMessage stream $ ChannelExtendedData (chanIdRemote channel) 1 bs+ pure True++ waitLocalWindowAdjust :: STM (IO Bool)+ waitLocalWindowAdjust = do+ check =<< Q.askWindowSpaceAdjustRecommended stdin+ increaseBy <- Q.fillWindowSpace stdin+ pure $ do+ sendMessage stream $ ChannelWindowAdjust (chanIdRemote channel) increaseBy+ pure True++getChannelSTM :: Connection identity -> ChannelId -> STM Channel+getChannelSTM connection channelId = do+ channels <- readTVar (connChannels connection)+ case M.lookup channelId channels of+ Just channel -> pure channel+ Nothing -> throwSTM exceptionInvalidChannelId++-- Two threads are forked: a worker thread running as Async and a+-- supervisor thread which is registered with the channel.+-- -> The worker thread does never outlive the supervisor thread (`withAsync`).+-- -> The supervisor thread terminates itself when either the worker thread+-- has terminated (`waitExit`) or gets cancelled when the channel/connection+-- gets closed.+-- -> The supervisor thread is started even if a thread is already running.+-- It is blocked until it is notified that it is the only one+-- running and its Async has been registered with the channel (meaning+-- it will be reliably cancelled on main thread termination).+registerThread :: Channel -> IO a -> (Async.Async a -> IO ()) -> IO ()+registerThread channel run supervise = do+ barrier <- newTVarIO False+ let prepare = Async.async $ do+ atomically $ readTVar barrier >>= check+ Async.withAsync run supervise+ let abort = Async.cancel+ let register thread =+ putTMVar (chanThread channel) thread+ <|> throwSTM exceptionAlreadyExecuting+ bracketOnError prepare abort $ \thread -> atomically $+ register thread >> writeTVar barrier True
+ src/Network/SSH/Server/Service/UserAuth.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Network.SSH.Server.Service.UserAuth where++import Control.Exception ( throwIO )+import Control.Concurrent ( threadDelay )+import qualified Control.Concurrent.Async as Async+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Data.ByteString as BS+import Data.Default+import Data.Word++import Network.SSH.Encoding+import Network.SSH.Exception+import Network.SSH.Key+import Network.SSH.Message+import Network.SSH.Name++-- | Configuration for the user authentication layer.+--+-- After a successful key exchange the client will usually+-- request the @user-auth@ service to authenticate against.+-- In this implementation, the @user-auth@ service is the+-- only service available after key exchange and the client+-- must request the connection layer through the authentication+-- layer. Except for transport messages, all other message types+-- will result in a disconnect as long as user authentication+-- is in progress (looking at you, libssh ;-)+data UserAuthConfig identity+ = UserAuthConfig+ { onAuthRequest :: UserName -> ServiceName -> PublicKey -> IO (Maybe identity)+ -- ^ This handler will be called for each authentication attempt.+ --+ -- (1) The client might try several methods and keys: Just return `Nothing`+ -- for every request that is not sufficient to determine the user's+ -- identity.+ --+ -- (2) When access shall be granted, return `Just`. The `identity` may+ -- contain whatever is desired; it may be just the `UserName`.+ --+ -- (3) When the client uses public key authentication, the transport layer+ -- has already determined that the client is in posession of the+ -- corresponding private key (by requesting and validating a signature).+ --+ -- (4) The default rejects all authentication attempts unconditionally.+ , userAuthMaxTime :: Word16+ -- ^ Timeout for user authentication in seconds (default is 60).+ --+ -- (1) A @SSH_DISCONNECT_BY_APPLICATION@ will be sent to the client+ -- when the timeout occurs before successful authentication.+ , userAuthMaxAttempts :: Word16+ -- ^ A limit for the number of failed attempts per connection (default is 20).+ --+ -- (1) A @SSH_DISCONNECT_BY_APPLICATION@ will be sent to the client+ -- when limit has been exceeded.+ }++instance Default (UserAuthConfig identity) where+ def = UserAuthConfig+ { onAuthRequest = \_ _ _ -> pure Nothing+ , userAuthMaxTime = 60+ , userAuthMaxAttempts = 20+ }++withAuthentication ::+ forall identity stream a. (MessageStream stream) =>+ UserAuthConfig identity -> stream -> SessionId ->+ (ServiceName -> Maybe (identity -> IO a)) -> IO a+withAuthentication config transport session serviceHandler = do+ ServiceRequest srv <- receiveMessage transport+ case srv of+ Name "ssh-userauth" -> do+ sendMessage transport (ServiceAccept srv)+ Async.race timeout (authenticate maxAttempts) >>= \case+ Left () -> throwIO exceptionAuthenticationTimeout+ Right (s,i) -> case serviceHandler s of+ Just h -> sendSuccess >> h i+ Nothing -> throwIO exceptionServiceNotAvailable+ _ -> throwIO exceptionServiceNotAvailable+ where+ maxAttempts = userAuthMaxAttempts config+ timeout = threadDelay $ 1000 * 1000 * fromIntegral (userAuthMaxTime config)++ sendSupportedAuthMethods =+ sendMessage transport $ UserAuthFailure [Name "publickey"] False+ sendPublicKeyIsOk pk =+ sendMessage transport $ UserAuthPublicKeyOk pk+ sendSuccess =+ sendMessage transport UserAuthSuccess++ authenticate limit+ | limit <= 0 = throwIO exceptionAuthenticationLimitExceeded+ | otherwise = do+ UserAuthRequest user service method <- receiveMessage transport+ case method of+ AuthPublicKey pk msig -> case msig of+ Just sig+ | verifyAuthSignature session user service pk sig -> do+ onAuthRequest config user service pk >>= \case+ Just idnt -> pure (service, idnt)+ Nothing -> do+ sendSupportedAuthMethods+ authenticate (limit - 1)+ | otherwise -> do+ sendSupportedAuthMethods+ authenticate (limit - 1)+ Nothing -> do+ sendPublicKeyIsOk pk+ authenticate (limit - 1)+ _ -> do+ sendSupportedAuthMethods+ authenticate (limit - 1)++verifyAuthSignature :: SessionId -> UserName -> ServiceName -> PublicKey -> Signature -> Bool+verifyAuthSignature sessionIdentifier userName serviceName publicKey signature =+ case (publicKey,signature) of+ (PublicKeyEd25519 k, SignatureEd25519 s) -> Ed25519.verify k signedData s+ -- TODO: Implement RSA+ -- (PublicKeyRSA k, SignatureRSA s) -> RSA.PKCS15.verify (Just Hash.SHA1) k signedData s+ _ -> False+ where+ signedData :: BS.ByteString+ signedData = runPut $+ put sessionIdentifier <>+ putWord8 50 <>+ putName userName <>+ putName serviceName <>+ putName (Name "publickey") <>+ putWord8 1 <>+ putName (name publicKey) <>+ put publicKey
+ src/Network/SSH/Stream.hs view
@@ -0,0 +1,96 @@+module Network.SSH.Stream where++import Control.Exception ( throwIO )+import Control.Monad ( when )+import Foreign.Ptr+import qualified Data.ByteString as BS+import qualified Data.ByteArray as BA++-- | A `DuplexStream` is an abstraction over all things that+-- behave like file handles or sockets.+class (InputStream stream, OutputStream stream) => DuplexStream stream where++-- | An `OutputStream` is something that chunks of bytes can be written to.+class OutputStream stream where+ -- | Send a chunk of bytes into the stream.+ --+ -- (1) This method shall block until at least one byte could be sent or+ -- the connection got closed.+ -- (2) Returns the number of bytes sent or 0 if the other side+ -- closed the connection. The return value must be checked when+ -- using a loop for sending or the program will get stuck in+ -- endless recursion!+ send :: stream -> BS.ByteString -> IO Int+ -- | Like `send`, but allows for more efficiency with less memory+ -- allocations when working with builders and re-usable buffers.+ sendUnsafe :: stream -> BA.MemView -> IO Int+ sendUnsafe stream view = do+ bs <- BA.copy view (const $ pure ())+ send stream bs+ {-# MINIMAL send #-}++-- | An `InputStream` is something that bytes can be read from.+class InputStream stream where+ -- | Like `receive`, but does not actually remove anything+ -- from the input buffer.+ --+ -- (1) Use with care! There are very few legitimate use cases+ -- for this.+ peek :: stream -> Int -> IO BS.ByteString+ -- | Receive a chunk of bytes from the stream.+ --+ -- (1) This method shall block until at least one byte becomes+ -- available or the connection got closed.+ -- (2) As with sockets, the chunk boundaries are not guaranteed to+ -- be preserved during transmission although this will be most often+ -- the case. Never rely on this behaviour!+ -- (3) The second parameter determines how many bytes to receive at most,+ -- but the `BS.ByteString` returned might be shorter.+ -- (4) Returns a chunk which is guaranteed to be shorter or equal+ -- than the given limit. It is empty when the connection got+ -- closed and all subsequent attempts to read shall return the+ -- empty string. This must be checked when collecting chunks in+ -- a loop or the program will get stuck in endless recursion!+ receive :: stream -> Int -> IO BS.ByteString+ -- | Like `receive`, but allows for more efficiency with less memory+ -- allocations when working with builders and re-usable buffers.+ receiveUnsafe :: stream -> BA.MemView -> IO Int+ receiveUnsafe stream (BA.MemView ptr n) = do+ bs <- receive stream n+ BA.copyByteArrayToPtr bs ptr+ pure (BS.length bs)+ {-# MINIMAL peek, receive #-}++-- | Try to send the complete `BS.ByteString`.+--+-- * Blocks until either the `BS.ByteString` has been sent+-- or throws an exception when the connection got terminated+-- while sending it.+sendAll :: OutputStream stream => stream -> BS.ByteString -> IO ()+sendAll stream bs+ | BS.null bs = pure ()+ | otherwise = BA.withByteArray bs $ sendAll' (BS.length bs)+ where+ sendAll' remaining ptr+ | remaining <= 0 = pure ()+ | otherwise = do+ sent <- sendUnsafe stream (BA.MemView ptr remaining)+ when (sent <= 0) (throwIO $ userError "sendAll: connection lost")+ sendAll' (remaining - sent) (plusPtr ptr sent)++-- | Try to receive a `BS.ByteString` of the designated length in bytes.+--+-- * Blocks until either the complete `BS.ByteString` has been received+-- or throws an exception when the connection got terminated+-- before enough bytes arrived.+receiveAll :: InputStream stream => stream -> Int -> IO BS.ByteString+receiveAll stream n+ | n <= 0 = pure mempty+ | otherwise = BA.alloc n $ receiveAll' n+ where+ receiveAll' remaining ptr+ | remaining <= 0 = pure ()+ | otherwise = do+ received <- receiveUnsafe stream (BA.MemView ptr remaining)+ when (received <= 0) (throwIO $ userError "receiveAll: connection lost")+ receiveAll' (remaining - received) (plusPtr ptr received)
+ src/Network/SSH/TStreamingQueue.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf #-}+module Network.SSH.TStreamingQueue where++import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TMVar+import Control.Monad.STM+import Control.Applicative+import Data.Word+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import Prelude hiding ( head+ , tail+ )++import qualified Network.SSH.Stream as S+import Network.SSH.Constants++data TStreamingQueue+ = TStreamingQueue+ { qCapacity :: Word32+ , qWindow :: TVar Word32+ , qSize :: TVar Word32+ , qEof :: TVar Bool+ , qHead :: TMVar SBS.ShortByteString+ , qTail :: TChan SBS.ShortByteString+ }++newTStreamingQueue :: Word32 -> TVar Word32 -> STM TStreamingQueue+newTStreamingQueue c window =+ TStreamingQueue c window <$> newTVar 0 <*> newTVar False <*> newEmptyTMVar <*> newTChan++capacity :: TStreamingQueue -> Word32+capacity = qCapacity++getSize :: TStreamingQueue -> STM Word32+getSize = readTVar . qSize++getFree :: TStreamingQueue -> STM Word32+getFree q = (capacity q -) <$> getSize q++getWindowSpace :: TStreamingQueue -> STM Word32+getWindowSpace = readTVar . qWindow++addWindowSpace :: TStreamingQueue -> Word32 -> STM ()+addWindowSpace q increment = do+ wndw <- getWindowSpace q :: STM Word32+ check $ (fromIntegral wndw + fromIntegral increment :: Word64) <= fromIntegral (maxBound :: Word32)+ writeTVar (qWindow q) $! wndw + increment++askWindowSpaceAdjustRecommended :: TStreamingQueue -> STM Bool+askWindowSpaceAdjustRecommended q = do+ size <- getSize q+ wndw <- getWindowSpace q+ let threshold = capacity q `div` 2+ -- 1st condition: window size must be below half of its maximum+ -- 2nd condition: queue size must be below half of its capacity+ -- in order to avoid byte-wise adjustment and flapping+ pure $ size <= threshold && wndw <= threshold++fillWindowSpace :: TStreamingQueue -> STM Word32+fillWindowSpace q = do+ free <- getFree q+ wndw <- getWindowSpace q+ writeTVar (qWindow q) $! wndw + free+ pure free++terminate :: TStreamingQueue -> STM ()+terminate q =+ writeTVar (qEof q) True++enqueue :: TStreamingQueue -> BS.ByteString -> STM Word32+enqueue q bs+ | BS.null bs = pure 0+ | otherwise = do+ eof <- readTVar (qEof q)+ if eof then pure 0 else do+ size <- getSize q+ wndw <- getWindowSpace q+ let free = capacity q - size+ requested = fromIntegral (BS.length bs) :: Word32+ available = min (min free wndw) maxBoundIntWord32 :: Word32+ check $ available > 0 -- Block until there's free capacity and window space.+ if | available >= requested -> do+ writeTVar (qSize q) $! size + requested+ writeTVar (qWindow q) $! wndw - requested+ writeTChan (qTail q) $! SBS.toShort bs+ pure requested+ | otherwise -> do+ writeTVar (qSize q) $! size + available+ writeTVar (qWindow q) $! wndw - available+ writeTChan (qTail q) $! SBS.toShort $ BS.take (fromIntegral available) bs+ pure available++dequeue :: TStreamingQueue -> Word32 -> STM BS.ByteString+dequeue q maxBufSize = do+ size <- getSize q+ eof <- readTVar (qEof q)+ check $ size > 0 || eof -- Block until there's at least 1 byte available.+ if size == 0 && eof+ then pure mempty+ else SBS.fromShort . mconcat <$> f size requested+ where+ f s 0 = do+ writeTVar (qSize q) $! s - requested+ pure []+ f s j = do+ bs <- takeTMVar (qHead q) <|> readTChan (qTail q) <|> pure mempty+ if | SBS.null bs -> do+ writeTVar (qSize q) 0+ pure []+ | fromIntegral (SBS.length bs) <= j ->+ (bs:) <$> f s (j - fromIntegral (SBS.length bs))+ | otherwise -> do+ writeTVar (qSize q) $! s - requested+ putTMVar (qHead q) $! SBS.toShort $ BS.drop (fromIntegral j) $ SBS.fromShort bs+ pure [ SBS.toShort $ BS.take (fromIntegral j) $ SBS.fromShort bs ]+ requested = min maxBufSize maxBoundIntWord32++dequeueShort :: TStreamingQueue -> Word32 -> STM SBS.ShortByteString+dequeueShort q maxBufSize = do+ size <- getSize q+ eof <- readTVar (qEof q)+ check $ size > 0 || eof -- Block until there's at least 1 byte available.+ if size == 0 && eof+ then pure mempty+ else mconcat <$> f size requested+ where+ f s 0 = do+ writeTVar (qSize q) $! s - requested+ pure []+ f s j = do+ bs <- takeTMVar (qHead q) <|> readTChan (qTail q) <|> pure mempty+ if | SBS.null bs -> do+ writeTVar (qSize q) 0+ pure []+ | fromIntegral (SBS.length bs) <= j ->+ (bs:) <$> f s (j - fromIntegral (SBS.length bs))+ | otherwise -> do+ writeTVar (qSize q) $! s - requested+ putTMVar (qHead q) $! SBS.toShort $ BS.drop (fromIntegral j) $ SBS.fromShort bs+ pure [ SBS.toShort $ BS.take (fromIntegral j) $ SBS.fromShort bs ]+ requested = min maxBufSize maxBoundIntWord32++lookAhead :: TStreamingQueue -> Word32 -> STM BS.ByteString+lookAhead q maxBufSize = do+ size <- getSize q+ eof <- readTVar (qEof q)+ check $ size > 0 || eof+ if size == 0 && eof+ then pure mempty+ else do+ bs <- readTMVar (qHead q) <|> peekTChan (qTail q)+ pure $ BS.take (fromIntegral maxBufSize) (SBS.fromShort bs)++instance S.DuplexStream TStreamingQueue++instance S.OutputStream TStreamingQueue where+ send q bs = fromIntegral <$> atomically (enqueue q bs)++instance S.InputStream TStreamingQueue where+ peek q i = atomically $ lookAhead q $ fromIntegral $ min i maxBoundIntWord32+ receive q i = atomically $ dequeue q $ fromIntegral $ min i maxBoundIntWord32
+ src/Network/SSH/Transport.hs view
@@ -0,0 +1,517 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+module Network.SSH.Transport+ ( Transport()+ , TransportConfig (..)+ , Disconnected (..)+ , withTransport+ , plainEncryptionContext+ , plainDecryptionContext+ , newChaCha20Poly1305EncryptionContext+ , newChaCha20Poly1305DecryptionContext+ )+where++import Control.Applicative+import Control.Concurrent ( threadDelay )+import Control.Concurrent.Async+import Control.Concurrent.MVar+import Control.Exception ( throwIO, handle, catch, fromException)+import Control.Monad ( when, void )+import Control.Monad.STM+import Data.Default+import Data.List+import Data.Monoid ( (<>) )+import Data.Word+import GHC.Clock+import qualified Crypto.Hash as Hash+import qualified Crypto.PubKey.Curve25519 as Curve25519+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.List.NonEmpty as NEL++import Network.SSH.Algorithms+import qualified Network.SSH.Builder as B+import Network.SSH.AuthAgent+import Network.SSH.Constants+import Network.SSH.Transport.Crypto+import Network.SSH.Encoding+import Network.SSH.Exception+import Network.SSH.Message+import Network.SSH.Name+import Network.SSH.Stream++data Transport+ = forall stream agent. (DuplexStream stream, AuthAgent agent) => TransportEnv+ { tStream :: stream+ , tConfig :: TransportConfig+ , tAuthAgent :: Maybe agent+ , tClientVersion :: Version+ , tServerVersion :: Version+ , tBytesSent :: MVar Word64+ , tPacketsSent :: MVar Word64+ , tBytesReceived :: MVar Word64+ , tPacketsReceived :: MVar Word64+ , tEncryptionCtx :: MVar EncryptionContext+ , tEncryptionCtxNext :: MVar EncryptionContext+ , tDecryptionCtx :: MVar DecryptionContext+ , tDecryptionCtxNext :: MVar DecryptionContext+ , tKexContinuation :: MVar KexContinuation+ , tSessionId :: MVar SessionId+ , tLastRekeyingTime :: MVar Word64+ , tLastRekeyingDataSent :: MVar Word64+ , tLastRekeyingDataReceived :: MVar Word64+ }++data TransportConfig+ = TransportConfig+ { serverHostKeyAlgorithms :: NEL.NonEmpty HostKeyAlgorithm+ , kexAlgorithms :: NEL.NonEmpty KeyExchangeAlgorithm+ , encryptionAlgorithms :: NEL.NonEmpty EncryptionAlgorithm+ , maxTimeBeforeRekey :: Word64+ , maxDataBeforeRekey :: Word64+ , onSend :: BS.ByteString -> IO ()+ , onReceive :: BS.ByteString -> IO ()+ }++instance Default TransportConfig where+ def = TransportConfig+ { serverHostKeyAlgorithms = pure SshEd25519+ , kexAlgorithms = pure Curve25519Sha256AtLibsshDotOrg+ , encryptionAlgorithms = pure Chacha20Poly1305AtOpensshDotCom+ , maxTimeBeforeRekey = 3600+ , maxDataBeforeRekey = 1000 * 1000 * 1000+ , onSend = const (pure ())+ , onReceive = const (pure ())+ }++data KexStep+ = Init KexInit+ | EcdhInit KexEcdhInit+ | EcdhReply KexEcdhReply++newtype KexContinuation = KexContinuation (Maybe KexStep -> IO KexContinuation)++instance MessageStream Transport where+ sendMessage t msg = do+ kexIfNecessary t+ transportSendMessage t msg+ receiveMessage t = do+ kexIfNecessary t+ transportReceiveMessage t++withTransport ::+ (DuplexStream stream, AuthAgent agent) =>+ TransportConfig -> Maybe agent -> stream ->+ (Transport -> SessionId -> IO a) -> IO (Either Disconnect a)+withTransport config magent stream runWith = withFinalExceptionHandler $ do+ (clientVersion, serverVersion) <- case magent of+ -- Receive the peer version and reject immediately if this+ -- is not an SSH connection attempt (before allocating+ -- any more resources); respond with the server version string.+ Just {} -> do+ cv <- receiveVersion stream+ sv <- sendVersion stream+ pure (cv, sv)+ -- Start with sending local version and then wait for response.+ Nothing -> do+ cv <- sendVersion stream+ sv <- receiveVersion stream+ pure (cv, sv)+ xBytesSent <- newMVar 0+ xPacketsSent <- newMVar 0+ xBytesReceived <- newMVar 0+ xPacketsReceived <- newMVar 0+ xEncryptionCtx <- newMVar (plainEncryptionContext stream)+ xEncryptionCtxNext <- newMVar (plainEncryptionContext stream)+ xDecryptionCtx <- newMVar (plainDecryptionContext stream)+ xDecryptionCtxNext <- newMVar (plainDecryptionContext stream)+ xKexContinuation <- newEmptyMVar+ xSessionId <- newEmptyMVar+ xRekeyTime <- newMVar =<< getEpochSeconds+ xRekeySent <- newMVar 0+ xRekeyRcvd <- newMVar 0+ let env = TransportEnv+ { tStream = stream+ , tConfig = config+ , tAuthAgent = magent+ , tClientVersion = clientVersion+ , tServerVersion = serverVersion+ , tBytesSent = xBytesSent+ , tPacketsSent = xPacketsSent+ , tBytesReceived = xBytesReceived+ , tPacketsReceived = xPacketsReceived+ , tEncryptionCtx = xEncryptionCtx+ , tEncryptionCtxNext = xEncryptionCtxNext+ , tDecryptionCtx = xDecryptionCtx+ , tDecryptionCtxNext = xDecryptionCtxNext+ , tKexContinuation = xKexContinuation+ , tSessionId = xSessionId+ , tLastRekeyingTime = xRekeyTime+ , tLastRekeyingDataSent = xRekeySent+ , tLastRekeyingDataReceived = xRekeyRcvd+ }+ withRespondingExceptionHandler env $ do+ sessionId <- kexInitialize env+ a <- runWith env sessionId+ sendMessage env (Disconnected DisconnectByApplication mempty mempty)+ pure a+ where+ withFinalExceptionHandler :: IO (Either Disconnect a) -> IO (Either Disconnect a)+ withFinalExceptionHandler =+ handle $ \e -> maybe (throwIO e) (pure . Left) (fromException e)++ withRespondingExceptionHandler :: Transport -> IO a -> IO (Either Disconnect a)+ withRespondingExceptionHandler env run = (Right <$> run) `catch` \e-> case e of+ Disconnect _ DisconnectConnectionLost _ -> pure (Left e)+ Disconnect Local r (DisconnectMessage m) ->+ withAsync (threadDelay (1000*1000)) $ \thread1 ->+ withAsync (transportSendMessage env $ Disconnected r (SBS.toShort m) mempty) $ \thread2 -> do+ atomically $ void (waitCatchSTM thread1) <|> void (waitCatchSTM thread2)+ pure (Left e)+ _ -> pure (Left e)++transportSendMessage :: Encoding msg => Transport -> msg -> IO ()+transportSendMessage env msg =+ modifyMVar_ (tEncryptionCtx env) $ \sendEncrypted -> do+ onSend (tConfig env) (runPut payload)+ packets <- modifyMVar (tPacketsSent env) $ \p -> pure . (,p) $! p + 1+ sent <- sendEncrypted packets payload+ modifyMVar_ (tBytesSent env) $ \bytes -> pure $! bytes + fromIntegral sent+ if B.babLength payload == 1 && runGet (runPut payload) == Just KexNewKeys+ then readMVar (tEncryptionCtxNext env)+ else pure sendEncrypted+ where+ payload = put msg++transportReceiveMessage :: Encoding msg => Transport -> IO msg+transportReceiveMessage env = do+ raw <- transportReceiveRawMessage env+ maybe (throwIO $ exceptionUnexpectedMessage raw) pure (runGet raw)++transportReceiveRawMessage :: Transport -> IO BS.ByteString+transportReceiveRawMessage env =+ maybe (transportReceiveRawMessage env) pure =<< transportReceiveRawMessageMaybe env++transportReceiveRawMessageMaybe :: Transport -> IO (Maybe BS.ByteString)+transportReceiveRawMessageMaybe env =+ modifyMVar (tDecryptionCtx env) $ \decrypt -> do+ packets <- readMVar (tPacketsReceived env)+ plainText <- decrypt packets+ onReceive (tConfig env) plainText+ modifyMVar_ (tPacketsReceived env) $ \pacs -> pure $! pacs + 1+ case interpreter plainText of+ Just i -> i >> pure (decrypt, Nothing)+ Nothing -> case runGet plainText of+ Just KexNewKeys -> do+ (,Nothing) <$> readMVar (tDecryptionCtxNext env)+ Nothing -> pure (decrypt, Just plainText)+ where+ interpreter plainText = f i0 <|> f i1 <|> f i2 <|> f i3 <|> f i4 <|> f i5 <|> f i6+ where+ f i = i <$> runGet plainText+ i0 (Disconnected r m _) = throwIO $ Disconnect Remote r (DisconnectMessage $ SBS.fromShort m)+ i1 Debug {} = pure ()+ i2 Ignore {} = pure ()+ i3 Unimplemented {} = pure ()+ i4 x@KexInit {} = kexContinue env (Init x)+ i5 x@KexEcdhInit {} = kexContinue env (EcdhInit x)+ i6 x@KexEcdhReply {} = kexContinue env (EcdhReply x)++-------------------------------------------------------------------------------+-- CRYPTO ---------------------------------------------------------------------+-------------------------------------------------------------------------------++setChaCha20Poly1305Context :: Transport -> KeyStreams -> IO ()+setChaCha20Poly1305Context env@TransportEnv { tStream = stream, tAuthAgent = agent } (KeyStreams keys) = do+ modifyMVar_ (tEncryptionCtxNext env) $ const $ case agent of+ Just {} -> newChaCha20Poly1305EncryptionContext stream headerKeySC mainKeySC+ Nothing -> newChaCha20Poly1305EncryptionContext stream headerKeyCS mainKeyCS+ modifyMVar_ (tDecryptionCtxNext env) $ const $ case agent of+ Just {} -> newChaCha20Poly1305DecryptionContext stream headerKeyCS mainKeyCS+ Nothing -> newChaCha20Poly1305DecryptionContext stream headerKeySC mainKeySC+ where+ -- Derive the required encryption/decryption keys.+ -- The integrity keys etc. are not needed with chacha20.+ mainKeyCS : headerKeyCS : _ = keys "C"+ mainKeySC : headerKeySC : _ = keys "D"++-------------------------------------------------------------------------------+-- KEY EXCHANGE ---------------------------------------------------------------+-------------------------------------------------------------------------------++kexInitialize :: Transport -> IO SessionId+kexInitialize env@TransportEnv { tAuthAgent = agent } = do+ cookie <- newCookie+ putMVar (tKexContinuation env) $ case agent of+ Just aa -> kexServerContinuation env cookie aa+ Nothing -> kexClientContinuation env cookie+ kexTrigger env+ dontAcceptMessageUntilKexComplete+ where+ dontAcceptMessageUntilKexComplete = do+ transportReceiveRawMessageMaybe env >>= \case+ Just _ -> throwIO exceptionKexInvalidTransition+ Nothing -> tryReadMVar (tSessionId env) >>= \case+ Nothing -> dontAcceptMessageUntilKexComplete+ Just sid -> pure sid++kexTrigger :: Transport -> IO ()+kexTrigger env = do+ modifyMVar_ (tKexContinuation env) $ \(KexContinuation f) -> f Nothing++kexIfNecessary :: Transport -> IO ()+kexIfNecessary env = do+ kexRekeyingRequired env >>= \case+ False -> pure ()+ True -> do+ void $ swapMVar (tLastRekeyingTime env) =<< getEpochSeconds+ void $ swapMVar (tLastRekeyingDataSent env) =<< readMVar (tBytesSent env)+ void $ swapMVar (tLastRekeyingDataReceived env) =<< readMVar (tBytesReceived env)+ kexTrigger env++kexContinue :: Transport -> KexStep -> IO ()+kexContinue env step = do+ modifyMVar_ (tKexContinuation env) $ \(KexContinuation f) -> f (Just step)++-- NB: Uses transportSendMessage to avoid rekeying-loop+kexClientContinuation :: Transport -> Cookie -> KexContinuation+kexClientContinuation env cookie = clientKex0+ where+ clientKex0 :: KexContinuation+ clientKex0 = KexContinuation $ \case+ Nothing -> do+ transportSendMessage env cki+ pure (clientKex1 cki)+ Just (Init ski) -> do+ cekSecret <- Curve25519.generateSecretKey+ let cek = Curve25519.toPublic cekSecret+ transportSendMessage env cki+ transportSendMessage env (KexEcdhInit cek)+ pure (clientKex2 cki ski cek cekSecret)+ _ -> throwIO exceptionKexInvalidTransition+ where+ cki = kexInit (tConfig env) cookie++ clientKex1 :: KexInit -> KexContinuation+ clientKex1 cki = KexContinuation $ \case+ Nothing ->+ pure (clientKex1 cki)+ Just (Init ski) -> do+ cekSecret <- Curve25519.generateSecretKey+ let cek = Curve25519.toPublic cekSecret+ transportSendMessage env (KexEcdhInit cek)+ pure (clientKex2 cki ski cek cekSecret)+ _ -> throwIO exceptionKexInvalidTransition++ clientKex2 :: KexInit -> KexInit -> Curve25519.PublicKey -> Curve25519.SecretKey -> KexContinuation+ clientKex2 cki ski cek cekSecret = KexContinuation $ \case+ Nothing ->+ pure (clientKex2 cki ski cek cekSecret)+ Just (EcdhReply ecdhReply) -> do+ consumeEcdhReply cki ski cek cekSecret ecdhReply+ pure clientKex0+ _ -> throwIO exceptionKexInvalidTransition++ consumeEcdhReply :: KexInit -> KexInit -> Curve25519.PublicKey -> Curve25519.SecretKey -> KexEcdhReply -> IO ()+ consumeEcdhReply cki ski cek cekSecret ecdhReply = do+ kexAlgorithm <- kexCommonKexAlgorithm ski cki+ encAlgorithmCS <- kexCommonEncAlgorithm ski cki kexEncryptionAlgorithmsClientToServer+ encAlgorithmSC <- kexCommonEncAlgorithm ski cki kexEncryptionAlgorithmsServerToClient+ case (kexAlgorithm, encAlgorithmCS, encAlgorithmSC) of+ (Curve25519Sha256AtLibsshDotOrg, Chacha20Poly1305AtOpensshDotCom, Chacha20Poly1305AtOpensshDotCom) ->+ kexWithVerifiedSignature shk hash sig $ do+ sid <- trySetSessionId env (SessionId $ SBS.toShort $ BA.convert hash)+ setChaCha20Poly1305Context env $ kexKeys sec hash sid+ transportSendMessage env KexNewKeys+ where+ cv = tClientVersion env+ sv = tServerVersion env+ shk = kexServerHostKey ecdhReply+ sek = kexServerEphemeralKey ecdhReply+ sec = Curve25519.dh sek cekSecret+ sig = kexHashSignature ecdhReply+ hash = kexHash cv sv cki ski shk cek sek sec++-- NB: Uses transportSendMessage to avoid rekeying-loop+kexServerContinuation :: AuthAgent agent => Transport -> Cookie -> agent -> KexContinuation+kexServerContinuation env cookie authAgent = serverKex0+ where+ serverKex0 :: KexContinuation+ serverKex0 = KexContinuation $ \case+ Nothing -> do+ transportSendMessage env ski+ pure (serverKex1 ski)+ Just (Init cki) -> do+ transportSendMessage env ski+ pure (serverKex2 cki ski)+ _ -> throwIO exceptionKexInvalidTransition+ where+ ski = kexInit (tConfig env) cookie++ serverKex1 :: KexInit -> KexContinuation+ serverKex1 ski = KexContinuation $ \case+ Nothing-> do+ pure (serverKex1 ski)+ Just (Init cki) ->+ pure (serverKex2 cki ski)+ _ -> throwIO exceptionKexInvalidTransition++ serverKex2 :: KexInit -> KexInit -> KexContinuation+ serverKex2 cki ski = KexContinuation $ \case+ Nothing -> do+ pure (serverKex2 cki ski)+ Just (EcdhInit (KexEcdhInit cek)) -> do+ emitEcdhReply cki ski cek+ pure serverKex0+ _ -> throwIO exceptionKexInvalidTransition++ emitEcdhReply :: KexInit -> KexInit -> Curve25519.PublicKey -> IO ()+ emitEcdhReply cki ski cek = do+ kexAlgorithm <- kexCommonKexAlgorithm ski cki+ encAlgorithmCS <- kexCommonEncAlgorithm ski cki kexEncryptionAlgorithmsClientToServer+ encAlgorithmSC <- kexCommonEncAlgorithm ski cki kexEncryptionAlgorithmsServerToClient+ getPublicKeys authAgent >>= \case+ [] -> throwIO exceptionKexNoSignature+ shk:_ -> case (kexAlgorithm, encAlgorithmCS, encAlgorithmSC) of+ (Curve25519Sha256AtLibsshDotOrg, Chacha20Poly1305AtOpensshDotCom, Chacha20Poly1305AtOpensshDotCom) -> do+ sekSecret <- Curve25519.generateSecretKey+ let cv = tClientVersion env+ sv = tServerVersion env+ sek = Curve25519.toPublic sekSecret+ sec = Curve25519.dh cek sekSecret+ hash = kexHash cv sv cki ski shk cek sek sec+ sig <- maybe (throwIO exceptionKexNoSignature) pure =<< getSignature authAgent shk hash+ sid <- trySetSessionId env (SessionId $ SBS.toShort $ BA.convert hash)+ setChaCha20Poly1305Context env $ kexKeys sec hash sid+ transportSendMessage env (KexEcdhReply shk sek sig)+ transportSendMessage env KexNewKeys++kexCommonKexAlgorithm :: KexInit -> KexInit -> IO KeyExchangeAlgorithm+kexCommonKexAlgorithm ski cki = case kexKexAlgorithms cki `intersect` kexKexAlgorithms ski of+ (x:_)+ | x == name Curve25519Sha256AtLibsshDotOrg -> pure Curve25519Sha256AtLibsshDotOrg+ _ -> throwIO exceptionKexNoCommonKexAlgorithm++kexCommonEncAlgorithm :: KexInit -> KexInit -> (KexInit -> [Name]) -> IO EncryptionAlgorithm+kexCommonEncAlgorithm ski cki f = case f cki `intersect` f ski of+ (x:_)+ | x == name Chacha20Poly1305AtOpensshDotCom -> pure Chacha20Poly1305AtOpensshDotCom+ _ -> throwIO exceptionKexNoCommonEncryptionAlgorithm++kexInit :: TransportConfig -> Cookie -> KexInit+kexInit config cookie = KexInit+ { kexCookie = cookie+ , kexServerHostKeyAlgorithms = NEL.toList $ fmap name (serverHostKeyAlgorithms config)+ , kexKexAlgorithms = NEL.toList $ fmap name (kexAlgorithms config)+ , kexEncryptionAlgorithmsClientToServer = NEL.toList $ fmap name (encryptionAlgorithms config)+ , kexEncryptionAlgorithmsServerToClient = NEL.toList $ fmap name (encryptionAlgorithms config)+ , kexMacAlgorithmsClientToServer = []+ , kexMacAlgorithmsServerToClient = []+ , kexCompressionAlgorithmsClientToServer = [name None]+ , kexCompressionAlgorithmsServerToClient = [name None]+ , kexLanguagesClientToServer = []+ , kexLanguagesServerToClient = []+ , kexFirstPacketFollows = False+ }++kexRekeyingRequired :: Transport -> IO Bool+kexRekeyingRequired env = do+ tNow <- getEpochSeconds+ t <- readMVar (tLastRekeyingTime env)+ sNow <- readMVar (tBytesSent env)+ s <- readMVar (tLastRekeyingDataSent env)+ rNow <- readMVar (tBytesReceived env)+ r <- readMVar (tLastRekeyingDataReceived env)+ pure $ t + interval < tNow+ || s + threshold < sNow+ || r + threshold < rNow+ where+ -- For reasons of fool-proofness the rekeying interval/threshold+ -- shall never be greater than 1 hour or 1GB.+ -- NB: This is security critical as some algorithms like ChaCha20+ -- use the packet counter as nonce and an overflow will lead to+ -- nonce reuse!+ interval = min (maxTimeBeforeRekey $ tConfig env) 3600+ threshold = min (maxDataBeforeRekey $ tConfig env) (1024 * 1024 * 1024)++trySetSessionId :: Transport -> SessionId -> IO SessionId+trySetSessionId env sidDef =+ tryReadMVar (tSessionId env) >>= \case+ Nothing -> putMVar (tSessionId env) sidDef >> pure sidDef+ Just sid -> pure sid++kexHash ::+ Version -> -- client version string+ Version -> -- server version string+ KexInit -> -- client kex init msg+ KexInit -> -- server kex init msg+ PublicKey -> -- server host key+ Curve25519.PublicKey -> -- client ephemeral key+ Curve25519.PublicKey -> -- server ephemeral key+ Curve25519.DhSecret -> -- dh secret+ Hash.Digest Hash.SHA256+kexHash (Version vc) (Version vs) ic is ks qc qs k+ = Hash.hash $ runPut $+ putShortString vc <>+ putShortString vs <>+ B.word32BE (len ic) <>+ put ic <>+ B.word32BE (len is) <>+ put is <>+ put ks <>+ put qc <>+ put qs <>+ putAsMPInt k+ where+ len = fromIntegral . B.length . put++kexKeys :: Curve25519.DhSecret -> Hash.Digest Hash.SHA256 -> SessionId -> KeyStreams+kexKeys secret hash (SessionId sess) = KeyStreams $ \i -> BA.convert <$> k1 i : f [k1 i]+ where+ k1 i = Hash.hashFinalize $+ flip Hash.hashUpdate (SBS.fromShort sess) $+ Hash.hashUpdate st i :: Hash.Digest Hash.SHA256+ f ks = kx : f (ks ++ [kx])+ where+ kx = Hash.hashFinalize (foldl Hash.hashUpdate st ks)+ st =+ flip Hash.hashUpdate hash $+ Hash.hashUpdate Hash.hashInit (runPut $ putAsMPInt secret)++kexWithVerifiedSignature :: BA.ByteArrayAccess hash => PublicKey -> hash -> Signature -> IO a -> IO a+kexWithVerifiedSignature key hash sig action = case (key, sig) of+ (PublicKeyEd25519 k, SignatureEd25519 s)+ | Ed25519.verify k hash s -> action+ _ -> throwIO exceptionKexInvalidSignature++-------------------------------------------------------------------------------+-- UTIL -----------------------------------------------------------------------+-------------------------------------------------------------------------------++sendVersion :: (OutputStream stream) => stream -> IO Version+sendVersion stream = do+ sendAll stream $ runPut $ put version+ pure version++-- The maximum length of the version string is 255 chars including CR+LF.+-- The version string is usually short and transmitted within+-- a single TCP segment.+receiveVersion :: (InputStream stream) => stream -> IO Version+receiveVersion stream = do+ bs <- peek stream 255+ when (BS.null bs) e0+ case BS.elemIndex 0x0a bs of+ Nothing -> e1+ Just i -> maybe e1 pure . runGet =<< receive stream (i+1)+ where+ e0 = throwIO exceptionConnectionLost+ e1 = throwIO exceptionProtocolVersionNotSupported++getEpochSeconds :: IO Word64+getEpochSeconds = (`div` 1000000000) <$> getMonotonicTimeNSec
+ src/Network/SSH/Transport/Crypto.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+module Network.SSH.Transport.Crypto+ ( KeyStreams (..)+ , EncryptionContext+ , DecryptionContext+ , plainEncryptionContext+ , plainDecryptionContext+ , newChaCha20Poly1305EncryptionContext+ , newChaCha20Poly1305DecryptionContext+ )+where++import Control.Exception ( throwIO )+import Control.Monad ( when )+import Data.Bits ( unsafeShiftL, (.|.) )+import Data.Memory.PtrMethods ( memCopy, memConstEqual )+import Data.Monoid ( (<>) )+import Data.Word+import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.Ptr+import Foreign.Storable ( peekByteOff )+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS++import Network.SSH.Constants+import Network.SSH.Encoding+import Network.SSH.Exception+import Network.SSH.Stream+import qualified Network.SSH.Builder as B+import qualified Network.SSH.Transport.Crypto.ChaCha as ChaChaM+import qualified Network.SSH.Transport.Crypto.Poly1305 as Poly1305M++newtype KeyStreams = KeyStreams (BS.ByteString -> [BA.Bytes])++type DecryptionContext = Word64 -> IO BS.ByteString+type EncryptionContext = Word64 -> B.ByteArrayBuilder -> IO Int++plainEncryptionContext :: OutputStream stream => stream -> EncryptionContext+plainEncryptionContext stream _ payload = allocaBytes messageLen $ \ptr -> do+ B.copyToPtr messageBuilder ptr+ sendAllUnsafe stream (BA.MemView ptr messageLen)+ pure packetLen+ where+ payloadLen = B.babLength payload+ paddingLen = 16 - (headerLen + 1 + payloadLen) `mod` 8+ packetLen = 1 + payloadLen + paddingLen+ messageLen = headerLen + packetLen+ messageBuilder =+ B.word32BE (fromIntegral packetLen) <>+ putWord8 (fromIntegral paddingLen) <>+ payload <>+ B.zeroes (fromIntegral paddingLen)++plainDecryptionContext :: InputStream stream => stream -> DecryptionContext+plainDecryptionContext stream = const $ allocaBytes headerLen $ \headerPtr -> do+ receiveAllUnsafe stream (BA.MemView headerPtr headerLen)+ packetLen <- peekPacketLen headerPtr+ (bsLen, bs) <- BA.allocRet packetLen $ \bsPtr -> do+ receiveAllUnsafe stream (BA.MemView bsPtr packetLen)+ -- the first byte of the packet announces the number of padding bytes+ paddingLen <- fromIntegral <$> (peekByteOff bsPtr 0 :: IO Word8)+ -- RFC: the padding must be >=4 && <= 255+ when (paddingLen < minPaddingLen) (throwIO exceptionInvalidPacket)+ -- the padding must not exceed the packet length+ when (paddingLen + 1 >= packetLen) (throwIO exceptionInvalidPacket)+ -- return the length of the actual message without padding+ pure (packetLen - 1 - paddingLen)+ pure $! BS.take bsLen (BS.drop 1 bs)++newChaCha20Poly1305EncryptionContext ::+ (OutputStream stream, BA.ByteArrayAccess key) =>+ stream -> key -> key -> IO EncryptionContext+newChaCha20Poly1305EncryptionContext stream headerKey mainKey = do+ chaChaState <- ChaChaM.new+ polyState <- Poly1305M.new+ poly64 <- BA.alloc (2 * polyKeyLen) (const $ pure ()) :: IO BA.Bytes+ pure $ \packetsSent plainBuilder -> do+ let plainLen = B.babLength plainBuilder :: Int+ packetLen = 1 + plainLen + paddingLen+ paddingLen = paddingLenFor plainLen+ messageLen = headerLen + packetLen + macLen+ allocaBytes messageLen $ \messagePtr -> do+ let headerPtr = messagePtr+ macPtr = plusPtr packetPtr packetLen+ noncePtr = macPtr+ nonceView = BA.MemView noncePtr nonceLen+ packetPtr = plusPtr headerPtr headerLen+ packetBuilder = B.word8 (fromIntegral paddingLen) <> plainBuilder <> B.zeroes paddingLen+ -- Use the MAC area to store the nonce temporarily and+ -- safe an allocation (made up 8% of all allocations in benchmark)+ B.copyToPtr (B.word64BE packetsSent) noncePtr+ -- Header+ ChaChaM.initialize chaChaState chaChaRounds headerKey nonceView+ B.copyToPtr (B.word32BE $ fromIntegral packetLen) headerPtr+ ChaChaM.combineUnsafe chaChaState headerPtr headerPtr headerLen+ -- Packet+ B.copyToPtr packetBuilder packetPtr+ BA.withByteArray poly64 $ \poly64Ptr -> do+ ChaChaM.initialize chaChaState chaChaRounds mainKey nonceView+ ChaChaM.generateUnsafe chaChaState poly64Ptr (2 * polyKeyLen)+ ChaChaM.combineUnsafe chaChaState packetPtr packetPtr packetLen+ -- MAC+ Poly1305M.authUnsafe polyState+ (BA.MemView poly64Ptr polyKeyLen)+ (BA.MemView headerPtr $ headerLen + packetLen) macPtr+ sendAllUnsafe stream (BA.MemView messagePtr messageLen)+ pure messageLen++newChaCha20Poly1305DecryptionContext ::+ InputStream stream => BA.ByteArrayAccess key =>+ stream -> key -> key -> IO DecryptionContext+newChaCha20Poly1305DecryptionContext stream headerKey mainKey = do+ -- The mutable states for ChaCha and Poly1305 are allocated once+ -- per new decryption context. They are re-used for the decryption of+ -- subsequent messages. This is safe as long as the context is used by+ -- only one thread at a time.+ -- Both states get scrubbed on connection loss or after rekeying.+ -- The states do contain secret data while they are alive, but+ -- the ephemeral keys are stored in memory anyway.+ chaChaState <- ChaChaM.new+ polyState <- Poly1305M.new+ -- A piece of memory is allocated once for the lifetime of this+ -- decryption context. It does not contain confidential data and+ -- does not need to be scrubbed.+ temp <- BA.alloc+ (nonceLen + 2 * headerLen + macLen + 2 * polyKeyLen)+ (const $ pure ()) :: IO BA.Bytes+ pure $ \packetsReceived -> BA.withByteArray temp $ \ tempPtr -> do+ let noncePtr = tempPtr+ nonceView = BA.MemView noncePtr nonceLen+ headerCryptPtr = noncePtr `plusPtr` nonceLen+ headerPlainPtr = headerCryptPtr `plusPtr` headerLen+ macTrustedPtr = headerPlainPtr `plusPtr` headerLen+ polyKeyPtr = macTrustedPtr `plusPtr` macLen+ -- Poke the current nonce to the pre-allocated memory location (big-endian).+ -- It is the caller's responsibility to avoid nonce-reuse by timely rekeying.+ B.copyToPtr (B.word64BE packetsReceived) noncePtr+ -- Receive and decrypt the header (packet length).+ -- The encrypted packet header is also needed for integrity check (below).+ receiveAllUnsafe stream (BA.MemView headerCryptPtr headerLen)+ ChaChaM.initialize chaChaState chaChaRounds headerKey (BA.MemView noncePtr nonceLen)+ ChaChaM.combineUnsafe chaChaState headerPlainPtr headerCryptPtr headerLen+ packetLen <- peekPacketLen headerPlainPtr+ -- 64 (2*polyKeyLen) bytes shall be taken from the main key stream of which+ -- the first 32 are used for Poly1305. The other 32 bytes are+ -- not needed, but generated in order to get the correct ChaCha state.+ ChaChaM.initialize chaChaState chaChaRounds mainKey nonceView+ ChaChaM.generateUnsafe chaChaState polyKeyPtr (2 * polyKeyLen)+ -- Receive and authenticate the remaining packet.+ (bsLen, bs) <- BA.allocRet (headerLen + packetLen + macLen) $ \bsPtr -> do+ let packetPtr = bsPtr `plusPtr` headerLen+ macUntrustedPtr = packetPtr `plusPtr` packetLen+ -- Copy the ciphered header for inclusion in integrity check.+ memCopy bsPtr headerCryptPtr headerLen+ -- Receive the announced packet len + mac.+ receiveAllUnsafe stream+ (BA.MemView packetPtr (packetLen + macLen))+ Poly1305M.authUnsafe polyState+ (BA.MemView polyKeyPtr polyKeyLen) -- authentication key+ (BA.MemView bsPtr (headerLen + packetLen)) -- authenticated data+ macTrustedPtr -- mac destination+ -- CRITICAL: check the message integrity!+ memConstEqual macTrustedPtr macUntrustedPtr macLen >>= \case+ False -> throwIO exceptionMacError+ True -> do+ -- decrypt message in-place+ ChaChaM.combineUnsafe chaChaState packetPtr packetPtr packetLen+ -- the first byte of the packet announces the number of padding bytes+ paddingLen <- fromIntegral <$> (peekByteOff packetPtr 0 :: IO Word8)+ -- RFC: the padding must be >=4 && <= 255+ when (paddingLen < minPaddingLen) (throwIO exceptionInvalidPacket)+ -- the padding must not exceed the packet length+ when (paddingLen + 1 >= packetLen) (throwIO exceptionInvalidPacket)+ -- return the length of the actual message without padding+ pure (packetLen - 1 - paddingLen)+ -- The resulting message is a slice of the `BS.ByteString` (without padding and mac).+ -- The header, padding and mac are not confidential and remain in memory until the+ -- whole `BS.ByteString` gets collected. This saves allocations.+ pure $! BS.take bsLen (BS.drop (headerLen + 1) bs)++-------------------------------------------------------------------------------+-- UTIL+-------------------------------------------------------------------------------++headerLen, macLen, nonceLen, polyKeyLen, chaChaRounds, minPaddingLen :: Int+headerLen = 4+macLen = 16+nonceLen = 8+polyKeyLen = 32+chaChaRounds = 20+minPaddingLen = 4++paddingLenFor :: Int -> Int+paddingLenFor plainLen =+ if p < minPaddingLen then p + minBlockSize else p+ where+ minBlockSize = 8+ p = minBlockSize - ((1 + plainLen) `mod` minBlockSize)++receiveAllUnsafe :: InputStream stream => stream -> BA.MemView -> IO ()+receiveAllUnsafe stream v@(BA.MemView ptr n)+ | n <= 0 = pure ()+ | otherwise = do+ m <- receiveUnsafe stream v+ when (m <= 0) (throwIO exceptionConnectionLost)+ receiveAllUnsafe stream (BA.MemView (plusPtr ptr m) (n - m))++sendAllUnsafe :: OutputStream stream => stream -> BA.MemView -> IO ()+sendAllUnsafe stream v@(BA.MemView ptr n)+ | n <= 0 = pure ()+ | otherwise = do+ m <- sendUnsafe stream v+ when (m <= 0) (throwIO exceptionConnectionLost)+ sendAllUnsafe stream (BA.MemView (plusPtr ptr m) (n - m))++peekPacketLen :: Ptr Word8 -> IO Int+peekPacketLen ptr = do+ packetLen <- f+ <$> (peekByteOff ptr 0 :: IO Word8)+ <*> (peekByteOff ptr 1 :: IO Word8)+ <*> (peekByteOff ptr 2 :: IO Word8)+ <*> (peekByteOff ptr 3 :: IO Word8)+ -- Any manipulation of the ciphered packet header will+ -- (with extreme likelyhood) result in a huge designated packet size+ -- after decryption. In this case, do not try to receive this packet+ -- and allocate memory for it but throw an exception and disconnect+ -- before even trying to authenticate the packet.+ when (packetLen > fromIntegral maxPacketLength) (throwIO exceptionMacError)+ -- Packet always consists of at least padding size byte, 1 byte payload+ -- and 4 bytes padding.+ when (packetLen < 1 + 1 + 4) (throwIO exceptionMacError)+ pure packetLen+ where+ f h0 h1 h2 h3 = g h0 24 .|. g h1 16 .|. g h2 8 .|. g h3 0+ g w8 = unsafeShiftL (fromIntegral w8)
+ src/Network/SSH/Transport/Crypto/ChaCha.hs view
@@ -0,0 +1,55 @@+-- |+-- Module : Network.SSH.Transport.Crypto.ChaCha+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : good+--+-- ChaCha implementation+--+-- This module is a copy taken from the cryptonite library and extended by mutable state+-- in order to reduce memory allocations when performing the+-- same operation again and again. Remove when cryptonite offers this funtionality!+--+module Network.SSH.Transport.Crypto.ChaCha where++import Data.Word+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)+import qualified Data.ByteArray as B+import Foreign.Ptr+import Foreign.C.Types++newtype MutableState = MutableState ScrubbedBytes++new :: IO MutableState+new = MutableState <$> B.alloc 132 (const $ pure ())++initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)+ => MutableState -> Int -> key -> nonce -> IO ()+initialize (MutableState state) rounds key nonce =+ B.withByteArray state $ \statePtr ->+ B.withByteArray nonce $ \noncePtr ->+ B.withByteArray key $ \keyPtr ->+ ccryptonite_chacha_init statePtr (fromIntegral rounds) keyLen keyPtr nonceLen noncePtr+ where+ keyLen = B.length key+ nonceLen = B.length nonce++generateUnsafe :: MutableState -> Ptr Word8 -> Int -> IO ()+generateUnsafe (MutableState state) dstPtr len =+ B.withByteArray state $ \statePtr ->+ ccryptonite_chacha_generate dstPtr statePtr (fromIntegral len)++combineUnsafe :: MutableState -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()+combineUnsafe (MutableState state) dstPtr srcPtr len =+ B.withByteArray state $ \statePtr ->+ ccryptonite_chacha_combine dstPtr statePtr srcPtr (fromIntegral len)++foreign import ccall unsafe "cryptonite_chacha_init"+ ccryptonite_chacha_init :: Ptr state -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()++foreign import ccall unsafe "cryptonite_chacha_combine"+ ccryptonite_chacha_combine :: Ptr Word8 -> Ptr state -> Ptr Word8 -> CUInt -> IO ()++foreign import ccall unsafe "cryptonite_chacha_generate"+ ccryptonite_chacha_generate :: Ptr Word8 -> Ptr state -> CUInt -> IO ()
+ src/Network/SSH/Transport/Crypto/Poly1305.hs view
@@ -0,0 +1,43 @@+-- |+-- Module : Network.SSH.Transport.Crypto.Poly1305+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Poly1305 implementation+--+-- This module is a copy taken from the cryptonite library and extended by mutable state+-- in order to reduce memory allocations when performing the+-- same operation again and again. Remove when cryptonite offers this funtionality!+--+module Network.SSH.Transport.Crypto.Poly1305 where++import Data.Word+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)+import qualified Data.ByteArray as B+import Foreign.Ptr+import Foreign.C.Types++newtype MutableState = MutableState ScrubbedBytes++new :: IO MutableState+new = MutableState <$> B.alloc 84 (const $ pure ())++authUnsafe :: (ByteArrayAccess key, ByteArrayAccess dat) => MutableState -> key -> dat -> Ptr Word8 -> IO ()+authUnsafe (MutableState ctx) key d dstPtr =+ B.withByteArray ctx $ \ctxPtr ->+ B.withByteArray key $ \keyPtr -> do+ c_poly1305_init (castPtr ctxPtr) keyPtr+ B.withByteArray d $ \dataPtr ->+ c_poly1305_update (castPtr ctxPtr) dataPtr (fromIntegral $ B.length d)+ c_poly1305_finalize dstPtr (castPtr ctxPtr)++foreign import ccall unsafe "cryptonite_poly1305.h cryptonite_poly1305_init"+ c_poly1305_init :: Ptr state -> Ptr Word8 -> IO ()++foreign import ccall unsafe "cryptonite_poly1305.h cryptonite_poly1305_update"+ c_poly1305_update :: Ptr state -> Ptr Word8 -> CUInt -> IO ()++foreign import ccall unsafe "cryptonite_poly1305.h cryptonite_poly1305_finalize"+ c_poly1305_finalize :: Ptr Word8 -> Ptr state -> IO ()
+ test/Spec.hs view
@@ -0,0 +1,22 @@+import Test.Tasty++import qualified Spec.Algorithms+import qualified Spec.Key+import qualified Spec.Message+import qualified Spec.Server+import qualified Spec.Server.Service.Connection+import qualified Spec.Server.Service.UserAuth+import qualified Spec.Transport+import qualified Spec.TStreamingQueue++main :: IO ()+main = defaultMain $ testGroup "Network.SSH"+ [ Spec.Algorithms.tests+ , Spec.Key.tests+ , Spec.Message.tests+ , Spec.Server.tests+ , Spec.Server.Service.Connection.tests+ , Spec.Server.Service.UserAuth.tests+ , Spec.Transport.tests+ , Spec.TStreamingQueue.tests+ ]
+ test/Spec/Algorithms.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Algorithms ( tests ) where++import Test.Tasty+import Test.Tasty.HUnit++import Network.SSH.Internal++tests :: TestTree+tests = testGroup "Network.SSH.Algorithms"+ [ testGroup "HostKeyAlgorithm"+ [ testHostKeyAlgorithm01+ , testHostKeyAlgorithm02+ , testHostKeyAlgorithm03+ ]+ , testGroup "KeyExchangeAlgorithm"+ [ testKeyExchangeAlgorithm01+ , testKeyExchangeAlgorithm02+ , testKeyExchangeAlgorithm03+ ]+ , testGroup "EncryptionAlgorithm"+ [ testEncryptionAlgorithm01+ , testEncryptionAlgorithm02+ , testEncryptionAlgorithm03+ ]+ , testGroup "CompressionAlgorithm"+ [ testCompressionAlgorithm01+ , testCompressionAlgorithm02+ , testCompressionAlgorithm03+ ]+ ]++testHostKeyAlgorithm01 :: TestTree+testHostKeyAlgorithm01 = testCase "Eq" $+ assertEqual "==" SshEd25519 SshEd25519++testHostKeyAlgorithm02 :: TestTree+testHostKeyAlgorithm02 = testCase "Show" $+ assertEqual "show" "SshEd25519" (show SshEd25519)++testHostKeyAlgorithm03 :: TestTree+testHostKeyAlgorithm03 = testCase "HasName" $+ assertEqual "nName" "ssh-ed25519" (name SshEd25519)++testKeyExchangeAlgorithm01 :: TestTree+testKeyExchangeAlgorithm01 = testCase "Eq" $+ assertEqual "==" Curve25519Sha256AtLibsshDotOrg Curve25519Sha256AtLibsshDotOrg++testKeyExchangeAlgorithm02 :: TestTree+testKeyExchangeAlgorithm02 = testCase "Show" $+ assertEqual "show" "Curve25519Sha256AtLibsshDotOrg" (show Curve25519Sha256AtLibsshDotOrg)++testKeyExchangeAlgorithm03 :: TestTree+testKeyExchangeAlgorithm03 = testCase "HasName" $+ assertEqual "name" "curve25519-sha256@libssh.org" (name Curve25519Sha256AtLibsshDotOrg)++testEncryptionAlgorithm01 :: TestTree+testEncryptionAlgorithm01 = testCase "Eq" $+ assertEqual "==" Chacha20Poly1305AtOpensshDotCom Chacha20Poly1305AtOpensshDotCom++testEncryptionAlgorithm02 :: TestTree+testEncryptionAlgorithm02 = testCase "Show" $+ assertEqual "show" "Chacha20Poly1305AtOpensshDotCom" (show Chacha20Poly1305AtOpensshDotCom)++testEncryptionAlgorithm03 :: TestTree+testEncryptionAlgorithm03 = testCase "HasName" $+ assertEqual "name" "chacha20-poly1305@openssh.com" (name Chacha20Poly1305AtOpensshDotCom)++testCompressionAlgorithm01 :: TestTree+testCompressionAlgorithm01 = testCase "Eq" $+ assertEqual "==" None None++testCompressionAlgorithm02 :: TestTree+testCompressionAlgorithm02 = testCase "Show" $+ assertEqual "show" "None" (show None)++testCompressionAlgorithm03 :: TestTree+testCompressionAlgorithm03 = testCase "HasName" $+ assertEqual "name" "none" (name None)
+ test/Spec/Key.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Key ( tests ) where++import Control.Monad (when, zipWithM_)+import Crypto.Error+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Data.ByteString as BS++import Network.SSH.Internal++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "Network.SSH.Key"+ [ testDecodePrivatePrivateKeyFile+ ]++testDecodePrivatePrivateKeyFile :: TestTree+testDecodePrivatePrivateKeyFile = testGroup "decodePrivateKeyFile"+ [ testCase "none, none, ed25519" $+ testPrivateKeyFileParser unencryptedEd25519PrivateKeyFile+ -- Re-enable these tests if cryptonite includes the necessary+ -- changes to support encrypted key files.+ -- , testCase "bcrypt, aes256-cbc, ed25519" $+ -- testPrivateKeyFileParser bcryptAes256CbcEd25519PrivateKeyFile+ -- , testCase "bcrypt, aes256-ctr, ed25519" $+ -- testPrivateKeyFileParser bcryptAes256CtrEd25519PrivateKeyFile+ ]++testPrivateKeyFileParser :: (BS.ByteString, BS.ByteString, [(KeyPair, BS.ByteString)]) -> Assertion+testPrivateKeyFileParser (file, passphrase, keys) = do+ keys' <- decodePrivateKeyFile passphrase file+ when (length keys /= length keys') (assertFailure "wrong number of keys")+ zipWithM_ f keys keys'+ where+ f (KeyPairEd25519 p0 s0, c0) (KeyPairEd25519 p1 s1, c1) = do+ c0 @=? c1+ p0 @=? p1+ s0 @=? s1++unencryptedEd25519PrivateKeyFile :: (BS.ByteString, BS.ByteString, [(KeyPair, BS.ByteString)])+unencryptedEd25519PrivateKeyFile = (file, passphrase, [(KeyPairEd25519 public secret, "lpetersen@gallifrey")])+ where+ file = mconcat+ [ "-----BEGIN OPENSSH PRIVATE KEY-----\n"+ , "b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAMwAAAAtzc2gtZW\n"+ , "QyNTUxOQAAACBqcmku9hX4rPO7yC339uHazvqRD/aMgyjq/4exCKGATwAAAJjG8+5kxvPu\n"+ , "ZAAAAAtzc2gtZWQyNTUxOQAAACBqcmku9hX4rPO7yC339uHazvqRD/aMgyjq/4exCKGATw\n"+ , "AAAEBPNkrjYh+rbEcLJEX5w63fHuNLuiw9hJOrOaZRxGqDgWpyaS72Ffis87vILff24drO\n"+ , "+pEP9oyDKOr/h7EIoYBPAAAAE2xwZXRlcnNlbkBnYWxsaWZyZXkBAg==\n"+ , "-----END OPENSSH PRIVATE KEY-----\n"+ ]+ passphrase = ""+ CryptoPassed public = Ed25519.publicKey+ ("jri.\246\NAK\248\172\243\187\200-\247\246\225\218\206\250\145\SI\246\140\131(\234\255\135\177\b\161\128O" :: BS.ByteString)+ CryptoPassed secret = Ed25519.secretKey+ ("O6J\227b\US\171lG\v$E\249\195\173\223\RS\227K\186,=\132\147\171\&9\166Q\196j\131\129" :: BS.ByteString)++bcryptAes256CbcEd25519PrivateKeyFile :: (BS.ByteString, BS.ByteString, [(KeyPair, BS.ByteString)])+bcryptAes256CbcEd25519PrivateKeyFile = (file, passphrase, [(KeyPairEd25519 public secret, "comment1234")])+ where+ file = mconcat+ [ "-----BEGIN OPENSSH PRIVATE KEY-----\n"+ , "b3BlbnNzaC1rZXktdjEAAAAACmFlczI1Ni1jYmMAAAAGYmNyeXB0AAAAGAAAABDTDrNhkD\n"+ , "C7tfLO0v9m/nKAAAAAEAAAAAEAAAAzAAAAC3NzaC1lZDI1NTE5AAAAIN/nNM4GQNcrKZv8\n"+ , "MkQ+oGPejLoeKwLqNobcoa1qiUSMAAAAkOeGAujVwOa7cGA/oHLDdCsGfpv1Mwh89GlPLE\n"+ , "OKztJLfh9htiGRpX3q5xkTvn+8KDIuB8ZO9G2YzVV3AD2Z40foUrgo6glZeLSxXBRDpOKA\n"+ , "qcaKRNOJ0iARTiaeLL3Dcmi3nEk07ZpAvlFuEKBuNkmgscooThDMBSzOHFcvMsWOW09zUY\n"+ , "duwiqJ+kj5LYPRzA==\n"+ , "-----END OPENSSH PRIVATE KEY-----\n"+ ]+ passphrase = "passphrase"+ CryptoPassed public = Ed25519.publicKey+ ("\223\231\&4\206\ACK@\215+)\155\252\&2D>\160c\222\140\186\RS+\STX\234\&6\134\220\161\173j\137D\140" :: BS.ByteString)+ CryptoPassed secret = Ed25519.secretKey+ ("\221\209\ETB\224\"M\133\169z\215H\158\DEL\134\&2n\155,q\227\229\251\183A+}\DC4qU\156\209n" :: BS.ByteString)++bcryptAes256CtrEd25519PrivateKeyFile :: (BS.ByteString, BS.ByteString, [(KeyPair, BS.ByteString)])+bcryptAes256CtrEd25519PrivateKeyFile = (file, passphrase, [(KeyPairEd25519 public secret, "comment")])+ where+ file = mconcat+ [ "-----BEGIN OPENSSH PRIVATE KEY-----\n"+ , "b3BlbnNzaC1rZXktdjEAAAAACmFlczI1Ni1jdHIAAAAGYmNyeXB0AAAAGAAAABD5G4pbe5\n"+ , "Cu7Ih7QIieGudEAAAAEAAAAAEAAAAzAAAAC3NzaC1lZDI1NTE5AAAAILC9T3iuRUd4wxSf\n"+ , "22Ox0NyYSn378Pay6AHmXnxw+cLwAAAAkKiDNwjUUzANV7bMOF4OP8/X9oP7F2qDqK+V9a\n"+ , "fSQKxcXviOmiKt4YLI4L/rPvfuaLMqwbwExrNS/pJMRclpgfR2TGwRYXWKyHOcDGJLHLyg\n"+ , "qUHIfaVjrlzYhlxrgLXI4hlTG5p0VTH/uMXEPi/vP+jfcL3+WrWjq40qfGPu3UnWD9Rx9r\n"+ , "mOKIl1w+TlqDKsSw==\n"+ , "-----END OPENSSH PRIVATE KEY-----\n"+ ]+ passphrase = "foobar"+ CryptoPassed public = Ed25519.publicKey+ ("\176\189Ox\174EGx\195\DC4\159\219c\177\208\220\152J}\251\240\246\178\232\SOH\230^|p\249\194\240" :: BS.ByteString)+ CryptoPassed secret = Ed25519.secretKey+ ("\191\149=\220c[\ETBp3\168\136\173~ \231\204}s\136T\230F\175Q\253p\162\145\a~\152=" :: BS.ByteString)+
+ test/Spec/Message.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+module Spec.Message ( tests ) where++import Crypto.Error+import qualified Crypto.PubKey.Curve25519 as Curve25519+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.RSA as RSA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import System.Exit++import Test.Tasty+import Test.Tasty.QuickCheck as QC++import Network.SSH.Internal++tests :: TestTree+tests = testGroup "Network.SSH.Message"+ [ testParserIdentity+ ]++testParserIdentity :: TestTree+testParserIdentity = testGroup "put . get == id"+ [ QC.testProperty ":: Disconnected" (parserIdentity :: Disconnected -> Property)+ , QC.testProperty ":: DisconnectReason" (parserIdentity :: DisconnectReason -> Property)+ , QC.testProperty ":: Ignore" (parserIdentity :: Ignore -> Property)+ , QC.testProperty ":: Unimplemented" (parserIdentity :: Unimplemented -> Property)+ , QC.testProperty ":: Debug" (parserIdentity :: Debug -> Property)+ , QC.testProperty ":: ServiceRequest" (parserIdentity :: ServiceRequest -> Property)+ , QC.testProperty ":: ServiceAccept" (parserIdentity :: ServiceAccept -> Property)+ , QC.testProperty ":: KexInit" (parserIdentity :: KexInit -> Property)+ , QC.testProperty ":: KexNewKeys" (parserIdentity :: KexNewKeys -> Property)+ , QC.testProperty ":: KexEcdhInit" (parserIdentity :: KexEcdhInit -> Property)+ , QC.testProperty ":: KexEcdhReply" (parserIdentity :: KexEcdhReply -> Property)+ , QC.testProperty ":: UserAuthRequest" (parserIdentity :: UserAuthRequest -> Property)+ , QC.testProperty ":: UserAuthFailure" (parserIdentity :: UserAuthFailure -> Property)+ , QC.testProperty ":: UserAuthSuccess" (parserIdentity :: UserAuthSuccess -> Property)+ , QC.testProperty ":: UserAuthBanner" (parserIdentity :: UserAuthBanner -> Property)+ , QC.testProperty ":: UserAuthPublicKeyOk" (parserIdentity :: UserAuthPublicKeyOk -> Property)+ , QC.testProperty ":: ChannelOpen" (parserIdentity :: ChannelOpen -> Property)+ , QC.testProperty ":: ChannelOpenConfirmation" (parserIdentity :: ChannelOpenConfirmation -> Property)+ , QC.testProperty ":: ChannelOpenFailure" (parserIdentity :: ChannelOpenFailure -> Property)+ , QC.testProperty ":: ChannelOpenFailureReason" (parserIdentity :: ChannelOpenFailureReason -> Property)+ , QC.testProperty ":: ChannelWindowAdjust" (parserIdentity :: ChannelWindowAdjust -> Property)+ , QC.testProperty ":: ChannelData" (parserIdentity :: ChannelData -> Property)+ , QC.testProperty ":: ChannelExtendedData" (parserIdentity :: ChannelExtendedData -> Property)+ , QC.testProperty ":: ChannelEof" (parserIdentity :: ChannelEof -> Property)+ , QC.testProperty ":: ChannelClose" (parserIdentity :: ChannelClose -> Property)+ , QC.testProperty ":: ChannelRequest" (parserIdentity :: ChannelRequest -> Property)+ , QC.testProperty ":: ChannelRequestEnv" (parserIdentity :: ChannelRequestEnv -> Property)+ , QC.testProperty ":: ChannelRequestPty" (parserIdentity :: ChannelRequestPty -> Property)+ , QC.testProperty ":: ChannelRequestWindowChange" (parserIdentity :: ChannelRequestWindowChange -> Property)+ , QC.testProperty ":: ChannelRequestShell" (parserIdentity :: ChannelRequestShell -> Property)+ , QC.testProperty ":: ChannelRequestExec" (parserIdentity :: ChannelRequestExec -> Property)+ , QC.testProperty ":: ChannelRequestSignal" (parserIdentity :: ChannelRequestSignal -> Property)+ , QC.testProperty ":: ChannelRequestExitSignal" (parserIdentity :: ChannelRequestExitSignal -> Property)+ , QC.testProperty ":: ChannelRequestExitStatus" (parserIdentity :: ChannelRequestExitStatus -> Property)+ , QC.testProperty ":: ChannelSuccess" (parserIdentity :: ChannelSuccess -> Property)+ , QC.testProperty ":: ChannelFailure" (parserIdentity :: ChannelFailure -> Property)+ , QC.testProperty ":: Version" (parserIdentity :: Version -> Property)+ , QC.testProperty ":: PublicKey" (parserIdentity :: PublicKey -> Property)+ , QC.testProperty ":: Signature" (parserIdentity :: Signature -> Property)+ , QC.testProperty ":: Message" (parserIdentity :: Message -> Property)+ ]+ where+ parserIdentity :: (Encoding a, Eq a, Show a) => a -> Property+ parserIdentity x = Just x === runGet (runPut $ put x)++instance Arbitrary BS.ByteString where+ arbitrary = elements+ [ ""+ , "1"+ , "1234567890"+ ]++instance Arbitrary SBS.ShortByteString where+ arbitrary = elements+ [ ""+ , "1"+ , "1234567890"+ ]++instance Arbitrary Command where+ arbitrary = elements+ [ Command ""+ , Command "foobar --xyz fasel"+ , Command "ls"+ ]++instance Arbitrary Message where+ arbitrary = oneof+ [ MsgDisconnect <$> arbitrary+ , MsgIgnore <$> arbitrary+ , MsgUnimplemented <$> arbitrary+ , MsgDebug <$> arbitrary+ , MsgServiceRequest <$> arbitrary+ , MsgServiceAccept <$> arbitrary+ , MsgKexInit <$> arbitrary+ , MsgKexNewKeys <$> arbitrary+ , MsgKexEcdhInit <$> arbitrary+ , MsgKexEcdhReply <$> arbitrary+ , MsgUserAuthRequest <$> arbitrary+ , MsgUserAuthFailure <$> arbitrary+ , MsgUserAuthSuccess <$> arbitrary+ , MsgUserAuthBanner <$> arbitrary+ , MsgUserAuthPublicKeyOk <$> arbitrary+ , MsgChannelOpen <$> arbitrary+ , MsgChannelOpenConfirmation <$> arbitrary+ , MsgChannelOpenFailure <$> arbitrary+ , MsgChannelData <$> arbitrary+ , MsgChannelExtendedData <$> arbitrary+ , MsgChannelEof <$> arbitrary+ , MsgChannelClose <$> arbitrary+ , MsgChannelRequest <$> arbitrary+ , MsgChannelSuccess <$> arbitrary+ , MsgChannelFailure <$> arbitrary+ , MsgUnknown <$> elements [ 128, 255 ]+ ]++instance Arbitrary Disconnected where+ arbitrary = Disconnected <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary DisconnectReason where+ arbitrary = elements+ [ DisconnectHostNotAllowedToConnect+ , DisconnectProtocolError+ , DisconnectKeyExchangeFailed+ , DisconnectReserved+ , DisconnectMacError+ , DisconnectCompressionError+ , DisconnectServiceNotAvailable+ , DisconnectProtocolVersionNotSupported+ , DisconnectHostKeyNotVerifiable+ , DisconnectConnectionLost+ , DisconnectByApplication+ , DisconnectTooManyConnection+ , DisconnectAuthCancelledByUser+ , DisconnectNoMoreAuthMethodsAvailable+ , DisconnectIllegalUsername+ ]++instance Arbitrary Ignore where+ arbitrary = pure Ignore++instance Arbitrary Unimplemented where+ arbitrary = Unimplemented <$> arbitrary++instance Arbitrary Debug where+ arbitrary = Debug+ <$> arbitrary+ <*> elements [ "", "debug message", "debug message containing\n linefeeds\n\r" ]+ <*> elements [ "", "de_DE", "en_US" ]++instance Arbitrary ServiceRequest where+ arbitrary = ServiceRequest <$> arbitrary++instance Arbitrary ServiceAccept where+ arbitrary = ServiceAccept <$> arbitrary++instance Arbitrary KexInit where+ arbitrary = KexInit <$> arbitrary <*> nameList <*> nameList <*> nameList+ <*> nameList <*> nameList <*> nameList <*> nameList+ <*> nameList <*> nameList <*> nameList <*> arbitrary+ where+ nameList = elements [ [], ["abc"], ["abc","def"] ]++instance Arbitrary KexNewKeys where+ arbitrary = pure KexNewKeys++instance Arbitrary KexEcdhInit where+ arbitrary = KexEcdhInit <$> arbitrary++instance Arbitrary KexEcdhReply where+ arbitrary = KexEcdhReply <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary UserAuthRequest where+ arbitrary = UserAuthRequest <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary UserAuthFailure where+ arbitrary = UserAuthFailure <$> arbitrary <*> arbitrary++instance Arbitrary UserAuthSuccess where+ arbitrary = pure UserAuthSuccess++instance Arbitrary UserAuthBanner where+ arbitrary = UserAuthBanner <$> arbitrary <*> arbitrary++instance Arbitrary UserAuthPublicKeyOk where+ arbitrary = UserAuthPublicKeyOk <$> arbitrary++instance Arbitrary ChannelOpen where+ arbitrary = ChannelOpen <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelOpenType where+ arbitrary = elements+ [ ChannelOpenSession+ , ChannelOpenDirectTcpIp "localhost" 8080 "10.0.0.1" 73594+ , ChannelOpenOther (ChannelType "other")+ ]++instance Arbitrary ChannelOpenConfirmation where+ arbitrary = ChannelOpenConfirmation <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelOpenFailure where+ arbitrary = ChannelOpenFailure <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelOpenFailureReason where+ arbitrary = elements+ [ ChannelOpenAdministrativelyProhibited+ , ChannelOpenConnectFailed+ , ChannelOpenUnknownChannelType+ , ChannelOpenResourceShortage+ ]++instance Arbitrary ChannelWindowAdjust where+ arbitrary = ChannelWindowAdjust <$> arbitrary <*> arbitrary++instance Arbitrary ChannelData where+ arbitrary = ChannelData <$> arbitrary <*> elements+ [ ""+ , "abc"+ , "asdhaskdjhaskhdkjahsdkjahsdkjhasdkjahdkj"+ ]++instance Arbitrary ChannelExtendedData where+ arbitrary = ChannelExtendedData <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelEof where+ arbitrary = ChannelEof <$> arbitrary++instance Arbitrary ChannelClose where+ arbitrary = ChannelClose <$> arbitrary++instance Arbitrary ChannelRequest where+ arbitrary = ChannelRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelRequestEnv where+ arbitrary = ChannelRequestEnv <$> arbitrary <*> arbitrary++instance Arbitrary ChannelRequestPty where+ arbitrary = ChannelRequestPty <$> arbitrary++instance Arbitrary ChannelRequestWindowChange where+ arbitrary = ChannelRequestWindowChange <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelRequestShell where+ arbitrary = pure ChannelRequestShell++instance Arbitrary ChannelRequestExec where+ arbitrary = ChannelRequestExec <$> arbitrary++instance Arbitrary ChannelRequestSignal where+ arbitrary = ChannelRequestSignal <$> arbitrary++instance Arbitrary ChannelRequestExitStatus where+ arbitrary = ChannelRequestExitStatus <$> (arbitrary >>= \i-> pure $ if i == 0 then ExitSuccess else ExitFailure (abs i))++instance Arbitrary ChannelRequestExitSignal where+ arbitrary = ChannelRequestExitSignal <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ChannelSuccess where+ arbitrary = ChannelSuccess <$> arbitrary++instance Arbitrary ChannelFailure where+ arbitrary = ChannelFailure <$> arbitrary++instance Arbitrary Version where+ arbitrary = elements+ [ Version "SSH-2.0-OpenSSH_4.3"+ , Version "SSH-2.0-hssh_0.1"+ ]++instance Arbitrary PtySettings where+ arbitrary = PtySettings+ <$> elements [ "xterm", "urxvt-unicode", "urxvt-unicode-color256" ]+ <*> elements [ 80 ]+ <*> elements [ 24 ]+ <*> elements [ 640 ]+ <*> elements [ 480 ]+ <*> elements [ "\129\NUL\NUL\150\NUL\128\NUL\NUL\150\NUL\SOH\NUL\NUL\NUL\ETX\STX\NUL\NUL\NUL\FS\ETX\NUL\NUL\NUL\DEL\EOT\NUL\NUL\NUL\NAK\ENQ\NUL\NUL\NUL\EOT\ACK\NUL\NUL\NUL\NUL\a\NUL\NUL\NUL\NUL\b\NUL\NUL\NUL\DC1\t\NUL\NUL\NUL\DC3\n\NUL\NUL\NUL\SUB\f\NUL\NUL\NUL\DC2\r\NUL\NUL\NUL\ETB\SO\NUL\NUL\NUL\SYN\DC2\NUL\NUL\NUL\SI\RS\NUL\NUL\NUL\SOH\US\NUL\NUL\NUL\NUL \NUL\NUL\NUL\NUL!\NUL\NUL\NUL\NUL\"\NUL\NUL\NUL\NUL#\NUL\NUL\NUL\NUL$\NUL\NUL\NUL\SOH%\NUL\NUL\NUL\NUL&\NUL\NUL\NUL\SOH'\NUL\NUL\NUL\NUL(\NUL\NUL\NUL\NUL)\NUL\NUL\NUL\SOH*\NUL\NUL\NUL\SOH2\NUL\NUL\NUL\SOH3\NUL\NUL\NUL\SOH4\NUL\NUL\NUL\NUL5\NUL\NUL\NUL\SOH6\NUL\NUL\NUL\SOH7\NUL\NUL\NUL\SOH8\NUL\NUL\NUL\NUL9\NUL\NUL\NUL\NUL:\NUL\NUL\NUL\NUL;\NUL\NUL\NUL\SOH<\NUL\NUL\NUL\SOH=\NUL\NUL\NUL\SOH>\NUL\NUL\NUL\NULF\NUL\NUL\NUL\SOHG\NUL\NUL\NUL\NULH\NUL\NUL\NUL\SOHI\NUL\NUL\NUL\NULJ\NUL\NUL\NUL\NULK\NUL\NUL\NUL\NULZ\NUL\NUL\NUL\SOH[\NUL\NUL\NUL\SOH\\\NUL\NUL\NUL\NUL]\NUL\NUL\NUL\NUL\NUL" ]++deriving instance Arbitrary ChannelId+deriving instance Arbitrary ChannelType++instance Arbitrary Cookie where+ arbitrary = pure nilCookie++instance Arbitrary Password where+ arbitrary = elements $ fmap Password+ [ "1234567890"+ ]++instance Arbitrary AuthMethod where+ arbitrary = oneof+ [ pure AuthNone+ , pure AuthHostBased+ , AuthPassword <$> arbitrary+ , AuthPublicKey <$> arbitrary <*> arbitrary+ ]++instance Arbitrary Name where+ arbitrary = elements [ "abc" ]++instance Arbitrary PublicKey where+ arbitrary = oneof+ [ PublicKeyEd25519 <$> x1+ , PublicKeyRSA <$> x2+ , PublicKeyOther <$> x3+ ]+ where+ x1 = pure $ case Ed25519.publicKey ("$\149\229m\164\ETB\GSA\ESC\185ThTc8\212\219\158\249\CAN\202\245\133\140a\bZQ\v\234\247x" :: BS.ByteString) of+ CryptoPassed pk -> pk+ CryptoFailed _ -> undefined+ x2 = pure $ RSA.PublicKey 24 65537 2834792+ x3 = pure "PUBLIC_KEY_OTHER"++instance Arbitrary Signature where+ arbitrary = oneof+ [ SignatureEd25519 <$> x1+ , SignatureRSA <$> x2+ , pure (SignatureOther "ssh-other")+ ]+ where+ x1 = pure $ case Ed25519.signature ("\169\150V0\235\151\ENQ\149w\DC1\172wKV]W|\b\ETB\f@\158\178\254\158\168\v>\180&\164D\DELF\204\133p\186\195(\169\177\144\168\STX\DC2\153!B\252\154o\251\230\154\164T\223\243\148'i\a\EOT" :: BS.ByteString) of+ CryptoPassed sig -> sig+ CryptoFailed _ -> undefined+ x2 = pure "SIGNATURE_RSA"++instance Arbitrary Curve25519.PublicKey where+ arbitrary = pure $ case Curve25519.publicKey ("\179g~\181\170\169\154\205\211\ft\162\&0@0dO\FS\DLEA\166@[r\150t~W\221cOF" :: BS.ByteString) of+ CryptoPassed pk -> pk+ CryptoFailed _ -> undefined
+ test/Spec/Server.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Server ( tests ) where++import Test.Tasty++tests :: TestTree+tests = testGroup "Network.SSH.Server" []
+ test/Spec/Server/Service/Connection.hs view
@@ -0,0 +1,937 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Server.Service.Connection ( tests ) where++import Control.Concurrent ( threadDelay )+import Control.Concurrent.Async+import Control.Concurrent.MVar+import Control.Exception ( onException )+import Control.Monad ( void )+import System.Exit+import Data.Default+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS++import Network.SSH.Internal++import Test.Tasty+import Test.Tasty.HUnit++import Spec.Util++tests :: TestTree+tests = testGroup "Network.SSH.Server.Service.Connection"+ [ test00+ , test01+ , test02+ , test03+ , test04+ , test05+ , test06+ , test07+ , test08+ , testGroup "channel requests"+ [ testRequest01+ , testGroup "session channel requests"+ [ testRequestSession01+ , testRequestSession02+ , testGroup "shell requests"+ [ testRequestSessionShell01+ , testRequestSessionShell02+ , testRequestSessionShell03+ , testRequestSessionShell04+ , testRequestSessionShell05+ , testRequestSessionShell06+ , testRequestSessionShell07+ ]+ , testGroup "channel data"+ [ testSessionData01+ , testSessionData02+ , testSessionData03+ ]+ , testGroup "flow control"+ [ testSessionFlowControl01+ , testSessionFlowControl02+ , testSessionFlowControl03+ , testSessionFlowControl04+ , testSessionFlowControl05+ ]+ ]+ ]+ ]++test00 :: TestTree+test00 = testCase "open one session channel (no handler, expect rejection)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ where+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenFailure rid ChannelOpenAdministrativelyProhibited mempty mempty++test01 :: TestTree+test01 = testCase "open one session channel (with handler)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = \_ _ -> pure $ Just undefined+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ where+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps++test02 :: TestTree+test02 = testCase "open two session channels (with handler)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = \_ _ -> pure $ Just undefined+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ where+ lid0 = ChannelId 0+ rid0 = ChannelId 3+ lid1 = ChannelId 1+ rid1 = ChannelId 4+ lws = 257 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid0 lid0 lws lps+ req1 = ChannelOpen rid1 rws rps ChannelOpenSession+ res1 = ChannelOpenConfirmation rid1 lid1 lws lps++test03 :: TestTree+test03 = testCase "open two session channels (exceed limit)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxCount = 1,+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = \_ _ -> pure $ Just undefined+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ where+ lid = ChannelId 0+ rid0 = ChannelId 1+ rid1 = ChannelId 2+ lws = 258 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid0 lid lws lps+ req1 = ChannelOpen rid1 rws rps ChannelOpenSession+ res1 = ChannelOpenFailure rid1 ChannelOpenResourceShortage mempty mempty++test04 :: TestTree+test04 = testCase "open two session channels (close first, reuse first)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = \_ _ -> pure $ Just undefined+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res2" res2+ where+ lid0 = ChannelId 0+ rid0 = ChannelId 1+ rid1 = ChannelId 2+ lws = 259 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid0 lid0 lws lps+ req1 = ChannelClose lid0+ res1 = ChannelClose rid0+ req2 = ChannelOpen rid1 rws rps ChannelOpenSession+ res2 = ChannelOpenConfirmation rid1 lid0 lws lps++test05 :: TestTree+test05 = testCase "open unknown channel type" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ where+ rid0 = ChannelId 1+ lws = 259 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps (ChannelOpenOther (ChannelType "unknown"))+ res0 = ChannelOpenFailure rid0 ChannelOpenUnknownChannelType mempty mempty++test06 :: TestTree+test06 = testCase "close non-existing channel id" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def+ withAsync (serveConnection config serverStream ()) $ \thread -> do+ sendMessage clientStream req0+ assertThrows "exp0" exp0 $ wait thread+ where+ lid0 = ChannelId 0+ req0 = ChannelClose lid0+ exp0 = exceptionInvalidChannelId++test07 :: TestTree+test07 = testCase "close channel (don't reuse unless acknowledged)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps, onSessionRequest = handler }+ withAsync (serveConnection config serverStream ()) $ const $ do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res2" res2+ where+ lid0 = ChannelId 0+ rid0 = ChannelId 23+ lid1 = ChannelId 1+ rid1 = ChannelId 24+ lws = 100+ lps = 200+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid0 lid0 lws lps+ req1 = ChannelRequest lid0 "shell" True mempty+ res10 = ChannelSuccess rid0+ res11 = ChannelEof rid0+ res12 = ChannelRequest rid0 "exit-status" False "\NUL\NUL\NUL\NUL"+ res13 = ChannelClose rid0+ req2 = ChannelOpen rid1 rws rps ChannelOpenSession+ res2 = ChannelOpenConfirmation rid1 lid1 lws lps+ handler _ _ = pure $ Just $ SessionHandler $ \env pty cmd stdin stdout stderr ->+ pure ExitSuccess++test08 :: TestTree+test08 = testCase "close channel (reuse when acknowledged)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps, onSessionRequest = handler }+ withAsync (serveConnection config serverStream ()) $ const $ do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ sendMessage clientStream req2+ sendMessage clientStream req3+ receiveMessage clientStream >>= assertEqual "res3" res3+ where+ lid0 = ChannelId 0+ rid0 = ChannelId 23+ rid1 = ChannelId 24+ lws = 100+ lps = 200+ rws = 123+ rps = 456+ req0 = ChannelOpen rid0 rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid0 lid0 lws lps+ req1 = ChannelRequest lid0 "shell" True mempty+ res10 = ChannelSuccess rid0+ res11 = ChannelEof rid0+ res12 = ChannelRequest rid0 "exit-status" False "\NUL\NUL\NUL\NUL"+ res13 = ChannelClose rid0+ req2 = ChannelClose lid0+ req3 = ChannelOpen rid1 rws rps ChannelOpenSession+ res3 = ChannelOpenConfirmation rid1 lid0 lws lps+ handler _ _ = pure $ Just $ SessionHandler $ \env pty cmd stdin stdout stderr ->+ pure ExitSuccess++testRequest01 :: TestTree+testRequest01 = testCase "reject unknown / unimplemented requests" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = \_ _ -> pure $ Just undefined+ }+ withAsync (serveConnection config serverStream ()) $ const $ do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ where+ lid = ChannelId 0+ rid = ChannelId 23+ lws = 100+ lps = 200+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "unknown" True mempty+ res1 = ChannelFailure rid++testRequestSession01 :: TestTree+testRequestSession01 = testCase "env request" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps, onSessionRequest = h }+ withAsync (serveConnection config serverStream ()) $ const $ do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res20" res20+ receiveMessage clientStream >>= assertEqual "res21" res21+ receiveMessage clientStream >>= assertEqual "res22" res22+ where+ lid = ChannelId 0+ rid = ChannelId 23+ lws = 100+ lps = 200+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "env" False "\NUL\NUL\NUL\ACKLC_ALL\NUL\NUL\NUL\ven_US.UTF-8"+ req2 = ChannelRequest lid "shell" True ""+ res20 = ChannelSuccess rid+ res21 = ChannelEof rid+ res22 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ h _ _ = pure $ Just $ SessionHandler $ \env pty cmd stdin stdout stderr -> pure $+ if env == Environment [("LC_ALL","en_US.UTF-8")] + then ExitSuccess+ else ExitFailure 1++testRequestSession02 :: TestTree+testRequestSession02 = testCase "pty request" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def { channelMaxQueueSize = lws, channelMaxPacketSize = lps, onSessionRequest = h }+ withAsync (serveConnection config serverStream ()) $ const $ do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res20" res20+ receiveMessage clientStream >>= assertEqual "res21" res21+ receiveMessage clientStream >>= assertEqual "res22" res22+ where+ lid = ChannelId 0+ rid = ChannelId 23+ lws = 100+ lps = 200+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "pty-req" True $ runPut (put pty)+ res1 = ChannelSuccess rid+ req2 = ChannelRequest lid "shell" True ""+ res20 = ChannelSuccess rid+ res21 = ChannelEof rid+ res22 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ pty = PtySettings+ { ptyEnv = "xterm"+ , ptyWidthCols = 80+ , ptyHeightRows = 23+ , ptyWidthPixels = 1024+ , ptyHeightPixels = 768+ , ptyModes = "fsldkjfsdjflskjdf"+ }+ h _ _ = pure $ Just $ SessionHandler $ \_ mpty _ _ _ _ -> pure $ case mpty of+ Just (TermInfo pty') | pty == pty' -> ExitSuccess+ _ -> ExitFailure 1++testRequestSessionShell01 :: TestTree+testRequestSessionShell01 = testCase "handler exits with 0" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ where+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res10 = ChannelSuccess rid+ res11 = ChannelEof rid+ res12 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ res13 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ Nothing _ _ _ ->+ pure ExitSuccess++testRequestSessionShell02 :: TestTree+testRequestSessionShell02 = testCase "handler exits with 1" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ where+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res10 = ChannelSuccess rid+ res11 = ChannelEof rid+ res12 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\SOH"+ res13 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ Nothing _ _ _ ->+ pure (ExitFailure 1)++testRequestSessionShell03 :: TestTree+testRequestSessionShell03 = testCase "handler exits with 0 after writing to stdout" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ receiveMessage clientStream >>= assertEqual "res14" res14+ where+ ping = "PING PING PING PING"+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res10 = ChannelSuccess rid+ res11 = ChannelData rid (SBS.toShort ping)+ res12 = ChannelEof rid+ res13 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ res14 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ Nothing _ stdout _ -> do+ void $ send stdout ping+ pure ExitSuccess++testRequestSessionShell04 :: TestTree+testRequestSessionShell04 = testCase "handler exits with 0 after writing to stderr" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res10" res10+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ receiveMessage clientStream >>= assertEqual "res14" res14+ where+ ping = "PING PING PING PING"+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res10 = ChannelSuccess rid+ res11 = ChannelExtendedData rid 1 (SBS.toShort ping)+ res12 = ChannelEof rid+ res13 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ res14 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ Nothing _ _ stderr -> do+ void $ send stderr ping+ pure ExitSuccess++testRequestSessionShell05 :: TestTree+testRequestSessionShell05 = testCase "handler exits with 0 after echoing stdin to stdout" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res21" res21+ receiveMessage clientStream >>= assertEqual "res22" res22+ receiveMessage clientStream >>= assertEqual "res23" res23+ receiveMessage clientStream >>= assertEqual "res24" res24+ where+ ping = "PING PING PING PING"+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelData lid (SBS.toShort ping)+ res21 = ChannelData rid (SBS.toShort ping)+ res22 = ChannelEof rid+ res23 = ChannelRequest rid "exit-status" False "\NUL\NUL\NUL\NUL"+ res24 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ Nothing stdin stdout _ -> do+ void (send stdout =<< receive stdin 128)+ pure ExitSuccess++testRequestSessionShell06 :: TestTree+testRequestSessionShell06 = testCase "handler throws exception" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ receiveMessage clientStream >>= assertEqual "res14" res14+ where+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res11 = ChannelSuccess rid+ res12 = ChannelEof rid+ res13 = ChannelRequest rid "exit-signal" False "\NUL\NUL\NUL\ETXILL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"+ res14 = ChannelClose rid+ handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ _ _ -> do+ error "nasty handler"+ pure ExitSuccess++testRequestSessionShell07 :: TestTree+testRequestSessionShell07 = testCase "handler running while closed by client" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ mvar1 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ _ _ -> do+ putMVar mvar0 ()+ threadDelay (1000*1000) `onException` putMVar mvar1 () + pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ readMVar mvar0 -- wait for handler thread start+ sendMessage clientStream req2+ readMVar mvar1 -- wait for handler thread termination by exception+ receiveMessage clientStream >>= assertEqual "res2" res2+ where+ lid = ChannelId 0+ rid = ChannelId 1+ lws = 256 * 1024+ lps = 32 * 1024+ rws = 123+ rps = 456+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelClose lid+ res2 = ChannelClose rid++testSessionData01 :: TestTree+testSessionData01 = testCase "honor remote max packet size" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ stdout _ -> do+ sendAll stdout msg+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ receiveMessage clientStream >>= assertEqual "res13" res13+ receiveMessage clientStream >>= assertEqual "res14" res14+ receiveMessage clientStream >>= assertEqual "res15" res15+ where+ msg = "ABC"+ lid = ChannelId 0+ rid = ChannelId 23+ rws = fromIntegral (BS.length msg)+ rps = 1+ lws = fromIntegral (BS.length msg)+ lps = fromIntegral (BS.length msg)+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res11 = ChannelSuccess rid+ res12 = ChannelData rid "A"+ res13 = ChannelData rid "B"+ res14 = ChannelData rid "C"+ res15 = ChannelEof rid++testSessionData02 :: TestTree+testSessionData02 = testCase "throw exception if local maxPacketSize is exeeded" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ mvar1 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ stdin _ _ -> do+ void $ takeMVar mvar0+ putMVar mvar1 =<< receive stdin 1+ void $ takeMVar mvar0+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \thread -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ -- Payload exceeds local maxPacketSize (lps).+ sendMessage clientStream req2+ assertThrows "exp2" exp2 $ wait thread+ -- Unblock handler.+ putMVar mvar0 ()+ where+ msg = "ABC"+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 0+ rps = 0+ lws = fromIntegral (SBS.length msg)+ lps = fromIntegral (SBS.length msg) - 1+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelData lid msg+ exp2 = exceptionPacketSizeExceeded++testSessionData03 :: TestTree+testSessionData03 = testCase "throw exception if remote sends data after eof" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ _ _ -> do+ void $ takeMVar mvar0+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \thread -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ sendMessage clientStream req3+ assertThrows "exp3" exp3 $ wait thread+ -- Unblock handler.+ putMVar mvar0 ()+ where+ msg = "ABC"+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 0+ rps = 0+ lws = fromIntegral (SBS.length msg)+ lps = fromIntegral (SBS.length msg)+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelEof lid+ req3 = ChannelData lid msg+ exp3 = exceptionDataAfterEof++testSessionFlowControl01 :: TestTree+testSessionFlowControl01 = testCase "adjust inbound window when < 50% and capacity available" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ mvar1 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ stdin _ _ -> do+ void $ takeMVar mvar0+ putMVar mvar1 =<< receive stdin 1+ void $ takeMVar mvar0+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ -- Initial window (lws) is 5.+ -- Send 3 bytes ("ABC"). Remaining window is then < 50%.+ sendMessage clientStream req2+ -- Window adjust not yet possible due to lack of free capacity.+ -- Handler shall consume 1 byte to increase capacity to > 50%.+ putMVar mvar0 ()+ assertEqual "first byte" "A" =<< takeMVar mvar1+ -- Now expecting window adjust..+ receiveMessage clientStream >>= assertEqual "res2" res2+ -- Let handler finish.+ putMVar mvar0 ()+ where+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 0+ rps = 0+ lws = 5+ lps = 5+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelData lid "ABC"+ res2 = ChannelWindowAdjust rid 3++testSessionFlowControl02 :: TestTree+testSessionFlowControl02 = testCase "throw exception on inbound window size underrun" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ _ _ -> do+ void $ takeMVar mvar0+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \thread -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ sendMessage clientStream req3+ assertThrows "exp3" exp3 $ wait thread+ -- Unblock handler.+ putMVar mvar0 ()+ where+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 0+ rps = 0+ lws = 1+ lps = 1+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelData lid "A"+ req3 = ChannelData lid "B"+ exp3 = exceptionWindowSizeUnderrun++testSessionFlowControl03 :: TestTree+testSessionFlowControl03 = testCase "honor outbound window size and adjustment" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ stdout _ -> do+ sendAll stdout msg+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res11" res11+ receiveMessage clientStream >>= assertEqual "res12" res12+ sendMessage clientStream req2+ receiveMessage clientStream >>= assertEqual "res2" res2+ sendMessage clientStream req3+ receiveMessage clientStream >>= assertEqual "res31" res31+ receiveMessage clientStream >>= assertEqual "res32" res32+ where+ msg = "ABCDEF"+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 3+ rps = fromIntegral (BS.length msg)+ lws = fromIntegral (BS.length msg)+ lps = fromIntegral (BS.length msg)+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res11 = ChannelSuccess rid+ res12 = ChannelData rid "ABC"+ req2 = ChannelWindowAdjust lid 2+ res2 = ChannelData rid "DE"+ req3 = ChannelWindowAdjust lid 1+ res31 = ChannelData rid "F"+ res32 = ChannelEof rid++testSessionFlowControl04 :: TestTree+testSessionFlowControl04 = testCase "remote adjusts window size to maximum" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ stdin stdout _ -> do+ sendAll stdout =<< receiveAll stdin (SBS.length msg)+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \_ -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ sendMessage clientStream req3+ receiveMessage clientStream >>= assertEqual "res31" res31+ receiveMessage clientStream >>= assertEqual "res32" res32+ where+ msg = "ABC"+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 0+ rps = fromIntegral (SBS.length msg)+ lws = fromIntegral (SBS.length msg)+ lps = fromIntegral (SBS.length msg)+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelData lid msg+ req3 = ChannelWindowAdjust lid maxBound+ res31 = ChannelData rid msg+ res32 = ChannelEof rid++testSessionFlowControl05 :: TestTree+testSessionFlowControl05 = testCase "throw exception if remote adjusts window size to (maximum + 1)" $ do+ (serverStream,clientStream) <- newDummyTransportPair+ mvar0 <- newEmptyMVar+ let handler _ _ = pure $ Just $ SessionHandler $ \_ _ _ _ _ _ -> do+ readMVar mvar0+ pure ExitSuccess+ let config = def {+ channelMaxQueueSize = lws,+ channelMaxPacketSize = lps,+ onSessionRequest = handler+ }+ withAsync (serveConnection config serverStream ()) $ \thread -> do+ sendMessage clientStream req0+ receiveMessage clientStream >>= assertEqual "res0" res0+ sendMessage clientStream req1+ receiveMessage clientStream >>= assertEqual "res1" res1+ sendMessage clientStream req2+ sendMessage clientStream req3+ putMVar mvar0 ()+ assertThrows "exp3" exp3 $ wait thread+ where+ lid = ChannelId 0+ rid = ChannelId 23+ rws = 1+ rps = 1+ lws = 1+ lps = 1+ req0 = ChannelOpen rid rws rps ChannelOpenSession+ res0 = ChannelOpenConfirmation rid lid lws lps+ req1 = ChannelRequest lid "shell" True mempty+ res1 = ChannelSuccess rid+ req2 = ChannelWindowAdjust lid maxBound+ req3 = ChannelData lid "ABC"+ exp3 = exceptionWindowSizeOverflow
+ test/Spec/Server/Service/UserAuth.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Server.Service.UserAuth ( tests ) where+ +import Control.Concurrent.Async+import Crypto.Error+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.RSA as RSA+import qualified Data.ByteString as BS+import Data.Default++import Test.Tasty+import Test.Tasty.HUnit++import Network.SSH.Internal++import Spec.Util++tests :: TestTree+tests = testGroup "Network.SSH.Server.Service.UserAuth"+ [ testGroup "service inactive (state 0)"+ [ testInactive01+ , testInactive02+ , testInactive03+ ]+ , testGroup "service active (state 1)"+ [ testActive01+ , testActive02+ , testActive03+ , testActive04+ , testActive05+ , testActive06+ , testActive07+ ]+ ]++testInactive01 :: TestTree+testInactive01 = testCase "request user auth service" $ do+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication def server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ where+ sess = SessionId mempty+ with _ = Just undefined+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")++testInactive02 :: TestTree+testInactive02 = testCase "request other service" $ do+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication def server sess with) $ \thread -> do+ sendMessage client req0+ assertThrows "exp0" exp0 (wait thread)+ where+ sess = SessionId mempty+ with _ = Just undefined+ req0 = ServiceRequest (Name "other-service")+ exp0 = exceptionServiceNotAvailable++testInactive03 :: TestTree+testInactive03 = testCase "dispatch other message" $ do+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication def server sess with) $ \thread -> do+ sendMessage client req0+ assertThrows "exp0" exp0 (wait thread)+ where+ sess = SessionId mempty+ with _ = Just undefined+ req0 = MsgUnknown 1+ exp0 = exceptionUnexpectedMessage "\x01"++testActive01 :: TestTree+testActive01 = testCase "authenticate by public key (no signature)" $ do+ let config = def { onAuthRequest = onAuth }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ where+ with _ = Just undefined+ user = Name "fnord"+ srvc = Name "ssh-connection"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyEd25519 (pass $ Ed25519.publicKey ("\185\EOT\150\CAN\142)\175\161\242\141/\SI\214=n$?\189Z\172\214\190\EM\190^\226\r\241\197\&8\235\130" :: BS.ByteString))+ auth = AuthPublicKey pubk Nothing+ req0 = MsgServiceRequest $ ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = MsgUserAuthRequest $ UserAuthRequest user srvc auth+ res1 = UserAuthPublicKeyOk pubk+ pass (CryptoPassed x) = x+ pass _ = undefined+ onAuth _ _ _ = pure (Just user)++testActive02 :: TestTree+testActive02 = testCase "authenticate by public key (incorrect signature)" $ do+ let config = def { onAuthRequest = onAuth }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ where+ with _ = Just undefined+ user = Name "fnord"+ srvc = Name "ssh-connection"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyEd25519 (pass $ Ed25519.publicKey ("\185\EOT\150\CAN\142)\175\161\242\141/\SI\214=n$?\189Z\172\214\190\EM\190^\226\r\241\197\&8\235\130" :: BS.ByteString))+ sign = SignatureEd25519 (pass $ Ed25519.signature ("\NUL\NULG\NULw2\NUL\b|\ETX\239\136\213&|\145Zp\ACK\240p\243\128\vL\139N\ESC\207LI\t?\139D\DC36\206\252p\172\190)\238 {\\*\206\203\253\176\vE\EM\SYNkG\211\&2\192\201\EOT\ACK" :: BS.ByteString))+ auth = AuthPublicKey pubk (Just sign)+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = UserAuthRequest user srvc auth+ res1 = UserAuthFailure ["publickey"] False+ pass (CryptoPassed x) = x+ pass _ = undefined+ onAuth _ _ _ = pure (Just user)++testActive03 :: TestTree+testActive03 = testCase "authenticate by public key (correct signature, user accepted)" $ do+ let config = def { onAuthRequest = onAuth }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \thread -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ wait thread >>= assertEqual "idnt" idnt+ where+ idnt = "identity" :: String+ user = Name "fnord"+ srvc = Name "ssh-connection"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyEd25519 (pass $ Ed25519.publicKey ("\185\EOT\150\CAN\142)\175\161\242\141/\SI\214=n$?\189Z\172\214\190\EM\190^\226\r\241\197\&8\235\130" :: BS.ByteString))+ sign = SignatureEd25519 (pass $ Ed25519.signature ("\152\211G\164w2\253\b|\ETX\239\136\213&|\145Zp\ACK\240p\243\128\vL\139N\ESC\207LI\t?\139D\DC36\206\252p\172\190)\238 {\\*\206\203\253\176\vE\EM\SYNkG\211\&2\192\201\EOT\ACK" :: BS.ByteString))+ auth = AuthPublicKey pubk (Just sign)+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = UserAuthRequest user srvc auth+ res1 = UserAuthSuccess+ pass (CryptoPassed x) = x+ pass _ = undefined+ with _ = Just pure+ onAuth u s p+ | u /= user = pure Nothing+ | s /= srvc = pure Nothing+ | p /= pubk = pure Nothing+ | otherwise = pure (Just idnt)++testActive04 :: TestTree+testActive04 = testCase "authenticate by public key (correct signature, user accepted, service not available)" $ do+ let config = def { onAuthRequest = \_ _ _ -> pure (Just idnt) }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \thread -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ assertThrows "exp1" exp1 $ wait thread+ where+ idnt = "identity" :: String+ user = Name "fnord"+ srvc = Name "unavailable-service"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyEd25519 (pass $ Ed25519.publicKey ("J\190r%\232\247\220\n\160\129m\132\RS\193\NULL\128\152}\142\SUB\161\f\229\f\137\254M\192>n\182" :: BS.ByteString))+ sign = SignatureEd25519 (pass $ Ed25519.signature ("\244\173\199<\202 \204Q\185z\EOTU\v\236\&37\"u\248TE^3fk\158|@^\215\142\DC4\234\234\DC1\224\236\FS{\CAN\144^\140\148X\169\174+\\:y\226\&9K\141\182:\NUL_\245\DC1a\228\b" :: BS.ByteString))+ auth = AuthPublicKey pubk (Just sign)+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = UserAuthRequest user srvc auth+ exp1 = Disconnect Local DisconnectServiceNotAvailable mempty+ pass (CryptoPassed x) = x+ pass _ = undefined+ with s+ | s == srvc = Nothing+ | otherwise = Just pure++testActive05 :: TestTree+testActive05 = testCase "authenticate by public key (correct signature, user rejected)" $ do+ let config = def { onAuthRequest = \_ _ _ -> pure Nothing }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ where+ user = Name "fnord"+ srvc = Name "ssh-connection"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyEd25519 (pass $ Ed25519.publicKey ("\185\EOT\150\CAN\142)\175\161\242\141/\SI\214=n$?\189Z\172\214\190\EM\190^\226\r\241\197\&8\235\130" :: BS.ByteString))+ sign = SignatureEd25519 (pass $ Ed25519.signature ("\152\211G\164w2\253\b|\ETX\239\136\213&|\145Zp\ACK\240p\243\128\vL\139N\ESC\207LI\t?\139D\DC36\206\252p\172\190)\238 {\\*\206\203\253\176\vE\EM\SYNkG\211\&2\192\201\EOT\ACK" :: BS.ByteString))+ auth = AuthPublicKey pubk (Just sign)+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = UserAuthRequest user srvc auth+ res1 = UserAuthFailure ["publickey"] False+ pass (CryptoPassed x) = x+ pass _ = undefined+ with _ = Just pure++testActive06 :: TestTree+testActive06 = testCase "authenticate by public key (key/signature type mismatch)" $ do+ let config = def { onAuthRequest = \_ _ _ -> pure Nothing }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ where+ user = Name "fnord"+ srvc = Name "ssh-connection"+ sess = SessionId "\196\249b\160;FF\DLE\173\&1>\179w=\238\210\140\&8!:\139=QUx\169C\209\165\FS\185I"+ pubk = PublicKeyRSA $ RSA.PublicKey 24 65537 2834792+ sign = SignatureEd25519 (pass $ Ed25519.signature ("\152\211G\164w2\253\b|\ETX\239\136\213&|\145Zp\ACK\240p\243\128\vL\139N\ESC\207LI\t?\139D\DC36\206\252p\172\190)\238 {\\*\206\203\253\176\vE\EM\SYNkG\211\&2\192\201\EOT\ACK" :: BS.ByteString))+ auth = AuthPublicKey pubk (Just sign)+ req0 = MsgServiceRequest $ ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = MsgUserAuthRequest $ UserAuthRequest user srvc auth+ res1 = UserAuthFailure ["publickey"] False+ pass (CryptoPassed x) = x+ pass _ = undefined+ with _ = Just pure++testActive07 :: TestTree+testActive07 = testCase "authenticate by other method (AuthNone)" $ do+ let config = def { onAuthRequest = \_ _ _ -> pure Nothing }+ (client, server) <- newDummyTransportPair+ withAsync (withAuthentication config server sess with) $ \_ -> do+ sendMessage client req0+ receiveMessage client >>= assertEqual "res0" res0+ sendMessage client req1+ receiveMessage client >>= assertEqual "res1" res1+ where+ sess = SessionId mempty+ req0 = ServiceRequest (Name "ssh-userauth")+ res0 = ServiceAccept (Name "ssh-userauth")+ req1 = UserAuthRequest (Name "fnord") (Name "ssh-connection") AuthNone+ res1 = UserAuthFailure ["publickey"] False+ with _ = Just pure
+ test/Spec/TStreamingQueue.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Spec.TStreamingQueue ( tests ) where++import Control.Monad.STM+import Control.Concurrent.STM.TVar++import Test.Tasty+import Test.Tasty.HUnit++import Network.SSH.Internal++tests :: TestTree+tests = testGroup "Network.SSH.TStreamingQueue"+ [ test01+ , test02+ , test03+ , test04+ , test05+ ]++test01 :: TestTree+test01 = testCase "send 3 bytes, send 3 bytes, receive up to 6 bytes" $ do+ window <- newTVarIO 1000000+ q <- atomically $ newTStreamingQueue 10 window+ assertEqual "sent" 3 =<< atomically (enqueue q "ABC")+ assertEqual "sent" 3 =<< atomically (enqueue q "DEF")+ assertEqual "received" "ABCDEF" =<< atomically (dequeue q 6)++test02 :: TestTree+test02 = testCase "send 3 bytes, send 3 bytes, receive up to 7 bytes" $ do+ window <- newTVarIO 1000000+ q <- atomically $ newTStreamingQueue 10 window+ assertEqual "sent" 3 =<< atomically (enqueue q "ABC")+ assertEqual "sent" 3 =<< atomically (enqueue q "DEF")+ assertEqual "received" "ABCDEF" =<< atomically (dequeue q 7)++test03 :: TestTree+test03 = testCase "send 3 bytes, send eof, receive up to 7 bytes" $ do+ window <- newTVarIO 1000000+ q <- atomically $ newTStreamingQueue 10 window+ assertEqual "sent" 3 =<< atomically (enqueue q "ABC")+ atomically $ terminate q+ assertEqual "received" "ABC" =<< atomically (dequeue q 7)++test04 :: TestTree+test04 = testCase "send 0 bytes" $ do+ window <- newTVarIO 1000000+ q <- atomically $ newTStreamingQueue 10 window+ assertEqual "sent" 0 =<< atomically (enqueue q "")++test05 :: TestTree+test05 = testCase "send 4, receive 3, send 4, receive 3, sent eof, receive 3" $ do+ window <- newTVarIO 1000000+ q <- atomically $ newTStreamingQueue 10 window+ assertEqual "sent" 4 =<< atomically (enqueue q "1234")+ assertEqual "rcvd" "123" =<< atomically (dequeue q 3)+ assertEqual "sent" 4 =<< atomically (enqueue q "5678")+ assertEqual "rcvd" "456" =<< atomically (dequeue q 3)+ atomically $ terminate q+ assertEqual "rcvd" "78" =<< atomically (dequeue q 3)
+ test/Spec/Transport.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Transport ( tests ) where++import Control.Concurrent.Async+import Control.Exception+import Control.Monad ( void )+import qualified Crypto.PubKey.Ed25519 as Ed25519+import Data.Default++import Test.Tasty+import Test.Tasty.HUnit++import Network.SSH.Internal++import Spec.Util++tests :: TestTree+tests = testGroup "Network.SSH.Transport"+ [ test01+ , test02+ , test03+ , test04+ , test05+ , test06+ ]++test01 :: TestTree+test01 = testCase "key exchange yields same session id on both sides" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server ->+ withAsync (runClient clientSocket def `finally` close clientSocket) $ \client -> do+ (Right sid1, Right sid2) <- waitBoth server client+ assertEqual "session ids" sid1 sid2+ where+ runServer stream config agent = withTransport config (Just agent) stream (const pure)+ runClient stream config = withTransport config (Nothing :: Maybe KeyPair) stream (const pure)++test02 :: TestTree+test02 = testCase "server sends first message, client receives" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server ->+ withAsync (runClient clientSocket def `finally` close clientSocket) $ \client -> do+ (s,c) <- waitBoth server client+ assertEqual "s" (Right ()) s+ assertEqual "c" (Right "ABCD") c+ where+ runServer stream config agent = withTransport config (Just agent) stream $ \transport _ -> do+ sendMessage transport (ChannelData (ChannelId 0) "ABCD")+ pure ()+ runClient stream config = withTransport config (Nothing :: Maybe KeyPair) stream $ \transport _ -> do+ ChannelData _ msg <- receiveMessage transport+ pure msg++test03 :: TestTree+test03 = testCase "client sends incorrect version string" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server -> do+ sendAll clientSocket "GET / HTTP/1.1\n\n"+ wait server >>= assertEqual "res" (Left exceptionProtocolVersionNotSupported)+ where+ runServer stream config agent = withTransport config (Just agent) stream (const pure)++test04 :: TestTree+test04 = testCase "client sends incomplete version string" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server -> do+ sendAll clientSocket "SSH-2.0-OpenSSH_4.3"+ wait server >>= assertEqual "res" (Left exceptionProtocolVersionNotSupported)+ where+ runServer stream config agent = withTransport config (Just agent) stream (const pure)++test05 :: TestTree+test05 = testCase "client disconnects hard before sending version string" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server -> do+ close clientSocket+ wait server >>= assertEqual "res" (Left exceptionConnectionLost)+ where+ runServer stream config agent = withTransport config (Just agent) stream (const pure)++test06 :: TestTree+test06 = testCase "client disconnects gracefully after sending version string" $ do+ (clientSocket, serverSocket) <- newSocketPair+ agent <- (\sk -> KeyPairEd25519 (Ed25519.toPublic sk) sk) <$> Ed25519.generateSecretKey+ withAsync (runServer serverSocket def agent `finally` close serverSocket) $ \server -> do+ sendAll clientSocket $ runPut $ put $ Version "SSH-2.0-OpenSSH_4.3"+ void $ plainEncryptionContext clientSocket 0 (put $ Disconnected DisconnectByApplication "ABC" mempty)+ wait server >>= assertEqual "res" (Left $ Disconnect Remote DisconnectByApplication "ABC")+ where+ runServer stream config agent = withTransport config (Just agent) stream (const pure)++{-+assertCorrectSignature ::+ Curve25519.SecretKey -> Curve25519.PublicKey ->+ Version -> Version ->+ KexInit -> KexInit ->+ KexEcdhReply -> Assertion+assertCorrectSignature csk cpk cv sv cki ski ser =+ assertBool "correct signature" $ Ed25519.verify k hash s+ where+ sig@(SignatureEd25519 s) = kexHashSignature ser+ shk@(PublicKeyEd25519 k) = kexServerHostKey ser+ spk = kexServerEphemeralKey ser+ secret = Curve25519.dh spk csk+ hash :: Hash.Digest Hash.SHA256+ hash = Hash.hash $ runPut $ do+ putString cv+ putString sv+ putWord32 (len cki)+ put cki+ putWord32 (len ski)+ put ski+ put shk+ put cpk+ put spk+ putAsMPInt secret++exchangeKeys :: Config identity -> Version -> Version -> Transport -> IO SessionId+exchangeKeys config cv sv transport = do+ cki <- newKexInit config+ sendMessage transport cki+ ski <- receiveMessage transport+ assertEqual "kex algorithms" ["curve25519-sha256@libssh.org"] (kexAlgorithms ski)+ assertEqual "kex algorithms server hostkey" ["ssh-ed25519"] (kexServerHostKeyAlgorithms ski)+ assertEqual "kex algorithms encryption client -> server" ["chacha20-poly1305@openssh.com"] (kexEncryptionAlgorithmsClientToServer ski)+ assertEqual "kex algorithms encryption server -> client" ["chacha20-poly1305@openssh.com"] (kexEncryptionAlgorithmsServerToClient ski)+ assertEqual "kex algorithms mac client -> server" [] (kexMacAlgorithmsClientToServer ski)+ assertEqual "kex algorithms mac server -> client" [] (kexMacAlgorithmsServerToClient ski)+ assertEqual "kex algorithms compression client -> server" ["none"] (kexCompressionAlgorithmsClientToServer ski)+ assertEqual "kex algorithms compression server -> client" ["none"] (kexCompressionAlgorithmsServerToClient ski)+ assertEqual "kex languages client -> server" [] (kexLanguagesClientToServer ski)+ assertEqual "kex languages server -> client" [] (kexLanguagesServerToClient ski)+ assertEqual "kex first packet follows" False (kexFirstPacketFollows ski)+ csk <- Curve25519.generateSecretKey+ cpk <- pure (Curve25519.toPublic csk)+ sendMessage transport (KexEcdhInit cpk)+ ser <- receiveMessage transport + assertCorrectSignature csk cpk cv sv cki ski ser+ -- set crypto context (client role)+ let shk = kexServerHostKey ser+ spk = kexServerEphemeralKey ser+ sec = Curve25519.dh spk csk+ sid = SessionId $ BA.convert hash+ hash :: Hash.Digest Hash.SHA256+ hash = Hash.hash $ runPut $ do+ putString cv+ putString sv+ putWord32 (len cki)+ put cki+ putWord32 (len ski)+ put ski+ put shk+ put cpk+ put spk+ putAsMPInt sec+ setChaCha20Poly1305Context transport Client $ deriveKeys sec hash sid+ assertEqual "new keys" (MsgKexNewKeys KexNewKeys) =<< receiveMessage transport+ sendMessage transport KexNewKeys+ switchEncryptionContext transport+ switchDecryptionContext transport+ pure sid+-}
+ test/Spec/Util.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}+module Spec.Util where++import qualified Data.ByteString as BS+import Control.Monad.STM+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Exception+import Control.Monad++import Test.Tasty.HUnit++import Network.SSH.Internal++assertThrows :: (Eq e, Exception e) => String -> e -> IO a -> Assertion+assertThrows label e action = (action >> failure0) `catch` \e'-> when (e /= e') (failure1 e')+ where+ failure0 = assertFailure (label ++ ": should have thrown " ++ show e)+ failure1 e' = assertFailure (label ++ ": should have thrown " ++ show e ++ " (saw " ++ show e' ++ " instead)")++data DummySocket = DummySocket TStreamingQueue TStreamingQueue++newSocketPair :: IO (DummySocket, DummySocket)+newSocketPair = atomically $ do+ window <- newTVar 1000000000+ x <- newTStreamingQueue 1000000000 window+ y <- newTStreamingQueue 1000000000 window+ pure (DummySocket x y, DummySocket y x)++instance DuplexStream DummySocket++instance OutputStream DummySocket where+ send (DummySocket q _) = send q++instance InputStream DummySocket where+ peek (DummySocket _ q) = peek q+ receive (DummySocket _ q) = receive q+ receiveUnsafe (DummySocket _ q) = receiveUnsafe q++close :: DummySocket -> IO ()+close (DummySocket q _) = atomically $ terminate q++newtype DummyTransport = DummyTransport (TChan BS.ByteString, TChan BS.ByteString)++newDummyTransportPair :: IO (DummyTransport, DummyTransport)+newDummyTransportPair = do+ inbound <- newTChanIO+ outbound <- newTChanIO+ pure (DummyTransport (inbound, outbound), DummyTransport (outbound,inbound))++instance MessageStream DummyTransport where+ sendMessage (DummyTransport (c,_)) msg = atomically $ writeTChan c $ runPut (put msg)+ receiveMessage (DummyTransport (_,c)) = do+ bs <- atomically $ readTChan c+ case runGet bs of+ Nothing -> throwIO (exceptionUnexpectedMessage bs)+ Just msg -> pure msg