tls 0.6.4 → 0.7.0

raw patch · 14 files changed

+490/−282 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Network/TLS.hs +2/−0
• Network/TLS/Cap.hs +1/−1
• Network/TLS/Cipher.hs +21/−18
• Network/TLS/Core.hs +184/−82
• Network/TLS/Packet.hs +107/−65
• Network/TLS/Receiving.hs +53/−22
• Network/TLS/Sending.hs +39/−48
• Network/TLS/State.hs +54/−24
• Network/TLS/Struct.hs +16/−10
• Network/TLS/Wire.hs +4/−1
• TODO +0/−4
• Tests.hs +7/−5
• tls.cabal +1/−1

@@ -1,4 +1,4 @@-Copyright (c) 2010 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>  All rights reserved. 

@@ -10,6 +10,8 @@ 	-- * Context configuration 	  TLSParams(..) 	, TLSLogging(..)+	, TLSCertificateUsage(..)+	, TLSCertificateRejectReason(..) 	, defaultParams 	, defaultLogging 

@@ -15,5 +15,5 @@  hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool -hasHelloExtensions ver = ver >= TLS12+hasHelloExtensions ver = ver >= SSL3 hasExplicitBlockIV ver = ver >= TLS11

@@ -33,15 +33,17 @@ 	                (IV -> B.ByteString -> (B.ByteString, IV))  data CipherKeyExchangeType =-	  CipherKeyExchangeRSA-	| CipherKeyExchangeDHE_RSA-	| CipherKeyExchangeECDHE_RSA-	| CipherKeyExchangeDHE_DSS-	| CipherKeyExchangeDH_DSS-	| CipherKeyExchangeDH_RSA-	| CipherKeyExchangeECDH_ECDSA-	| CipherKeyExchangeECDH_RSA-	| CipherKeyExchangeECDHE_ECDSA+	  CipherKeyExchange_RSA+	| CipherKeyExchange_DH_Anon+	| CipherKeyExchange_DHE_RSA+	| CipherKeyExchange_ECDHE_RSA+	| CipherKeyExchange_DHE_DSS+	| CipherKeyExchange_DH_DSS+	| CipherKeyExchange_DH_RSA+	| CipherKeyExchange_ECDH_ECDSA+	| CipherKeyExchange_ECDH_RSA+	| CipherKeyExchange_ECDHE_ECDSA+	deriving (Show,Eq)  -- | Cipher algorithm data Cipher = Cipher@@ -65,12 +67,13 @@ 	(==) c1 c2 = cipherID c1 == cipherID c2  cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool-cipherExchangeNeedMoreData CipherKeyExchangeRSA         = False-cipherExchangeNeedMoreData CipherKeyExchangeDHE_RSA     = True-cipherExchangeNeedMoreData CipherKeyExchangeECDHE_RSA   = True-cipherExchangeNeedMoreData CipherKeyExchangeDHE_DSS     = True-cipherExchangeNeedMoreData CipherKeyExchangeDH_DSS      = False-cipherExchangeNeedMoreData CipherKeyExchangeDH_RSA      = False-cipherExchangeNeedMoreData CipherKeyExchangeECDH_ECDSA  = True-cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA    = True-cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True+cipherExchangeNeedMoreData CipherKeyExchange_RSA         = False+cipherExchangeNeedMoreData CipherKeyExchange_DH_Anon     = True+cipherExchangeNeedMoreData CipherKeyExchange_DHE_RSA     = True+cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_RSA   = True+cipherExchangeNeedMoreData CipherKeyExchange_DHE_DSS     = True+cipherExchangeNeedMoreData CipherKeyExchange_DH_DSS      = False+cipherExchangeNeedMoreData CipherKeyExchange_DH_RSA      = False+cipherExchangeNeedMoreData CipherKeyExchange_ECDH_ECDSA  = True+cipherExchangeNeedMoreData CipherKeyExchange_ECDH_RSA    = True+cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_ECDSA = True

@@ -11,12 +11,15 @@ 	-- * Context configuration 	  TLSParams(..) 	, TLSLogging(..)+	, TLSCertificateUsage(..)+	, TLSCertificateRejectReason(..) 	, defaultLogging 	, defaultParams  	-- * Context object 	, TLSCtx 	, ctxHandle+	, ctxEOF  	-- * Internal packet sending and receiving 	, sendPacket@@ -53,7 +56,11 @@ import Control.Applicative ((<$>)) import Control.Concurrent.MVar import Control.Monad.State+import Control.Exception (throwIO, Exception(), onException, fromException, catch)+import Data.IORef import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush)+import System.IO.Error (mkIOError, eofErrorType)+import Prelude hiding (catch)  data TLSLogging = TLSLogging 	{ loggingPacketSent :: String -> IO ()@@ -62,6 +69,20 @@ 	, loggingIORecv     :: Header -> Bytes -> IO () 	} +-- | Certificate and Chain rejection reason+data TLSCertificateRejectReason =+	  CertificateRejectExpired+	| CertificateRejectRevoked+	| CertificateRejectUnknownCA+	| CertificateRejectOther String+	deriving (Show,Eq)++-- | Certificate Usage callback possible returns values.+data TLSCertificateUsage =+	  CertificateUsageAccept                            -- ^ usage of certificate accepted+	| CertificateUsageReject TLSCertificateRejectReason -- ^ usage of certificate rejected+	deriving (Show,Eq)+ data TLSParams = TLSParams 	{ pConnectVersion    :: Version             -- ^ version to use on client connection. 	, pAllowedVersions   :: [Version]           -- ^ allowed versions that we can use.@@ -69,9 +90,10 @@ 	, pCompressions      :: [Compression]       -- ^ all compression supported ordered by priority. 	, pWantClientCert    :: Bool                -- ^ request a certificate from client. 	                                            -- use by server only.+	, 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-	, onCertificatesRecv :: ([X509] -> IO Bool) -- ^ callback to verify received cert chain.+	, onCertificatesRecv :: ([X509] -> IO TLSCertificateUsage) -- ^ callback to verify received cert chain. 	}  defaultLogging :: TLSLogging@@ -84,14 +106,15 @@  defaultParams :: TLSParams defaultParams = TLSParams-	{ pConnectVersion    = TLS10-	, pAllowedVersions   = [TLS10,TLS11]-	, pCiphers           = []-	, pCompressions      = [nullCompression]-	, pWantClientCert    = False-	, pCertificates      = []-	, pLogging           = defaultLogging-	, onCertificatesRecv = (\_ -> return True)+	{ pConnectVersion         = TLS10+	, pAllowedVersions        = [TLS10,TLS11]+	, pCiphers                = []+	, pCompressions           = [nullCompression]+	, pWantClientCert         = False+	, pUseSecureRenegotiation = True+	, pCertificates           = []+	, pLogging                = defaultLogging+	, onCertificatesRecv      = (\_ -> return CertificateUsageAccept) 	}  instance Show TLSParams where@@ -109,36 +132,44 @@ 	{ ctxHandle :: Handle        -- ^ return the handle associated with this context 	, ctxParams :: TLSParams 	, ctxState  :: MVar TLSState+	, ctxEOF_   :: IORef Bool    -- ^ is the handle as EOFed or not. 	} +ctxEOF :: MonadIO m => TLSCtx -> m Bool+ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)++throwCore :: (MonadIO m, Exception e) => e -> m a+throwCore = liftIO . throwIO+ newCtx :: Handle -> TLSParams -> TLSState -> IO TLSCtx newCtx handle params st = do 	hSetBuffering handle NoBuffering 	stvar <- newMVar st+	eof   <- newIORef False 	return $ TLSCtx 		{ ctxHandle = handle 		, ctxParams = params 		, ctxState  = stvar+		, ctxEOF_   = eof 		}  ctxLogging :: TLSCtx -> TLSLogging ctxLogging = pLogging . ctxParams  usingState :: MonadIO m => TLSCtx -> TLSSt a -> m (Either TLSError a)-usingState ctx f = liftIO (takeMVar mvar) >>= execAndStore+usingState ctx f = liftIO (takeMVar mvar) >>= \st -> liftIO $ onException (execAndStore st) (putMVar mvar st) 	where 		mvar = ctxState ctx 		execAndStore st = do-			-- FIXME add onException with (putMVar mvar st) 			let (a, newst) = runTLSState f st-			liftIO (putMVar mvar newst)+			putMVar mvar newst 			return a  usingState_ :: MonadIO m => TLSCtx -> TLSSt a -> m a usingState_ ctx f = do 	ret <- usingState ctx f 	case ret of-		Left err -> error ("assertion failed, wrong use of state_: " ++ show err)+		Left err -> throwCore err 		Right r  -> return r  getStateRNG :: MonadIO m => TLSCtx -> Int -> m Bytes@@ -149,23 +180,51 @@ 	b <- usingState_ ctx (p . stStatus <$> get) 	when b (a >> whileStatus ctx p a) --- | receive one enveloppe from the context that contains 1 or--- many packets (many only in case of handshake). if will returns a+errorToAlert :: TLSError -> Packet+errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]+errorToAlert _                           = Alert [(AlertLevel_Fatal, InternalError)]++setEOF :: MonadIO m => TLSCtx -> m ()+setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True++readExact :: MonadIO m => TLSCtx -> Int -> m Bytes+readExact ctx sz = do+	hdrbs <- liftIO $ B.hGet (ctxHandle ctx) sz+	when (B.length hdrbs < sz) $ do+		setEOF ctx+		if B.null hdrbs+			then throwCore Error_EOF+			else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs)))+	return hdrbs++-- | 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 -> m (Either TLSError [Packet])+recvPacket :: MonadIO m => TLSCtx -> m (Either TLSError Packet) recvPacket ctx = do-	hdr <- (liftIO $ B.hGet (ctxHandle ctx) 5) >>= return . decodeHeader-	case hdr of+	hdrbs <- readExact ctx 5+	case decodeHeader hdrbs of 		Left err                          -> return $ Left err-		Right header@(Header _ _ readlen) -> do-			content <- liftIO $ B.hGet (ctxHandle ctx) (fromIntegral readlen)-			liftIO $ (loggingIORecv $ ctxLogging ctx) header content-			pkt <- usingState ctx $ readPacket header (EncryptedData content)-			case pkt of-				Right p -> liftIO $ mapM_ ((loggingPacketRecv $ ctxLogging ctx) . show) p-				_       -> return ()-			return pkt+		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 header (EncryptedData content)+		case pkt of+			Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p+			_       -> return ()+		return pkt +recvPacketSuccess :: MonadIO m => TLSCtx -> m ()+recvPacketSuccess ctx = do+	pkt <- recvPacket ctx+	case pkt of+		Left err -> throwCore err+		Right _  -> return ()+ -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx -> Packet -> m () sendPacket ctx pkt = do@@ -192,7 +251,7 @@ -- -- this doesn't actually close the handle bye :: MonadIO m => TLSCtx -> m ()-bye ctx = sendPacket ctx $ Alert (AlertLevel_Warning, CloseNotify)+bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]  -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server.@@ -200,26 +259,25 @@ handshakeClient ctx = do 	-- Send ClientHello 	crand <- getStateRNG ctx 32 >>= return . ClientRandom-	sendPacket ctx $ Handshake $ ClientHello ver crand-	                                         (Session Nothing)-	                                         (map cipherID ciphers)-	                                         (map compressionID compressions)-	                                         Nothing+	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 -> error ("error received: " ++ show err)-			Right l  -> mapM_ processServerInfo l+			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))+	when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts]) -	-- Send ClientKeyXchg-	prerand <- getStateRNG ctx 46 >>= return . ClientKeyData-	sendPacket ctx $ Handshake (ClientKeyXchg ver prerand)+	sendClientKeyXchg  	{- maybe send certificateVerify -} 	{- FIXME not implemented yet -}@@ -229,10 +287,10 @@  	-- Send Finished 	cf <- usingState_ ctx $ getHandshakeDigest True-	sendPacket ctx (Handshake $ Finished $ B.unpack cf)+	sendPacket ctx (Handshake [Finished cf])  	-- receive changeCipherSpec & Finished-	recvPacket ctx >> recvPacket ctx >> return ()+	recvPacketSuccess ctx >> recvPacketSuccess ctx >> return ()  	where 		params       = ctxParams ctx@@ -241,32 +299,59 @@ 		ciphers      = pCiphers params 		compressions = pCompressions params 		clientCerts  = map fst $ pCertificates params+		getExtensions =+			if pUseSecureRenegotiation params+			then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, vd) ]+			else return [] -		processServerInfo (Handshake (ServerHello rver _ _ cipher _ _)) = do+		processServerInfo (Handshake hss) = mapM_ processHandshake hss+		processServerInfo _               = return ()++		processHandshake (ServerHello rver _ _ cipher _ _) = do+			when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) 			case find ((==) rver) allowedvers of-				Nothing -> error ("received version which is not allowed: " ++ show ver)+				Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) 				Just _  -> usingState_ ctx $ setVersion ver 			case find ((==) cipher . cipherID) ciphers of-				Nothing -> error "no cipher in common with the server"+				Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) 				Just c  -> usingState_ ctx $ setCipher c -		processServerInfo (Handshake (CertRequest _ _ _)) = do+		processHandshake (Certificates certs) = do+			let cb = onCertificatesRecv $ params+			usage <- liftIO $ cb certs+			case usage of+				CertificateUsageAccept        -> return ()+				CertificateUsageReject reason -> certificateRejected reason++		processHandshake (CertRequest _ _ _) = do 			return () 			--modify (\sc -> sc { scCertRequested = True })+		processHandshake _ = return () -		processServerInfo (Handshake (Certificates certs)) = do-			let cb = onCertificatesRecv $ params-			valid <- liftIO $ cb certs-			unless valid $ error "certificates received deemed invalid by user"+		sendClientKeyXchg = do+			prerand <- getStateRNG ctx 46 >>= return . ClientKeyData+			sendPacket ctx $ Handshake [ClientKeyXchg ver prerand] -		processServerInfo _ = return ()+		-- on certificate reject, throw an exception with the proper protocol alert error.+		certificateRejected CertificateRejectRevoked =+			throwCore $ Error_Protocol ("certificate is revoked", True, CertificateRevoked)+		certificateRejected CertificateRejectExpired =+			throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired)+		certificateRejected CertificateRejectUnknownCA =+			throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)+		certificateRejected (CertificateRejectOther s) =+			throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown)  handshakeServerWith :: MonadIO m => TLSCtx -> Handshake -> m () handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do 	-- Handle Client hello-	when (not $ elem ver (pAllowedVersions params)) $ fail "unsupported version"-	when (commonCiphers == []) $ fail "no common cipher supported"-	when (commonCompressions == []) $ fail "no common compression supported"+	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)+	when (commonCiphers == []) $+		throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)+	when (commonCompressions == []) $+		throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure) 	usingState_ ctx $ modify (\st -> st 		{ stVersion = ver 		, stCipher  = Just usedCipher@@ -278,13 +363,13 @@ 	liftIO $ hFlush $ ctxHandle ctx  	-- Receive client info until client Finished.-	whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacket ctx)+	whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx)  	sendPacket ctx ChangeCipherSpec  	-- Send Finish 	cf <- usingState_ ctx $ getHandshakeDigest False-	sendPacket ctx (Handshake $ Finished $ B.unpack cf)+	sendPacket ctx (Handshake [Finished cf])  	liftIO $ hFlush $ ctxHandle ctx 	return ()@@ -309,22 +394,31 @@ 			-- the necessary bits set.  			-- send ServerHello & Certificate & ServerKeyXchg & CertReq-			sendPacket ctx $ Handshake $ ServerHello ver srand-			                                         (Session Nothing)-			                                         (cipherID usedCipher)-			                                         (compressionID usedCompression)-			                                         Nothing-			sendPacket ctx (Handshake $ Certificates srvCerts)+			secReneg   <- usingState_ ctx getSecureRenegotiation+			extensions <- if secReneg+				then do+					vf <- usingState_ ctx $ do+						cvf <- getVerifiedData True+						svf <- getVerifiedData False+						return $ encodeExtSecureRenegotiation cvf (Just svf)+					return [ (0xff01, vf) ]+				else return []+			usingState_ ctx (setVersion ver >> setServerRandom srand)+			sendPacket ctx $ Handshake+				[ ServerHello ver srand (Session Nothing) (cipherID usedCipher)+				                        (compressionID usedCompression) extensions+				, Certificates srvCerts+				] 			when needKeyXchg $ do 				let skg = SKX_RSA Nothing-				sendPacket ctx (Handshake $ ServerKeyXchg skg)+				sendPacket ctx (Handshake [ServerKeyXchg skg]) 			-- FIXME we don't do this on a Anonymous server 			when (pWantClientCert params) $ do 				let certTypes = [ CertificateType_RSA_Sign ] 				let creq = CertRequest certTypes Nothing [0,0,0]-				sendPacket ctx (Handshake creq)+				sendPacket ctx (Handshake [creq]) 			-- Send HelloDone-			sendPacket ctx (Handshake ServerHelloDone)+			sendPacket ctx (Handshake [ServerHelloDone])  handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello" @@ -333,24 +427,29 @@ handshakeServer ctx = do 	pkts <- recvPacket ctx 	case pkts of-		Right [Handshake hs] -> handshakeServerWith ctx hs-		x                    -> fail ("unexpected type received. expecting handshake ++ " ++ show x)+		Right (Handshake [hs]) -> handshakeServerWith ctx hs+		x                      -> fail ("unexpected type received. expecting handshake ++ " ++ show x)  -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegociation-handshake :: MonadIO m => TLSCtx -> m ()+handshake :: MonadIO m => TLSCtx -> m Bool handshake ctx = do 	cc <- usingState_ ctx (stClientContext <$> get)-	if cc-		then handshakeClient ctx-		else handshakeServer ctx+	liftIO $ handleException $ if cc then handshakeClient ctx else handshakeServer ctx+	where+		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 "")  -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => TLSCtx -> L.ByteString -> m ()-sendData ctx dataToSend = mapM_ sendDataChunk (L.toChunks dataToSend)-	where sendDataChunk d =-		if B.length d > 16384+sendData ctx dataToSend = do+	eofed <- ctxEOF ctx+	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "sendData" (Just (ctxHandle ctx)) Nothing+	mapM_ sendDataChunk (L.toChunks dataToSend)+		where sendDataChunk d = if B.length d > 16384 			then do 				let (sending, remain) = B.splitAt 16384 d 				sendPacket ctx $ AppData sending@@ -362,19 +461,22 @@ -- a Handshake ClientHello is received recvData :: MonadIO m => TLSCtx -> m L.ByteString recvData ctx = do-	pkt <- recvPacket ctx+	eofed <- ctxEOF ctx+	when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "recvData" (Just (ctxHandle ctx)) Nothing+	pkt   <- recvPacket ctx 	case pkt of 		-- on server context receiving a client hello == renegociation-		Right [Handshake ch@(ClientHello _ _ _ _ _ _)] ->+		Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) -> 			handshakeServerWith ctx ch >> recvData ctx 		-- on client context, receiving a hello request == renegociation-		Right [Handshake HelloRequest] ->+		Right (Handshake [HelloRequest]) -> 			handshakeClient ctx >> recvData ctx-		Right l           -> do-			let dat = map getAppData l-			when (length dat < length l) $ error "error mixed type packet"-			return $ L.fromChunks $ catMaybes dat+		Right (Alert [(AlertLevel_Fatal, _)]) -> do+			setEOF ctx+			return L.empty+		Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do+			setEOF ctx+			return L.empty+		Right (AppData x) -> return $ L.fromChunks [x]+		Right p           -> error ("error unexpected packet: p" ++ show p) 		Left err          -> error ("error received: " ++ show err)-	where-		getAppData (AppData x) = Just x-		getAppData _           = Nothing

@@ -11,19 +11,23 @@ -- module Network.TLS.Packet 	(+	-- * params for encoding and decoding+	  CurrentParams(..) 	-- * marshall functions for header messages-	  decodeHeader+	, decodeHeader 	, encodeHeader 	, encodeHeaderNoVer -- use for SSL3  	-- * marshall functions for alert messages 	, decodeAlert-	, encodeAlert+	, decodeAlerts+	, encodeAlerts  	-- * marshall functions for handshake messages 	, decodeHandshakes 	, decodeHandshake 	, encodeHandshake+	, encodeHandshakes 	, encodeHandshakeHeader 	, encodeHandshakeContent @@ -31,6 +35,10 @@ 	, decodeChangeCipherSpec 	, encodeChangeCipherSpec +	-- * marshall extensions+	, decodeExtSecureRenegotiation+	, encodeExtSecureRenegotiation+ 	-- * generate things for packet content 	, generateMasterSecret 	, generateKeyBlock@@ -39,23 +47,30 @@ 	) where  import Network.TLS.Struct-import Network.TLS.Cap import Network.TLS.Wire+import Network.TLS.Cap import Data.Either (partitionEithers) import Data.Maybe (fromJust)+import Data.Bits ((.|.)) import Control.Applicative ((<$>)) import Control.Monad import Data.Certificate.X509 import Network.TLS.Crypto import Network.TLS.MAC+import Network.TLS.Cipher (CipherKeyExchangeType(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B 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+data CurrentParams = CurrentParams+	{ cParamsVersion     :: Version               -- ^ current protocol version+	, cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type+	} deriving (Show,Eq) +runGetErr :: String -> Get a -> ByteString -> Either TLSError a+runGetErr lbl f = either (Left . Error_Packet_Parsing) Right . runGet lbl f+ {- marshall helpers -} getVersion :: Get Version getVersion = do@@ -76,6 +91,7 @@ 		Nothing -> fail ("invalid header type: " ++ show ty) 		Just t  -> return t +putHeaderType :: ProtocolType -> Put putHeaderType = putWord8 . valOfType  getHandshakeType :: Get HandshakeType@@ -89,7 +105,7 @@  - decode and encode headers  -} decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGetErr $ do+decodeHeader = runGetErr "header" $ do 	ty  <- getHeaderType 	v   <- getVersion 	len <- getWord16@@ -106,8 +122,8 @@ {-  - decode and encode ALERT  -}-decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription)-decodeAlert = runGetErr $ do+decodeAlert :: Get (AlertLevel, AlertDescription)+decodeAlert = do 	al <- getWord8 	ad <- getWord8 	case (valToType al, valToType ad) of@@ -115,39 +131,47 @@ 		(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))+decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)]+decodeAlerts = runGetErr "alerts" $ loop+	where loop = do+		r <- remaining+		if r == 0+			then return []+			else liftM2 (:) decodeAlert loop +encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString+encodeAlerts l = runPut $ mapM_ encodeAlert l+	where encodeAlert (al, ad) = (putWord8 (valOfType al) >> putWord8 (valOfType ad))+ {- decode and encode HANDSHAKE -} decodeHandshakeHeader :: Get (HandshakeType, Bytes) decodeHandshakeHeader = do-	ty <- getHandshakeType-	len <- getWord24+	ty      <- getHandshakeType+	len     <- getWord24 	content <- getBytes len 	return (ty, content)  decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]-decodeHandshakes b = runGetErr getAll b-	where-		getAll = do-			x <- decodeHandshakeHeader-			empty <- isEmpty-			if empty-				then return [x]-				else getAll >>= \l -> return (x : l)+decodeHandshakes b = runGetErr "handshakes" getAll b where+	getAll = do+		x <- decodeHandshakeHeader+		empty <- isEmpty+		if empty+			then return [x]+			else getAll >>= \l -> return (x : l) -decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake-decodeHandshake ver ty = runGetErr $ case ty of+decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake+decodeHandshake cp ty = runGetErr "handshake" $ case ty of 	HandshakeType_HelloRequest    -> decodeHelloRequest 	HandshakeType_ClientHello     -> decodeClientHello 	HandshakeType_ServerHello     -> decodeServerHello 	HandshakeType_Certificate     -> decodeCertificates-	HandshakeType_ServerKeyXchg   -> decodeServerKeyXchg ver-	HandshakeType_CertRequest     -> decodeCertRequest ver+	HandshakeType_ServerKeyXchg   -> decodeServerKeyXchg cp+	HandshakeType_CertRequest     -> decodeCertRequest cp 	HandshakeType_ServerHelloDone -> decodeServerHelloDone 	HandshakeType_CertVerify      -> decodeCertVerify 	HandshakeType_ClientKeyXchg   -> decodeClientKeyXchg-	HandshakeType_Finished        -> decodeFinished ver+	HandshakeType_Finished        -> decodeFinished  decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest@@ -161,8 +185,8 @@ 	compressions <- getWords8 	r            <- remaining 	exts <- if hasHelloExtensions ver && r > 0-		then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just-		else return Nothing+		then fmap fromIntegral getWord16 >>= getExtensions+		else return [] 	return $ ClientHello ver random session ciphers compressions exts  decodeServerHello :: Get Handshake@@ -174,8 +198,8 @@ 	compressionid <- getWord8 	r             <- remaining 	exts <- if hasHelloExtensions ver && r > 0-		then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just-		else return Nothing+		then fmap fromIntegral getWord16 >>= getExtensions+		else return [] 	return $ ServerHello ver random session cipherid compressionid exts  decodeServerHelloDone :: Get Handshake@@ -190,16 +214,10 @@ 		then fail ("error certificate parsing: " ++ show l) 		else return $ Certificates r -decodeFinished :: Version -> Get Handshake-decodeFinished ver = do-	-- unfortunately passing the verify_data_size here would be tedious for >=TLS12,-	-- so just return the remaining string.-	len <- if ver >= TLS12-		then remaining-		else if ver == SSL3 then return 36-			else return 12-	opaque <- getBytes (fromIntegral len)-	return $ Finished $ B.unpack opaque+decodeFinished :: Get Handshake+decodeFinished = do+	opaque <- remaining >>= getBytes+	return $ Finished $ opaque  getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ] getSignatureHashAlgorithm 0   = return []@@ -209,17 +227,17 @@ 	xs <- getSignatureHashAlgorithm (len - 2) 	return ((h, s) : xs) -decodeCertRequest :: Version -> Get Handshake-decodeCertRequest ver = do+decodeCertRequest :: CurrentParams -> Get Handshake+decodeCertRequest cp = do 	certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8 -	sigHashAlgs <- if ver >= TLS12+	sigHashAlgs <- if cParamsVersion cp >= TLS12 		then do 			sighashlen <- getWord16 			Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen) 		else return Nothing 	dNameLen <- getWord16-	when (ver < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"+	when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size" 	dName <- getBytes $ fromIntegral dNameLen 	return $ CertRequest certTypes sigHashAlgs (B.unpack dName) @@ -234,33 +252,34 @@ 	ran <- getClientKeyData46 	return $ ClientKeyXchg ver ran --- FIXME need to work out how we marshall an opaque number---numberise :: ByteString -> Integer-numberise _ = 0+os2ip :: ByteString -> Integer+os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0  decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = do 	p <- getWord16 >>= getBytes . fromIntegral 	g <- getWord16 >>= getBytes . fromIntegral 	y <- getWord16 >>= getBytes . fromIntegral-	return $ ServerDHParams { dh_p = numberise p, dh_g = numberise g, dh_Ys = numberise y }+	return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y }  decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = do 	modulus <- getWord16 >>= getBytes . fromIntegral-	expo <- getWord16 >>= getBytes . fromIntegral-	return $ ServerRSAParams { rsa_modulus = numberise modulus, rsa_exponent = numberise expo }+	expo    <- getWord16 >>= getBytes . fromIntegral+	return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } -decodeServerKeyXchg :: Version -> Get Handshake-decodeServerKeyXchg ver = do-	-- mostly unimplemented-	skxAlg <- case ver of-		TLS12 -> return $ SKX_RSA Nothing-		TLS10 -> do+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-			return $ SKX_RSA Nothing+			bs <- remaining >>= getBytes+			return $ SKX_Unknown bs 	return (ServerKeyXchg skxAlg)  encodeHandshake :: Handshake -> ByteString@@ -270,6 +289,9 @@ 	let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in 	B.concat [ header, content ] +encodeHandshakes :: [Handshake] -> ByteString+encodeHandshakes hss = B.concat $ map encodeHandshake hss+ encodeHandshakeHeader :: HandshakeType -> Int -> Put encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len @@ -315,7 +337,7 @@  encodeHandshakeContent (CertVerify _) = undefined -encodeHandshakeContent (Finished opaque) = mapM_ putWord8 opaque+encodeHandshakeContent (Finished opaque) = putBytes opaque  {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get Bytes@@ -374,18 +396,17 @@ 	extdatalen <- getWord16 	extdata <- getBytes $ fromIntegral extdatalen 	extxs <- getExtensions (len - fromIntegral extdatalen - 4)-	return $ (extty, B.unpack extdata) : extxs+	return $ (extty, extdata) : extxs  putExtension :: Extension -> Put putExtension (ty, l) = do 	putWord16 ty-	putWord16 (fromIntegral $ length l)-	putBytes (B.pack l)+	putWord16 (fromIntegral $ B.length l)+	putBytes l -putExtensions :: Maybe [Extension] -> Put-putExtensions Nothing   = return ()-putExtensions (Just es) =-	putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs+putExtensions :: [Extension] -> Put+putExtensions [] = return ()+putExtensions es = putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs 	where 		extbs = runPut $ mapM_ putExtension es @@ -394,12 +415,33 @@  -}  decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec = runGetErr $ do+decodeChangeCipherSpec = runGetErr "changecipherspec" $ do 	x <- getWord8 	when (x /= 1) (fail "unknown change cipher spec content")  encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1)+++{-+ - decode and encode various extensions+ -}+decodeExtSecureRenegotiation :: Bool -> Bytes -> Either TLSError (Bytes, Maybe Bytes)+decodeExtSecureRenegotiation isServerHello = runGetErr "ext-secure-renegotiation" $ do+	l <- fromIntegral <$> getWord8+	if isServerHello+		then do+			cvd <- getBytes (l `div` 2) +			svd <- getBytes (l `div` 2)+			return (cvd, Just svd)+		else getBytes (l `div` 2) >>= \cvd -> return (cvd, Nothing)++encodeExtSecureRenegotiation :: Bytes -> Maybe Bytes -> Bytes+encodeExtSecureRenegotiation cvd msvd = runPut $ do+	let svd = maybe B.empty id msvd+	putWord8 $ fromIntegral (B.length cvd + B.length svd)+	putBytes cvd+	putBytes svd  {-  - generate things for packet content

@@ -18,7 +18,6 @@ import Control.Monad.Error  import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B  import Network.TLS.Util@@ -36,13 +35,15 @@ returnEither (Left err) = throwError err returnEither (Right a)  = return a -readPacket :: Header -> EncryptedData -> TLSSt [Packet]+readPacket :: Header -> EncryptedData -> TLSSt Packet readPacket hdr content = checkState hdr >> decryptContent hdr content >>= processPacket hdr  checkState :: Header -> TLSSt () checkState (Header pt _ _) =-		stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show 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@@ -53,11 +54,11 @@ 		allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True 		allowed _ _ = False -processPacket :: Header -> Bytes -> TLSSt [Packet]+processPacket :: Header -> Bytes -> TLSSt Packet -processPacket (Header ProtocolType_AppData _ _) content = return [AppData content]+processPacket (Header ProtocolType_AppData _ _) content = return $ AppData content -processPacket (Header ProtocolType_Alert _ _) content = return . (:[]) . Alert =<< returnEither (decodeAlert content)+processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlerts content)  processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do 	e <- updateStatusCC False@@ -66,42 +67,72 @@ 	returnEither $ decodeChangeCipherSpec content 	switchRxEncryption 	isClientContext >>= \cc -> when (not cc) setKeyBlock-	return [ChangeCipherSpec]+	return ChangeCipherSpec  processPacket (Header ProtocolType_Handshake ver _) dcontent = do 	handshakes <- returnEither (decodeHandshakes dcontent)-	forM handshakes $ \(ty, content) -> do+	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 Packet+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-	when (isJust e) $ throwError (fromJust "" e)+	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 ver ty content) of+	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 	clientmode <- isClientContext 	case hs of-		ClientHello cver ran _ _ _ _ -> unless clientmode $ do+		ClientHello cver ran _ _ _ ex -> unless clientmode $ do+			mapM_ processClientExtension ex 			startHandshakeClient cver ran-		ServerHello sver ran _ _ _ _ -> when clientmode $ do+		ServerHello sver ran _ _ _ ex -> when clientmode $ do+			-- FIXME notify the user to take action if the extension requested is missing+			-- secreneg <- getSecureRenegotiation+			-- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ...+			mapM_ processServerExtension ex 			setServerRandom ran 			setVersion sver-		Certificates certs           -> when clientmode $ do processCertificates certs-		ClientKeyXchg cver _         -> unless clientmode $ do+		Certificates certs            -> when clientmode $ do processCertificates certs+		ClientKeyXchg cver _          -> unless clientmode $ do 			processClientKeyXchg cver content-		Finished fdata               -> processClientFinished fdata-		_                            -> return ()-	return $ Handshake hs+		Finished fdata                -> processClientFinished fdata+		_                             -> return ()+	return hs+	where+		-- secure renegotiation+		processClientExtension (0xff01, content) = do+			v <- getVerifiedData True+			let bs = encodeExtSecureRenegotiation v Nothing+			when (bs /= content) $ throwError $+				Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content, True, HandshakeFailure)+			setSecureRenegotiation True+		-- unknown extensions+		processClientExtension _ = return () +		processServerExtension (0xff01, content) = do+			cv <- getVerifiedData True+			sv <- getVerifiedData False+			let bs = encodeExtSecureRenegotiation cv (Just sv)+			when (bs /= content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)+			return ()++		processServerExtension _ = return ()+ decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do 	ver <- stVersion <$> get@@ -123,9 +154,9 @@ processClientFinished fdata = do 	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.-		fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))+	when (expected /= fdata) $ do+		throwError $ Error_Protocol( "bad record mac", True, BadRecordMac)+	updateVerifiedData False fdata 	return ()  decryptContent :: Header -> EncryptedData -> TLSSt ByteString@@ -159,7 +190,7 @@ 				else return $ maybe True (const False) $ B.find (/= fromIntegral b) pad  	unless (and $! [ macValid, paddingValid ]) $ do-		throwError $ Error_Digest ([], [])+		throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)  	return $ cipherDataContent cdata 

@@ -76,21 +76,23 @@ {-  - just update TLS state machine  -}-preProcessPacket :: Packet -> TLSSt Packet-preProcessPacket pkt = do-	e <- case pkt of-		Handshake hs     -> updateStatusHs (typeOfHandshake hs)-		AppData _        -> return Nothing-		ChangeCipherSpec -> updateStatusCC True-		Alert _          -> return Nothing-	return pkt+preProcessPacket :: Packet -> TLSSt ()+preProcessPacket (Alert _)          = return ()+preProcessPacket (AppData _)        = return ()+preProcessPacket (ChangeCipherSpec) = updateStatusCC True >> return () -- FIXME don't ignore this error just in case+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 ()  {-  - writePacket transform a packet into marshalled data related to current state  - and updating state on the go  -} writePacket :: Packet -> TLSSt ByteString-writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>=+writePacket pkt = preProcessPacket pkt >> makePacketData pkt >>= processPacketData >>=                   encryptPacketData >>= postprocessPacketData >>= encodePacket  {------------------------------------------------------------------------------}@@ -133,54 +135,43 @@ 			B.empty 	let writekey = cstKey cst -	econtent <- case cipherF cipher of+	case cipherF cipher of 		CipherNoneF -> return content 		CipherBlockF encrypt _ -> do-			let iv = cstIV cst+			-- before TLS 1.1, the block cipher IV is made of the residual of the previous block.+			iv <- if hasExplicitBlockIV $ stVersion st+				then genTLSRandom (fromIntegral $ cipherIVSize cipher)+				else return $ cstIV cst 			let e = encrypt writekey iv (B.concat [ content, padding ])-			let newiv = fromJust "new iv" $ takelast (fromIntegral $ cipherIVSize cipher) e-			put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }-			return $ if hasExplicitBlockIV $ stVersion st-				then B.concat [iv,e]-				else e+			if hasExplicitBlockIV $ stVersion st+				then return $ B.concat [iv,e]+				else do+					let newiv = fromJust "new iv" $ takelast (fromIntegral $ cipherIVSize cipher) e+					put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+					return e 		CipherStreamF 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-	return econtent -encodePacketContent :: Packet -> ByteString-encodePacketContent (Handshake h)      = encodeHandshake h-encodePacketContent (Alert a)          = encodeAlert a-encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec-encodePacketContent (AppData x)        = x- writePacketContent :: Packet -> TLSSt ByteString-writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do-	ver <- get >>= return . stVersion -	let premastersecret = runPut $ encodeHandshakeContent ckx-	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 ckx)-	                                         (fromIntegral (B.length econtent + B.length extralength))-	return $ B.concat [hdr, extralength, econtent]--writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do-	cc <- isClientContext-	when cc (startHandshakeClient ver crand)-	return $ encodePacketContent pkt+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 -writePacketContent pkt@(Handshake (ServerHello ver srand _ _ _ _)) = do-	cc <- isClientContext-	unless cc $ do-		setVersion ver-		setServerRandom srand-	return $ encodePacketContent pkt+		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 pkt = return $ encodePacketContent pkt+writePacketContent (Alert a)          = return $ encodeAlerts a+writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec+writePacketContent (AppData x)        = return x

@@ -24,6 +24,7 @@ 	, assert -- FIXME move somewhere else (Internal.hs ?) 	, updateStatusHs 	, updateStatusCC+	, updateVerifiedData 	, finishHandshakeTypeMaterial 	, finishHandshakeMaterial 	, makeDigest@@ -34,8 +35,12 @@ 	, setVersion 	, setCipher 	, setServerRandom+	, setSecureRenegotiation+	, getSecureRenegotiation+	, getVerifiedData 	, switchTxEncryption 	, switchRxEncryption+	, getCipherKeyExchangeType 	, isClientContext 	, startHandshakeClient 	, updateHandshakeDigest@@ -112,18 +117,21 @@ 	show _ = "rng[..]"  data TLSState = TLSState-	{ stClientContext :: Bool-	, stVersion       :: !Version-	, stStatus        :: !TLSStatus-	, stHandshake     :: !(Maybe TLSHandshakeState)-	, stTxEncrypted   :: Bool-	, stRxEncrypted   :: Bool-	, stTxCryptState  :: !(Maybe TLSCryptState)-	, stRxCryptState  :: !(Maybe TLSCryptState)-	, stTxMacState    :: !(Maybe TLSMacState)-	, stRxMacState    :: !(Maybe TLSMacState)-	, stCipher        :: Maybe Cipher-	, stRandomGen     :: StateRNG+	{ stClientContext       :: Bool+	, stVersion             :: !Version+	, stStatus              :: !TLSStatus+	, stHandshake           :: !(Maybe TLSHandshakeState)+	, stTxEncrypted         :: Bool+	, stRxEncrypted         :: Bool+	, stTxCryptState        :: !(Maybe TLSCryptState)+	, stRxCryptState        :: !(Maybe TLSCryptState)+	, stTxMacState          :: !(Maybe TLSMacState)+	, stRxMacState          :: !(Maybe TLSMacState)+	, stCipher              :: Maybe Cipher+	, stRandomGen           :: StateRNG+	, stSecureRenegotiation :: Bool  -- RFC 5746+	, stClientVerifiedData  :: Bytes -- RFC 5746+	, stServerVerifiedData  :: Bytes -- RFC 5746 	} deriving (Show)  newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a }@@ -141,18 +149,21 @@  newTLSState :: CryptoRandomGen g => g -> TLSState newTLSState rng = TLSState-	{ stClientContext = False-	, stVersion       = TLS10-	, stStatus        = StatusInit-	, stHandshake     = Nothing-	, stTxEncrypted   = False-	, stRxEncrypted   = False-	, stTxCryptState  = Nothing-	, stRxCryptState  = Nothing-	, stTxMacState    = Nothing-	, stRxMacState    = Nothing-	, stCipher        = Nothing-	, stRandomGen     = StateRNG rng+	{ stClientContext       = False+	, stVersion             = TLS10+	, stStatus              = StatusInit+	, stHandshake           = Nothing+	, stTxEncrypted         = False+	, stRxEncrypted         = False+	, stTxCryptState        = Nothing+	, stRxCryptState        = Nothing+	, stTxMacState          = Nothing+	, stRxMacState          = Nothing+	, stCipher              = Nothing+	, stRandomGen           = StateRNG rng+	, stSecureRenegotiation = False+	, stClientVerifiedData  = B.empty+	, stServerVerifiedData  = B.empty 	}  withTLSRNG :: StateRNG -> (forall g . CryptoRandomGen g => g -> Either e (a,g)) -> Either e (a, StateRNG)@@ -249,6 +260,13 @@ 		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+	if cc /= sending+		then modify (\st -> st { stServerVerifiedData = bs })+		else modify (\st -> st { stClientVerifiedData = bs })+ finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello     = True finishHandshakeTypeMaterial HandshakeType_ServerHello     = True@@ -328,6 +346,18 @@  setVersion :: MonadState TLSState m => Version -> m () setVersion ver = modify (\st -> st { stVersion = ver })++setSecureRenegotiation :: MonadState TLSState m => Bool -> m ()+setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b })++getSecureRenegotiation :: MonadState TLSState m => m Bool+getSecureRenegotiation = get >>= return . stSecureRenegotiation++getCipherKeyExchangeType :: MonadState TLSState m => m (Maybe CipherKeyExchangeType)+getCipherKeyExchangeType = get >>= return . (maybe Nothing (Just . cipherKeyExchange) . stCipher)++getVerifiedData :: MonadState TLSState m => Bool -> m Bytes+getVerifiedData client = get >>= return . (if client then stClientVerifiedData else stServerVerifiedData)  isClientContext :: MonadState TLSState m => m Bool isClientContext = get >>= return . stClientContext

@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | -- Module      : Network.TLS.Struct -- License     : BSD-style@@ -48,7 +49,9 @@ import qualified Data.ByteString as B (length) import Data.Word import Data.Certificate.X509+import Data.Typeable import Control.Monad.Error (Error(..))+import Control.Exception (Exception(..))  type Bytes = ByteString @@ -107,10 +110,11 @@  -- | TLSError that might be returned through the TLS stack data TLSError =-	  Error_Misc String+	  Error_Misc String        -- ^ mainly for instance of Error+	| Error_Protocol (String, Bool, AlertDescription) 	| Error_Certificate String 	| Error_Random String-	| Error_Digest ([Word8], [Word8])+	| Error_EOF 	| Error_Packet String 	| Error_Packet_Size_Mismatch (Int, Int) 	| Error_Packet_unexpected String String@@ -118,16 +122,17 @@ 	| Error_Internal_Packet_ByteProcessed Int Int Int 	| Error_Unknown_Version Word8 Word8 	| Error_Unknown_Type String-	deriving (Eq, Show)+	deriving (Eq, Show, Typeable)  instance Error TLSError where 	noMsg  = Error_Misc "" 	strMsg = Error_Misc +instance Exception TLSError  data Packet =-	  Handshake Handshake-	| Alert (AlertLevel, AlertDescription)+	  Handshake [Handshake]+	| Alert [(AlertLevel, AlertDescription)] 	| ChangeCipherSpec 	| AppData ByteString 	deriving (Show,Eq)@@ -140,8 +145,8 @@ newtype Session = Session (Maybe Bytes) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8-type FinishedData = [Word8]-type Extension = (Word16, [Word8])+type FinishedData = Bytes+type Extension = (Word16, Bytes)  constrRandom32 :: (Bytes -> a) -> Bytes -> Maybe a constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing@@ -164,7 +169,7 @@ 	  CloseNotify 	| UnexpectedMessage 	| BadRecordMac-	| DecryptionFailed+	| DecryptionFailed       -- ^ deprecated alert, should never be sent by compliant implementation 	| RecordOverflow 	| DecompressionFailure 	| HandshakeFailure@@ -217,11 +222,12 @@ 	| SKX_RSA (Maybe ServerRSAParams) 	| SKX_DH_DSS (Maybe ServerRSAParams) 	| SKX_DH_RSA (Maybe ServerRSAParams)+	| SKX_Unknown Bytes 	deriving (Show,Eq)  data Handshake =-	  ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] (Maybe [Extension])-	| ServerHello !Version !ServerRandom !Session !CipherID !CompressionID (Maybe [Extension])+	  ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [Extension]+	| ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [Extension] 	| Certificates [X509] 	| HelloRequest 	| ServerHelloDone

@@ -31,13 +31,16 @@ 	, encodeWord64 	) where -import Data.Serialize.Get+import Data.Serialize.Get hiding (runGet)+import qualified Data.Serialize.Get as G import Data.Serialize.Put import Control.Applicative ((<$>)) import Control.Monad.Error import Data.Word import Data.Bits import Network.TLS.Struct++runGet lbl f = G.runGet (label lbl f)  getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8

@@ -1,10 +1,7 @@ protocol: -- finish implementing renegocitiation Client and Server - implement Certificate Verify / Certificate Request - add Client Certificates-- add check for non-self signed certificate-- alert correctly on errors - process session as they should - put 4 bytes of time in client/server random - implement compression@@ -13,7 +10,6 @@  tls v1.2: -- finish implementation of extensions - implement finish digest generation with hmac256 - implement finish digest generation with client/server negociated algorithm - proper version dispatch in marshalling packets

@@ -9,6 +9,7 @@ import Data.Certificate.X509  import qualified Data.ByteString as B+import Network.TLS.Cipher import Network.TLS.Struct import Network.TLS.Packet import Control.Monad@@ -66,7 +67,7 @@ 	arbitrary = elements 		[ CertificateType_RSA_Sign, CertificateType_DSS_Sign 		, CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH-		, CertificateType_RSA_Ephemeral_dh, CertificateType_DSS_Ephemeral_dh+		, CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH 		, CertificateType_fortezza_dms ]  -- we hardcode the pubkey for generated X509. at later stage this will be generated as well.@@ -74,8 +75,8 @@  instance Arbitrary Handshake where 	arbitrary = oneof-		[ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return Nothing)-		, liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return Nothing)+		[ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return [])+		, liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return []) 		--, liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey) 		, return HelloRequest 		, return ServerHelloDone@@ -83,7 +84,7 @@ 		--, liftM  ServerKeyXchg 		--, liftM3 CertRequest arbitrary (return Nothing) (return []) 		--, liftM CertVerify (return [])-		, liftM Finished (vector 12)+		, liftM Finished (genByteString 12) 		]  {- quickcheck property -}@@ -91,7 +92,8 @@ prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x 	where-		decodeHs b = either (Left . id) (uncurry (decodeHandshake TLS10) . head) $ decodeHandshakes b+		decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b+		cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA }  myQuickCheckArgs = stdArgs 	{ replay     = Nothing

@@ -1,5 +1,5 @@ Name:                tls-Version:             0.6.4+Version:             0.7.0 Description:    native TLS protocol implementation, focusing on purity and more type-checking.    .