tls 0.1.1 → 0.1.2

raw patch · 11 files changed

+126/−70 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Network/TLS/Client.hs +34/−19
• Network/TLS/Packet.hs +15/−14
• Network/TLS/Receiving.hs +7/−6
• Network/TLS/Sending.hs +1/−1
• Network/TLS/Server.hs +9/−0
• Network/TLS/Struct.hs +3/−1
• Network/TLS/Wire.hs +6/−5
• Stunnel.hs +30/−18
• TODO +0/−1
• Tests.hs +16/−0
• tls.cabal +5/−5

@@ -12,7 +12,9 @@ -- module Network.TLS.Client 	( TLSClientParams(..)+	, TLSClientCallbacks(..) 	, TLSStateClient+	, TLSClient (..) 	, runTLSClient 	-- * low level packet sending receiving. 	, recvPacket@@ -26,6 +28,7 @@  import Data.Maybe import Data.Word+import Control.Applicative ((<$>)) import Control.Monad.Trans import Control.Monad.State import Data.Certificate.X509@@ -40,12 +43,20 @@ import System.IO (Handle, hFlush) import Data.List (find) +data TLSClientCallbacks = TLSClientCallbacks+	{ cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates+	}++instance Show TLSClientCallbacks where+	show _ = "[callbacks]"+ data TLSClientParams = TLSClientParams-	{ cpConnectVersion  :: Version           -- ^ client version we're sending by default-	, cpAllowedVersions :: [Version]         -- ^ allowed versions from the server-	, cpSession         :: Maybe [Word8]     -- ^ session for this connection-	, cpCiphers         :: [Cipher]          -- ^ all ciphers for this connection-	, cpCertificate     :: Maybe Certificate -- ^ an optional client certificate+	{ cpConnectVersion  :: Version            -- ^ client version we're sending by default+	, cpAllowedVersions :: [Version]          -- ^ allowed versions from the server+	, cpSession         :: Maybe [Word8]      -- ^ session for this connection+	, cpCiphers         :: [Cipher]           -- ^ all ciphers for this connection+	, cpCertificate     :: Maybe Certificate  -- ^ an optional client certificate+	, cpCallbacks       :: TLSClientCallbacks -- ^ user callbacks 	} deriving (Show)  data TLSStateClient = TLSStateClient@@ -92,8 +103,9 @@  recvServerHello :: Handle -> TLSClient IO () recvServerHello handle = do-	ciphers <- fmap (cpCiphers . scParams) get-	allowedvers <- fmap (cpAllowedVersions . scParams) get+	ciphers <- cpCiphers . scParams <$> get+	allowedvers <- cpAllowedVersions . scParams <$> get+	callbacks <- cpCallbacks . scParams <$> get 	pkt <- recvPacket handle 	let hs = case pkt of 		Right (Handshake h) -> h@@ -109,27 +121,30 @@ 				Nothing -> error "no cipher in common with the server" 				Just c  -> setCipher c 			recvServerHello handle-		CertRequest _ _ _ -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle-		Certificates _    -> recvServerHello handle-		ServerHelloDone   -> return ()-		_                 -> error "unexpected handshake message received in server hello messages"+		CertRequest _ _ _  -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle+		Certificates certs -> do+			valid <- lift $ maybe (return True) (\cb -> cb certs) (cbCertificates callbacks)+			unless valid $ error "certificates received deemed invalid by user"+			recvServerHello handle+		ServerHelloDone    -> return ()+		_                  -> error "unexpected handshake message received in server hello messages"  connectSendClientHello :: Handle -> ClientRandom -> TLSClient IO () connectSendClientHello handle crand = do-	ver <- fmap (cpConnectVersion . scParams) get-	ciphers <- fmap (cpCiphers . scParams) get+	ver <- cpConnectVersion . scParams <$> get+	ciphers <- cpCiphers . scParams <$> get 	sendPacket handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing)  connectSendClientCertificate :: Handle -> TLSClient IO () connectSendClientCertificate handle = do-	certRequested <- fmap scCertRequested get+	certRequested <- scCertRequested <$> get 	when certRequested $ do-		clientCert <- fmap (cpCertificate . scParams) get+		clientCert <- cpCertificate . scParams <$> get 		sendPacket handle $ Handshake (Certificates $ maybe [] (:[]) clientCert) -connectSendClientKeyXchg :: Handle -> [Word8] -> TLSClient IO ()+connectSendClientKeyXchg :: Handle -> ClientKeyData -> TLSClient IO () connectSendClientKeyXchg handle prerand = do-	ver <- fmap (cpConnectVersion . scParams) get+	ver <- cpConnectVersion . scParams <$> get 	sendPacket handle $ Handshake (ClientKeyXchg ver prerand)  connectSendFinish :: Handle -> TLSClient IO ()@@ -138,7 +153,7 @@ 	sendPacket handle (Handshake $ Finished $ L.unpack cf)  {- | connect through a handle as a new TLS connection. -}-connect :: Handle -> ClientRandom -> [Word8] -> TLSClient IO ()+connect :: Handle -> ClientRandom -> ClientKeyData -> TLSClient IO () connect handle crand premasterRandom = do 	connectSendClientHello handle crand 	recvServerHello handle@@ -194,7 +209,7 @@ 			let (premaster, rng'') = getRandomBytes rng' 46 			putTLSState $ st { stRandomGen = rng'' } 			let crand = fromJust $ clientRandom bytes-			connect handle crand premaster+			connect handle crand (ClientKeyData premaster) 			recvData handle 		Left err          -> error ("error received: " ++ show err) 		_                 -> error "unexpected item"

@@ -40,6 +40,7 @@ import Network.TLS.Wire import Data.Either (partitionEithers) import Data.Maybe (fromJust, isNothing)+import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.Error import Network.TLS.Struct@@ -167,19 +168,19 @@ getSignatureHashAlgorithm :: Int -> Get [ (HashAlgorithm, SignatureAlgorithm) ] getSignatureHashAlgorithm 0   = return [] getSignatureHashAlgorithm len = do-	h <- fmap (fromJust . valToType) getWord8-	s <- fmap (fromJust . valToType) getWord8+	h <- fromJust . valToType <$> getWord8+	s <- fromJust . valToType <$> getWord8 	xs <- getSignatureHashAlgorithm (len - 2) 	return ((h, s) : xs)  decodeCertRequest :: Version -> Get Handshake decodeCertRequest ver = do-	certTypes <- fmap (map (fromJust . valToType . fromIntegral)) getWords8+	certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8  	sigHashAlgs <- if ver >= TLS12 		then do 			sighashlen <- getWord16-			fmap Just $ getSignatureHashAlgorithm $ fromIntegral sighashlen+			Just <$> getSignatureHashAlgorithm (fromIntegral sighashlen) 		else return Nothing 	dNameLen <- getWord16 	when (ver < TLS12 && dNameLen < 3) $ throwError (Error_Misc "certrequest distinguishname not of the correct size")@@ -194,7 +195,7 @@ decodeClientKeyXchg :: Get Handshake decodeClientKeyXchg = do 	ver <- getVersion-	ran <- getRandom46+	ran <- getClientKeyData46 	return $ ClientKeyXchg ver ran  -- FIXME need to work out how we marshall an opaque number@@ -260,7 +261,7 @@  encodeHandshakeContent (ClientKeyXchg version random) = do 	putVersion version-	putRandom46 random+	putClientKeyData46 random  encodeHandshakeContent (ServerKeyXchg _) = do 	-- FIXME@@ -295,13 +296,13 @@  {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get [Word8]-getRandom32 = fmap B.unpack $ getBytes 32+getRandom32 = B.unpack <$> getBytes 32  getServerRandom32 :: Get ServerRandom-getServerRandom32 = fmap ServerRandom getRandom32+getServerRandom32 = ServerRandom <$> getRandom32  getClientRandom32 :: Get ClientRandom-getClientRandom32 = fmap ClientRandom getRandom32+getClientRandom32 = ClientRandom <$> getRandom32  putRandom32 :: [Word8] -> Put putRandom32 = mapM_ putWord8@@ -312,18 +313,18 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r -getRandom46 :: Get [Word8]-getRandom46 = fmap B.unpack $ getBytes 46+getClientKeyData46 :: Get ClientKeyData+getClientKeyData46 = ClientKeyData . B.unpack <$> getBytes 46 -putRandom46 :: [Word8] -> Put-putRandom46 = mapM_ putWord8+putClientKeyData46 :: ClientKeyData -> Put+putClientKeyData46 (ClientKeyData d) = mapM_ putWord8 d  getSession :: Get Session getSession = do 	len8 <- getWord8 	case fromIntegral len8 of 		0   -> return $ Session Nothing-		len -> fmap (Session . Just . B.unpack) $ getBytes len+		len -> Session . Just . B.unpack <$> getBytes len  putSession :: Session -> Put putSession (Session session) =

@@ -14,6 +14,7 @@ 	readPacket 	) where +import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.Maybe@@ -53,7 +54,7 @@  readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet) readPacket hdr@(Header ProtocolType_AppData _ _) content =-	runTLSRead (fmap AppData $ decryptContent hdr content)+	runTLSRead (AppData <$> decryptContent hdr content)  readPacket hdr@(Header ProtocolType_Alert _ _)   content = 	runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert)@@ -109,7 +110,7 @@ 			return econtent 	hs <- case (ty, decodeHandshake ver ty content) of 		(_, Right x)                            -> return x-		(HandshakeType_ClientKeyXchg, Left _)   -> return $ ClientKeyXchg SSL2 []+		(HandshakeType_ClientKeyXchg, Left _)   -> return $ ClientKeyXchg SSL2 (ClientKeyData $ replicate 0xff 46) 		(_, Left err)                           -> throwError err 	clientmode <- isClientContext 	case hs of@@ -118,7 +119,7 @@ 		ServerHello sver ran _ _ _ _ -> when clientmode $ do 			setServerRandom ran 			setVersion sver-		Certificates [cert]          -> when clientmode $ do processCertificate cert+		Certificates certs           -> when clientmode $ do processCertificates certs 		ClientKeyXchg cver _         -> unless clientmode $ do 			processClientKeyXchg cver content 		Finished fdata               -> processClientFinished fdata@@ -185,9 +186,9 @@ 			else contentpadded 	return content -processCertificate :: Certificate -> TLSRead ()-processCertificate cert = do-	case certPubKey cert of+processCertificates :: [Certificate] -> TLSRead ()+processCertificates certs = do+	case certPubKey $ head certs of 		PubKey _ (PubKeyRSA (lm, m, e)) -> do 			let pk = PublicKey { public_size = fromIntegral lm, public_n = m, public_e = e } 			setPublicKey pk

@@ -97,7 +97,7 @@ 	let g = stRandomGen st 	let rsakey = fromJust $ hstRSAPublicKey $ fromJust $ stHandshake st 	case rsaEncrypt g rsakey content of-		Nothing             -> return L.empty+		Nothing             -> fail "no RSA key selected" 		Just (econtent, g') -> do 			putTLSState (st { stRandomGen = g' }) 			return econtent

@@ -12,6 +12,7 @@  module Network.TLS.Server 	( TLSServerParams(..)+	, TLSServerCallbacks(..) 	, TLSStateServer 	, runTLSServer 	-- * low level packet sending receiving.@@ -44,12 +45,20 @@  type TLSServerCert = (L.ByteString, Certificate, CertificateKey.PrivateKey) +data TLSServerCallbacks = TLSServerCallbacks+	{ cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates+	}++instance Show TLSServerCallbacks where+	show _ = "[callbacks]"+ data TLSServerParams = TLSServerParams 	{ spAllowedVersions :: [Version]           -- ^ allowed versions that we can use 	, spSessions        :: [[Word8]]           -- ^ placeholder for futur known sessions 	, spCiphers         :: [Cipher]            -- ^ all ciphers that the server side support 	, spCertificate     :: Maybe TLSServerCert -- ^ the certificate we serve to the client 	, spWantClientCert  :: Bool                -- ^ configure if we do a cert request to the client+	, spCallbacks       :: TLSServerCallbacks  -- ^ user callbacks 	}  data TLSStateServer = TLSStateServer

@@ -25,6 +25,7 @@ 	, Header(..) 	, ServerRandom(..) 	, ClientRandom(..)+	, ClientKeyData(..) 	, serverRandom 	, clientRandom 	, FinishedData@@ -108,6 +109,7 @@  newtype ServerRandom = ServerRandom [Word8] deriving (Show, Eq) newtype ClientRandom = ClientRandom [Word8] deriving (Show, Eq)+newtype ClientKeyData = ClientKeyData [Word8] deriving (Show, Eq) newtype Session = Session (Maybe [Word8]) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8@@ -196,7 +198,7 @@ 	| Certificates [Certificate] 	| HelloRequest 	| ServerHelloDone-	| ClientKeyXchg Version [Word8]+	| ClientKeyXchg Version ClientKeyData 	| ServerKeyXchg ServerKeyXchgAlgorithmData 	| CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] 	| CertVerify [Word8]

@@ -39,6 +39,7 @@ import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L+import Control.Applicative ((<$>)) import Control.Monad.Error import Data.Word import Data.Bits@@ -61,10 +62,10 @@ runGet f b = Bin.runGet (runErrorT (runGE f)) b  remaining :: Get Int-remaining = fmap fromIntegral $ liftGet Bin.remaining+remaining = fromIntegral <$> liftGet Bin.remaining  bytesRead :: Get Int-bytesRead = fmap fromIntegral $ liftGet Bin.bytesRead+bytesRead = fromIntegral <$> liftGet Bin.bytesRead  getWord8 :: Get Word8 getWord8 = liftGet Bin.getWord8@@ -80,9 +81,9 @@  getWord24 :: Get Int getWord24 = do-	a <- fmap fromIntegral getWord8-	b <- fmap fromIntegral getWord8-	c <- fmap fromIntegral getWord8+	a <- fromIntegral <$> getWord8+	b <- fromIntegral <$> getWord8+	c <- fromIntegral <$> getWord8 	return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c  getBytes :: Int -> Get ByteString

@@ -1,29 +1,36 @@ import Network import System.IO import System+ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LC +import Control.Applicative ((<$>))+import Control.Concurrent (forkIO) import Control.Exception (bracket)-import Network.TLS.Cipher-import qualified Network.TLS.Client as C-import qualified Network.TLS.Server as S-import Network.TLS.SRandom-import Network.TLS.Struct-import Network.TLS.MAC+import Control.Monad (forM_, when, replicateM)+import Control.Monad.Trans (lift)+ import Data.Word import Data.Bits import Data.Maybe-import Control.Monad (forM_, when, replicateM)-import Control.Monad.Trans (lift)-import Random-import qualified Codec.Crypto.AES.Random as AESRand-import Control.Concurrent (forkIO)+ import Data.Certificate.PEM import Data.Certificate.X509 import Data.Certificate.Key +import Network.TLS.Cipher+import Network.TLS.SRandom+import Network.TLS.Struct+import Network.TLS.MAC++import qualified Network.TLS.Client as C+import qualified Network.TLS.Server as S++import Random+import qualified Codec.Crypto.AES.Random as AESRand+ ciphers :: [Cipher] ciphers = 	[ cipher_AES128_SHA1@@ -52,13 +59,13 @@ mainClient :: String -> Int -> IO () mainClient host port = do 	{- generate some random stuff ready to be used after skipping some byte for no particular reason -}-	ranByte <- fmap B.head $ AESRand.randBytes 1+	ranByte <- B.head <$> AESRand.randBytes 1 	_ <- AESRand.randBytes (fromIntegral ranByte)-	clientRandom <- fmap (fromJust . clientRandom . B.unpack) $ AESRand.randBytes 32-	premasterRandom <- fmap B.unpack $ AESRand.randBytes 46-	seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4+	clientRandom <- fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32+	premasterRandom <- (ClientKeyData . B.unpack) <$> AESRand.randBytes 46+	seqInit <- conv . B.unpack <$> AESRand.randBytes 4 -	handle <- connectTo host (PortNumber 6061)+	handle <- connectTo host (PortNumber $ fromIntegral port) 	hSetBuffering handle NoBuffering  	let clientstate = C.TLSClientParams@@ -67,6 +74,9 @@ 		, C.cpSession = Nothing 		, C.cpCiphers = ciphers 		, C.cpCertificate = Nothing+		, C.cpCallbacks = C.TLSClientCallbacks+			{ C.cbCertificates = Nothing+			} 		} 	C.runTLSClient (tlsclient handle clientRandom premasterRandom) clientstate (makeSRandomGen seqInit) @@ -80,8 +90,8 @@ 	lift $ putStrLn "end"  clientProcess ((certdata, cert), pk) (handle, src) = do-	serverRandom <- fmap (fromJust . serverRandom . B.unpack) $ AESRand.randBytes 32-	seqInit <- fmap (conv . B.unpack) $ AESRand.randBytes 4+	serverRandom <- fromJust . serverRandom . B.unpack <$> AESRand.randBytes 32+	seqInit <- conv . B.unpack <$> AESRand.randBytes 4  	let serverstate = S.TLSServerParams 		{ S.spAllowedVersions = [TLS10]@@ -89,6 +99,8 @@ 		, S.spCiphers = ciphers 		, S.spCertificate = Just (certdata, cert, pk) 		, S.spWantClientCert = False+		, S.spCallbacks = S.TLSServerCallbacks+			{ S.cbCertificates = Nothing } 		}  	S.runTLSServer (tlsserver handle serverRandom) serverstate (makeSRandomGen seqInit)

@@ -4,7 +4,6 @@ - implement Certificate Verify / Certificate Request - add Client Certificates - add check for non-self signed certificate-- don't fail straight away if clientkeyxchg failed. required for security - alert correctly on errors - process session as they should - put 4 bytes of time in client/server random

@@ -45,6 +45,9 @@ instance Arbitrary ServerRandom where 	arbitrary = ServerRandom `fmap` someWords8 32 +instance Arbitrary ClientKeyData where+	arbitrary = ClientKeyData `fmap` someWords8 46+ instance Arbitrary Session where 	arbitrary = do 		i <- choose (1,2) :: Gen Int@@ -58,12 +61,25 @@ arbitraryCompressionIDs :: Gen [Word8] arbitraryCompressionIDs = choose (0,200) >>= someWords8 +instance Arbitrary CertificateType where+	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_fortezza_dms ]+ instance Arbitrary Handshake where 	arbitrary = oneof 		[ liftM6 ClientHello arbitrary arbitrary arbitrary arbitraryCiphersIDs arbitraryCompressionIDs (return Nothing) 		, liftM6 ServerHello arbitrary arbitrary arbitrary arbitrary arbitrary (return Nothing)+		, return (Certificates []) 		, return HelloRequest 		, return ServerHelloDone+		, liftM2 ClientKeyXchg arbitrary arbitrary+		--, liftM  ServerKeyXchg+		--, liftM3 CertRequest arbitrary (return Nothing) (return [])+		--, liftM CertVerify (return [])+		, liftM Finished (someWords8 12) 		]  {- quickcheck property -}

@@ -1,5 +1,5 @@ Name:                tls-Version:             0.1.1+Version:             0.1.2 Description:    Implementation of the TLS protocol, focusing on purity and more type-checking.    .@@ -39,15 +39,15 @@   Exposed-modules:   Network.TLS.Client                      Network.TLS.Server                      Network.TLS.Struct-  other-modules:     Network.TLS.Cipher-                     Network.TLS.Compression-                     Network.TLS.Crypto+                     Network.TLS.Cipher+                     Network.TLS.SRandom                      Network.TLS.MAC+  other-modules:     Network.TLS.Compression+                     Network.TLS.Crypto                      Network.TLS.Packet                      Network.TLS.State                      Network.TLS.Sending                      Network.TLS.Receiving-                     Network.TLS.SRandom                      Network.TLS.Wire   ghc-options:       -Wall