diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -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) diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -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. diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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 diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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