diff --git a/src/Network/SSH/Connection.hs b/src/Network/SSH/Connection.hs index 290ac47..8122698 100644 --- a/src/Network/SSH/Connection.hs +++ b/src/Network/SSH/Connection.hs @@ -6,6 +6,7 @@ module Network.SSH.Connection where import Network.SSH.Messages import Network.SSH.State import Network.SSH.TerminalModes +import Network.SSH.Rekey import Control.Concurrent import Control.Concurrent.STM @@ -71,6 +72,11 @@ connectionService :: Connection () connectionService = do msg <- connectionReceive case msg of + SshMsgKexInit i_c -> + do (client,state) <- Connection ask + liftIO (rekeyKeyExchange client state i_c) + connectionService + SshMsgChannelOpen SshChannelTypeSession senderChannel initialWindowSize maximumPacketSize -> do startSession senderChannel initialWindowSize maximumPacketSize diff --git a/src/Network/SSH/Rekey.hs b/src/Network/SSH/Rekey.hs new file mode 100644 index 0000000..2e6e6c3 --- /dev/null +++ b/src/Network/SSH/Rekey.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.SSH.Rekey where + +import Network.SSH.Named +import Network.SSH.Mac +import Network.SSH.Ciphers +import Network.SSH.Compression +import Network.SSH.Messages +import Network.SSH.Keys +import Network.SSH.PubKey +import Network.SSH.State +import Network.SSH.Packet + +import Control.Applicative ((<|>)) +import Data.List (find) +import Data.IORef (readIORef, modifyIORef') +import Control.Concurrent + +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +initialKeyExchange :: Client -> SshState -> IO () +initialKeyExchange client state = + do i_s <- supportedKex (map nameOf (sshAuthMethods state)) `fmap` newCookie + send client state (SshMsgKexInit i_s) + SshMsgKexInit i_c <- receive client state + rekeyConnection client state i_s i_c + + +rekeyKeyExchange :: Client -> SshState -> SshProposal -> IO () +rekeyKeyExchange client state i_c = + do i_s <- supportedKex (map nameOf (sshAuthMethods state)) `fmap` newCookie + send client state (SshMsgKexInit i_s) + rekeyConnection client state i_s i_c + + +rekeyConnection :: Client -> SshState -> SshProposal -> SshProposal -> IO () +rekeyConnection client state i_s i_c = + do (v_s, v_c) <- readIORef (sshIdents state) + let sAuth = sshAuthMethods state + + suite <- maybe (fail "negotiation failed") return + $ computeSuite sAuth i_s i_c + + SshMsgKexDhInit pub_c <- receive client state + (pub_s, k) <- kexRun (suite_kex suite) pub_c + + let sid = SshSessionId + $ kexHash (suite_kex suite) + $ sshDhHash v_c v_s i_c i_s (suite_host_pub suite) pub_c pub_s k + modifyIORef' (sshSessionId state) (<|> Just sid) + + sig <- sign (suite_host_priv suite) sid + send client state (SshMsgKexDhReply (suite_host_pub suite) pub_s sig) + + installSecurity client state suite sid k + +installSecurity :: + Client -> SshState -> CipherSuite -> + SshSessionId -> + S.ByteString {- ^ shared secret -} -> + IO () +installSecurity client state suite sid k = + do Just osid <- readIORef (sshSessionId state) + let keys = genKeys (kexHash (suite_kex suite)) k sid osid + + send client state SshMsgNewKeys + transitionKeysOutgoing suite keys state + + SshMsgNewKeys <- receive client state + transitionKeysIncoming suite keys state + +transitionKeysOutgoing :: CipherSuite -> Keys -> SshState -> IO () +transitionKeysOutgoing CipherSuite{..} Keys{..} SshState{..} = + do compress <- makeCompress suite_s2c_comp + modifyMVar_ sshSendState $ \(seqNum,_,_,_,drg) -> + return ( seqNum + , suite_s2c_cipher k_s2c_cipherKeys + , suite_s2c_mac k_s2c_integKey + , compress + , drg + ) + +transitionKeysIncoming :: CipherSuite -> Keys -> SshState -> IO () +transitionKeysIncoming CipherSuite{..} Keys{..} SshState{..} = + do decompress <- makeDecompress suite_c2s_comp + modifyIORef' sshRecvState $ \(seqNum, _, _, _) -> + ( seqNum + , suite_c2s_cipher k_c2s_cipherKeys + , suite_c2s_mac k_c2s_integKey + , decompress + ) + +data CipherSuite = CipherSuite + { suite_kex :: Kex + , suite_c2s_cipher, suite_s2c_cipher :: CipherKeys -> Cipher + , suite_c2s_mac , suite_s2c_mac :: L.ByteString -> Mac + , suite_c2s_comp , suite_s2c_comp :: Compression + , suite_host_priv :: PrivateKey + , suite_host_pub :: SshPubCert + } + +-- | Compute a cipher suite given two proposals. The first algorithm +-- requested by the client that the server also supports is selected. +computeSuite :: [ServerCredential] -> SshProposal -> SshProposal -> Maybe CipherSuite +computeSuite auths server client = + do let det = determineAlg server client + + suite_kex <- lookupNamed allKex =<< det sshKexAlgs + + c2s_cipher_name <- det (sshClientToServer.sshEncAlgs) + suite_c2s_cipher <- lookupNamed allCipher c2s_cipher_name + + s2c_cipher_name <- det (sshServerToClient.sshEncAlgs) + suite_s2c_cipher <- lookupNamed allCipher s2c_cipher_name + + suite_c2s_mac <- if c2s_cipher_name `elem` aeadModes + then Just (namedThing mac_none) + else lookupNamed allMac =<< det (sshClientToServer.sshMacAlgs) + + suite_s2c_mac <- if s2c_cipher_name `elem` aeadModes + then Just (namedThing mac_none) + else lookupNamed allMac =<< det (sshServerToClient.sshMacAlgs) + + (suite_host_pub, suite_host_priv) <- lookupNamed auths =<< det sshServerHostKeyAlgs + + s2c_comp_name <- det (sshServerToClient.sshCompAlgs) + suite_s2c_comp <- lookupNamed allCompression s2c_comp_name + + c2s_comp_name <- det (sshClientToServer.sshCompAlgs) + suite_c2s_comp <- lookupNamed allCompression c2s_comp_name + + return CipherSuite{..} + +-- | Select first client choice acceptable to the server +determineAlg :: + SshProposal {- ^ server -} -> + SshProposal {- ^ client -} -> + (SshProposal -> [ShortByteString]) {- ^ selector -} -> + Maybe ShortByteString +determineAlg server client f = find (`elem` f server) (f client) + +supportedKex :: [ShortByteString] -> SshCookie -> SshProposal +supportedKex hostKeyAlgs cookie = + SshProposal + { sshKexAlgs = (map nameOf allKex) + , sshServerHostKeyAlgs = hostKeyAlgs + , sshEncAlgs = SshAlgs (map nameOf allCipher) (map nameOf allCipher) + , sshMacAlgs = SshAlgs (map nameOf allMac) (map nameOf allMac) + , sshCompAlgs = SshAlgs (map nameOf allCompression) (map nameOf allCompression) + , sshLanguages = SshAlgs [] [] + , sshFirstKexFollows = False + , sshProposalCookie = cookie + } + diff --git a/src/Network/SSH/Server.hs b/src/Network/SSH/Server.hs index ed3c4c0..d352ac1 100644 --- a/src/Network/SSH/Server.hs +++ b/src/Network/SSH/Server.hs @@ -13,31 +13,22 @@ module Network.SSH.Server ( ) where -import Network.SSH.Ciphers import Network.SSH.Connection -import Network.SSH.Compression -import Network.SSH.Keys -import Network.SSH.Mac import Network.SSH.Messages -import Network.SSH.Named import Network.SSH.Packet -import Network.SSH.PubKey +import Network.SSH.Rekey import Network.SSH.State import Control.Concurrent import Control.Monad (forever) import qualified Control.Exception as X -import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy as L -import Data.List (find) import Data.Monoid ((<>)) -import Data.IORef ( modifyIORef ) +import Data.IORef (writeIORef, readIORef) -- Public API ------------------------------------------------------------------ -type ServerCredential = Named (SshPubCert, PrivateKey) - data Server = Server { sAccept :: IO Client , sAuthenticationAlgs :: [ServerCredential] @@ -49,14 +40,15 @@ sshServer sock = forever $ do client <- sAccept sock forkIO $ - do state <- initialState + do state <- initialState (sAuthenticationAlgs sock) let v_s = sIdent sock v_c <- sayHello state client v_s - sessionId <- keyExchangePhase client state v_s v_c (sAuthenticationAlgs sock) + writeIORef (sshIdents state) (v_s,v_c) + initialKeyExchange client state -- Connection established! - result <- handleAuthentication state client sessionId + result <- handleAuthentication state client case result of Nothing -> send client state (SshMsgDisconnect SshDiscNoMoreAuthMethodsAvailable @@ -68,101 +60,6 @@ sshServer sock = forever $ `X.finally` cClose client -keyExchangePhase :: - Client -> - SshState -> - SshIdent {- ^ server -} -> - SshIdent {- ^ client -} -> - [ServerCredential] -> - IO SshSessionId {- ^ session id for client authentication -} -keyExchangePhase client state v_s v_c sAuth = - do (i_s, i_c) <- startKex state client (map nameOf sAuth) - suite <- maybe (fail "negotiation failed") return - $ computeSuite sAuth i_s i_c - - SshMsgKexDhInit pub_c <- receive client state - (pub_s, k) <- kexRun (suite_kex suite) pub_c - - let sid = SshSessionId - $ kexHash (suite_kex suite) - $ sshDhHash v_c v_s i_c i_s (suite_host_pub suite) pub_c pub_s k - - sig <- sign (suite_host_priv suite) sid - send client state (SshMsgKexDhReply (suite_host_pub suite) pub_s sig) - - installSecurity client state suite sid k - return sid - -data CipherSuite = CipherSuite - { suite_kex :: Kex - , suite_c2s_cipher, suite_s2c_cipher :: CipherKeys -> Cipher - , suite_c2s_mac , suite_s2c_mac :: L.ByteString -> Mac - , suite_c2s_comp , suite_s2c_comp :: Compression - , suite_host_priv :: PrivateKey - , suite_host_pub :: SshPubCert - } - --- | Compute a cipher suite given two proposals. The first algorithm --- requested by the client that the server also supports is selected. -computeSuite :: [ServerCredential] -> SshProposal -> SshProposal -> Maybe CipherSuite -computeSuite auths server client = - do let det = determineAlg server client - - suite_kex <- lookupNamed allKex =<< det sshKexAlgs - - c2s_cipher_name <- det (sshClientToServer.sshEncAlgs) - suite_c2s_cipher <- lookupNamed allCipher c2s_cipher_name - - s2c_cipher_name <- det (sshServerToClient.sshEncAlgs) - suite_s2c_cipher <- lookupNamed allCipher s2c_cipher_name - - suite_c2s_mac <- if c2s_cipher_name `elem` aeadModes - then Just (namedThing mac_none) - else lookupNamed allMac =<< det (sshClientToServer.sshMacAlgs) - - suite_s2c_mac <- if s2c_cipher_name `elem` aeadModes - then Just (namedThing mac_none) - else lookupNamed allMac =<< det (sshServerToClient.sshMacAlgs) - - (suite_host_pub, suite_host_priv) <- lookupNamed auths =<< det sshServerHostKeyAlgs - - s2c_comp_name <- det (sshServerToClient.sshCompAlgs) - suite_s2c_comp <- lookupNamed allCompression s2c_comp_name - - c2s_comp_name <- det (sshClientToServer.sshCompAlgs) - suite_c2s_comp <- lookupNamed allCompression c2s_comp_name - - return CipherSuite{..} - --- | Select first client choice acceptable to the server -determineAlg :: - SshProposal {- ^ server -} -> - SshProposal {- ^ client -} -> - (SshProposal -> [ShortByteString]) {- ^ selector -} -> - Maybe ShortByteString -determineAlg server client f = find (`elem` f server) (f client) - --- | Install new keys (and algorithms) into the SshState. -transitionKeysOutgoing :: CipherSuite -> Keys -> SshState -> IO () -transitionKeysOutgoing CipherSuite{..} Keys{..} SshState{..} = - do compress <- makeCompress suite_s2c_comp - modifyMVar_ sshSendState $ \(seqNum,_,_,_,drg) -> - return ( seqNum - , suite_s2c_cipher k_s2c_cipherKeys - , suite_s2c_mac k_s2c_integKey - , compress - , drg - ) - -transitionKeysIncoming :: CipherSuite -> Keys -> SshState -> IO () -transitionKeysIncoming CipherSuite{..} Keys{..} SshState{..} = - do decompress <- makeDecompress suite_c2s_comp - modifyIORef sshRecvState $ \(seqNum, _, _, _) -> - ( seqNum - , suite_c2s_cipher k_c2s_cipherKeys - , suite_c2s_mac k_c2s_integKey - , decompress - ) -- | Exchange identification information sayHello :: SshState -> Client -> SshIdent -> IO SshIdent @@ -171,49 +68,14 @@ sayHello state client v_s = -- parseFrom used because ident doesn't use the normal framing parseFrom client (sshBuf state) getSshIdent -supportedKex :: [ShortByteString] -> SshCookie -> SshProposal -supportedKex hostKeyAlgs cookie = - SshProposal - { sshKexAlgs = (map nameOf allKex) - , sshServerHostKeyAlgs = hostKeyAlgs - , sshEncAlgs = SshAlgs (map nameOf allCipher) (map nameOf allCipher) - , sshMacAlgs = SshAlgs (map nameOf allMac) (map nameOf allMac) - , sshCompAlgs = SshAlgs (map nameOf allCompression) (map nameOf allCompression) - , sshLanguages = SshAlgs [] [] - , sshFirstKexFollows = False - , sshProposalCookie = cookie - } - -startKex :: - SshState -> Client -> [ShortByteString] -> - IO (SshProposal, SshProposal) -startKex state client hostKeyAlgs = - do let i_s = supportedKex hostKeyAlgs (sshCookie state) - send client state (SshMsgKexInit i_s) - SshMsgKexInit i_c <- receive client state - return (i_s, i_c) - -installSecurity :: - Client -> SshState -> CipherSuite -> - SshSessionId -> - S.ByteString {- ^ shared secret -} -> - IO () -installSecurity client state suite sid k = - do let keys = genKeys (kexHash (suite_kex suite)) k sid - - send client state SshMsgNewKeys - transitionKeysOutgoing suite keys state - - SshMsgNewKeys <- receive client state - transitionKeysIncoming suite keys state - handleAuthentication :: - SshState -> Client -> SshSessionId -> IO (Maybe (S.ByteString, SshService)) -handleAuthentication state client session_id = + SshState -> Client -> IO (Maybe (S.ByteString, SshService)) +handleAuthentication state client = do let notAvailable = send client state $ SshMsgDisconnect SshDiscServiceNotAvailable "" "" + Just session_id <- readIORef (sshSessionId state) req <- receive client state case req of diff --git a/src/Network/SSH/State.hs b/src/Network/SSH/State.hs index 62e119a..0986192 100644 --- a/src/Network/SSH/State.hs +++ b/src/Network/SSH/State.hs @@ -11,6 +11,7 @@ import Network.SSH.Mac import Network.SSH.Messages import Network.SSH.Named import Network.SSH.Packet +import Network.SSH.PubKey (PrivateKey) import Network.SSH.TerminalModes import Data.IORef @@ -72,12 +73,16 @@ data SshState = SshState { sshRecvState :: !(IORef (Word32, Cipher, Mac, CompressFun)) -- ^ Client context , sshBuf :: !(IORef S.ByteString) , sshSendState :: !(MVar (Word32, Cipher, Mac, CompressFun, ChaChaDRG)) -- ^ Server encryption context - , sshCookie :: SshCookie + , sshSessionId :: !(IORef (Maybe SshSessionId)) + , sshAuthMethods :: [ServerCredential] + , sshIdents :: !(IORef (SshIdent, SshIdent)) -- server, client } +type ServerCredential = Named (SshPubCert, PrivateKey) -initialState :: IO SshState -initialState = + +initialState :: [ServerCredential] -> IO SshState +initialState creds = do drg <- drgNew sshRecvState <- newIORef (0,namedThing cipher_none nullKeys ,namedThing mac_none "" @@ -87,7 +92,9 @@ initialState = ,return . L.fromStrict -- no compression ,drg) sshBuf <- newIORef S.empty - sshCookie <- newCookie + sshSessionId <- newIORef Nothing + sshIdents <- newIORef (error "idents uninitialized") + let sshAuthMethods = creds return SshState { .. } -- | Construct a new, random cookie diff --git a/ssh-hans.cabal b/ssh-hans.cabal index a690cdc..2618bc3 100644 --- a/ssh-hans.cabal +++ b/ssh-hans.cabal @@ -23,6 +23,7 @@ library Network.SSH.Messages Network.SSH.Protocol Network.SSH.Packet + Network.SSH.Rekey Network.SSH.TerminalModes Network.SSH.PrivateKeyFormat Network.SSH.Named