tls 0.8.2 → 0.8.3
raw patch · 13 files changed
+690/−540 lines, 13 filesdep +cprng-aesdep +time
Dependencies added: cprng-aes, time
Files
- Network/TLS/Core.hs +165/−87
- Network/TLS/Measurement.hs +46/−0
- Network/TLS/Packet.hs +28/−25
- Network/TLS/Receiving.hs +25/−148
- Network/TLS/Record.hs +10/−74
- Network/TLS/Record/Disengage.hs +117/−0
- Network/TLS/Record/Engage.hs +89/−0
- Network/TLS/Record/Types.hs +96/−0
- Network/TLS/Sending.hs +4/−88
- Network/TLS/State.hs +0/−97
- Network/TLS/Struct.hs +3/−4
- Tests.hs +98/−15
- tls.cabal +9/−2
Network/TLS/Core.hs view
@@ -11,6 +11,7 @@ -- * Context configuration TLSParams(..) , TLSLogging(..)+ , Measurement(..) , TLSCertificateUsage(..) , TLSCertificateRejectReason(..) , defaultLogging@@ -49,6 +50,7 @@ import Network.TLS.State import Network.TLS.Sending import Network.TLS.Receiving+import Network.TLS.Measurement import Data.Maybe import Data.Certificate.X509 import Data.List (intersect, intercalate, find)@@ -96,6 +98,7 @@ , pUseSecureRenegotiation :: Bool -- notify that we want to use secure renegotation , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. , pLogging :: TLSLogging -- ^ callback for logging+ , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake , onCertificatesRecv :: [X509] -> IO TLSCertificateUsage -- ^ callback to verify received cert chain. } @@ -117,6 +120,7 @@ , pUseSecureRenegotiation = True , pCertificates = [] , pLogging = defaultLogging+ , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept) } @@ -135,20 +139,27 @@ { ctxConnection :: a -- ^ return the connection object associated with this context , ctxParams :: TLSParams , ctxState :: MVar TLSState+ , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ is the handle has EOFed or not. , ctxConnectionFlush :: IO () , ctxConnectionSend :: Bytes -> IO () , ctxConnectionRecv :: Int -> IO Bytes } +updateMeasure :: MonadIO m => TLSCtx c -> (Measurement -> Measurement) -> m ()+updateMeasure ctx f = liftIO $ modifyIORef (ctxMeasurement ctx) f++withMeasure :: MonadIO m => TLSCtx c -> (Measurement -> IO a) -> m a+withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f)+ connectionFlush :: TLSCtx c -> IO ()-connectionFlush c = (ctxConnectionFlush c)+connectionFlush c = ctxConnectionFlush c connectionSend :: TLSCtx c -> Bytes -> IO ()-connectionSend c b = (ctxConnectionSend c) b+connectionSend c b = updateMeasure c (addBytesSent $ B.length b) >> (ctxConnectionSend c) b connectionRecv :: TLSCtx c -> Int -> IO Bytes-connectionRecv c sz = (ctxConnectionRecv c) sz+connectionRecv c sz = updateMeasure c (addBytesReceived sz) >> (ctxConnectionRecv c) sz ctxEOF :: MonadIO m => TLSCtx a -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)@@ -160,11 +171,13 @@ newCtxWith c flushF sendF recvF params st = do stvar <- newMVar st eof <- newIORef False+ stats <- newIORef newMeasurement return $ TLSCtx- { ctxConnection = c- , ctxParams = params- , ctxState = stvar- , ctxEOF_ = eof+ { ctxConnection = c+ , ctxParams = params+ , ctxState = stvar+ , ctxMeasurement = stats+ , ctxEOF_ = eof , ctxConnectionFlush = flushF , ctxConnectionSend = sendF , ctxConnectionRecv = recvF@@ -197,11 +210,6 @@ getStateRNG :: MonadIO m => TLSCtx c -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n) -whileStatus :: MonadIO m => TLSCtx c -> (TLSStatus -> Bool) -> m a -> m ()-whileStatus ctx p a = do- b <- usingState_ ctx (p . stStatus <$> get)- when b (a >> whileStatus ctx p a)- errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]@@ -219,34 +227,68 @@ else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs +recvRecord :: MonadIO m => TLSCtx c -> m (Either TLSError (Record Plaintext))+recvRecord ctx = 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)+ | otherwise = do+ content <- readExact ctx (fromIntegral readlen)+ 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 => TLSCtx c -> m (Either TLSError Packet) recvPacket ctx = do- hdrbs <- readExact ctx 5- case decodeHeader hdrbs of- Left err -> return $ Left err- Right header@(Header _ _ readlen) ->- if readlen > (16384 + 2048)- then return $ Left $ Error_Protocol ("record exceeding maximum size",True, RecordOverflow)- else recvLength header readlen- where recvLength header readlen = do- content <- readExact ctx (fromIntegral readlen)- liftIO $ (loggingIORecv $ ctxLogging ctx) header content- pkt <- usingState ctx $ readPacket $ rawToRecord header (fragmentCiphertext content)- case pkt of- Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p- _ -> return ()- return pkt+ erecord <- recvRecord ctx+ case erecord of+ Left err -> return $ Left err+ Right record -> do+ pkt <- usingState ctx $ processPacket record+ case pkt of+ Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p+ _ -> return ()+ return pkt -recvPacketSuccess :: MonadIO m => TLSCtx c -> m ()-recvPacketSuccess ctx = do- pkt <- recvPacket ctx- case pkt of- Left err -> throwCore err- Right _ -> return ()+recvPacketHandshake :: MonadIO m => TLSCtx c -> m [Handshake]+recvPacketHandshake ctx = do+ pkts <- recvPacket ctx+ case pkts of+ Right (Handshake l) -> return l+ Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x)+ Left err -> throwCore err +data RecvState m =+ RecvStateNext (Packet -> m (RecvState m))+ | RecvStateHandshake (Handshake -> m (RecvState m))+ | RecvStateDone++runRecvState :: MonadIO m => TLSCtx a -> RecvState m -> m ()+runRecvState _ (RecvStateDone) = return ()+runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx+runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx+ where+ loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m)+ loop recvState [] = return recvState+ loop (RecvStateHandshake f) (x:xs) = do+ nstate <- f x+ usingState_ ctx $ processHandshake x+ loop nstate xs+ loop _ _ = unexpected "spurious handshake" Nothing++sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m ()+sendChangeCipherAndFinish ctx isClient = do+ sendPacket ctx ChangeCipherSpec+ liftIO $ connectionFlush ctx+ cf <- usingState_ ctx $ getHandshakeDigest isClient+ sendPacket ctx (Handshake [Finished cf])+ liftIO $ connectionFlush ctx++unexpected :: MonadIO m => String -> Maybe [Char] -> m a+unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)+ -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx c -> Packet -> m () sendPacket ctx pkt = do@@ -291,40 +333,13 @@ -- values intertwined with response from the server. handshakeClient :: MonadIO m => TLSCtx c -> m () handshakeClient ctx = do- -- Send ClientHello- crand <- getStateRNG ctx 32 >>= return . ClientRandom- extensions <- getExtensions- usingState_ ctx (startHandshakeClient ver crand)- sendPacket ctx $ Handshake- [ ClientHello ver crand (Session Nothing) (map cipherID ciphers)- (map compressionID compressions) extensions- ]-- -- Receive Server information until ServerHelloDone- whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do- pkts <- recvPacket ctx- case pkts of- Left err -> throwCore err- Right l -> processServerInfo l-- -- Send Certificate if requested. XXX disabled for now.- certRequested <- return False- when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])-- sendClientKeyXchg-- {- maybe send certificateVerify -}- {- FIXME not implemented yet -}-- sendPacket ctx ChangeCipherSpec- liftIO $ connectionFlush ctx-- -- Send Finished- cf <- usingState_ ctx $ getHandshakeDigest True- sendPacket ctx (Handshake [Finished cf])-- -- receive changeCipherSpec & Finished- recvPacketSuccess ctx >> recvPacketSuccess ctx >> return ()+ updateMeasure ctx incrementNbHandshakes+ sendClientHello+ recvServerHello+ sendCertificate >> sendClientKeyXchg >> sendCertificateVerify+ sendChangeCipherAndFinish ctx True+ recvChangeCipherAndFinish+ updateMeasure ctx resetBytesCounters where params = ctxParams ctx@@ -338,10 +353,36 @@ then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ] else return [] - processServerInfo (Handshake hss) = mapM_ processHandshake hss- processServerInfo _ = return ()+ sendClientHello = do+ crand <- getStateRNG ctx 32 >>= return . ClientRandom+ extensions <- getExtensions+ usingState_ ctx (startHandshakeClient ver crand)+ sendPacket ctx $ Handshake+ [ ClientHello ver crand (Session Nothing) (map cipherID ciphers)+ (map compressionID compressions) extensions+ ] - processHandshake (ServerHello rver _ _ cipher _ _) = do+ recvChangeCipherAndFinish = runRecvState ctx (RecvStateNext expectChangeCipher)+ where+ expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish+ expectChangeCipher p = unexpected (show p) (Just "change cipher")+ expectFinish (Finished _) = return RecvStateDone+ expectFinish p = unexpected (show p) (Just "Handshake Finished")++ sendCertificate = do+ -- Send Certificate if requested. XXX disabled for now.+ certRequested <- return False+ when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])++ sendCertificateVerify =+ {- maybe send certificateVerify -}+ {- FIXME not implemented yet -}+ return ()++ recvServerHello = runRecvState ctx (RecvStateHandshake processServerHello)++ processServerHello :: MonadIO m => Handshake -> m (RecvState m)+ processServerHello (ServerHello rver _ _ cipher _ _) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)@@ -349,22 +390,39 @@ case find ((==) cipher . cipherID) ciphers of Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) Just c -> usingState_ ctx $ setCipher c+ return $ RecvStateHandshake processCertificate+ processServerHello p = unexpected (show p) (Just "server hello") - processHandshake (Certificates certs) = do+ processCertificate :: MonadIO m => Handshake -> m (RecvState m)+ processCertificate (Certificates certs) = do let cb = onCertificatesRecv $ params usage <- liftIO $ cb certs case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason+ return $ RecvStateHandshake processServerKeyExchange+ processCertificate p = processServerKeyExchange p - processHandshake (CertRequest _ _ _) = do- return ()+ processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m)+ processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest+ processServerKeyExchange p = processCertificateRequest p++ processCertificateRequest (CertRequest _ _ _) = do --modify (\sc -> sc { scCertRequested = True })- processHandshake _ = return ()+ return $ RecvStateHandshake processServerHelloDone+ processCertificateRequest p = processServerHelloDone p + processServerHelloDone ServerHelloDone = return RecvStateDone+ processServerHelloDone p = unexpected (show p) (Just "server hello data")+ sendClientKeyXchg = do- prerand <- getStateRNG ctx 46 >>= return . ClientKeyData- sendPacket ctx $ Handshake [ClientKeyXchg ver prerand]+ encryptedPreMaster <- usingState_ ctx $ do+ xver <- stVersion <$> get+ prerand <- genTLSRandom 46+ let premaster = encodePreMasterSecret xver prerand+ setMasterSecret premaster+ encryptRSA premaster+ sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster] -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected CertificateRejectRevoked =@@ -377,8 +435,14 @@ throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()-handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do+handshakeServerWith ctx clientHello@(ClientHello ver _ _ ciphers compressions _) = do+ -- check if policy allow this new handshake to happens+ handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)+ unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")+ updateMeasure ctx incrementNbHandshakes+ -- Handle Client hello+ usingState_ ctx $ processHandshake clientHello when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) when (not $ elem ver (pAllowedVersions params)) $ throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)@@ -397,15 +461,10 @@ liftIO $ connectionFlush ctx -- Receive client info until client Finished.- whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx)-- sendPacket ctx ChangeCipherSpec-- -- Send Finish- cf <- usingState_ ctx $ getHandshakeDigest False- sendPacket ctx (Handshake [Finished cf])+ recvClientData+ sendChangeCipherAndFinish ctx False - liftIO $ connectionFlush ctx+ updateMeasure ctx resetBytesCounters return () where params = ctxParams ctx@@ -417,6 +476,25 @@ privKeys = map snd $ pCertificates params needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher + ---+ recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate)++ processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange+ processClientCertificate p = processClientKeyExchange p++ processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify+ processClientKeyExchange p = unexpected (show p) (Just "client key exchange")++ processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher+ processCertificateVerify p = expectChangeCipher p++ expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish+ expectChangeCipher p = unexpected (show p) (Just "change cipher")++ expectFinish (Finished _) = return RecvStateDone+ expectFinish p = unexpected (show p) (Just "Handshake Finished")+ ---+ handshakeSendServerData = do srand <- getStateRNG ctx 32 >>= return . ServerRandom @@ -456,7 +534,7 @@ handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello" --- after receiving a client hello, we need to redo a handshake -}+-- after receiving a client hello, we need to redo a handshake handshakeServer :: MonadIO m => TLSCtx c -> m () handshakeServer ctx = do pkts <- recvPacket ctx@@ -474,7 +552,7 @@ handleException f = catch (f >> return True) (\e -> handler e >> return False) handler e = case fromException e of Just err -> sendPacket ctx (errorToAlert err)- Nothing -> sendPacket ctx (errorToAlert $ Error_Misc "")+ Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e) -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size
+ Network/TLS/Measurement.hs view
@@ -0,0 +1,46 @@+-- |+-- Module : Network.TLS.Measurement+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Measurement+ ( Measurement(..)+ , newMeasurement+ , addBytesReceived+ , addBytesSent+ , resetBytesCounters+ , incrementNbHandshakes+ ) where++import Data.Word++-- | record some data about this connection.+data Measurement = Measurement+ { nbHandshakes :: !Word32 -- ^ number of handshakes on this context+ , bytesReceived :: !Word32 -- ^ bytes received since last handshake+ , bytesSent :: !Word32 -- ^ bytes sent since last handshake+ } deriving (Show,Eq)++newMeasurement :: Measurement+newMeasurement = Measurement+ { nbHandshakes = 0+ , bytesReceived = 0+ , bytesSent = 0+ }++addBytesReceived :: Int -> Measurement -> Measurement+addBytesReceived sz measure =+ measure { bytesReceived = bytesReceived measure + fromIntegral sz }++addBytesSent :: Int -> Measurement -> Measurement+addBytesSent sz measure =+ measure { bytesSent = bytesSent measure + fromIntegral sz }++resetBytesCounters :: Measurement -> Measurement+resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 }++incrementNbHandshakes :: Measurement -> Measurement+incrementNbHandshakes measure =+ measure { nbHandshakes = nbHandshakes measure + 1 }
Network/TLS/Packet.hs view
@@ -35,6 +35,9 @@ , decodeChangeCipherSpec , encodeChangeCipherSpec + , decodePreMasterSecret+ , encodePreMasterSecret+ -- * marshall extensions , decodeExtSecureRenegotiation , encodeExtSecureRenegotiation@@ -247,10 +250,7 @@ return $ CertVerify [] decodeClientKeyXchg :: Get Handshake-decodeClientKeyXchg = do- ver <- getVersion- ran <- getClientKeyData46- return $ ClientKeyXchg ver ran+decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes) os2ip :: ByteString -> Integer os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0@@ -269,18 +269,20 @@ return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp = do- skxAlg <- case cParamsKeyXchgType cp of- CipherKeyExchange_RSA -> do- rsaparams <- decodeServerKeyXchg_RSA- return $ SKX_RSA $ Just rsaparams- CipherKeyExchange_DH_Anon -> do- dhparams <- decodeServerKeyXchg_DH- return $ SKX_DH_Anon dhparams- _ -> do- bs <- remaining >>= getBytes- return $ SKX_Unknown bs- return (ServerKeyXchg skxAlg)+decodeServerKeyXchg cp = ServerKeyXchg <$> case cParamsKeyXchgType cp of+ CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA+ CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH+ CipherKeyExchange_DHE_RSA -> do+ dhparams <- decodeServerKeyXchg_DH+ signature <- getWord16 >>= getBytes . fromIntegral+ return $ SKX_DHE_RSA dhparams (B.unpack signature)+ CipherKeyExchange_DHE_DSS -> do+ dhparams <- decodeServerKeyXchg_DH+ signature <- getWord16 >>= getBytes . fromIntegral+ return $ SKX_DHE_DSS dhparams (B.unpack signature)+ _ -> do+ bs <- remaining >>= getBytes+ return $ SKX_Unknown bs encodeHandshake :: Handshake -> ByteString encodeHandshake o =@@ -317,9 +319,8 @@ certbs = runPut $ mapM_ putCert certs len = fromIntegral $ B.length certbs -encodeHandshakeContent (ClientKeyXchg version random) = do- putVersion version- putClientKeyData46 random+encodeHandshakeContent (ClientKeyXchg content) = do+ putBytes content encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME@@ -358,12 +359,6 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r -getClientKeyData46 :: Get ClientKeyData-getClientKeyData46 = ClientKeyData <$> getBytes 46--putClientKeyData46 :: ClientKeyData -> Put-putClientKeyData46 (ClientKeyData d) = putBytes d- getSession :: Get Session getSession = do len8 <- getWord8@@ -440,6 +435,14 @@ putWord8 $ fromIntegral (B.length cvd + B.length svd) putBytes cvd putBytes svd++-- rsa pre master secret+decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes)+decodePreMasterSecret = runGetErr "pre-master-secret" $ do+ liftM2 (,) getVersion (getBytes 46)++encodePreMasterSecret :: Version -> Bytes -> Bytes+encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) {- - generate things for packet content
Network/TLS/Receiving.hs view
@@ -8,26 +8,20 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state ---module Network.TLS.Receiving (- readPacket- ) where+module Network.TLS.Receiving (processHandshake, processPacket) where -import Data.Maybe (isJust) import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.ByteString (ByteString)-import qualified Data.ByteString as B import Network.TLS.Util-import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher-import Network.TLS.Compression import Network.TLS.Crypto import Data.Certificate.X509 @@ -35,25 +29,6 @@ returnEither (Left err) = throwError err returnEither (Right a) = return a -readPacket :: Record Ciphertext -> TLSSt Packet-readPacket record = checkState record >> decryptContent record >>= uncompressContent >>= processPacket--checkState :: Record a -> TLSSt ()-checkState (Record pt _ _) =- stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError (err status)- where- err st = Error_Protocol ("unexpected message received: status=" ++ show st, True, UnexpectedMessage)-- allowed :: ProtocolType -> TLSStatus -> Bool- allowed ProtocolType_Alert _ = True- allowed ProtocolType_Handshake _ = True- allowed ProtocolType_AppData StatusHandshakeReq = True- allowed ProtocolType_AppData StatusOk = True- allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientFinished) = True- allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientKeyXchg) = True- allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True- allowed _ _ = False- processPacket :: Record Plaintext -> TLSSt Packet processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment@@ -61,40 +36,26 @@ processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do- e <- updateStatusCC False- when (isJust e) $ throwError (fromJust "" e)- returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment switchRxEncryption isClientContext >>= \cc -> when (not cc) setKeyBlock return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do- handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)- hss <- forM handshakes $ \(ty, content) -> do- hs <- processHandshake ver ty content- when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content- return hs- return $ Handshake hss--processHandshake :: Version -> HandshakeType -> ByteString -> TLSSt Handshake-processHandshake ver ty econtent = do- -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.- e <- updateStatusHs ty- maybe (return ()) throwError e- keyxchg <- getCipherKeyExchangeType let currentparams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg }- content <- case ty of- HandshakeType_ClientKeyXchg -> either (const econtent) id <$> decryptRSA econtent- _ -> return econtent- hs <- case (ty, decodeHandshake currentparams ty content) of- (_, Right x) -> return x- (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)- (_, Left err) -> throwError err+ 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+ return $ Handshake hss++processHandshake :: Handshake -> TLSSt ()+processHandshake hs = do clientmode <- isClientContext case hs of ClientHello cver ran _ _ _ ex -> unless clientmode $ do@@ -108,11 +69,11 @@ setServerRandom ran setVersion sver Certificates certs -> when clientmode $ do processCertificates certs- ClientKeyXchg cver _ -> unless clientmode $ do- processClientKeyXchg cver content+ ClientKeyXchg content -> unless clientmode $ do+ processClientKeyXchg content Finished fdata -> processClientFinished fdata _ -> return ()- return hs+ when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) where -- secure renegotiation processClientExtension (0xff01, content) = do@@ -135,20 +96,24 @@ decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do- 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)+ return $ kxDecrypt rsapriv econtent -- 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+processClientKeyXchg :: ByteString -> TLSSt ()+processClientKeyXchg encryptedPremaster = do expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get- setMasterSecret =<<- if expectedVer /= ver- then genTLSRandom (fromIntegral $ B.length content)- else return content+ random <- genTLSRandom 48+ ePremaster <- decryptRSA encryptedPremaster+ case ePremaster of+ Left _ -> setMasterSecret random+ Right premaster -> case decodePreMasterSecret premaster of+ Left _ -> setMasterSecret random+ Right (ver, _)+ | ver /= expectedVer -> setMasterSecret random+ | otherwise -> setMasterSecret premaster processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do@@ -158,94 +123,6 @@ throwError $ Error_Protocol("bad record mac", True, BadRecordMac) updateVerifiedData False fdata return ()---- just `decompress' by returning the data for now till we have compression implemented-uncompressContent :: Record Compressed -> TLSSt (Record Plaintext)-uncompressContent record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes--decryptContent :: Record Ciphertext -> TLSSt (Record Compressed)-decryptContent record = onRecordFragment record $ fragmentUncipher $ \e -> do- st <- get- if stRxEncrypted st- then decryptData e >>= getCipherData record- else return e--getCipherData :: Record a -> CipherData -> TLSSt ByteString-getCipherData (Record pt ver _) cdata = do- -- check if the MAC is valid.- macValid <- case cipherDataMAC cdata of- Nothing -> return True- Just digest -> do- let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)- expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata- return (expected_digest `bytesEq` digest)-- -- check if the padding is filled with the correct pattern if it exists- paddingValid <- case cipherDataPadding cdata of- Nothing -> return True- Just pad -> do- cver <- stVersion <$> get- let b = B.length pad - 1- return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad)-- unless (macValid &&! paddingValid) $ do- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)-- return $ cipherDataContent cdata--decryptData :: Bytes -> TLSSt CipherData-decryptData econtent = do- st <- get-- let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "rx crypt state" $ stRxCryptState st- let digestSize = hashSize $ cipherHash cipher- let writekey = cstKey cst-- case bulkF bulk of- BulkNoneF -> do- let contentlen = B.length econtent - digestSize- case partition3 econtent (contentlen, digestSize, 0) of- Nothing ->- throwError $ Error_Misc "partition3 failed"- Just (content, mac, _) ->- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- BulkBlockF _ decryptF -> do- {- update IV -}- let (iv, econtent') =- if hasExplicitBlockIV $ stVersion st- then B.splitAt (bulkIVSize bulk) econtent- else (cstIV cst, econtent)- let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent'- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }-- let content' = decryptF writekey iv econtent'- let paddinglength = fromIntegral (B.last content') + 1- let contentlen = B.length content' - paddinglength - digestSize- let (content, mac, padding) = fromJust "p3" $ partition3 content' (contentlen, digestSize, paddinglength)- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just padding- }- BulkStreamF initF _ decryptF -> do- let iv = cstIV cst- let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent- {- update Ctx -}- let contentlen = B.length content' - digestSize- let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- } processCertificates :: [X509] -> TLSSt () processCertificates certs = do
Network/TLS/Record.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Record -- License : BSD-style@@ -13,84 +12,21 @@ -- higher-level clients. -- module Network.TLS.Record- ( Header(..)- , ProtocolType(..)- , packetType- -- * TLS Records- , Record(..)- -- * TLS Record fragment and constructors+ ( Record(..) , Fragment+ , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext- , fragmentGetBytes+ , recordToRaw+ , rawToRecord+ , recordToHeader , Plaintext , Compressed , Ciphertext- -- * manipulate record- , onRecordFragment- , fragmentCompress- , fragmentCipher- , fragmentUncipher- , fragmentUncompress- -- * serialize record- , rawToRecord- , recordToRaw- , recordToHeader+ , engageRecord+ , disengageRecord ) where -import Network.TLS.Struct-import Network.TLS.State-import qualified Data.ByteString as B-import Control.Applicative ((<$>))---- | Represent a TLS record.-data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)--newtype Fragment a = Fragment Bytes deriving (Show,Eq)--data Plaintext-data Compressed-data Ciphertext--fragmentPlaintext :: Bytes -> Fragment Plaintext-fragmentPlaintext bytes = Fragment bytes--fragmentCiphertext :: Bytes -> Fragment Ciphertext-fragmentCiphertext bytes = Fragment bytes--fragmentGetBytes :: Fragment a -> Bytes-fragmentGetBytes (Fragment bytes) = bytes--onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b)-onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag--fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b)-fragmentMap f (Fragment b) = Fragment <$> f b---- | turn a plaintext record into a compressed record using the compression function supplied-fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed)-fragmentCompress f = fragmentMap f---- | turn a compressed record into a ciphertext record using the cipher function supplied-fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext)-fragmentCipher f = fragmentMap f---- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied-fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed)-fragmentUncipher f = fragmentMap f---- | turn a compressed fragment into a plaintext fragment using the decompression function supplied-fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext)-fragmentUncompress f = fragmentMap f---- | turn a record into an header and bytes-recordToRaw :: Record a -> (Header, Bytes)-recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes)---- | turn a header and a fragment into a record-rawToRecord :: Header -> Fragment a -> Record a-rawToRecord (Header pt ver _) fragment = Record pt ver fragment---- | turn a record into a header-recordToHeader :: Record a -> Header-recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes)+import Network.TLS.Record.Types+import Network.TLS.Record.Engage+import Network.TLS.Record.Disengage
+ Network/TLS/Record/Disengage.hs view
@@ -0,0 +1,117 @@+-- |+-- Module : Network.TLS.Record.Disengage+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Disengage a record from the Record layer.+-- The record is decrypted, checked for integrity and then decompressed.+--+module Network.TLS.Record.Disengage+ ( disengageRecord+ ) where++import Control.Monad.State+import Control.Monad.Error++import Network.TLS.Struct+import Network.TLS.Cap+import Network.TLS.State+import Network.TLS.Record.Types+import Network.TLS.Cipher+import Network.TLS.Compression+import Network.TLS.Util+import Data.ByteString (ByteString)+import qualified Data.ByteString as B++disengageRecord :: Record Ciphertext -> TLSSt (Record Plaintext)+disengageRecord = decryptRecord >=> uncompressRecord++uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext)+uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->+ withCompression $ compressionInflate bytes++decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed)+decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do+ st <- get+ if stRxEncrypted st+ then decryptData e >>= getCipherData record+ else return e++getCipherData :: Record a -> CipherData -> TLSSt ByteString+getCipherData (Record pt ver _) cdata = do+ -- check if the MAC is valid.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata+ return (expected_digest `bytesEq` digest)++ -- check if the padding is filled with the correct pattern if it exists+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just pad -> do+ cver <- gets stVersion+ let b = B.length pad - 1+ return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad)++ unless (macValid &&! paddingValid) $ do+ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)++ return $ cipherDataContent cdata++decryptData :: Bytes -> TLSSt CipherData+decryptData econtent = do+ st <- get++ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "rx crypt state" $ stRxCryptState st+ let digestSize = hashSize $ cipherHash cipher+ let writekey = cstKey cst++ case bulkF bulk of+ BulkNoneF -> do+ let contentlen = B.length econtent - digestSize+ case partition3 econtent (contentlen, digestSize, 0) of+ Nothing ->+ throwError $ Error_Misc "partition3 failed"+ Just (content, mac, _) ->+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ BulkBlockF _ decryptF -> do+ {- update IV -}+ let (iv, econtent') =+ if hasExplicitBlockIV $ stVersion st+ then B.splitAt (bulkIVSize bulk) econtent+ else (cstIV cst, econtent)+ let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent'+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }++ let content' = decryptF writekey iv econtent'+ let paddinglength = fromIntegral (B.last content') + 1+ let contentlen = B.length content' - paddinglength - digestSize+ let (content, mac, padding) = fromJust "p3" $ partition3 content' (contentlen, digestSize, paddinglength)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just padding+ }+ BulkStreamF initF _ decryptF -> do+ let iv = cstIV cst+ let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent+ {- update Ctx -}+ let contentlen = B.length content' - digestSize+ let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+
+ Network/TLS/Record/Engage.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Network.TLS.Record.Engage+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Engage a record into the Record layer.+-- The record is compressed, added some integrity field, then encrypted.+--+module Network.TLS.Record.Engage+ ( engageRecord+ ) where++import Control.Monad.State++import Network.TLS.Cap+import Network.TLS.State+import Network.TLS.Record.Types+import Network.TLS.Cipher+import Network.TLS.Compression+import Network.TLS.Util+import Data.ByteString (ByteString)+import qualified Data.ByteString as B++engageRecord :: Record Plaintext -> TLSSt (Record Ciphertext)+engageRecord = compressRecord >=> encryptRecord++compressRecord :: Record Plaintext -> TLSSt (Record Compressed)+compressRecord record =+ onRecordFragment record $ fragmentCompress $ \bytes -> do+ withCompression $ compressionDeflate bytes++{-+ - when Tx Encrypted is set, we pass the data through encryptContent, otherwise+ - we just return the packet+ -}+encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext)+encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do+ st <- get+ if stTxEncrypted st+ then encryptContent record bytes+ else return bytes++encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString+encryptContent record content = do+ digest <- makeDigest True (recordToHeader record) content+ encryptData $ B.concat [content, digest]++encryptData :: ByteString -> TLSSt ByteString+encryptData content = do+ st <- get++ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "tx crypt state" $ stTxCryptState st++ let writekey = cstKey cst++ case bulkF bulk of+ BulkNoneF -> return content+ BulkBlockF encrypt _ -> do+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding = if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize) in+ let padbyte' = if padbyte == 0 then blockSize else padbyte in+ B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else+ B.empty++ -- before TLS 1.1, the block cipher IV is made of the residual of the previous block.+ iv <- if hasExplicitBlockIV $ stVersion st+ then genTLSRandom (bulkIVSize bulk)+ else return $ cstIV cst+ let e = encrypt writekey iv (B.concat [ content, padding ])+ if hasExplicitBlockIV $ stVersion st+ then return $ B.concat [iv,e]+ else do+ let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return e+ BulkStreamF initF encryptF _ -> do+ let iv = cstIV cst+ let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return e+
+ Network/TLS/Record/Types.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE EmptyDataDecls #-}+-- |+-- Module : Network.TLS.Record.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- The Record Protocol takes messages to be transmitted, fragments the+-- data into manageable blocks, optionally compresses the data, applies+-- a MAC, encrypts, and transmits the result. Received data is+-- decrypted, verified, decompressed, reassembled, and then delivered to+-- higher-level clients.+--+module Network.TLS.Record.Types+ ( Header(..)+ , ProtocolType(..)+ , packetType+ -- * TLS Records+ , Record(..)+ -- * TLS Record fragment and constructors+ , Fragment+ , fragmentPlaintext+ , fragmentCiphertext+ , fragmentGetBytes+ , Plaintext+ , Compressed+ , Ciphertext+ -- * manipulate record+ , onRecordFragment+ , fragmentCompress+ , fragmentCipher+ , fragmentUncipher+ , fragmentUncompress+ -- * serialize record+ , rawToRecord+ , recordToRaw+ , recordToHeader+ ) where++import Network.TLS.Struct+import Network.TLS.State+import qualified Data.ByteString as B+import Control.Applicative ((<$>))++-- | Represent a TLS record.+data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)++newtype Fragment a = Fragment Bytes deriving (Show,Eq)++data Plaintext+data Compressed+data Ciphertext++fragmentPlaintext :: Bytes -> Fragment Plaintext+fragmentPlaintext bytes = Fragment bytes++fragmentCiphertext :: Bytes -> Fragment Ciphertext+fragmentCiphertext bytes = Fragment bytes++fragmentGetBytes :: Fragment a -> Bytes+fragmentGetBytes (Fragment bytes) = bytes++onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b)+onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag++fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b)+fragmentMap f (Fragment b) = Fragment <$> f b++-- | turn a plaintext record into a compressed record using the compression function supplied+fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed)+fragmentCompress f = fragmentMap f++-- | turn a compressed record into a ciphertext record using the cipher function supplied+fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext)+fragmentCipher f = fragmentMap f++-- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed)+fragmentUncipher f = fragmentMap f++-- | turn a compressed fragment into a plaintext fragment using the decompression function supplied+fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext)+fragmentUncompress f = fragmentMap f++-- | turn a record into an header and bytes+recordToRaw :: Record a -> (Header, Bytes)+recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes)++-- | turn a header and a fragment into a record+rawToRecord :: Header -> Fragment a -> Record a+rawToRecord (Header pt ver _) fragment = Record pt ver fragment++-- | turn a record into a header+recordToHeader :: Record a -> Header+recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes)
Network/TLS/Sending.hs view
@@ -8,9 +8,7 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state ---module Network.TLS.Sending (- writePacket- ) where+module Network.TLS.Sending (writePacket, encryptRSA) where import Control.Applicative ((<$>)) import Control.Monad.State@@ -19,14 +17,10 @@ import qualified Data.ByteString as B import Network.TLS.Util-import Network.TLS.Cap-import Network.TLS.Wire import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State-import Network.TLS.Cipher-import Network.TLS.Compression import Network.TLS.Crypto {-@@ -47,23 +41,7 @@ when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment) return record -compressRecord :: Record Plaintext -> TLSSt (Record Compressed)-compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes- {-- - when Tx Encrypted is set, we pass the data through encryptContent, otherwise- - we just return the packet- -}-encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext)-encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do- st <- get- if stTxEncrypted st- then encryptContent record bytes- else return bytes--{- - ChangeCipherSpec state change need to be handled after encryption otherwise - its own packet would be encrypted with the new context, instead of beeing sent - under the current context@@ -86,10 +64,8 @@ preProcessPacket :: Packet -> TLSSt () preProcessPacket (Alert _) = return () preProcessPacket (AppData _) = return ()-preProcessPacket (ChangeCipherSpec) = updateStatusCC True >> return () -- FIXME don't ignore this error just in case+preProcessPacket (ChangeCipherSpec) = return () preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do- -- FIXME don't ignore this error- _ <- updateStatusHs (typeOfHandshake hs) case hs of Finished fdata -> updateVerifiedData True fdata _ -> return ()@@ -101,7 +77,7 @@ writePacket :: Packet -> TLSSt ByteString writePacket pkt = do preProcessPacket pkt- makeRecord pkt >>= processRecord >>= compressRecord >>= encryptRecord >>= postprocessRecord >>= encodeRecord+ makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -}@@ -118,68 +94,8 @@ Left err -> fail ("rsa encrypt failed: " ++ show err) Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent -encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString-encryptContent record content = do- digest <- makeDigest True (recordToHeader record) content- encryptData $ B.concat [content, digest]--encryptData :: ByteString -> TLSSt ByteString-encryptData content = do- st <- get-- let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "tx crypt state" $ stTxCryptState st-- let writekey = cstKey cst-- case bulkF bulk of- BulkNoneF -> return content- BulkBlockF encrypt _ -> do- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding = if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize) in- let padbyte' = if padbyte == 0 then blockSize else padbyte in- B.replicate padbyte' (fromIntegral (padbyte' - 1))- else- B.empty-- -- before TLS 1.1, the block cipher IV is made of the residual of the previous block.- iv <- if hasExplicitBlockIV $ stVersion st- then genTLSRandom (bulkIVSize bulk)- else return $ cstIV cst- let e = encrypt writekey iv (B.concat [ content, padding ])- if hasExplicitBlockIV $ stVersion st- then return $ B.concat [iv,e]- else do- let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e- put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }- return e- BulkStreamF initF encryptF _ -> do- let iv = cstIV cst- let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content- put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }- return e- writePacketContent :: Packet -> TLSSt ByteString-writePacketContent (Handshake hss) = return . B.concat =<< mapM makeContent hss where- makeContent hs@(ClientKeyXchg _ _) = do- ver <- get >>= return . stVersion- let premastersecret = runPut $ encodeHandshakeContent hs- setMasterSecret premastersecret- econtent <- encryptRSA premastersecret-- let extralength =- if ver < TLS10- then B.empty- else runPut $ putWord16 $ fromIntegral $ B.length econtent- let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake hs)- (fromIntegral (B.length econtent + B.length extralength))- return $ B.concat [hdr, extralength, econtent]- makeContent hs = return $ encodeHandshakes [hs]-+writePacketContent (Handshake hss) = return $ encodeHandshakes hss writePacketContent (Alert a) = return $ encodeAlerts a writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec writePacketContent (AppData x) = return x
Network/TLS/State.hs view
@@ -16,15 +16,11 @@ , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..)- , TLSStatus(..)- , HandshakeStatus(..) , newTLSState , genTLSRandom , withTLSRNG , withCompression , assert -- FIXME move somewhere else (Internal.hs ?)- , updateStatusHs- , updateStatusCC , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial@@ -45,13 +41,11 @@ , isClientContext , startHandshakeClient , updateHandshakeDigest- , updateHandshakeDigestSplitted , getHandshakeDigest , endHandshake ) where import Data.Word-import Data.List (find) import Data.Maybe (isNothing) import Network.TLS.Util import Network.TLS.Struct@@ -72,28 +66,6 @@ assert fctname list = forM_ list $ \ (name, assumption) -> do when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") -data HandshakeStatus =- HsStatusClientHello- | HsStatusServerHello- | HsStatusServerCertificate- | HsStatusServerKeyXchg- | HsStatusServerCertificateReq- | HsStatusServerHelloDone- | HsStatusClientCertificate- | HsStatusClientKeyXchg- | HsStatusClientCertificateVerify- | HsStatusClientChangeCipher- | HsStatusClientFinished- | HsStatusServerChangeCipher- deriving (Show,Eq)--data TLSStatus =- StatusInit- | StatusHandshakeReq- | StatusHandshake HandshakeStatus- | StatusOk- deriving (Show,Eq)- data TLSCryptState = TLSCryptState { cstKey :: !Bytes , cstIV :: !Bytes@@ -122,7 +94,6 @@ data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version- , stStatus :: !TLSStatus , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool , stRxEncrypted :: Bool@@ -155,7 +126,6 @@ newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10- , stStatus = StatusInit , stHandshake = Nothing , stTxEncrypted = False , stRxEncrypted = False@@ -210,68 +180,6 @@ modify (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms }) return digest -hsStatusTransitionTable :: [ (HandshakeType, TLSStatus, [ TLSStatus ]) ]-hsStatusTransitionTable =- [ (HandshakeType_HelloRequest, StatusHandshakeReq,- [ StatusOk ])- , (HandshakeType_ClientHello, StatusHandshake HsStatusClientHello,- [ StatusInit, StatusHandshakeReq ])- , (HandshakeType_ServerHello, StatusHandshake HsStatusServerHello,- [ StatusHandshake HsStatusClientHello ])- , (HandshakeType_Certificate, StatusHandshake HsStatusServerCertificate,- [ StatusHandshake HsStatusServerHello ])- , (HandshakeType_ServerKeyXchg, StatusHandshake HsStatusServerKeyXchg,- [ StatusHandshake HsStatusServerHello- , StatusHandshake HsStatusServerCertificate ])- , (HandshakeType_CertRequest, StatusHandshake HsStatusServerCertificateReq,- [ StatusHandshake HsStatusServerHello- , StatusHandshake HsStatusServerCertificate- , StatusHandshake HsStatusServerKeyXchg ])- , (HandshakeType_ServerHelloDone, StatusHandshake HsStatusServerHelloDone,- [ StatusHandshake HsStatusServerHello- , StatusHandshake HsStatusServerCertificate- , StatusHandshake HsStatusServerKeyXchg- , StatusHandshake HsStatusServerCertificateReq ])- , (HandshakeType_Certificate, StatusHandshake HsStatusClientCertificate,- [ StatusHandshake HsStatusServerHelloDone ])- , (HandshakeType_ClientKeyXchg, StatusHandshake HsStatusClientKeyXchg,- [ StatusHandshake HsStatusServerHelloDone- , StatusHandshake HsStatusClientCertificate ])- , (HandshakeType_CertVerify, StatusHandshake HsStatusClientCertificateVerify,- [ StatusHandshake HsStatusClientKeyXchg ])- , (HandshakeType_Finished, StatusHandshake HsStatusClientFinished,- [ StatusHandshake HsStatusClientChangeCipher ])- , (HandshakeType_Finished, StatusOk,- [ StatusHandshake HsStatusServerChangeCipher ])- ]--updateStatus :: MonadState TLSState m => TLSStatus -> m ()-updateStatus x = modify (\st -> st { stStatus = x })--updateStatusHs :: MonadState TLSState m => HandshakeType -> m (Maybe TLSError)-updateStatusHs ty = do- status <- return . stStatus =<< get- ns <- return . transition . stStatus =<< get- case ns of- Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("handshake:" ++ show ty)- Just (_,x,_) -> updateStatus x >> return Nothing- where- edgeEq cur (ety, _, aprevs) = ty == ety && (maybe False (const True) $ find (== cur) aprevs)- transition currentStatus = find (edgeEq currentStatus) hsStatusTransitionTable--updateStatusCC :: MonadState TLSState m => Bool -> m (Maybe TLSError)-updateStatusCC sending = do- status <- return . stStatus =<< get- cc <- isClientContext- let x = case (cc /= sending, status) of- (False, StatusHandshake HsStatusClientKeyXchg) -> Just (StatusHandshake HsStatusClientChangeCipher)- (False, StatusHandshake HsStatusClientCertificateVerify) -> Just (StatusHandshake HsStatusClientChangeCipher)- (True, StatusHandshake HsStatusClientFinished) -> Just (StatusHandshake HsStatusServerChangeCipher)- _ -> Nothing- case x of- Just newstatus -> updateStatus newstatus >> return Nothing- Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("Client Context: " ++ show cc)- updateVerifiedData :: MonadState TLSState m => Bool -> Bytes -> m () updateVerifiedData sending bs = do cc <- isClientContext@@ -407,11 +315,6 @@ updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" $ \hs -> hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content }--updateHandshakeDigestSplitted :: MonadState TLSState m => HandshakeType -> Bytes -> m ()-updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes]- where- hdr = runPut $ encodeHandshakeHeader ty (B.length bytes) getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes getHandshakeDigest client = do
Network/TLS/Struct.hs view
@@ -28,7 +28,6 @@ , Header(..) , ServerRandom(..) , ClientRandom(..)- , ClientKeyData(..) , serverRandom , clientRandom , FinishedData@@ -112,6 +111,7 @@ Error_Misc String -- ^ mainly for instance of Error | Error_Protocol (String, Bool, AlertDescription) | Error_Certificate String+ | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_Random String | Error_EOF | Error_Packet String@@ -140,7 +140,6 @@ newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)-newtype ClientKeyData = ClientKeyData Bytes deriving (Show, Eq) newtype Session = Session (Maybe Bytes) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8@@ -227,7 +226,7 @@ | Certificates [X509] | HelloRequest | ServerHelloDone- | ClientKeyXchg Version ClientKeyData+ | ClientKeyXchg Bytes | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] | CertVerify [Word8]@@ -246,7 +245,7 @@ typeOfHandshake (Certificates _) = HandshakeType_Certificate typeOfHandshake (HelloRequest) = HandshakeType_HelloRequest typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone-typeOfHandshake (ClientKeyXchg _ _) = HandshakeType_ClientKeyXchg+typeOfHandshake (ClientKeyXchg _) = HandshakeType_ClientKeyXchg typeOfHandshake (ServerKeyXchg _) = HandshakeType_ServerKeyXchg typeOfHandshake (CertRequest _ _ _) = HandshakeType_CertRequest typeOfHandshake (CertVerify _) = HandshakeType_CertVerify
Tests.hs view
@@ -1,23 +1,29 @@ {-# LANGUAGE CPP #-} import Test.QuickCheck-import Test.QuickCheck.Test+import Test.QuickCheck.Monadic import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) ---import Tests.Certificate+import Tests.Certificate+import Tests.PipeChan+import Tests.Connection import Data.Word-import Data.Certificate.X509 import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Network.TLS.Core import Network.TLS.Cipher import Network.TLS.Struct import Network.TLS.Packet-import Control.Monad import Control.Applicative-import System.IO+import Control.Concurrent+import Control.Exception (throw, catch, SomeException)+import Control.Monad +import Prelude hiding (catch)+ genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i @@ -49,15 +55,12 @@ instance Arbitrary ServerRandom where arbitrary = ServerRandom <$> (genByteString 32) -instance Arbitrary ClientKeyData where- arbitrary = ClientKeyData <$> (genByteString 46)- instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of- 1 -> return $ Session Nothing 2 -> liftM (Session . Just) (genByteString 32)+ _ -> return $ Session Nothing arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0,200) >>= vector@@ -88,10 +91,10 @@ <*> arbitrary <*> arbitrary <*> (return [])- --, liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey)+ , liftM Certificates (resize 2 $ listOf $ arbitraryX509) , pure HelloRequest , pure ServerHelloDone- , ClientKeyXchg <$> arbitrary <*> arbitrary+ , ClientKeyXchg <$> genByteString 48 --, liftM ServerKeyXchg --, liftM3 CertRequest arbitrary (return Nothing) (return []) --, liftM CertVerify (return [])@@ -100,15 +103,95 @@ {- quickcheck property -} +prop_header_marshalling_id :: Header -> Bool prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x++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 cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA } -tests = testGroup "Marshalling"- [ testProperty "Header" prop_header_marshalling_id- , testProperty "Handshake" prop_handshake_marshalling_id+prop_pipe_work :: PropertyM IO ()+prop_pipe_work = do+ pipe <- run newPipe+ _ <- run (runPipe pipe)++ let bSize = 16+ n <- pick (choose (1, 32))++ let d1 = B.replicate (bSize * n) 40+ let d2 = B.replicate (bSize * n) 45++ d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1))+ d1 `assertEq` d1'++ d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2))+ d2 `assertEq` d2'++ return ()++prop_handshake_initiate :: PropertyM IO ()+prop_handshake_initiate = do+ -- initial setup+ pipe <- run newPipe+ _ <- run (runPipe pipe)+ startQueue <- run newChan+ resultQueue <- run newChan++ params <- pick arbitraryPairParams+ (cCtx, sCtx) <- run $ newPairContext pipe params++ _ <- run $ forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")+ _ <- run $ forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client")++ {- the test involves writing data on one side of the data "pipe" and+ - then checking we received them on the other side of the data "pipe" -}+ d <- L.pack <$> pick (someWords8 256)+ run $ writeChan startQueue d++ dres <- run $ readChan resultQueue+ d `assertEq` dres++ return ()+ where+ printAndRaise :: String -> SomeException -> IO ()+ printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e++ someWords8 :: Int -> Gen [Word8]+ someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))++ tlsServer ctx queue = do+ hSuccess <- handshake ctx+ unless hSuccess $ fail "handshake failed on server side"+ d <- recvData ctx+ writeChan queue d+ return ()+ tlsClient queue ctx = do+ hSuccess <- handshake ctx+ unless hSuccess $ fail "handshake failed on client side"+ d <- readChan queue+ sendData ctx d+ bye ctx+ return ()++assertEq :: (Show a, Monad m, Eq a) => a -> a -> m ()+assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)++main :: IO ()+main = defaultMain+ [ tests_marshalling+ , tests_handshake ]+ where+ -- lowlevel tests to check the packet marshalling.+ tests_marshalling = testGroup "Marshalling"+ [ testProperty "Header" prop_header_marshalling_id+ , testProperty "Handshake" prop_handshake_marshalling_id+ ] -main = defaultMain [ tests ]+ -- high level tests between a client and server with fake ciphers.+ tests_handshake = testGroup "Handshakes"+ [ testProperty "setup" (monadicIO prop_pipe_work)+ , testProperty "initiate" (monadicIO prop_handshake_initiate)+ ]
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.8.2+Version: 0.8.3 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -49,11 +49,15 @@ Network.TLS.Internal other-modules: Network.TLS.Cap Network.TLS.Struct- Network.TLS.MAC Network.TLS.Core Network.TLS.Crypto+ Network.TLS.MAC+ Network.TLS.Measurement Network.TLS.Packet Network.TLS.Record+ Network.TLS.Record.Types+ Network.TLS.Record.Engage+ Network.TLS.Record.Disengage Network.TLS.State Network.TLS.Sending Network.TLS.Receiving@@ -70,6 +74,9 @@ , test-framework , test-framework-quickcheck2 , bytestring+ , time+ , cprng-aes+ , cryptocipher >= 0.3.0 else Buildable: False ghc-options: -Wall -fhpc