tls 1.0.2 → 1.0.3
raw patch · 11 files changed
+127/−26 lines, 11 filesdep ~cprng-aes
Dependency ranges changed: cprng-aes
Files
- Network/TLS/Context.hs +21/−7
- Network/TLS/Core.hs +5/−0
- Network/TLS/Handshake/Client.hs +1/−1
- Network/TLS/Handshake/Server.hs +1/−1
- Network/TLS/IO.hs +28/−4
- Network/TLS/Packet.hs +43/−3
- Network/TLS/Receiving.hs +7/−2
- Network/TLS/Struct.hs +9/−5
- Tests.hs +1/−0
- Tests/PubKey.hs +1/−1
- tls.cabal +10/−2
Network/TLS/Context.hs view
@@ -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.
Network/TLS/Core.hs view
@@ -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
Network/TLS/Handshake/Client.hs view
@@ -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
Network/TLS/Handshake/Server.hs view
@@ -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")
Network/TLS/IO.hs view
@@ -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
Network/TLS/Packet.hs view
@@ -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
Network/TLS/Receiving.hs view
@@ -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)
Network/TLS/Struct.hs view
@@ -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
Tests.hs view
@@ -93,6 +93,7 @@ <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs <*> (return [])+ <*> (return Nothing) , ServerHello <$> arbitrary <*> arbitrary
Tests/PubKey.hs view
@@ -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
tls.cabal view
@@ -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