diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.1.0.0 Lars Petersen 2018-10-31 + + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/hssh.cabal b/hssh.cabal new file mode 100644 --- /dev/null +++ b/hssh.cabal @@ -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 +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 diff --git a/src/Network/SSH.hs b/src/Network/SSH.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH.hs @@ -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 diff --git a/src/Network/SSH/Algorithms.hs b/src/Network/SSH/Algorithms.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Algorithms.hs @@ -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" diff --git a/src/Network/SSH/AuthAgent.hs b/src/Network/SSH/AuthAgent.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/AuthAgent.hs @@ -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 diff --git a/src/Network/SSH/Builder.hs b/src/Network/SSH/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Builder.hs @@ -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 diff --git a/src/Network/SSH/Client.hs b/src/Network/SSH/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Client.hs @@ -0,0 +1,3 @@ +module Network.SSH.Client where + +-- Nothing there yet. diff --git a/src/Network/SSH/Constants.hs b/src/Network/SSH/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Constants.hs @@ -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 diff --git a/src/Network/SSH/Encoding.hs b/src/Network/SSH/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Encoding.hs @@ -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) diff --git a/src/Network/SSH/Exception.hs b/src/Network/SSH/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Exception.hs @@ -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] diff --git a/src/Network/SSH/Internal.hs b/src/Network/SSH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Internal.hs @@ -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 diff --git a/src/Network/SSH/Key.hs b/src/Network/SSH/Key.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Key.hs @@ -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) diff --git a/src/Network/SSH/Message.hs b/src/Network/SSH/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Message.hs @@ -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) diff --git a/src/Network/SSH/Name.hs b/src/Network/SSH/Name.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Name.hs @@ -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 diff --git a/src/Network/SSH/Server.hs b/src/Network/SSH/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Server.hs @@ -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 + } diff --git a/src/Network/SSH/Server/Service/Connection.hs b/src/Network/SSH/Server/Service/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Server/Service/Connection.hs @@ -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 diff --git a/src/Network/SSH/Server/Service/UserAuth.hs b/src/Network/SSH/Server/Service/UserAuth.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Server/Service/UserAuth.hs @@ -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 diff --git a/src/Network/SSH/Stream.hs b/src/Network/SSH/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Stream.hs @@ -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) diff --git a/src/Network/SSH/TStreamingQueue.hs b/src/Network/SSH/TStreamingQueue.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/TStreamingQueue.hs @@ -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 diff --git a/src/Network/SSH/Transport.hs b/src/Network/SSH/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Transport.hs @@ -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 diff --git a/src/Network/SSH/Transport/Crypto.hs b/src/Network/SSH/Transport/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Transport/Crypto.hs @@ -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) diff --git a/src/Network/SSH/Transport/Crypto/ChaCha.hs b/src/Network/SSH/Transport/Crypto/ChaCha.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Transport/Crypto/ChaCha.hs @@ -0,0 +1,55 @@ +-- | +-- Module : Network.SSH.Transport.Crypto.ChaCha +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 () diff --git a/src/Network/SSH/Transport/Crypto/Poly1305.hs b/src/Network/SSH/Transport/Crypto/Poly1305.hs new file mode 100644 --- /dev/null +++ b/src/Network/SSH/Transport/Crypto/Poly1305.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Network.SSH.Transport.Crypto.Poly1305 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Spec/Algorithms.hs b/test/Spec/Algorithms.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Algorithms.hs @@ -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) diff --git a/test/Spec/Key.hs b/test/Spec/Key.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Key.hs @@ -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) + diff --git a/test/Spec/Message.hs b/test/Spec/Message.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Message.hs @@ -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 diff --git a/test/Spec/Server.hs b/test/Spec/Server.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Server.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +module Spec.Server ( tests ) where + +import Test.Tasty + +tests :: TestTree +tests = testGroup "Network.SSH.Server" [] diff --git a/test/Spec/Server/Service/Connection.hs b/test/Spec/Server/Service/Connection.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Server/Service/Connection.hs @@ -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 diff --git a/test/Spec/Server/Service/UserAuth.hs b/test/Spec/Server/Service/UserAuth.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Server/Service/UserAuth.hs @@ -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 diff --git a/test/Spec/TStreamingQueue.hs b/test/Spec/TStreamingQueue.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TStreamingQueue.hs @@ -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) diff --git a/test/Spec/Transport.hs b/test/Spec/Transport.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Transport.hs @@ -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 +-} diff --git a/test/Spec/Util.hs b/test/Spec/Util.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Util.hs @@ -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