use strict bytestring instead of lazy bytestring.
the API stays mostly similar except for clientkeyxchg that need a bytes instead of [word8]. remove lots of unnessary packing/unpacking when setting up ciphers.
This commit is contained in:
Vincent Hanquez
parent
c70736cf19
commit
8f91009884
13 changed files with 251 additions and 218 deletions
|
|
@ -37,11 +37,11 @@ type IV = B.ByteString
|
|||
|
||||
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 @@ data Cipher = Cipher
|
|||
, 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_ECDSA = True
|
|||
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 @@ toCtx iv =
|
|||
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 @@ cipher_null_null = Cipher
|
|||
, cipherIVSize = 0
|
||||
, cipherKeyBlockSize = 0
|
||||
, cipherPaddingSize = 0
|
||||
, cipherHMAC = (\_ _ -> L.empty)
|
||||
, cipherHMAC = (\_ _ -> B.empty)
|
||||
, cipherKeyExchange = CipherKeyExchangeRSA
|
||||
, cipherF = CipherNoneF
|
||||
, cipherMinVer = Nothing
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ import Network.TLS.State
|
|||
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)
|
||||
|
|
@ -88,18 +89,18 @@ runTLSClient f params rng = runTLSClientST f (TLSStateClient { scParams = params
|
|||
{- | 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 @@ connectSendClientKeyXchg handle prerand = do
|
|||
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 @@ connect handle crand premasterRandom = do
|
|||
|
||||
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 @@ recvData handle = do
|
|||
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"
|
||||
|
|
|
|||
|
|
@ -28,10 +28,12 @@ module Network.TLS.Crypto
|
|||
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 Control.Arrow (first)
|
||||
import System.Random
|
||||
|
||||
data HashCtx =
|
||||
|
|
@ -49,28 +51,28 @@ data HashType = HashTypeSHA1 | HashTypeMD5
|
|||
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,14 @@ finalizeHash (MD5 ctx) = finalizeMD5 ctx
|
|||
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 = 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 ]
|
||||
|
|
|
|||
|
|
@ -10,54 +10,50 @@ module Network.TLS.MAC
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
-- Module : Network.TLS.Packet
|
||||
-- License : BSD-style
|
||||
|
|
@ -48,9 +49,10 @@ import Control.Monad.Error
|
|||
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
|
||||
|
|
@ -90,7 +92,7 @@ encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad
|
|||
|
||||
{- 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
|
||||
|
|
@ -100,7 +102,7 @@ decodeHandshakeHeader = runGet $ do
|
|||
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
|
||||
|
|
@ -231,9 +233,9 @@ decodeServerKeyXchg ver = do
|
|||
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
|
||||
|
|
@ -255,10 +257,10 @@ encodeHandshakeContent (ServerHello version random session cipherID compressionI
|
|||
>> 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
|
||||
|
|
@ -276,7 +278,7 @@ encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do
|
|||
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
|
||||
|
||||
|
|
@ -296,8 +298,8 @@ putVersion ver = putWord8 major >> putWord8 minor
|
|||
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
|
||||
|
|
@ -305,8 +307,8 @@ getServerRandom32 = ServerRandom <$> getRandom32
|
|||
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
|
||||
|
|
@ -315,25 +317,25 @@ putServerRandom32 :: ServerRandom -> Put
|
|||
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
|
||||
|
|
@ -342,8 +344,8 @@ getCerts len = do
|
|||
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 []
|
||||
|
|
@ -358,12 +360,12 @@ putExtension :: Extension -> Put
|
|||
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
|
||||
|
||||
|
|
@ -382,29 +384,26 @@ encodeChangeCipherSpec = runPut (putWord8 1)
|
|||
{-
|
||||
- generate things for packet content
|
||||
-}
|
||||
generateMasterSecret :: ByteString -> ClientRandom -> ServerRandom -> ByteString
|
||||
generateMasterSecret :: Bytes -> ClientRandom -> ServerRandom -> Bytes
|
||||
generateMasterSecret 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
|
||||
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 :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes
|
||||
generateFinished 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"
|
||||
generateClientFinished :: Bytes -> HashCtx -> HashCtx -> Bytes
|
||||
generateClientFinished = generateFinished (BC.pack "client finished")
|
||||
|
||||
generateServerFinished :: ByteString -> HashCtx -> HashCtx -> ByteString
|
||||
generateServerFinished = generateFinished "server finished"
|
||||
generateServerFinished :: Bytes -> HashCtx -> HashCtx -> Bytes
|
||||
generateServerFinished = generateFinished (BC.pack "server finished")
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ import Control.Monad.State
|
|||
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
|
||||
|
||||
|
|
@ -72,14 +72,14 @@ readPacket hdr@(Header ProtocolType_Handshake ver _) content =
|
|||
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 +93,7 @@ processClientFinished :: FinishedData -> TLSRead ()
|
|||
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 +110,7 @@ processHsPacket ver dcontent = do
|
|||
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
|
||||
|
|
@ -132,14 +132,14 @@ 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 (unencrypted_msg, digest) = B.splitAt (B.length unencrypted_content - fromIntegral digestSize) unencrypted_content
|
||||
let (Header pt ver _) = hdr
|
||||
let new_hdr = Header pt ver (fromIntegral $ L.length unencrypted_msg)
|
||||
let new_hdr = Header pt ver (fromIntegral $ B.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)
|
||||
else throwError $ Error_Digest (B.unpack expected_digest, B.unpack digest)
|
||||
|
||||
decryptContent :: Header -> EncryptedData -> TLSRead ByteString
|
||||
decryptContent hdr e@(EncryptedData b) = do
|
||||
|
|
@ -163,26 +163,26 @@ decryptData (EncryptedData econtent) = do
|
|||
let cst = fromJust $ stRxCryptState st
|
||||
let padding_size = fromIntegral $ cipherPaddingSize cipher
|
||||
|
||||
let writekey = B.pack $ cstKey cst
|
||||
let iv = B.pack $ cstIV cst
|
||||
let writekey = cstKey cst
|
||||
let iv = cstIV cst
|
||||
|
||||
contentpadded <- case cipherF cipher of
|
||||
CipherNoneF -> fail "none decrypt"
|
||||
CipherBlockF _ decryptF -> do
|
||||
{- update IV -}
|
||||
let newiv = takelast padding_size $ L.unpack econtent
|
||||
let newiv = B.pack $ takelast padding_size $ B.unpack econtent
|
||||
putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }
|
||||
return $ decryptF writekey iv econtent
|
||||
CipherStreamF initF _ decryptF -> do
|
||||
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 } }
|
||||
putTLSState $ st { stRxCryptState = Just $ cst { cstIV = 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
|
||||
let pb = B.last contentpadded + 1 in
|
||||
fst $ B.splitAt ((B.length contentpadded) - fromIntegral pb) contentpadded
|
||||
else contentpadded
|
||||
return content
|
||||
|
||||
|
|
|
|||
|
|
@ -15,13 +15,14 @@ module Network.TLS.Sending (
|
|||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Binary.Put (runPut, putWord16be)
|
||||
--import Data.Binary.Put (runPut, putWord16be)
|
||||
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.Wire
|
||||
import Network.TLS.Struct
|
||||
import Network.TLS.Packet
|
||||
import Network.TLS.State
|
||||
|
|
@ -36,7 +37,7 @@ makePacketData :: MonadTLSState m => Packet -> m (Header, ByteString)
|
|||
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 @@ postprocessPacketData dat = return dat
|
|||
- 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,8 +106,8 @@ encryptRSA content = do
|
|||
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]
|
||||
|
|
@ -124,27 +125,27 @@ encryptData content = do
|
|||
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
|
||||
let iv = cstIV 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 e = encrypt writekey iv (B.concat [ content, padding ])
|
||||
let newiv = B.pack $ takelast (fromIntegral padding_size) $ B.unpack e
|
||||
putTLSState $ st { stTxCryptState = Just $ cst { cstIV = newiv } }
|
||||
return e
|
||||
CipherStreamF initF encryptF _ -> do
|
||||
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 @@ writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -40,10 +40,11 @@ import Network.TLS.State
|
|||
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
|
||||
|
|
@ -89,18 +90,18 @@ runTLSServer f params rng = runTLSServerST f (TLSStateServer { scParams = params
|
|||
{- | 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
|
||||
|
|
@ -183,7 +184,7 @@ handshakeSendServerData handle srand = do
|
|||
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 @@ listen handle srand = do
|
|||
|
||||
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 @@ recvData handle = do
|
|||
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"
|
||||
|
||||
|
|
|
|||
|
|
@ -43,8 +43,7 @@ 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 +51,9 @@ assert fctname list = forM_ list $ \ (name, assumption) -> do
|
|||
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 +64,7 @@ data TLSHandshakeState = TLSHandshakeState
|
|||
{ 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
|
||||
|
|
@ -109,7 +108,7 @@ newTLSState rng = TLSState
|
|||
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 +119,7 @@ makeDigest w hdr content = do
|
|||
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 +151,7 @@ switchRxEncryption = getTLSState >>= putTLSState . (\st -> st { stRxEncrypted =
|
|||
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"
|
||||
|
|
@ -161,7 +160,7 @@ setMasterSecret premastersecret = do
|
|||
|
||||
updateHandshake "master secret" (\hst ->
|
||||
let ms = generateMasterSecret premastersecret (hstClientRandom hst) (fromJust $ hstServerRandom hst) in
|
||||
hst { hstMasterSecret = Just $ L.unpack ms } )
|
||||
hst { hstMasterSecret = Just ms } )
|
||||
return ()
|
||||
|
||||
setPublicKey :: MonadTLSState m => PublicKey -> m ()
|
||||
|
|
@ -189,21 +188,21 @@ setKeyBlock = do
|
|||
let ivSize = 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, r1) = B.splitAt (fromIntegral digestSize) kb
|
||||
let (sMACSecret, r2) = B.splitAt (fromIntegral digestSize) r1
|
||||
let (cWriteKey, r3) = B.splitAt (fromIntegral keySize) r2
|
||||
let (sWriteKey, r4) = B.splitAt (fromIntegral keySize) r3
|
||||
let (cWriteIV, r5) = B.splitAt (fromIntegral ivSize) r4
|
||||
let (sWriteIV, _) = B.splitAt (fromIntegral ivSize) r5
|
||||
|
||||
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 +249,23 @@ updateHandshake n f = do
|
|||
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) msecret md5ctx sha1ctx
|
||||
|
||||
endHandshake :: MonadTLSState m => m ()
|
||||
endHandshake = modifyTLSState (\st -> st { stHandshake = Nothing })
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
-- the Struct module contains all definitions and values of the TLS protocol
|
||||
--
|
||||
module Network.TLS.Struct
|
||||
( Version(..)
|
||||
( Bytes
|
||||
, Version(..)
|
||||
, ConnectionEnd(..)
|
||||
, CipherType(..)
|
||||
, Extension
|
||||
|
|
@ -41,10 +42,12 @@ module Network.TLS.Struct
|
|||
, 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
|
||||
|
|
@ -107,17 +110,17 @@ data Packet =
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -30,14 +30,13 @@ module Network.TLS.Wire
|
|||
, 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 @@ instance Error TLSError where
|
|||
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 @@ getWord24 = do
|
|||
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 @@ processBytes i f = do
|
|||
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 @@ putWord24 i = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ mainClient host port = do
|
|||
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)
|
||||
|
|
@ -118,13 +118,13 @@ usage = do
|
|||
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)
|
||||
|
|
|
|||
18
Tests.hs
18
Tests.hs
|
|
@ -3,18 +3,20 @@ import Data.Word
|
|||
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 @@ instance Arbitrary ProtocolType where
|
|||
, 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 @@ instance Arbitrary Header where
|
|||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue