From 2ed8c777b6f7e0bec2d05f52d8d5f2579537d1c0 Mon Sep 17 00:00:00 2001 From: Lennart Kolmodin Date: Thu, 16 Feb 2012 12:05:46 +0400 Subject: [PATCH] Add client side of Next Protocol Negotiation. --- Network/TLS/Context.hs | 2 ++ Network/TLS/Core.hs | 35 ++++++++++++++++++++++++++++------- Network/TLS/State.hs | 10 ++++++++++ Network/TLS/Wire.hs | 10 ++++++++++ 4 files changed, 50 insertions(+), 7 deletions(-) diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs index f920225..cf219ad 100644 --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -85,6 +85,7 @@ data TLSParams = TLSParams , onSessionEstablished :: SessionID -> SessionData -> IO () -- ^ callback when session have been established , onSessionInvalidated :: SessionID -> IO () -- ^ callback when session is invalidated by error , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- ^ suggested next protocols accoring to the next protocol negotiation extension. + , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) , sessionResumeWith :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session. } @@ -113,6 +114,7 @@ defaultParams = TLSParams , onSessionEstablished = (\_ _ -> return ()) , onSessionInvalidated = (\_ -> return ()) , onSuggestNextProtocols = return Nothing + , onNPNServerSuggest = Nothing , sessionResumeWith = Nothing } diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs index e18fa53..16cb6a6 100644 --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -44,7 +44,7 @@ import Network.TLS.State as S import Network.TLS.Sending import Network.TLS.Receiving import Network.TLS.Measurement -import Network.TLS.Wire (encodeWord16, encodeNPNAlternatives) +import Network.TLS.Wire (encodeWord16, encodeNPNAlternatives, decodeNPNAlternatives) import Data.Maybe import Data.Data import Data.List (intersect, find) @@ -147,6 +147,17 @@ runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState > sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m () sendChangeCipherAndFinish ctx isClient = do sendPacket ctx ChangeCipherSpec + when isClient $ do + suggest <- usingState_ ctx $ getServerNextProtocolSuggest + case (onNPNServerSuggest (ctxParams ctx), suggest) of + -- client offered, server picked up. send NPN handshake. + (Just io, Just protos) -> do proto <- liftIO $ io protos + sendPacket ctx (Handshake [NextProtocolNegotiation proto]) + usingState_ ctx $ setNegotiatedProtocol proto + -- client offered, server didn't pick up. do nothing. + (Just _, Nothing) -> return () + -- client didn't offer. do nothing. + (Nothing, _) -> return () liftIO $ connectionFlush ctx cf <- usingState_ ctx $ getHandshakeDigest isClient sendPacket ctx (Handshake [Finished cf]) @@ -263,11 +274,14 @@ handshakeClient ctx = do ciphers = pCiphers params compressions = pCompressions params clientCerts = map fst $ pCertificates params - getExtensions = + getExtensions = sequence [secureReneg, npnExtention] >>= return . catMaybes + secureReneg = if pUseSecureRenegotiation params - then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ] - else return [] - + then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just (0xff01, encodeExtSecureRenegotiation vd Nothing) + else return Nothing + npnExtention = if isJust $ onNPNServerSuggest params + then return $ Just (13172, "") + else return Nothing sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom let clientSession = Session . maybe Nothing (Just . fst) $ sessionResumeWith params @@ -296,7 +310,7 @@ handshakeClient ctx = do recvServerHello = runRecvState ctx (RecvStateHandshake onServerHello) onServerHello :: MonadIO m => Handshake -> m (RecvState m) - onServerHello sh@(ServerHello rver _ serverSession cipher _ _) = do + onServerHello sh@(ServerHello rver _ serverSession cipher _ exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) @@ -310,6 +324,12 @@ handshakeClient ctx = do Nothing -> Nothing usingState_ ctx $ setSession serverSession (isJust resumingSession) usingState_ ctx $ processServerHello sh + case fmap decodeNPNAlternatives (lookup 13172 exts) of + Just (Right protos) -> usingState_ ctx $ do + setExtensionNPN True + setServerNextProtocolSuggest protos + Just (Left err) -> throwCore (Error_Protocol ("could not decode NPN handshake: " ++ err, True, DecodeError)) + Nothing -> return () case resumingSession of Nothing -> return $ RecvStateHandshake processCertificate Just sessionData -> do @@ -466,7 +486,8 @@ handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession ciphers com then liftIO $ onSuggestNextProtocols params else return Nothing npnExt <- case nextProtocols of - Just protos -> do usingState_ ctx $ setExtensionNPN True + Just protos -> do usingState_ ctx $ do setExtensionNPN True + setServerNextProtocolSuggest protos return [ (13172, encodeNPNAlternatives protos) ] Nothing -> return [] let extensions = secRengExt ++ npnExt diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs index 77739e4..6acd6d6 100644 --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -39,6 +39,8 @@ module Network.TLS.State , getExtensionNPN , setNegotiatedProtocol , getNegotiatedProtocol + , setServerNextProtocolSuggest + , getServerNextProtocolSuggest , getVerifiedData , setSession , getSession @@ -120,6 +122,7 @@ data TLSState = TLSState , stServerVerifiedData :: Bytes -- RFC 5746 , stExtensionNPN :: Bool -- NPN draft extension , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol + , stServerNextProtocolSuggest :: Maybe [B.ByteString] } deriving (Show) newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a } @@ -156,6 +159,7 @@ newTLSState rng = TLSState , stServerVerifiedData = B.empty , stExtensionNPN = False , stNegotiatedProtocol = Nothing + , stServerNextProtocolSuggest = Nothing } withTLSRNG :: StateRNG -> (forall g . CryptoRandomGen g => g -> Either e (a,g)) -> Either e (a, StateRNG) @@ -336,6 +340,12 @@ setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s }) getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString) getNegotiatedProtocol = get >>= return . stNegotiatedProtocol +setServerNextProtocolSuggest :: MonadState TLSState m => [B.ByteString] -> m () +setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps}) + +getServerNextProtocolSuggest :: MonadState TLSState m => m (Maybe [B.ByteString]) +getServerNextProtocolSuggest = get >>= return . stServerNextProtocolSuggest + getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType) getCipherKeyExchangeType = get >>= return . (maybe Nothing (Just . cipherKeyExchange) . stCipher) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs index 55d8b59..e0f3ffc 100644 --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -37,6 +37,7 @@ module Network.TLS.Wire , encodeWord16 , encodeWord64 , encodeNPNAlternatives + , decodeNPNAlternatives ) where import Data.Serialize.Get hiding (runGet) @@ -120,3 +121,12 @@ encodeWord64 = runPut . putWord64be encodeNPNAlternatives :: [Bytes] -> Bytes encodeNPNAlternatives = runPut . mapM_ putOpaque8 + +decodeNPNAlternatives :: Bytes -> Either String [Bytes] +decodeNPNAlternatives = runGet "" p + where + p = do + avail <- remaining + case avail of + 0 -> return [] + _ -> do liftM2 (:) getOpaque8 p