diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -36,6 +36,8 @@ , ctxParams , ctxConnection , ctxEOF + , ctxHasSSLv2ClientHello + , ctxDisableSSLv2ClientHello , ctxEstablished , ctxLogging , setEOF @@ -271,12 +273,15 @@ -- | A TLS Context keep tls specific state, parameters and backend information. data Context = Context - { ctxConnection :: Backend -- ^ return the backend object associated with this context - , ctxParams :: Params - , ctxState :: MVar TLSState - , ctxMeasurement :: IORef Measurement - , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. - , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. + { ctxConnection :: Backend -- ^ return the backend object associated with this context + , ctxParams :: Params + , ctxState :: MVar TLSState + , ctxMeasurement :: IORef Measurement + , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. + , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful. + , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. + -- the flag will be set to false regardless of its initial value + -- after the first packet received. } -- deprecated types, setup as aliases for compatibility. @@ -309,6 +314,12 @@ ctxEOF :: MonadIO m => Context -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx) +ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool +ctxHasSSLv2ClientHello ctx = liftIO (readIORef $ ctxSSLv2ClientHello ctx) + +ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m () +ctxDisableSSLv2ClientHello ctx = liftIO (writeIORef (ctxSSLv2ClientHello ctx) False) + setEOF :: MonadIO m => Context -> m () setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True @@ -328,7 +339,6 @@ -> rng -- ^ Random number generator associated with this context. -> m Context contextNew backend params rng = liftIO $ do - let clientContext = case roleParams params of Client {} -> True Server {} -> False @@ -338,6 +348,9 @@ eof <- newIORef False established <- newIORef False stats <- newIORef newMeasurement + -- we enable the reception of SSLv2 ClientHello message only in the + -- server context, where we might be dealing with an old/compat client. + sslv2Compat <- newIORef (not clientContext) return $ Context { ctxConnection = backend , ctxParams = params @@ -345,6 +358,7 @@ , ctxMeasurement = stats , ctxEOF_ = eof , ctxEstablished_ = established + , ctxSSLv2ClientHello = sslv2Compat } -- | create a new context on an handle. diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -71,6 +71,11 @@ pkt <- recvPacket ctx case pkt of -- on server context receiving a client hello == renegotiation + Right (Handshake [(ClientHello _ _ _ _ _ _ (Just _))]) -> + -- reject renegotiation with SSLv2 header + case roleParams $ ctxParams ctx of + Server _ -> error "assert, deprecated hello request in server context" + Client {} -> error "assert, unexpected client hello in client context" Right (Handshake [ch@(ClientHello {})]) -> case roleParams $ ctxParams ctx of Server sparams -> handshakeServerWith sparams ctx ch >> recvData ctx diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -77,7 +77,7 @@ usingState_ ctx (startHandshakeClient (pConnectVersion params) crand) sendPacket ctx $ Handshake [ ClientHello (pConnectVersion params) crand clientSession (map cipherID ciphers) - (map compressionID compressions) extensions + (map compressionID compressions) extensions Nothing ] return $ map fst extensions diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -77,7 +77,7 @@ -- -> finish <- finish -- handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m () -handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts) = do +handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx) unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.IO -- License : BSD-style @@ -50,21 +51,43 @@ else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs -recvRecord :: MonadIO m => Context -> m (Either TLSError (Record Plaintext)) -recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader +recvRecord :: MonadIO m => Bool -- ^ flag to enable SSLv2 compat ClientHello reception + -> Context -- ^ TLS context + -> m (Either TLSError (Record Plaintext)) +recvRecord compatSSLv2 ctx +#ifdef SSLV2_COMPATIBLE + | compatSSLv2 = do + header <- readExact ctx 2 + if B.head header < 0x80 + then readExact ctx 3 >>= either (return . Left) recvLength . decodeHeader . B.append header + else either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header +#endif + | otherwise = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader where recvLength header@(Header _ _ readlen) - | readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow) + | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded + | otherwise = readExact ctx (fromIntegral readlen) >>= makeRecord header +#ifdef SSLV2_COMPATIBLE + recvDeprecatedLength readlen + | readlen > 1024 * 4 = return $ Left maximumSizeExceeded | otherwise = do content <- readExact ctx (fromIntegral readlen) + case decodeDeprecatedHeader readlen content of + Left err -> return $ Left err + Right header -> makeRecord header content +#endif + maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) + makeRecord header content = do liftIO $ (loggingIORecv $ ctxLogging ctx) header content usingState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) + -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket :: MonadIO m => Context -> m (Either TLSError Packet) recvPacket ctx = do - erecord <- recvRecord ctx + compatSSLv2 <- ctxHasSSLv2ClientHello ctx + erecord <- recvRecord compatSSLv2 ctx case erecord of Left err -> return $ Left err Right record -> do @@ -72,6 +95,7 @@ case pkt of Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p _ -> return () + ctxDisableSSLv2ClientHello ctx return pkt -- | Send one packet to the context diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -15,6 +15,8 @@ CurrentParams(..) -- * marshall functions for header messages , decodeHeader + , decodeDeprecatedHeaderLength + , decodeDeprecatedHeader , encodeHeader , encodeHeaderNoVer -- use for SSL3 @@ -26,6 +28,7 @@ -- * marshall functions for handshake messages , decodeHandshakes , decodeHandshake + , decodeDeprecatedHandshake , encodeHandshake , encodeHandshakes , encodeHandshakeHeader @@ -52,6 +55,7 @@ import Network.TLS.Cap import Data.Either (partitionEithers) import Data.Maybe (fromJust) +import Data.Word import Data.Bits ((.|.)) import Control.Applicative ((<$>)) import Control.Monad @@ -109,6 +113,16 @@ decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ liftM3 Header getHeaderType getVersion getWord16 +decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 +decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16 + +decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header +decodeDeprecatedHeader size = + runGetErr "deprecatedheader" $ do + 1 <- getWord8 + version <- getVersion + return $ Header ProtocolType_DeprecatedHandshake version size + encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len) {- FIXME check len <= 2^14 -} @@ -173,6 +187,28 @@ unless (cParamsSupportNPN cp) $ fail "unsupported handshake type" decodeNextProtocolNegotiation +decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake +decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where + getDeprecated = do + 1 <- getWord8 + ver <- getVersion + cipherSpecLen <- fromEnum <$> getWord16 + sessionIdLen <- fromEnum <$> getWord16 + challengeLen <- fromEnum <$> getWord16 + ciphers <- getCipherSpec cipherSpecLen + session <- getSessionId sessionIdLen + random <- getChallenge challengeLen + let compressions = [0] + return $ ClientHello ver random session ciphers compressions [] (Just b) + getCipherSpec len | len < 3 = return [] + getCipherSpec len = do + [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 + ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) + getSessionId 0 = return $ Session Nothing + getSessionId len = Session . Just <$> getBytes len + getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 + getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len + decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest @@ -187,7 +223,7 @@ exts <- if hasHelloExtensions ver && r > 0 then fmap fromIntegral getWord16 >>= getExtensions else return [] - return $ ClientHello ver random session ciphers compressions exts + return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do @@ -300,7 +336,9 @@ encodeHandshake o = let content = runPut $ encodeHandshakeContent o in let len = fromIntegral $ B.length content in - let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in + let header = case o of + ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message + _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in B.concat [ header, content ] encodeHandshakes :: [Handshake] -> ByteString @@ -311,7 +349,9 @@ encodeHandshakeContent :: Handshake -> Put -encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do +encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do + putBytes deprecated +encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do putVersion version putClientRandom32 random putSession session diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -58,11 +58,16 @@ Right hs -> return hs return $ Handshake hss +processPacket (Record ProtocolType_DeprecatedHandshake _ fragment) = + case decodeDeprecatedHandshake $ fragmentGetBytes fragment of + Left err -> throwError err + Right hs -> return $ Handshake [hs] + processHandshake :: Handshake -> TLSSt () processHandshake hs = do clientmode <- isClientContext case hs of - ClientHello cver ran _ _ _ ex -> unless clientmode $ do + ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do mapM_ processClientExtension ex startHandshakeClient cver ran Certificates certs -> processCertificates clientmode certs @@ -143,7 +148,7 @@ processCertificates :: Bool -> [X509] -> TLSSt () processCertificates clientmode certs = do - if null certs + if null certs then when (clientmode) $ throwError $ Error_Protocol ("server certificate missing", True, HandshakeFailure) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -108,6 +108,7 @@ | ProtocolType_Alert | ProtocolType_Handshake | ProtocolType_AppData + | ProtocolType_DeprecatedHandshake deriving (Eq, Show) -- | TLSError that might be returned through the TLS stack @@ -233,8 +234,10 @@ | SKX_Unknown Bytes deriving (Show,Eq) +type DeprecatedRecord = ByteString + data Handshake = - ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] + ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] | Certificates [X509] | HelloRequest @@ -304,10 +307,11 @@ valToType _ = Nothing instance TypeValuable ProtocolType where - valOfType ProtocolType_ChangeCipherSpec = 20 - valOfType ProtocolType_Alert = 21 - valOfType ProtocolType_Handshake = 22 - valOfType ProtocolType_AppData = 23 + valOfType ProtocolType_ChangeCipherSpec = 20 + valOfType ProtocolType_Alert = 21 + valOfType ProtocolType_Handshake = 22 + valOfType ProtocolType_AppData = 23 + valOfType ProtocolType_DeprecatedHandshake = 128 -- unused valToType 20 = Just ProtocolType_ChangeCipherSpec valToType 21 = Just ProtocolType_Alert diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -93,6 +93,7 @@ <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs <*> (return []) + <*> (return Nothing) , ServerHello <$> arbitrary <*> arbitrary diff --git a/Tests/PubKey.hs b/Tests/PubKey.hs --- a/Tests/PubKey.hs +++ b/Tests/PubKey.hs @@ -16,7 +16,7 @@ arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) arbitraryRSAPair = do - rng <- (either (error . show) id . RNG.make . B.pack) `fmap` vector 64 + rng <- (maybe (error "making rng") id . RNG.make . B.pack) `fmap` vector 64 arbitraryRSAPairWithRNG rng arbitraryRSAPairWithRNG rng = case RSA.generate rng 128 65537 of diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 1.0.2 +Version: 1.0.3 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -34,6 +34,10 @@ Description: Build the executable Default: False +Flag compat + Description: Accept SSLv2 compatible handshake + Default: True + Library Build-Depends: base >= 3 && < 5 , mtl @@ -78,6 +82,8 @@ ghc-options: -Wall if impl(ghc == 7.6.1) ghc-options: -O0 + if flag(compat) + cpp-options: -DSSLV2_COMPATIBLE executable Tests Main-is: Tests.hs @@ -93,13 +99,15 @@ , time , cryptocipher >= 0.3.0 && < 0.4.0 , network - , cprng-aes + , cprng-aes >= 0.3.0 , cryptohash >= 0.6 , certificate >= 1.3.0 && < 1.4.0 , crypto-api >= 0.5 else Buildable: False ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fhpc + if flag(compat) + cpp-options: -DSSLV2_COMPATIBLE source-repository head type: git