tls 1.2.2 → 1.2.3
raw patch · 12 files changed
+79/−58 lines, 12 filesdep +byteable
Dependencies added: byteable
Files
- CHANGELOG.md +3/−0
- Network/TLS/Backend.hs +4/−4
- Network/TLS/Core.hs +0/−13
- Network/TLS/Internal.hs +2/−0
- Network/TLS/Packet.hs +4/−13
- Network/TLS/Receiving.hs +21/−13
- Network/TLS/Record.hs +0/−1
- Network/TLS/Record/Types.hs +3/−3
- Network/TLS/State.hs +4/−1
- Network/TLS/Wire.hs +26/−4
- Tests/Marshalling.hs +5/−1
- tls.cabal +7/−5
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## Version 1.2.3 (22 Mar 2014)++- Fixed handshake records not being able to span multiples records.
Network/TLS/Backend.hs view
@@ -5,11 +5,11 @@ -- Stability : experimental -- Portability : unknown ----- Backend represent a unified way to do IO on differents--- types without burdening our calling API with multiples--- way to initialize a new context.+-- A Backend represents a unified way to do IO on different+-- types without burdening our calling API with multiple+-- ways to initialize a new context. ----- Typically any backend much implement:+-- Typically, a backend provides: -- * a way to read data -- * a way to write data -- * a way to close the stream
Network/TLS/Core.hs view
@@ -81,21 +81,8 @@ process (Handshake [ch@(ClientHello {})]) = withRWLock ctx ((ctxDoHandshakeWith ctx) ctx ch) >> recvData ctx- {-- case roleParams $ ctxParams ctx of- Server sparams -> withRWLock ctx (handshakeServerWith sparams ctx ch) >> recvData ctx- Client {} -> let reason = "unexpected client hello in client context" in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- -} process (Handshake [hr@HelloRequest]) = withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hr) >> recvData ctx- {-- -- on client context, receiving a hello request == renegotiation- case roleParams $ ctxParams ctx of- Server {} -> let reason = "unexpected hello request in server context" in- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Client cparams -> withRWLock ctx (handshakeClient cparams ctx) >> recvData ctx- -} process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do
Network/TLS/Internal.hs view
@@ -11,6 +11,7 @@ , module Network.TLS.Packet , module Network.TLS.Receiving , module Network.TLS.Sending+ , module Network.TLS.Wire , sendPacket , recvPacket ) where@@ -19,4 +20,5 @@ import Network.TLS.Packet import Network.TLS.Receiving import Network.TLS.Sending+import Network.TLS.Wire import Network.TLS.Core (sendPacket, recvPacket)
Network/TLS/Packet.hs view
@@ -26,7 +26,7 @@ , encodeAlerts -- * marshall functions for handshake messages- , decodeHandshakes+ , decodeHandshakeRecord , decodeHandshake , decodeDeprecatedHandshake , encodeHandshake@@ -157,23 +157,14 @@ where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad) {- decode and encode HANDSHAKE -}-decodeHandshakeHeader :: Get (HandshakeType, Bytes)-decodeHandshakeHeader = do+decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, Bytes)+decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType content <- getOpaque24 return (ty, content) -decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]-decodeHandshakes b = runGetErr "handshakes" getAll b- where getAll = do- x <- decodeHandshakeHeader- empty <- isEmpty- if empty- then return [x]- else liftM ((:) x) getAll- decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake-decodeHandshake cp ty = runGetErr "handshake" $ case ty of+decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello HandshakeType_ServerHello -> decodeServerHello
Network/TLS/Receiving.hs view
@@ -20,23 +20,22 @@ import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet+import Network.TLS.Wire import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util -returnEither :: Either TLSError a -> TLSSt a-returnEither (Left err) = throwError err-returnEither (Right a) = return a+import Data.Byteable processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) -processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment+processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ toBytes fragment -processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` (decodeAlerts $ fragmentGetBytes fragment))+processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` (decodeAlerts $ toBytes fragment)) processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ case decodeChangeCipherSpec $ toBytes fragment of Left err -> return $ Left err Right _ -> do switchRxEncryption ctx return $ Right ChangeCipherSpec@@ -45,20 +44,29 @@ keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do npn <- getExtensionNPN- let currentparams = CurrentParams+ let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg , cParamsSupportNPN = npn }- handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)- hss <- forM handshakes $ \(ty, content) -> do- case decodeHandshake currentparams ty content of- Left err -> throwError err- Right hs -> return hs+ -- get back the optional continuation, and parse as many handshake record as possible.+ mCont <- gets stHandshakeRecordCont+ modify (\st -> st { stHandshakeRecordCont = Nothing })+ hss <- parseMany currentParams mCont (toBytes fragment) return $ Handshake hss+ where parseMany currentParams mCont bs =+ case maybe decodeHandshakeRecord id mCont $ bs of+ GotError err -> throwError err+ GotPartial cont -> modify (\st -> st { stHandshakeRecordCont = Just cont }) >> return []+ GotSuccess (ty,content) ->+ either throwError (return . (:[])) $ decodeHandshake currentParams ty content+ GotSuccessRemaining (ty,content) left ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right hh -> (hh:) `fmap` parseMany currentParams Nothing left processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) =- case decodeDeprecatedHandshake $ fragmentGetBytes fragment of+ case decodeDeprecatedHandshake $ toBytes fragment of Left err -> return $ Left err Right hs -> return $ Right $ Handshake [hs]
Network/TLS/Record.hs view
@@ -15,7 +15,6 @@ ( Record(..) -- * Fragment manipulation types , Fragment- , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext , recordToRaw
Network/TLS/Record/Types.hs view
@@ -22,7 +22,6 @@ , Fragment , fragmentPlaintext , fragmentCiphertext- , fragmentGetBytes , Plaintext , Compressed , Ciphertext@@ -41,6 +40,7 @@ import Network.TLS.Struct import Network.TLS.Record.State import qualified Data.ByteString as B+import Data.Byteable import Control.Applicative ((<$>)) -- | Represent a TLS record.@@ -58,8 +58,8 @@ fragmentCiphertext :: Bytes -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes -fragmentGetBytes :: Fragment a -> Bytes-fragmentGetBytes (Fragment bytes) = bytes+instance Byteable (Fragment a) where+ toBytes (Fragment b) = b onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag
Network/TLS/State.hs view
@@ -51,6 +51,7 @@ import Network.TLS.Struct import Network.TLS.RNG import Network.TLS.Types (Role(..))+import Network.TLS.Wire (GetContinuation) import qualified Data.ByteString as B import Control.Monad.State import Control.Monad.Error@@ -64,13 +65,14 @@ , stClientVerifiedData :: Bytes -- RFC 5746 , stServerVerifiedData :: Bytes -- RFC 5746 , stExtensionNPN :: Bool -- NPN draft extension+ , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, Bytes)) , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol , stServerNextProtocolSuggest :: Maybe [B.ByteString] , stClientCertificateChain :: Maybe CertificateChain , stRandomGen :: StateRNG , stVersion :: Maybe Version , stClientContext :: Role- } deriving (Show)+ } newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a } deriving (Monad, MonadError TLSError, Functor, Applicative)@@ -93,6 +95,7 @@ , stClientVerifiedData = B.empty , stServerVerifiedData = B.empty , stExtensionNPN = False+ , stHandshakeRecordCont = Nothing , stNegotiatedProtocol = Nothing , stServerNextProtocolSuggest = Nothing , stClientCertificateChain = Nothing
Network/TLS/Wire.hs view
@@ -10,9 +10,12 @@ -- module Network.TLS.Wire ( Get+ , GetResult(..)+ , GetContinuation , runGet , runGetErr , runGetMaybe+ , tryGet , remaining , getWord8 , getWords8@@ -54,14 +57,33 @@ import Network.TLS.Struct import Network.TLS.Util.Serialization -runGet :: String -> Get a -> Bytes -> Either String a-runGet lbl f = G.runGet (label lbl f)+type GetContinuation a = Bytes -> GetResult a+data GetResult a =+ GotError TLSError+ | GotPartial (GetContinuation a)+ | GotSuccess a+ | GotSuccessRemaining a Bytes +runGet :: String -> Get a -> Bytes -> GetResult a+runGet lbl f = toGetResult <$> G.runGetPartial (label lbl f)+ where toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err)+ toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont)+ toGetResult (G.Done r bsLeft)+ | B.null bsLeft = GotSuccess r+ | otherwise = GotSuccessRemaining r bsLeft+ runGetErr :: String -> Get a -> Bytes -> Either TLSError a-runGetErr lbl f = either (Left . Error_Packet_Parsing) Right . runGet lbl f+runGetErr lbl getter b = toSimple $ runGet lbl getter b+ where toSimple (GotError err) = Left err+ toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet"))+ toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes"))+ toSimple (GotSuccess r) = Right r runGetMaybe :: Get a -> Bytes -> Maybe a-runGetMaybe f = either (const Nothing) Just . runGet "" f+runGetMaybe f = either (const Nothing) Just . G.runGet f++tryGet :: Get a -> Bytes -> Maybe a+tryGet f = either (const Nothing) Just . G.runGet f getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8
Tests/Marshalling.hs view
@@ -103,5 +103,9 @@ prop_handshake_marshalling_id :: Handshake -> Bool prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x- where decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b+ where decodeHs b = case decodeHandshakeRecord b of+ GotPartial _ -> error "got partial"+ GotError e -> error ("got error: " ++ show e)+ GotSuccessRemaining _ _ -> error "got remaining byte left"+ GotSuccess (ty, content) -> decodeHandshake cp ty content cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA, cParamsSupportNPN = True }
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.2.2+Version: 1.2.3 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -8,11 +8,11 @@ type system, high level constructions and common Haskell features. . Currently implement the SSL3.0, TLS1.0, TLS1.1 and TLS1.2 protocol,- with only RSA supported for Key Exchange.+ and support RSA and Ephemeral Diffie Hellman key exchanges,+ and many extensions. .- Only core protocol available here, have a look at the- <http://hackage.haskell.org/package/tls-extra/> package for default- ciphers, compressions and certificates functions.+ Some debug tools linked with tls, are available through the+ <http://hackage.haskell.org/package/tls-debug/>. License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez <vincent@snarc.org>@@ -25,6 +25,7 @@ Cabal-Version: >=1.8 Homepage: http://github.com/vincenthz/hs-tls extra-source-files: Tests/*.hs+ CHANGELOG.md Flag compat Description: Accept SSLv2 compatible handshake@@ -35,6 +36,7 @@ , mtl , cereal >= 0.3 , bytestring+ , byteable , network , data-default-class -- crypto related