tls 0.6.0 → 0.6.1
raw patch · 6 files changed
+90/−136 lines, 6 filesdep −binary
Dependencies removed: binary
Files
- Network/TLS/Core.hs +6/−6
- Network/TLS/Packet.hs +49/−42
- Network/TLS/Receiving.hs +16/−21
- Network/TLS/Struct.hs +7/−1
- Network/TLS/Wire.hs +11/−64
- tls.cabal +1/−2
Network/TLS/Core.hs view
@@ -93,9 +93,9 @@ } newCtx :: Handle -> TLSParams -> TLSState -> IO TLSCtx-newCtx handle params state = do+newCtx handle params st = do hSetBuffering handle NoBuffering- stvar <- newMVar state+ stvar <- newMVar st return $ TLSCtx { ctxHandle = handle , ctxParams = params@@ -148,14 +148,14 @@ -- | Create a new Client context with a configuration, a RNG, and a Handle. -- It reconfigures the handle buffermode to noBuffering client :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m TLSCtx-client params rng handle = liftIO $ newCtx handle params state- where state = (newTLSState rng) { stClientContext = True }+client params rng handle = liftIO $ newCtx handle params st+ where st = (newTLSState rng) { stClientContext = True } -- | Create a new Server context with a configuration, a RNG, and a Handle. -- It reconfigures the handle buffermode to noBuffering server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m TLSCtx-server params rng handle = liftIO $ newCtx handle params state- where state = (newTLSState rng) { stClientContext = False }+server params rng handle = liftIO $ newCtx handle params st+ where st = (newTLSState rng) { stClientContext = False } -- | notify the context that this side wants to close connection. -- this is important that it is called before closing the handle, otherwise
Network/TLS/Packet.hs view
@@ -42,10 +42,9 @@ import Network.TLS.Cap import Network.TLS.Wire import Data.Either (partitionEithers)-import Data.Maybe (fromJust, isNothing)+import Data.Maybe (fromJust) import Control.Applicative ((<$>)) import Control.Monad-import Control.Monad.Error import Data.Certificate.X509 import Network.TLS.Crypto import Network.TLS.MAC@@ -54,43 +53,67 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L +runGetErr :: Get a -> ByteString -> Either TLSError a+runGetErr f = either (Left . Error_Packet_Parsing) Right . runGet f++{- marshall helpers -}+getVersion :: Get Version+getVersion = do+ major <- getWord8+ minor <- getWord8+ case verOfNum (major, minor) of+ Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor)+ Just v -> return v++putVersion :: Version -> Put+putVersion ver = putWord8 major >> putWord8 minor+ where (major, minor) = numericalVer ver++getHeaderType :: Get ProtocolType+getHeaderType = do+ ty <- getWord8+ case valToType ty of+ Nothing -> fail ("invalid header type: " ++ show ty)+ Just t -> return t++putHeaderType = putWord8 . valOfType++getHandshakeType :: Get HandshakeType+getHandshakeType = do+ ty <- getWord8+ case valToType ty of+ Nothing -> fail ("invalid handshake type: " ++ show ty)+ Just t -> return t+ {- - decode and encode headers -} decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGet $ do- ty <- getWord8- major <- getWord8- minor <- getWord8+decodeHeader = runGetErr $ do+ ty <- getHeaderType+ v <- getVersion len <- getWord16- case (valToType ty, verOfNum (major, minor)) of- (Just y, Just v) -> return $ Header y v len- (Nothing, _) -> throwError (Error_Packet "invalid type")- (_, Nothing) -> throwError (Error_Packet "invalid version")+ return $ Header ty v len encodeHeader :: Header -> ByteString-encodeHeader (Header pt ver len) =+encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len) {- FIXME check len <= 2^14 -}- runPut (putWord8 (valOfType pt) >> putWord8 major >> putWord8 minor >> putWord16 len)- where (major, minor) = numericalVer ver encodeHeaderNoVer :: Header -> ByteString-encodeHeaderNoVer (Header pt _ len) =+encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len) {- FIXME check len <= 2^14 -}- runPut (putWord8 (valOfType pt) >> putWord16 len) {- - decode and encode ALERT -}- decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription)-decodeAlert = runGet $ do+decodeAlert = runGetErr $ do al <- getWord8 ad <- getWord8 case (valToType al, valToType ad) of (Just a, Just d) -> return (a, d)- (Nothing, _) -> throwError (Error_Packet "missing alert level")- (_, Nothing) -> throwError (Error_Packet "missing alert description")+ (Nothing, _) -> fail "cannot decode alert level"+ (_, Nothing) -> fail "cannot decode alert description" encodeAlert :: (AlertLevel, AlertDescription) -> ByteString encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad))@@ -98,16 +121,13 @@ {- decode and encode HANDSHAKE -} decodeHandshakeHeader :: Get (HandshakeType, Bytes) decodeHandshakeHeader = do- tyopt <- getWord8 >>= return . valToType- ty <- if isNothing tyopt- then throwError (Error_Unknown_Type "handshake type")- else return $ fromJust tyopt+ ty <- getHandshakeType len <- getWord24 content <- getBytes len return (ty, content) decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]-decodeHandshakes b = runGet getAll b+decodeHandshakes b = runGetErr getAll b where getAll = do x <- decodeHandshakeHeader@@ -117,7 +137,7 @@ else getAll >>= \l -> return (x : l) decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake-decodeHandshake ver ty = runGet $ case ty of+decodeHandshake ver ty = runGetErr $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello HandshakeType_ServerHello -> decodeServerHello@@ -167,7 +187,7 @@ certs <- getCerts certslen >>= return . map (decodeCertificate . L.fromChunks . (:[])) let (l, r) = partitionEithers certs if length l > 0- then throwError $ Error_Certificate $ show l+ then fail ("error certificate parsing: " ++ show l) else return $ Certificates r decodeFinished :: Version -> Get Handshake@@ -199,7 +219,7 @@ Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen) else return Nothing dNameLen <- getWord16- when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size")+ when (ver < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size" dName <- getBytes $ fromIntegral dNameLen return $ CertRequest certTypes sigHashAlgs (B.unpack dName) @@ -297,19 +317,6 @@ encodeHandshakeContent (Finished opaque) = mapM_ putWord8 opaque -{- marshall helpers -}-getVersion :: Get Version-getVersion = do- major <- getWord8- minor <- getWord8- case verOfNum (major, minor) of- Just v -> return v- Nothing -> throwError (Error_Unknown_Version major minor)--putVersion :: Version -> Put-putVersion ver = putWord8 major >> putWord8 minor- where (major, minor) = numericalVer ver- {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get Bytes getRandom32 = getBytes 32@@ -387,9 +394,9 @@ -} decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec = runGet $ do+decodeChangeCipherSpec = runGetErr $ do x <- getWord8- when (x /= 1) (throwError $ Error_Misc "unknown change cipher spec content")+ when (x /= 1) (fail "unknown change cipher spec content") encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1)
Network/TLS/Receiving.hs view
@@ -82,15 +82,12 @@ when (isJust e) $ throwError (fromJust "" e) content <- case ty of- HandshakeType_ClientKeyXchg -> do- copt <- decryptRSA econtent- return $ either (const econtent) id copt- _ ->- return econtent+ HandshakeType_ClientKeyXchg -> either (const econtent) id <$> decryptRSA econtent+ _ -> return econtent hs <- case (ty, decodeHandshake ver ty content) of- (_, Right x) -> return x- (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)- (_, Left err) -> throwError err+ (_, Right x) -> return x+ (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)+ (_, Left err) -> throwError err clientmode <- isClientContext case hs of ClientHello cver ran _ _ _ _ -> unless clientmode $ do@@ -107,26 +104,24 @@ decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do- ver <- return . stVersion =<< get- rsapriv <- get >>= return . fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake+ ver <- stVersion <$> get+ rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) -setMasterSecretRandom :: ByteString -> TLSSt ()-setMasterSecretRandom content = do- bytes <- genTLSRandom (fromIntegral $ B.length content)- setMasterSecret bytes-+-- process the client key exchange message. the protocol expects the initial+-- client version received in ClientHello, not the negociated version.+-- in case the version mismatch, generate a random master secret processClientKeyXchg :: Version -> ByteString -> TLSSt () processClientKeyXchg ver content = do- {- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -}- expectedVer <- get >>= return . hstClientVersion . fromJust "handshake" . stHandshake- if expectedVer /= ver- then setMasterSecretRandom content- else setMasterSecret content+ expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get+ setMasterSecret =<<+ if expectedVer /= ver+ then genTLSRandom (fromIntegral $ B.length content)+ else return content processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do- cc <- get >>= return . stClientContext+ cc <- stClientContext <$> get expected <- getHandshakeDigest (not cc) when (expected /= B.pack fdata) $ do -- FIXME don't fail, but report the error so that the code can send a BadMac Alert.
Network/TLS/Struct.hs view
@@ -48,6 +48,7 @@ import qualified Data.ByteString as B (length) import Data.Word import Data.Certificate.X509+import Control.Monad.Error (Error(..)) type Bytes = ByteString @@ -113,11 +114,16 @@ | Error_Packet String | Error_Packet_Size_Mismatch (Int, Int) | Error_Packet_unexpected String String- | Error_Internal_Packet_Remaining Int+ | Error_Packet_Parsing String | Error_Internal_Packet_ByteProcessed Int Int Int | Error_Unknown_Version Word8 Word8 | Error_Unknown_Type String deriving (Eq, Show)++instance Error TLSError where+ noMsg = Error_Misc ""+ strMsg = Error_Misc+ data Packet = Handshake Handshake
Network/TLS/Wire.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving,FlexibleInstances #-}- -- | -- Module : Network.TLS.Wire -- License : BSD-style@@ -7,14 +5,13 @@ -- Stability : experimental -- Portability : unknown ----- the Wire module is a specialized Binary package related to the TLS protocol.+-- the Wire module is a specialized marshalling/unmarshalling package related to the TLS protocol. -- all multibytes values are written as big endian. -- module Network.TLS.Wire ( Get , runGet , remaining- , bytesRead , getWord8 , getWords8 , getWord16@@ -34,46 +31,19 @@ , encodeWord64 ) where -import qualified Data.Binary.Get as G-import qualified Data.Binary.Put as P-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import Data.Serialize.Get+import Data.Serialize.Put import Control.Applicative ((<$>)) import Control.Monad.Error import Data.Word import Data.Bits import Network.TLS.Struct -instance Error TLSError where- noMsg = Error_Misc ""- strMsg = Error_Misc--newtype Get a = GE { runGE :: ErrorT TLSError G.Get a }- deriving (Monad, MonadError TLSError)--instance Functor Get where- fmap f = GE . fmap f . runGE--liftGet :: G.Get a -> Get a-liftGet = GE . lift--runGet :: Get a -> Bytes -> Either TLSError a-runGet f b = G.runGet (runErrorT (runGE f)) (L.fromChunks [b])--remaining :: Get Int-remaining = fromIntegral <$> liftGet G.remaining--bytesRead :: Get Int-bytesRead = fromIntegral <$> liftGet G.bytesRead--getWord8 :: Get Word8-getWord8 = liftGet G.getWord8- getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 getWord16 :: Get Word16-getWord16 = liftGet G.getWord16be+getWord16 = getWord16be getWords16 :: Get [Word16] getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16@@ -85,33 +55,16 @@ c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c -getBytes :: Int -> Get Bytes-getBytes i = liftGet $ G.getBytes i- processBytes :: Int -> Get a -> Get a-processBytes i f = do- r1 <- bytesRead- ret <- f- r2 <- bytesRead- if r2 == (r1 + i)- then return ret- else throwError (Error_Internal_Packet_ByteProcessed r1 r2 i)- -isEmpty :: Get Bool-isEmpty = liftGet G.isEmpty--type Put = P.Put--putWord8 :: Word8 -> Put-putWord8 = P.putWord8+processBytes i f = isolate i f putWords8 :: [Word8] -> Put putWords8 l = do- P.putWord8 $ fromIntegral (length l)- mapM_ P.putWord8 l+ putWord8 $ fromIntegral (length l)+ mapM_ putWord8 l putWord16 :: Word16 -> Put-putWord16 = P.putWord16be+putWord16 = putWord16be putWords16 :: [Word16] -> Put putWords16 l = do@@ -123,16 +76,10 @@ let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff)- mapM_ P.putWord8 [a,b,c]+ mapM_ putWord8 [a,b,c] putBytes :: Bytes -> Put-putBytes = P.putByteString--lazyToBytes :: L.ByteString -> Bytes-lazyToBytes = B.concat . L.toChunks--runPut :: Put -> Bytes-runPut = lazyToBytes . P.runPut+putBytes = putByteString encodeWord64 :: Word64 -> Bytes-encodeWord64 = runPut . P.putWord64be+encodeWord64 = runPut . putWord64be
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.6.0+Version: 0.6.1 Description: native TLS protocol implementation, focusing on purity and more type-checking. .@@ -33,7 +33,6 @@ Build-Depends: base >= 3 && < 5 , mtl , cryptohash >= 0.6- , binary >= 0.5 , cereal >= 0.3 , bytestring , crypto-api >= 0.5