tls 0.1.2 → 0.1.3
raw patch · 18 files changed
+424/−277 lines, 18 filesdep +randomdep ~AESdep ~RSAdep ~bytestring
Dependencies added: random
Dependency ranges changed: AES, RSA, bytestring, haskell98, spoon, vector
Files
- Network/TLS/Cap.hs +19/−0
- Network/TLS/Cipher.hs +26/−23
- Network/TLS/Client.hs +17/−13
- Network/TLS/Crypto.hs +23/−14
- Network/TLS/MAC.hs +19/−23
- Network/TLS/Packet.hs +64/−42
- Network/TLS/Receiving.hs +64/−41
- Network/TLS/SRandom.hs +1/−1
- Network/TLS/Sending.hs +23/−22
- Network/TLS/Server.hs +18/−14
- Network/TLS/State.hs +28/−32
- Network/TLS/Struct.hs +19/−8
- Network/TLS/Util.hs +37/−0
- Network/TLS/Wire.hs +35/−22
- Stunnel.hs +7/−7
- TODO +7/−3
- Tests.hs +10/−8
- tls.cabal +7/−4
+ Network/TLS/Cap.hs view
@@ -0,0 +1,19 @@+-- |+-- Module : Network.TLS.Cap+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--++module Network.TLS.Cap+ ( hasHelloExtensions+ , hasExplicitBlockIV+ ) where++import Network.TLS.Struct++hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool++hasHelloExtensions ver = ver >= TLS12+hasExplicitBlockIV ver = ver >= TLS11
Network/TLS/Cipher.hs view
@@ -37,11 +37,11 @@ data CipherTypeFunctions = CipherNoneF -- special value for 0- | CipherBlockF (Key -> IV -> L.ByteString -> L.ByteString)- (Key -> IV -> L.ByteString -> L.ByteString)+ | CipherBlockF (Key -> IV -> B.ByteString -> B.ByteString)+ (Key -> IV -> B.ByteString -> B.ByteString) | CipherStreamF (Key -> IV)- (IV -> L.ByteString -> (L.ByteString, IV))- (IV -> L.ByteString -> (L.ByteString, IV))+ (IV -> B.ByteString -> (B.ByteString, IV))+ (IV -> B.ByteString -> (B.ByteString, IV)) data CipherKeyExchangeType = CipherKeyExchangeRSA@@ -63,7 +63,7 @@ , cipherKeyBlockSize :: Word8 , cipherPaddingSize :: Word8 , cipherKeyExchange :: CipherKeyExchangeType- , cipherHMAC :: L.ByteString -> L.ByteString -> L.ByteString+ , cipherHMAC :: B.ByteString -> B.ByteString -> B.ByteString , cipherF :: CipherTypeFunctions , cipherMinVer :: Maybe Version }@@ -82,29 +82,32 @@ cipherExchangeNeedMoreData CipherKeyExchangeECDH_RSA = True cipherExchangeNeedMoreData CipherKeyExchangeECDHE_ECDSA = True -repack :: Int -> L.ByteString -> [B.ByteString]+repack :: Int -> B.ByteString -> [B.ByteString] repack bs x =- if L.length x > fromIntegral bs+ if B.length x > bs then- let (c1, c2) = L.splitAt (fromIntegral bs) x in- B.pack (L.unpack c1) : repack 16 c2+ let (c1, c2) = B.splitAt bs x in+ B.pack (B.unpack c1) : repack 16 c2 else- [ B.pack (L.unpack x) ]+ [ x ] -aes128_cbc_encrypt :: Key -> IV -> L.ByteString -> L.ByteString-aes128_cbc_encrypt key iv d = AES.crypt AES.CBC key iv AES.Encrypt d16+lazyToStrict :: L.ByteString -> B.ByteString+lazyToStrict = B.concat . L.toChunks++aes128_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes128_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16 where d16 = L.fromChunks $ repack 16 d -aes128_cbc_decrypt :: Key -> IV -> L.ByteString -> L.ByteString-aes128_cbc_decrypt key iv d = AES.crypt AES.CBC key iv AES.Decrypt d16+aes128_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes128_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16 where d16 = L.fromChunks $ repack 16 d -aes256_cbc_encrypt :: Key -> IV -> L.ByteString -> L.ByteString-aes256_cbc_encrypt key iv d = AES.crypt AES.CBC key iv AES.Encrypt d16+aes256_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes256_cbc_encrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Encrypt d16 where d16 = L.fromChunks $ repack 16 d -aes256_cbc_decrypt :: Key -> IV -> L.ByteString -> L.ByteString-aes256_cbc_decrypt key iv d = AES.crypt AES.CBC key iv AES.Decrypt d16+aes256_cbc_decrypt :: Key -> IV -> B.ByteString -> B.ByteString+aes256_cbc_decrypt key iv d = lazyToStrict $ AES.crypt AES.CBC key iv AES.Decrypt d16 where d16 = L.fromChunks $ repack 32 d toIV :: RC4.Ctx -> IV@@ -119,11 +122,11 @@ initF_rc4 :: Key -> IV initF_rc4 key = toIV $ RC4.initCtx (B.unpack key) -encryptF_rc4 :: IV -> L.ByteString -> (L.ByteString, IV)-encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encryptlazy (toCtx iv) d+encryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)+encryptF_rc4 iv d = (\(ctx, e) -> (e, toIV ctx)) $ RC4.encrypt (toCtx iv) d -decryptF_rc4 :: IV -> L.ByteString -> (L.ByteString, IV)-decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decryptlazy (toCtx iv) e+decryptF_rc4 :: IV -> B.ByteString -> (B.ByteString, IV)+decryptF_rc4 iv e = (\(ctx, d) -> (d, toIV ctx)) $ RC4.decrypt (toCtx iv) e {- TLS 1.0 ciphers definition@@ -171,7 +174,7 @@ , cipherIVSize = 0 , cipherKeyBlockSize = 0 , cipherPaddingSize = 0- , cipherHMAC = (\_ _ -> L.empty)+ , cipherHMAC = (\_ _ -> B.empty) , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherNoneF , cipherMinVer = Nothing
Network/TLS/Client.hs view
@@ -39,6 +39,7 @@ import Network.TLS.Sending import Network.TLS.Receiving import Network.TLS.SRandom+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import System.IO (Handle, hFlush) import Data.List (find)@@ -83,23 +84,23 @@ runTLSClient :: TLSClient m a -> TLSClientParams -> SRandomGen -> m (a, TLSStateClient) runTLSClient f params rng = runTLSClientST f (TLSStateClient { scParams = params, scTLSState = state, scCertRequested = False })- where state = (newTLSState rng) { stVersion = TLS10, stClientContext = True }+ where state = (newTLSState rng) { stVersion = cpConnectVersion params, stClientContext = True } {- | receive a single TLS packet or on error a TLSError -} recvPacket :: Handle -> TLSClient IO (Either TLSError Packet) recvPacket handle = do- hdr <- lift $ L.hGet handle 5 >>= return . decodeHeader+ hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader case hdr of Left err -> return $ Left err Right header@(Header _ _ readlen) -> do- content <- lift $ L.hGet handle (fromIntegral readlen)+ content <- lift $ B.hGet handle (fromIntegral readlen) readPacket header (EncryptedData content) {- | send a single TLS packet -} sendPacket :: Handle -> Packet -> TLSClient IO () sendPacket handle pkt = do dataToSend <- writePacket pkt- lift $ L.hPut handle dataToSend+ lift $ B.hPut handle dataToSend recvServerHello :: Handle -> TLSClient IO () recvServerHello handle = do@@ -150,7 +151,7 @@ connectSendFinish :: Handle -> TLSClient IO () connectSendFinish handle = do cf <- getHandshakeDigest True- sendPacket handle (Handshake $ Finished $ L.unpack cf)+ sendPacket handle (Handshake $ Finished $ B.unpack cf) {- | connect through a handle as a new TLS connection. -} connect :: Handle -> ClientRandom -> ClientKeyData -> TLSClient IO ()@@ -184,24 +185,27 @@ return () -{- | sendData sends a bunch of data -}-sendData :: Handle -> L.ByteString -> TLSClient IO ()-sendData handle d = do- if L.length d > 16384+sendDataChunk :: Handle -> B.ByteString -> TLSClient IO ()+sendDataChunk handle d =+ if B.length d > 16384 then do- let (sending, remain) = L.splitAt 16384 d+ let (sending, remain) = B.splitAt 16384 d sendPacket handle $ AppData sending- sendData handle remain+ sendDataChunk handle remain else sendPacket handle $ AppData d +{- | sendData sends a bunch of data -}+sendData :: Handle -> L.ByteString -> TLSClient IO ()+sendData handle d = mapM_ (sendDataChunk handle) (L.toChunks d)+ {- | recvData get data out of Data packet, and automatically try to renegociate if - a Handshake HelloRequest is received -} recvData :: Handle -> TLSClient IO L.ByteString recvData handle = do pkt <- recvPacket handle case pkt of- Right (AppData x) -> return x+ Right (AppData x) -> return $ L.fromChunks [x] Right (Handshake HelloRequest) -> do -- SECURITY FIXME audit the rng here.. st <- getTLSState@@ -209,7 +213,7 @@ let (premaster, rng'') = getRandomBytes rng' 46 putTLSState $ st { stRandomGen = rng'' } let crand = fromJust $ clientRandom bytes- connect handle crand (ClientKeyData premaster)+ connect handle crand (ClientKeyData $ B.pack premaster) recvData handle Left err -> error ("error received: " ++ show err) _ -> error "unexpected item"
Network/TLS/Crypto.hs view
@@ -28,11 +28,13 @@ import qualified Data.CryptoHash.SHA1 as SHA1 import qualified Data.CryptoHash.MD5 as MD5 import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.ByteString (ByteString) import Codec.Crypto.RSA (PublicKey(..), PrivateKey(..)) import qualified Codec.Crypto.RSA as RSA import Control.Spoon-import Random+import Control.Arrow (first)+import System.Random data HashCtx = SHA1 !SHA1.Ctx@@ -49,28 +51,28 @@ initMD5 :: MD5.Ctx initMD5 = MD5.init -updateMD5 :: MD5.Ctx -> B.ByteString -> MD5.Ctx+updateMD5 :: MD5.Ctx -> ByteString -> MD5.Ctx updateMD5 = MD5.update -finalizeMD5 :: MD5.Ctx -> B.ByteString+finalizeMD5 :: MD5.Ctx -> ByteString finalizeMD5 = MD5.finalize -hashMD5 :: ByteString -> B.ByteString-hashMD5 = MD5.hashlazy+hashMD5 :: ByteString -> ByteString+hashMD5 = MD5.hash {- SHA1 -} initSHA1 :: SHA1.Ctx initSHA1 = SHA1.init -updateSHA1 :: SHA1.Ctx -> B.ByteString -> SHA1.Ctx+updateSHA1 :: SHA1.Ctx -> ByteString -> SHA1.Ctx updateSHA1 = SHA1.update -finalizeSHA1 :: SHA1.Ctx -> B.ByteString+finalizeSHA1 :: SHA1.Ctx -> ByteString finalizeSHA1 = SHA1.finalize -hashSHA1 :: ByteString -> B.ByteString-hashSHA1 = SHA1.hashlazy+hashSHA1 :: ByteString -> ByteString+hashSHA1 = SHA1.hash {- generic Hashing -} @@ -94,8 +96,15 @@ need to fix the RSA package to return "Either String X". -} -rsaEncrypt :: RandomGen g => g -> PublicKey -> ByteString -> Maybe (ByteString, g)-rsaEncrypt g pk b = teaspoon (RSA.rsaes_pkcs1_v1_5_encrypt g pk b)+lazyToStrict :: L.ByteString -> B.ByteString+lazyToStrict = B.concat . L.toChunks -rsaDecrypt :: PrivateKey -> ByteString -> Maybe ByteString-rsaDecrypt pk b = teaspoon (RSA.rsaes_pkcs1_v1_5_decrypt pk b)+rsaEncrypt :: RandomGen g => g -> PublicKey -> B.ByteString -> Maybe (B.ByteString, g)+rsaEncrypt g pk b = maybe Nothing (Just . first lazyToStrict) $ teaspoon (RSA.rsaes_pkcs1_v1_5_encrypt g pk blazy)+ where+ blazy = L.fromChunks [ b ]++rsaDecrypt :: PrivateKey -> B.ByteString -> Maybe B.ByteString+rsaDecrypt pk b = maybe Nothing (Just . lazyToStrict) $ teaspoon (RSA.rsaes_pkcs1_v1_5_decrypt pk blazy)+ where+ blazy = L.fromChunks [ b ]
Network/TLS/MAC.hs view
@@ -10,54 +10,50 @@ import qualified Data.CryptoHash.MD5 as MD5 import qualified Data.CryptoHash.SHA1 as SHA1 import qualified Data.CryptoHash.SHA256 as SHA256-import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString)+import Data.ByteString (ByteString) import Data.Bits (xor) -lazyOfStrict :: B.ByteString -> ByteString-lazyOfStrict b = L.fromChunks [ b ]- hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString hmac f bl secret msg =- f $! L.append opad (f $! L.append ipad msg)+ f $! B.append opad (f $! B.append ipad msg) where- opad = L.map (xor 0x5c) k'- ipad = L.map (xor 0x36) k'+ opad = B.map (xor 0x5c) k'+ ipad = B.map (xor 0x36) k' - k' = L.append kt pad+ k' = B.append kt pad where- kt = if L.length secret > fromIntegral bl then f secret else secret- pad = L.replicate (fromIntegral bl - L.length kt) 0+ kt = if B.length secret > fromIntegral bl then f secret else secret+ pad = B.replicate (fromIntegral bl - B.length kt) 0 hmacMD5 :: ByteString -> ByteString -> ByteString-hmacMD5 secret msg = hmac (lazyOfStrict . MD5.hashlazy) 64 secret msg+hmacMD5 secret msg = hmac MD5.hash 64 secret msg hmacSHA1 :: ByteString -> ByteString -> ByteString-hmacSHA1 secret msg = hmac (lazyOfStrict . SHA1.hashlazy) 64 secret msg+hmacSHA1 secret msg = hmac SHA1.hash 64 secret msg hmacSHA256 :: ByteString -> ByteString -> ByteString-hmacSHA256 secret msg = hmac (lazyOfStrict . SHA256.hashlazy) 64 secret msg+hmacSHA256 secret msg = hmac SHA256.hash 64 secret msg hmacIter :: (ByteString -> ByteString -> ByteString) -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] hmacIter f secret seed aprev len = let an = f secret aprev in- let out = f secret (L.concat [an, seed]) in- let digestsize = fromIntegral $ L.length out in+ let out = f secret (B.concat [an, seed]) in+ let digestsize = fromIntegral $ B.length out in if digestsize >= len- then [ L.take (fromIntegral len) out ]+ then [ B.take (fromIntegral len) out ] else out : hmacIter f secret seed an (len - digestsize) prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA1 secret seed len = L.concat $ hmacIter hmacSHA1 secret seed seed len+prf_SHA1 secret seed len = B.concat $ hmacIter hmacSHA1 secret seed seed len prf_MD5 :: ByteString -> ByteString -> Int -> ByteString-prf_MD5 secret seed len = L.concat $ hmacIter hmacMD5 secret seed seed len+prf_MD5 secret seed len = B.concat $ hmacIter hmacMD5 secret seed seed len prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString prf_MD5SHA1 secret seed len =- L.pack $ L.zipWith xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ B.pack $ B.zipWith xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) where- slen = L.length secret- s1 = L.take (slen `div` 2 + slen `mod` 2) secret- s2 = L.drop (slen `div` 2) secret+ slen = B.length secret+ s1 = B.take (slen `div` 2 + slen `mod` 2) secret+ s2 = B.drop (slen `div` 2) secret
Network/TLS/Packet.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Packet -- License : BSD-style@@ -36,20 +37,21 @@ , generateServerFinished ) where -import Data.Word+import Network.TLS.Struct+import Network.TLS.Cap 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 import Data.Certificate.X509 import Network.TLS.Crypto import Network.TLS.MAC-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L (pack, length, concat, fromChunks)+import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as L {- - decode and encode headers@@ -89,7 +91,7 @@ {- decode and encode HANDSHAKE -} -decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, ByteString)+decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, Bytes) decodeHandshakeHeader = runGet $ do tyopt <- getWord8 >>= return . valToType ty <- if isNothing tyopt@@ -99,7 +101,7 @@ content <- getBytes len empty <- isEmpty unless empty (throwError (Error_Internal_Packet_Remaining 1))- return (ty, L.fromChunks [content])+ return (ty, content) decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake ver ty = runGet $ case ty of@@ -125,7 +127,7 @@ ciphers <- getWords16 compressions <- getWords8 r <- remaining- exts <- if ver >= TLS12 && r > 0+ exts <- if hasHelloExtensions ver && r > 0 then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just else return Nothing return $ ClientHello ver random session ciphers compressions exts@@ -138,7 +140,7 @@ cipherid <- getWord16 compressionid <- getWord8 r <- remaining- exts <- if ver >= TLS12 && r > 0+ exts <- if hasHelloExtensions ver && r > 0 then fmap fromIntegral getWord16 >>= getExtensions >>= return . Just else return Nothing return $ ServerHello ver random session cipherid compressionid exts@@ -161,7 +163,8 @@ -- so just return the remaining string. len <- if ver >= TLS12 then remaining- else return 12+ else if ver == SSL3 then return 36+ else return 12 opaque <- getBytes (fromIntegral len) return $ Finished $ B.unpack opaque @@ -230,9 +233,9 @@ encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = runPut $ encodeHandshakeContent o in- let len = fromIntegral $ L.length content in+ let len = fromIntegral $ B.length content in let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in- L.concat [ header, content ]+ B.concat [ header, content ] encodeHandshakeHeader :: HandshakeType -> Int -> Put encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len@@ -254,10 +257,10 @@ >> putExtensions exts >> return () encodeHandshakeContent (Certificates certs) =- putWord24 len >> putLazyByteString certbs+ putWord24 len >> putBytes certbs where certbs = runPut $ mapM_ putCert certs- len = fromIntegral $ L.length certbs+ len = fromIntegral $ B.length certbs encodeHandshakeContent (ClientKeyXchg version random) = do putVersion version@@ -275,7 +278,7 @@ case sigAlgs of Nothing -> return () Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l- putByteString $ B.pack certAuthorities+ putBytes $ B.pack certAuthorities encodeHandshakeContent (CertVerify _) = undefined @@ -295,8 +298,8 @@ where (major, minor) = numericalVer ver {- FIXME make sure it return error if not 32 available -}-getRandom32 :: Get [Word8]-getRandom32 = B.unpack <$> getBytes 32+getRandom32 :: Get Bytes+getRandom32 = getBytes 32 getServerRandom32 :: Get ServerRandom getServerRandom32 = ServerRandom <$> getRandom32@@ -304,8 +307,8 @@ getClientRandom32 :: Get ClientRandom getClientRandom32 = ClientRandom <$> getRandom32 -putRandom32 :: [Word8] -> Put-putRandom32 = mapM_ putWord8+putRandom32 :: Bytes -> Put+putRandom32 = putBytes putClientRandom32 :: ClientRandom -> Put putClientRandom32 (ClientRandom r) = putRandom32 r@@ -314,25 +317,25 @@ putServerRandom32 (ServerRandom r) = putRandom32 r getClientKeyData46 :: Get ClientKeyData-getClientKeyData46 = ClientKeyData . B.unpack <$> getBytes 46+getClientKeyData46 = ClientKeyData <$> getBytes 46 putClientKeyData46 :: ClientKeyData -> Put-putClientKeyData46 (ClientKeyData d) = mapM_ putWord8 d+putClientKeyData46 (ClientKeyData d) = putBytes d getSession :: Get Session getSession = do len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing- len -> Session . Just . B.unpack <$> getBytes len+ len -> Session . Just <$> getBytes len putSession :: Session -> Put putSession (Session session) = case session of Nothing -> putWord8 0- Just s -> putWord8 (fromIntegral $ length s) >> mapM_ putWord8 s+ Just s -> putWord8 (fromIntegral $ B.length s) >> putBytes s -getCerts :: Int -> Get [B.ByteString]+getCerts :: Int -> Get [Bytes] getCerts 0 = return [] getCerts len = do certlen <- getWord24@@ -341,8 +344,8 @@ return (cert : certxs) putCert :: Certificate -> Put-putCert cert = putWord24 (fromIntegral $ L.length content) >> putLazyByteString content- where content = encodeCertificate cert+putCert cert = putWord24 (fromIntegral $ B.length content) >> putBytes content+ where content = B.concat $ L.toChunks $ encodeCertificate cert getExtensions :: Int -> Get [Extension] getExtensions 0 = return []@@ -357,12 +360,12 @@ putExtension (ty, l) = do putWord16 ty putWord16 (fromIntegral $ length l)- putByteString (B.pack l)+ putBytes (B.pack l) putExtensions :: Maybe [Extension] -> Put putExtensions Nothing = return () putExtensions (Just es) =- putWord16 (fromIntegral $ L.length extbs) >> putLazyByteString extbs+ putWord16 (fromIntegral $ B.length extbs) >> putBytes extbs where extbs = runPut $ mapM_ putExtension es @@ -381,29 +384,48 @@ {- - generate things for packet content -}-generateMasterSecret :: ByteString -> ClientRandom -> ServerRandom -> ByteString-generateMasterSecret premasterSecret (ClientRandom c) (ServerRandom s) =+generateMasterSecret_TLS, generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes+generateMasterSecret_TLS premasterSecret (ClientRandom c) (ServerRandom s) = prf_MD5SHA1 premasterSecret seed 48 where- label = map (toEnum . fromEnum) "master secret"- seed = L.concat $ map L.pack [ label, c, s]+ seed = B.concat [ BC.pack "master secret", c, s ] -generateKeyBlock :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString+generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =+ B.concat $ map (computeMD5 . BC.pack) [ "A", "BB", "CCC" ]+ where+ computeMD5 label = hashMD5 $ B.concat [ premasterSecret, computeSHA1 label ]+ computeSHA1 label = hashSHA1 $ B.concat [ label, premasterSecret, c, s ]++generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes+generateMasterSecret ver =+ if ver < TLS10 then generateMasterSecret_SSL else generateMasterSecret_TLS++generateKeyBlock :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes generateKeyBlock (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf_MD5SHA1 mastersecret seed kbsize where- label = map (toEnum . fromEnum) "key expansion"- seed = L.concat $ map L.pack [ label, s, c ]+ seed = B.concat [ BC.pack "key expansion", s, c ] -generateFinished :: String -> ByteString -> HashCtx -> HashCtx -> ByteString-generateFinished label mastersecret md5ctx sha1ctx =+generateFinished_TLS :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes+generateFinished_TLS label mastersecret md5ctx sha1ctx = prf_MD5SHA1 mastersecret seed 12 where- plabel = B.pack $ map (toEnum . fromEnum) label- seed = L.fromChunks [ plabel, finalizeHash md5ctx, finalizeHash sha1ctx ]+ seed = B.concat [ label, finalizeHash md5ctx, finalizeHash sha1ctx ] -generateClientFinished :: ByteString -> HashCtx -> HashCtx -> ByteString-generateClientFinished = generateFinished "client finished"+generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes+generateFinished_SSL sender mastersecret md5ctx sha1ctx =+ B.concat [md5hash, sha1hash]+ where+ md5hash = hashMD5 $ B.concat [ mastersecret, pad2, md5left ]+ sha1hash = hashSHA1 $ B.concat [ mastersecret, pad2, sha1left ]+ pad2 = B.empty -- FIXME+ md5left = hashMD5 B.empty+ sha1left = hashSHA1 B.empty -generateServerFinished :: ByteString -> HashCtx -> HashCtx -> ByteString-generateServerFinished = generateFinished "server finished"+generateClientFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes+generateClientFinished ver =+ if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS (BC.pack "client finished")++generateServerFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes+generateServerFinished ver =+ if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS (BC.pack "server finished")
Network/TLS/Receiving.hs view
@@ -19,10 +19,12 @@ import Control.Monad.Error import Data.Maybe -import Data.ByteString.Lazy (ByteString)+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B +import Network.TLS.Util+import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Packet import Network.TLS.State@@ -72,14 +74,14 @@ decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString) decryptRSA econtent = do rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake- return $ rsaDecrypt rsapriv (L.drop 2 econtent)+ return $ rsaDecrypt rsapriv (B.drop 2 econtent) setMasterSecretRandom :: ByteString -> TLSRead () setMasterSecretRandom content = do st <- getTLSState- let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ L.length content)+ let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content) putTLSState $ st { stRandomGen = g' }- setMasterSecret (L.pack bytes)+ setMasterSecret (B.pack bytes) processClientKeyXchg :: Version -> ByteString -> TLSRead () processClientKeyXchg ver content = do@@ -93,7 +95,7 @@ processClientFinished fdata = do cc <- getTLSState >>= return . stClientContext expected <- getHandshakeDigest (not cc)- when (expected /= L.pack fdata) $ do+ 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)) return ()@@ -110,7 +112,7 @@ return econtent hs <- case (ty, decodeHandshake ver ty content) of (_, Right x) -> return x- (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ replicate 0xff 46)+ (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff) (_, Left err) -> throwError err clientmode <- isClientContext case hs of@@ -127,31 +129,40 @@ when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent) return $ Handshake hs -decryptContentReally :: Header -> EncryptedData -> TLSRead ByteString-decryptContentReally hdr e = do- st <- getTLSState- unencrypted_content <- decryptData e- let digestSize = cipherDigestSize $ fromJust $ stCipher st- let (unencrypted_msg, digest) = L.splitAt (L.length unencrypted_content - fromIntegral digestSize) unencrypted_content- let (Header pt ver _) = hdr- let new_hdr = Header pt ver (fromIntegral $ L.length unencrypted_msg)- expected_digest <- makeDigest False new_hdr unencrypted_msg - if expected_digest == digest- then return $ unencrypted_msg- else throwError $ Error_Digest (L.unpack expected_digest, L.unpack digest)- decryptContent :: Header -> EncryptedData -> TLSRead ByteString decryptContent hdr e@(EncryptedData b) = do st <- getTLSState if stRxEncrypted st- then decryptContentReally hdr e+ then decryptData e >>= getCipherData hdr else return b -takelast :: Int -> [a] -> [a]-takelast i b = drop (length b - i) b+getCipherData :: Header -> CipherData -> TLSRead ByteString+getCipherData hdr cdata = do+ -- check if the MAC is valid.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let (Header pt ver _) = hdr+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata+ if expected_digest == digest+ then return True+ else return False -decryptData :: EncryptedData -> TLSRead ByteString+ -- check if the padding is filled with the correct pattern if it exists+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just pad -> do+ let b = B.length pad - 1+ return $ maybe True (const False) $ B.find (/= fromIntegral b) pad++ unless (and $! [ macValid, paddingValid ]) $ do+ throwError $ Error_Digest ([], [])++ return $ cipherDataContent cdata++decryptData :: EncryptedData -> TLSRead CipherData decryptData (EncryptedData econtent) = do st <- getTLSState @@ -159,32 +170,44 @@ [ ("cipher", isNothing $ stCipher st) , ("crypt state", isNothing $ stRxCryptState st) ] - let cipher = fromJust $ stCipher st- let cst = fromJust $ stRxCryptState st+ let cipher = fromJust $ stCipher st+ let cst = fromJust $ stRxCryptState st let padding_size = fromIntegral $ cipherPaddingSize cipher-- let writekey = B.pack $ cstKey cst- let iv = B.pack $ cstIV cst+ let digestSize = fromIntegral $ cipherDigestSize cipher+ let writekey = cstKey cst - contentpadded <- case cipherF cipher of+ case cipherF cipher of CipherNoneF -> fail "none decrypt" CipherBlockF _ decryptF -> do {- update IV -}- let newiv = takelast padding_size $ L.unpack econtent+ let (iv, econtent') =+ if hasExplicitBlockIV $ stVersion st+ then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent+ else (cstIV cst, econtent)+ let newiv = fromJust $ takelast padding_size econtent' putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }- return $ decryptF writekey iv econtent++ 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 $ partition3 content' (contentlen, digestSize, paddinglength)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just padding+ } CipherStreamF initF _ decryptF -> do- let (content, newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent+ let iv = cstIV cst+ let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent {- update Ctx -}- putTLSState $ st { stRxCryptState = Just $ cst { cstIV = B.unpack newiv } }- return $ content- let content =- if cipherPaddingSize cipher > 0- then- let pb = L.last contentpadded + 1 in- fst $ L.splitAt ((L.length contentpadded) - fromIntegral pb) contentpadded- else contentpadded- return content+ let contentlen = B.length content' - digestSize+ let (content, mac, _) = fromJust $ partition3 content' (contentlen, digestSize, 0)+ putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ } processCertificates :: [Certificate] -> TLSRead () processCertificates certs = do
Network/TLS/SRandom.hs view
@@ -7,7 +7,7 @@ , getRandomBytes ) where -import Random+import System.Random import Control.Arrow (first) import Data.Word
Network/TLS/Sending.hs view
@@ -15,13 +15,14 @@ ) where import Control.Monad.State-import Data.Binary.Put (runPut, putWord16be) import Data.Maybe -import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L+import Data.ByteString (ByteString) 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.Packet import Network.TLS.State@@ -36,7 +37,7 @@ makePacketData pkt = do ver <- getTLSState >>= return . stVersion content <- writePacketContent pkt- let hdr = Header (packetType pkt) ver (fromIntegral $ L.length content)+ let hdr = Header (packetType pkt) ver (fromIntegral $ B.length content) return (hdr, content) {-@@ -73,7 +74,7 @@ - marshall packet data -} encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString-encodePacket (hdr, content) = return $ L.concat [ encodeHeader hdr, content ]+encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ] {-@@ -105,13 +106,10 @@ encryptContent :: MonadTLSState m => (Header, ByteString) -> m (Header, ByteString) encryptContent (hdr@(Header pt ver _), content) = do digest <- makeDigest True hdr content- encrypted_msg <- encryptData $ L.concat [content, digest]- let hdrnew = Header pt ver (fromIntegral $ L.length encrypted_msg)+ encrypted_msg <- encryptData $ B.concat [content, digest]+ let hdrnew = Header pt ver (fromIntegral $ B.length encrypted_msg) return (hdrnew, encrypted_msg) -takelast :: Int -> [a] -> [a]-takelast i b = drop (length b - i) b- encryptData :: MonadTLSState m => ByteString -> m ByteString encryptData content = do st <- getTLSState@@ -124,27 +122,30 @@ let cst = fromJust $ stTxCryptState st let padding_size = fromIntegral $ cipherPaddingSize cipher - let msg_len = L.length content+ let msg_len = B.length content let padding = if padding_size > 0 then let padbyte = padding_size - (msg_len `mod` padding_size) in let padbyte' = if padbyte == 0 then padding_size else padbyte in- L.replicate padbyte' (fromIntegral (padbyte' - 1))+ B.replicate padbyte' (fromIntegral (padbyte' - 1)) else- L.empty- let writekey = B.pack $ cstKey cst- let iv = B.pack $ cstIV cst+ B.empty+ let writekey = cstKey cst econtent <- case cipherF cipher of CipherNoneF -> fail "none encrypt" CipherBlockF encrypt _ -> do- let e = encrypt writekey iv (L.concat [ content, padding ])- let newiv = takelast (fromIntegral padding_size) $ L.unpack e+ let iv = cstIV cst+ let e = encrypt writekey iv (B.concat [ content, padding ])+ let newiv = fromJust $ takelast (fromIntegral $ cipherIVSize cipher) e putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }- return e+ return $ if hasExplicitBlockIV $ stVersion st+ then B.concat [iv,e]+ else e CipherStreamF initF encryptF _ -> do+ let iv = cstIV cst let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content- putTLSState $ st { stTxCryptState = Just $ cst { cstIV = B.unpack newiv } }+ putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } } return e return econtent @@ -159,9 +160,9 @@ let premastersecret = runPut $ encodeHandshakeContent ckx setMasterSecret premastersecret econtent <- encryptRSA premastersecret- let extralength = runPut $ putWord16be $ fromIntegral $ L.length econtent- let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (L.length econtent + 2))- return $ L.concat [hdr, extralength, econtent]+ let extralength = runPut $ putWord16 $ fromIntegral $ B.length econtent+ let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (B.length econtent + 2))+ return $ B.concat [hdr, extralength, econtent] writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do cc <- isClientContext
Network/TLS/Server.hs view
@@ -40,10 +40,11 @@ import Network.TLS.Sending import Network.TLS.Receiving import Network.TLS.SRandom+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import System.IO (Handle, hFlush) -type TLSServerCert = (L.ByteString, Certificate, CertificateKey.PrivateKey)+type TLSServerCert = (B.ByteString, Certificate, CertificateKey.PrivateKey) data TLSServerCallbacks = TLSServerCallbacks { cbCertificates :: Maybe ([Certificate] -> IO Bool) -- ^ optional callback to verify certificates@@ -84,23 +85,23 @@ runTLSServer :: TLSServer m a -> TLSServerParams -> SRandomGen -> m (a, TLSStateServer) runTLSServer f params rng = runTLSServerST f (TLSStateServer { scParams = params, scTLSState = state })- where state = (newTLSState rng) { stVersion = TLS10, stClientContext = False }+ where state = (newTLSState rng) { stClientContext = False } {- | receive a single TLS packet or on error a TLSError -} recvPacket :: Handle -> TLSServer IO (Either TLSError Packet) recvPacket handle = do- hdr <- lift $ L.hGet handle 5 >>= return . decodeHeader+ hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader case hdr of Left err -> return $ Left err Right header@(Header _ _ readlen) -> do- content <- lift $ L.hGet handle (fromIntegral readlen)+ content <- lift $ B.hGet handle (fromIntegral readlen) readPacket header (EncryptedData content) {- | send a single TLS packet -} sendPacket :: Handle -> Packet -> TLSServer IO () sendPacket handle pkt = do dataToSend <- writePacket pkt- lift $ L.hPut handle dataToSend+ lift $ B.hPut handle dataToSend handleClientHello :: Handshake -> TLSServer IO () handleClientHello (ClientHello ver _ _ ciphers compressionID _) = do@@ -173,7 +174,7 @@ when needkeyxchg $ do let skg = SKX_RSA Nothing sendPacket handle (Handshake $ ServerKeyXchg skg)- -- FIXME we don't do this on a Anonyous server+ -- FIXME we don't do this on a Anonymous server when (spWantClientCert sp) $ do let certTypes = [ CertificateType_RSA_Sign ] let creq = CertRequest certTypes Nothing [0,0,0]@@ -183,7 +184,7 @@ handshakeSendFinish :: Handle -> TLSServer IO () handshakeSendFinish handle = do cf <- getHandshakeDigest False- sendPacket handle (Handshake $ Finished $ L.unpack cf)+ sendPacket handle (Handshake $ Finished $ B.unpack cf) {- after receiving a client hello, we need to redo a handshake -} handshake :: Handle -> ServerRandom -> TLSServer IO ()@@ -213,17 +214,20 @@ return () -{- | sendData sends a bunch of data -}-sendData :: Handle -> L.ByteString -> TLSServer IO ()-sendData handle d =- if L.length d > 16384+sendDataChunk :: Handle -> B.ByteString -> TLSServer IO ()+sendDataChunk handle d =+ if B.length d > 16384 then do- let (sending, remain) = L.splitAt 16384 d+ let (sending, remain) = B.splitAt 16384 d sendPacket handle $ AppData sending- sendData handle remain+ sendDataChunk handle remain else sendPacket handle $ AppData d +{- | sendData sends a bunch of data -}+sendData :: Handle -> L.ByteString -> TLSServer IO ()+sendData handle d = mapM_ (sendDataChunk handle) (L.toChunks d)+ {- | recvData get data out of Data packet, and automatically renegociate if - a Handshake ClientHello is received -} recvData :: Handle -> TLSServer IO L.ByteString@@ -238,7 +242,7 @@ let srand = fromJust $ serverRandom bytes handshake handle srand recvData handle- Right (AppData x) -> return x+ Right (AppData x) -> return $ L.fromChunks [x] Left err -> error ("error received: " ++ show err) _ -> error "unexpected item"
Network/TLS/State.hs view
@@ -37,14 +37,14 @@ import Data.Word import Data.Maybe (fromJust, isNothing)+import Network.TLS.Util import Network.TLS.Struct import Network.TLS.SRandom import Network.TLS.Wire import Network.TLS.Packet import Network.TLS.Crypto import Network.TLS.Cipher-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B import Control.Monad assert :: Monad m => String -> [(String,Bool)] -> m ()@@ -52,9 +52,9 @@ when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") data TLSCryptState = TLSCryptState- { cstKey :: ![Word8]- , cstIV :: ![Word8]- , cstMacSecret :: L.ByteString+ { cstKey :: !Bytes+ , cstIV :: !Bytes+ , cstMacSecret :: !Bytes } deriving (Show) data TLSMacState = TLSMacState@@ -65,7 +65,7 @@ { hstClientVersion :: !(Version) , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom)- , hstMasterSecret :: !(Maybe [Word8])+ , hstMasterSecret :: !(Maybe Bytes) , hstRSAPublicKey :: !(Maybe PublicKey) , hstRSAPrivateKey :: !(Maybe PrivateKey) , hstHandshakeDigest :: Maybe (HashCtx, HashCtx) -- FIXME could be only 1 hash in tls12@@ -73,7 +73,6 @@ data TLSState = TLSState { stClientContext :: Bool- , stClientVersion :: !(Maybe Version) , stVersion :: !Version , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool@@ -93,7 +92,6 @@ newTLSState :: SRandomGen -> TLSState newTLSState rng = TLSState { stClientContext = False- , stClientVersion = Nothing , stVersion = TLS10 , stHandshake = Nothing , stTxEncrypted = False@@ -109,7 +107,7 @@ modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m () modifyTLSState f = getTLSState >>= \st -> putTLSState (f st) -makeDigest :: (MonadTLSState m) => Bool -> Header -> ByteString -> m ByteString+makeDigest :: (MonadTLSState m) => Bool -> Header -> Bytes -> m Bytes makeDigest w hdr content = do st <- getTLSState assert "make digest"@@ -120,7 +118,7 @@ let ms = fromJust $ if w then stTxMacState st else stRxMacState st let cipher = fromJust $ stCipher st - let hmac_msg = L.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]+ let hmac_msg = B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ] let digest = (cipherHMAC cipher) (cstMacSecret cst) hmac_msg let newms = ms { msSequence = (msSequence ms) + 1 }@@ -152,7 +150,7 @@ setServerRandom :: MonadTLSState m => ServerRandom -> m () setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) -setMasterSecret :: MonadTLSState m => ByteString -> m ()+setMasterSecret :: MonadTLSState m => Bytes -> m () setMasterSecret premastersecret = do st <- getTLSState hasValidHandshake "master secret"@@ -160,8 +158,8 @@ [ ("server random", (isNothing $ hstServerRandom $ fromJust $ stHandshake st)) ] updateHandshake "master secret" (\hst ->- let ms = generateMasterSecret premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in- hst { hstMasterSecret = Just $ L.unpack ms } )+ let ms = generateMasterSecret (stVersion st) premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in+ hst { hstMasterSecret = Just ms } ) return () setPublicKey :: MonadTLSState m => PublicKey -> m ()@@ -184,26 +182,23 @@ let cc = stClientContext st let cipher = fromJust $ stCipher st let keyblockSize = fromIntegral $ cipherKeyBlockSize cipher- let digestSize = cipherDigestSize cipher- let keySize = cipherKeySize cipher- let ivSize = cipherIVSize cipher+ let digestSize = fromIntegral $ cipherDigestSize cipher+ let keySize = fromIntegral $ cipherKeySize cipher+ let ivSize = fromIntegral $ cipherIVSize cipher let kb = generateKeyBlock (hstClientRandom hst) (fromJust $ hstServerRandom hst)- (L.pack $ fromJust $ hstMasterSecret hst) keyblockSize- let (cMACSecret, r1) = L.splitAt (fromIntegral digestSize) kb- let (sMACSecret, r2) = L.splitAt (fromIntegral digestSize) r1- let (cWriteKey, r3) = L.splitAt (fromIntegral keySize) r2- let (sWriteKey, r4) = L.splitAt (fromIntegral keySize) r3- let (cWriteIV, r5) = L.splitAt (fromIntegral ivSize) r4- let (sWriteIV, _) = L.splitAt (fromIntegral ivSize) r5+ (fromJust $ hstMasterSecret hst) keyblockSize + let (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =+ fromJust $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)+ let cstClient = TLSCryptState- { cstKey = L.unpack cWriteKey- , cstIV = L.unpack cWriteIV+ { cstKey = cWriteKey+ , cstIV = cWriteIV , cstMacSecret = cMACSecret } let cstServer = TLSCryptState- { cstKey = L.unpack sWriteKey- , cstIV = L.unpack sWriteIV+ { cstKey = sWriteKey+ , cstIV = sWriteIV , cstMacSecret = sMACSecret } let msClient = TLSMacState { msSequence = 0 } let msServer = TLSMacState { msSequence = 0 }@@ -250,22 +245,23 @@ hasValidHandshake n modifyTLSState (\st -> st { stHandshake = maybe Nothing (Just . f) (stHandshake st) }) -updateHandshakeDigest :: MonadTLSState m => ByteString -> m ()+updateHandshakeDigest :: MonadTLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" (\hs ->- let ctxs = case hstHandshakeDigest hs of+ let (c1, c2) = case hstHandshakeDigest hs of Nothing -> (initHash HashTypeSHA1, initHash HashTypeMD5) Just (sha1ctx, md5ctx) -> (sha1ctx, md5ctx) in- let (nc1, nc2) = foldl (\(c1, c2) s -> (updateHash c1 s, updateHash c2 s)) ctxs $ L.toChunks content in+ let nc1 = updateHash c1 content in+ let nc2 = updateHash c2 content in hs { hstHandshakeDigest = Just (nc1, nc2) } ) -getHandshakeDigest :: MonadTLSState m => Bool -> m ByteString+getHandshakeDigest :: MonadTLSState m => Bool -> m Bytes getHandshakeDigest client = do st <- getTLSState let hst = fromJust $ stHandshake st let (sha1ctx, md5ctx) = fromJust $ hstHandshakeDigest hst let msecret = fromJust $ hstMasterSecret hst- return $ (if client then generateClientFinished else generateServerFinished) (L.pack msecret) md5ctx sha1ctx+ return $ (if client then generateClientFinished else generateServerFinished) (stVersion st) msecret md5ctx sha1ctx endHandshake :: MonadTLSState m => m () endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing })
Network/TLS/Struct.hs view
@@ -8,9 +8,11 @@ -- the Struct module contains all definitions and values of the TLS protocol -- module Network.TLS.Struct- ( Version(..)+ ( Bytes+ , Version(..) , ConnectionEnd(..) , CipherType(..)+ , CipherData(..) , Extension , EncryptedData(..) , CertificateType(..)@@ -41,14 +43,23 @@ , typeOfHandshake ) where -import Data.ByteString.Lazy (ByteString)+import Data.ByteString (ByteString, pack) import Data.Word import Data.Certificate.X509 +type Bytes = ByteString+ data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD++data CipherData = CipherData+ { cipherDataContent :: Bytes+ , cipherDataMAC :: Maybe Bytes+ , cipherDataPadding :: Maybe Bytes+ } deriving (Show,Eq)+ data CertificateType = CertificateType_RSA_Sign -- TLS10 | CertificateType_DSS_Sign -- TLS10@@ -107,17 +118,17 @@ data Header = Header ProtocolType Version Word16 deriving (Show, Eq) -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)+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 type FinishedData = [Word8] type Extension = (Word16, [Word8]) -constrRandom32 :: ([Word8] -> a) -> [Word8] -> Maybe a-constrRandom32 constr l = if length l == 32 then Just (constr l) else Nothing+constrRandom32 :: (Bytes -> a) -> [Word8] -> Maybe a+constrRandom32 constr l = if length l == 32 then Just (constr $ pack l) else Nothing serverRandom :: [Word8] -> Maybe ServerRandom serverRandom l = constrRandom32 ServerRandom l
+ Network/TLS/Util.hs view
@@ -0,0 +1,37 @@+module Network.TLS.Util+ ( sub+ , takelast+ , partition3+ , partition6+ ) where++import Network.TLS.Struct (Bytes)+import Network.TLS.Wire+import qualified Data.ByteString as B++sub :: Bytes -> Int -> Int -> Maybe Bytes+sub b offset len+ | B.length b < offset + len = Nothing+ | otherwise = Just $ B.take len $ snd $ B.splitAt offset b++takelast :: Int -> Bytes -> Maybe Bytes+takelast i b+ | B.length b >= i = sub b (B.length b - i) i+ | otherwise = Nothing++partition3 :: Bytes -> (Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes)+partition3 bytes (d1,d2,d3) = either (const Nothing) Just $ (flip runGet) bytes $ do+ p1 <- getBytes d1+ p2 <- getBytes d2+ p3 <- getBytes d3+ return (p1,p2,p3)++partition6 :: Bytes -> (Int,Int,Int,Int,Int,Int) -> Maybe (Bytes, Bytes, Bytes, Bytes, Bytes, Bytes)+partition6 bytes (d1,d2,d3,d4,d5,d6) = either (const Nothing) Just $ (flip runGet) bytes $ do+ p1 <- getBytes d1+ p2 <- getBytes d2+ p3 <- getBytes d3+ p4 <- getBytes d4+ p5 <- getBytes d5+ p6 <- getBytes d6+ return (p1,p2,p3,p4,p5,p6)
Network/TLS/Wire.hs view
@@ -30,14 +30,13 @@ , putWord16 , putWords16 , putWord24- , putByteString- , putLazyByteString+ , putBytes , encodeWord64 ) where -import qualified Data.Binary.Get as Bin-import Data.Binary.Put-import Data.ByteString (ByteString)+import qualified Data.Binary.Get as G+import qualified Data.Binary.Put as P+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Control.Applicative ((<$>)) import Control.Monad.Error@@ -49,32 +48,32 @@ noMsg = Error_Misc "" strMsg = Error_Misc -newtype Get a = GE { runGE :: ErrorT TLSError Bin.Get a }+newtype Get a = GE { runGE :: ErrorT TLSError G.Get a } deriving (Monad, MonadError TLSError) instance Functor Get where fmap f = GE . fmap f . runGE -liftGet :: Bin.Get a -> Get a+liftGet :: G.Get a -> Get a liftGet = GE . lift -runGet :: Get a -> L.ByteString -> Either TLSError a-runGet f b = Bin.runGet (runErrorT (runGE f)) b+runGet :: Get a -> Bytes -> Either TLSError a+runGet f b = G.runGet (runErrorT (runGE f)) (L.fromChunks [b]) remaining :: Get Int-remaining = fromIntegral <$> liftGet Bin.remaining+remaining = fromIntegral <$> liftGet G.remaining bytesRead :: Get Int-bytesRead = fromIntegral <$> liftGet Bin.bytesRead+bytesRead = fromIntegral <$> liftGet G.bytesRead getWord8 :: Get Word8-getWord8 = liftGet Bin.getWord8+getWord8 = liftGet G.getWord8 getWords8 :: Get [Word8] getWords8 = getWord8 >>= \lenb -> replicateM (fromIntegral lenb) getWord8 getWord16 :: Get Word16-getWord16 = liftGet Bin.getWord16be+getWord16 = liftGet G.getWord16be getWords16 :: Get [Word16] getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16@@ -86,8 +85,8 @@ c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c -getBytes :: Int -> Get ByteString-getBytes i = liftGet $ Bin.getBytes i+getBytes :: Int -> Get Bytes+getBytes i = liftGet $ G.getBytes i processBytes :: Int -> Get a -> Get a processBytes i f = do@@ -99,15 +98,20 @@ else throwError (Error_Internal_Packet_ByteProcessed r1 r2 i) isEmpty :: Get Bool-isEmpty = liftGet Bin.isEmpty+isEmpty = liftGet G.isEmpty +type Put = P.Put++putWord8 :: Word8 -> Put+putWord8 = P.putWord8+ putWords8 :: [Word8] -> Put putWords8 l = do- putWord8 $ fromIntegral (length l)- mapM_ putWord8 l+ P.putWord8 $ fromIntegral (length l)+ mapM_ P.putWord8 l putWord16 :: Word16 -> Put-putWord16 = putWord16be+putWord16 = P.putWord16be putWords16 :: [Word16] -> Put putWords16 l = do@@ -119,7 +123,16 @@ let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff)- mapM_ putWord8 [a,b,c]+ mapM_ P.putWord8 [a,b,c] -encodeWord64 :: Word64 -> L.ByteString-encodeWord64 = runPut . putWord64be+putBytes :: Bytes -> Put+putBytes = P.putByteString++lazyToBytes :: L.ByteString -> Bytes+lazyToBytes = B.concat . L.toChunks++runPut :: Put -> Bytes+runPut = lazyToBytes . P.runPut++encodeWord64 :: Word64 -> Bytes+encodeWord64 = runPut . P.putWord64be
Stunnel.hs view
@@ -28,7 +28,7 @@ import qualified Network.TLS.Client as C import qualified Network.TLS.Server as S -import Random+import System.Random import qualified Codec.Crypto.AES.Random as AESRand ciphers :: [Cipher]@@ -62,7 +62,7 @@ ranByte <- B.head <$> AESRand.randBytes 1 _ <- AESRand.randBytes (fromIntegral ranByte) clientRandom <- fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32- premasterRandom <- (ClientKeyData . B.unpack) <$> AESRand.randBytes 46+ premasterRandom <- ClientKeyData <$> AESRand.randBytes 46 seqInit <- conv . B.unpack <$> AESRand.randBytes 4 handle <- connectTo host (PortNumber $ fromIntegral port)@@ -70,7 +70,7 @@ let clientstate = C.TLSClientParams { C.cpConnectVersion = TLS10- , C.cpAllowedVersions = [ TLS10 ]+ , C.cpAllowedVersions = [ TLS10, TLS11 ] , C.cpSession = Nothing , C.cpCiphers = ciphers , C.cpCertificate = Nothing@@ -94,7 +94,7 @@ seqInit <- conv . B.unpack <$> AESRand.randBytes 4 let serverstate = S.TLSServerParams- { S.spAllowedVersions = [TLS10]+ { S.spAllowedVersions = [TLS10,TLS11] , S.spSessions = [] , S.spCiphers = ciphers , S.spCertificate = Just (certdata, cert, pk)@@ -118,13 +118,13 @@ putStrLn "usage: stunnel [client|server] <params...>" exitFailure -readCertificate :: FilePath -> IO (L.ByteString, Certificate)+readCertificate :: FilePath -> IO (B.ByteString, Certificate) readCertificate filepath = do content <- B.readFile filepath let certdata = case parsePEMCert content of Left err -> error ("cannot read PEM certificate: " ++ err)- Right x -> L.fromChunks [x]- let cert = case decodeCertificate certdata of+ Right x -> x+ let cert = case decodeCertificate $ L.fromChunks [certdata] of Left err -> error ("cannot decode certificate: " ++ err) Right x -> x return (certdata, cert)
TODO view
@@ -20,6 +20,11 @@ - properly separate different version of the protocol - implement AEAD +ssl3:++- finish generation of stuff+- test with popular server+ code cleanup: - remove show derivation on internal crypto state@@ -27,16 +32,15 @@ security audit: -- add unit tests for pure parts+- add more unit tests for pure parts - fix SRandomGen and random usage with proper CPRNG - match security recommendation from the RFC - audit the RSA implementation and the usage in TLS (remove spoon). misc: -- verify it works with gnutls - stunnel: use crypto secure random generator-- stunnel: actually make it works like stunnel instead of hardcoding the data and the port.+- stunnel: actually make it works like stunnel instead of hardcoding the data received/sent - investigate an iteratee interface - portability - implement more ciphers
Tests.hs view
@@ -3,18 +3,20 @@ import Test.QuickCheck import Test.QuickCheck.Test +import qualified Data.ByteString as B import Network.TLS.Struct import Network.TLS.Packet import Control.Monad+import Control.Applicative ((<$>)) import System.IO liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } someWords8 :: Int -> Gen [Word8] -someWords8 i = replicateM i (fromIntegral `fmap` (choose (0,255) :: Gen Int))+someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int)) someWords16 :: Int -> Gen [Word16] -someWords16 i = replicateM i (fromIntegral `fmap` (choose (0,65535) :: Gen Int))+someWords16 i = replicateM i (fromIntegral <$> (choose (0,65535) :: Gen Int)) instance Arbitrary Version where arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ]@@ -27,10 +29,10 @@ , ProtocolType_AppData ] instance Arbitrary Word8 where- arbitrary = fromIntegral `fmap` (choose (0,255) :: Gen Int)+ arbitrary = fromIntegral <$> (choose (0,255) :: Gen Int) instance Arbitrary Word16 where- arbitrary = fromIntegral `fmap` (choose (0,65535) :: Gen Int)+ arbitrary = fromIntegral <$> (choose (0,65535) :: Gen Int) instance Arbitrary Header where arbitrary = do@@ -40,20 +42,20 @@ return $ Header pt ver len instance Arbitrary ClientRandom where- arbitrary = ClientRandom `fmap` someWords8 32+ arbitrary = ClientRandom . B.pack <$> someWords8 32 instance Arbitrary ServerRandom where- arbitrary = ServerRandom `fmap` someWords8 32+ arbitrary = ServerRandom . B.pack <$> someWords8 32 instance Arbitrary ClientKeyData where- arbitrary = ClientKeyData `fmap` someWords8 46+ arbitrary = ClientKeyData . B.pack <$> someWords8 46 instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of 1 -> return $ Session Nothing- 2 -> (Session . Just) `fmap` someWords8 32+ 2 -> Session . Just . B.pack <$> someWords8 32 arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0,200) >>= someWords16
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.1.2+Version: 0.1.3 Description: Implementation of the TLS protocol, focusing on purity and more type-checking. .@@ -15,6 +15,7 @@ Category: Network stability: experimental Cabal-Version: >=1.6+Homepage: http://github.com/vincenthz/hs-tls data-files: README, TODO Flag test@@ -32,7 +33,7 @@ binary >= 0.5, bytestring, vector,- haskell98,+ random, AES, RSA, spoon, cryptocipher, certificate >= 0.2@@ -42,12 +43,14 @@ Network.TLS.Cipher Network.TLS.SRandom Network.TLS.MAC- other-modules: Network.TLS.Compression+ other-modules: Network.TLS.Cap+ Network.TLS.Compression Network.TLS.Crypto Network.TLS.Packet Network.TLS.State Network.TLS.Sending Network.TLS.Receiving+ Network.TLS.Util Network.TLS.Wire ghc-options: -Wall @@ -63,7 +66,7 @@ Main-is: Tests.hs if flag(test) Buildable: True- Build-Depends: base >= 3 && < 5, HUnit, QuickCheck >= 2 && < 2.3, bytestring, haskell98+ Build-Depends: base >= 3 && < 5, HUnit, QuickCheck >= 2 && < 2.3, bytestring, random else Buildable: False