From f59804f459edebd0aef4891ae8a627f125b04b3a Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Wed, 24 Jul 2013 05:50:56 +0000 Subject: [PATCH] move processServerHello in Handshake --- core/Network/TLS/Extension.hs | 13 ++++++------- core/Network/TLS/Handshake/Client.hs | 22 ++++++++++++++++++++-- core/Network/TLS/Handshake/Server.hs | 4 ++-- core/Network/TLS/Receiving.hs | 21 +-------------------- core/Network/TLS/State.hs | 4 ++-- debug/src/SimpleClient.hs | 28 +++++++++++++++++----------- 6 files changed, 48 insertions(+), 44 deletions(-) diff --git a/core/Network/TLS/Extension.hs b/core/Network/TLS/Extension.hs index 382da6e..da584f9 100644 --- a/core/Network/TLS/Extension.hs +++ b/core/Network/TLS/Extension.hs @@ -110,13 +110,12 @@ instance Extension SecureRenegotiation where extensionID _ = extensionID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd) - extensionDecode isServerHello = runGetMaybe getSecureReneg - where getSecureReneg = do - opaque <- getOpaque8 - if isServerHello - then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque - in return $ SecureRenegotiation cvd (Just svd) - else return $ SecureRenegotiation opaque Nothing + extensionDecode isServerHello = runGetMaybe $ do + opaque <- getOpaque8 + if isServerHello + then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque + in return $ SecureRenegotiation cvd (Just svd) + else return $ SecureRenegotiation opaque Nothing -- | Next Protocol Negotiation data NextProtocolNegotiation = NextProtocolNegotiation [ByteString] diff --git a/core/Network/TLS/Handshake/Client.hs b/core/Network/TLS/Handshake/Client.hs index 6ad9f00..b9ef76e 100644 --- a/core/Network/TLS/Handshake/Client.hs +++ b/core/Network/TLS/Handshake/Client.hs @@ -20,9 +20,9 @@ import Network.TLS.Extension import Network.TLS.IO import Network.TLS.State hiding (getNegotiatedProtocol) import Network.TLS.Sending -import Network.TLS.Receiving import Network.TLS.Measurement import Network.TLS.Wire (encodeWord16) +import Network.TLS.Util (bytesEq) import Network.TLS.Types import Network.TLS.X509 import Data.Maybe @@ -32,6 +32,7 @@ import Data.ByteString.Char8 () import Control.Applicative ((<$>)) import Control.Monad.State +import Control.Monad.Error import Control.Exception (SomeException) import qualified Control.Exception as E @@ -65,7 +66,7 @@ handshakeClient cparams ctx = do secureReneg = if pUseSecureRenegotiation params - then usingState_ ctx (getVerifiedData True) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing + then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing npnExtention = if isJust $ onNPNServerSuggest cparams then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] @@ -261,6 +262,23 @@ sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertifi _ -> return () +processServerHello :: Handshake -> TLSSt () +processServerHello (ServerHello sver ran _ _ _ ex) = do + -- FIXME notify the user to take action if the extension requested is missing + -- secreneg <- getSecureRenegotiation + -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ... + mapM_ processServerExtension ex + withHandshakeM $ setServerRandom ran + setVersion sver + where processServerExtension (0xff01, content) = do + cv <- getVerifiedData ClientRole + sv <- getVerifiedData ServerRole + let bs = extensionEncode (SecureRenegotiation cv $ Just sv) + unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) + return () + + processServerExtension _ = return () +processServerHello _ = error "processServerHello called on wrong type" throwMiscErrorOnException :: MonadIO m => String -> SomeException -> m a throwMiscErrorOnException msg e = diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs index 436df06..ae53a5b 100644 --- a/core/Network/TLS/Handshake/Server.hs +++ b/core/Network/TLS/Handshake/Server.hs @@ -147,8 +147,8 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip secRengExt <- if secReneg then do vf <- usingState_ ctx $ do - cvf <- getVerifiedData True - svf <- getVerifiedData False + cvf <- getVerifiedData ClientRole + svf <- getVerifiedData ServerRole return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ (0xff01, vf) ] else return [] diff --git a/core/Network/TLS/Receiving.hs b/core/Network/TLS/Receiving.hs index bcd6cf5..9c7f92d 100644 --- a/core/Network/TLS/Receiving.hs +++ b/core/Network/TLS/Receiving.hs @@ -11,7 +11,6 @@ module Network.TLS.Receiving ( processHandshake , processPacket - , processServerHello , verifyRSA ) where @@ -90,7 +89,7 @@ processHandshake hs = do when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ withHandshakeM $ updateHandshakeDigest encoded where -- secure renegotiation processClientExtension (0xff01, content) = do - v <- getVerifiedData True + v <- getVerifiedData ClientRole let bs = extensionEncode (SecureRenegotiation v Nothing) unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure) @@ -114,24 +113,6 @@ verifyRSA hsh econtent sign = do rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get return $ kxVerify rsapriv hsh econtent sign -processServerHello :: Handshake -> TLSSt () -processServerHello (ServerHello sver ran _ _ _ ex) = do - -- FIXME notify the user to take action if the extension requested is missing - -- secreneg <- getSecureRenegotiation - -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ... - mapM_ processServerExtension ex - withHandshakeM $ setServerRandom ran - setVersion sver - where processServerExtension (0xff01, content) = do - cv <- getVerifiedData True - sv <- getVerifiedData False - let bs = extensionEncode (SecureRenegotiation cv $ Just sv) - unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) - return () - - processServerExtension _ = return () -processServerHello _ = error "processServerHello called on wrong type" - -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negotiated version. -- in case the version mismatch, generate a random master secret diff --git a/core/Network/TLS/State.hs b/core/Network/TLS/State.hs index 40b098d..8ff6084 100644 --- a/core/Network/TLS/State.hs +++ b/core/Network/TLS/State.hs @@ -242,8 +242,8 @@ setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Jus getClientCertificateChain :: MonadState TLSState m => m (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain -getVerifiedData :: MonadState TLSState m => Bool -> m Bytes -getVerifiedData client = gets (if client then stClientVerifiedData else stServerVerifiedData) +getVerifiedData :: MonadState TLSState m => Role -> m Bytes +getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: MonadState TLSState m => m Role isClientContext = getRecordState stClientContext diff --git a/debug/src/SimpleClient.hs b/debug/src/SimpleClient.hs index 8638340..d9ae15a 100644 --- a/debug/src/SimpleClient.hs +++ b/debug/src/SimpleClient.hs @@ -82,6 +82,7 @@ data Flag = Verbose | Debug | NoValidateCert | Session | Http11 | NoSNI | Uri String | UserAgent String + | Output String | Help deriving (Show,Eq) @@ -90,6 +91,7 @@ options = [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout" , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout" , Option ['s'] ["session"] (NoArg Session) "try to resume a session" + , Option ['O'] ["output"] (ReqArg Output "stdout") "output " , Option [] ["no-validation"] (NoArg NoValidateCert) "disable certificate validation" , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0" , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0 as default" @@ -106,7 +108,7 @@ runOn (sStorage, certStore) flags port hostname = do when (Session `elem` flags) $ do session <- readIORef sStorage doTLS (Just session) - where doTLS sess = do + where doTLS sess = do let query = LC.pack ( "GET " ++ findURI flags @@ -114,27 +116,31 @@ runOn (sStorage, certStore) flags port hostname = do ++ userAgent ++ "\r\n\r\n") when (Verbose `elem` flags) (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "") + out <- maybe (return stdout) (flip openFile WriteMode) getOutput runTLS (getDefaultParams flags hostname certStore sStorage sess) hostname port $ \ctx -> do handshake ctx sendData ctx $ query - loopRecv ctx + loopRecv out ctx bye ctx return () - loopRecv ctx = do + loopRecv out ctx = do d <- timeout 2000000 (recvData ctx) -- 2s per recv case d of Nothing -> when (Debug `elem` flags) (hPutStrLn stderr "timeout") >> return () Just b | BC.null b -> return () - | otherwise -> BC.putStrLn b >> loopRecv ctx + | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx - findURI [] = "/" - findURI (Uri u:_) = u - findURI (_:xs) = findURI xs + findURI [] = "/" + findURI (Uri u:_) = u + findURI (_:xs) = findURI xs - userAgent = maybe "" (\s -> "\r\nUser-Agent: " ++ s) mUserAgent - mUserAgent = foldl f Nothing flags - where f _ (UserAgent ua) = Just ua - f acc _ = acc + userAgent = maybe "" (\s -> "\r\nUser-Agent: " ++ s) mUserAgent + mUserAgent = foldl f Nothing flags + where f _ (UserAgent ua) = Just ua + f acc _ = acc + getOutput = foldl f Nothing flags + where f _ (Output o) = Just o + f acc _ = acc printUsage = putStrLn $ usageInfo "usage: simpleclient [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options