re-indent
This commit is contained in:
Vincent Hanquez
parent
5d69715a50
commit
67f01872dd
1 changed files with 212 additions and 219 deletions
|
|
@ -73,40 +73,40 @@ import qualified Crypto.Hash.SHA1 as SHA1
|
|||
import qualified Crypto.Hash.MD5 as MD5
|
||||
|
||||
data CurrentParams = CurrentParams
|
||||
{ cParamsVersion :: Version -- ^ current protocol version
|
||||
, cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type
|
||||
, cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension
|
||||
} deriving (Show,Eq)
|
||||
{ cParamsVersion :: Version -- ^ current protocol version
|
||||
, cParamsKeyXchgType :: CipherKeyExchangeType -- ^ current key exchange type
|
||||
, cParamsSupportNPN :: Bool -- ^ support Next Protocol Negotiation extension
|
||||
} deriving (Show,Eq)
|
||||
|
||||
{- marshall helpers -}
|
||||
getVersion :: Get Version
|
||||
getVersion = do
|
||||
major <- getWord8
|
||||
minor <- getWord8
|
||||
case verOfNum (major, minor) of
|
||||
Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor)
|
||||
Just v -> return v
|
||||
major <- getWord8
|
||||
minor <- getWord8
|
||||
case verOfNum (major, minor) of
|
||||
Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor)
|
||||
Just v -> return v
|
||||
|
||||
putVersion :: Version -> Put
|
||||
putVersion ver = putWord8 major >> putWord8 minor
|
||||
where (major, minor) = numericalVer ver
|
||||
where (major, minor) = numericalVer ver
|
||||
|
||||
getHeaderType :: Get ProtocolType
|
||||
getHeaderType = do
|
||||
ty <- getWord8
|
||||
case valToType ty of
|
||||
Nothing -> fail ("invalid header type: " ++ show ty)
|
||||
Just t -> return t
|
||||
ty <- getWord8
|
||||
case valToType ty of
|
||||
Nothing -> fail ("invalid header type: " ++ show ty)
|
||||
Just t -> return t
|
||||
|
||||
putHeaderType :: ProtocolType -> Put
|
||||
putHeaderType = putWord8 . valOfType
|
||||
|
||||
getHandshakeType :: Get HandshakeType
|
||||
getHandshakeType = do
|
||||
ty <- getWord8
|
||||
case valToType ty of
|
||||
Nothing -> fail ("invalid handshake type: " ++ show ty)
|
||||
Just t -> return t
|
||||
ty <- getWord8
|
||||
case valToType ty of
|
||||
Nothing -> fail ("invalid handshake type: " ++ show ty)
|
||||
Just t -> return t
|
||||
|
||||
{-
|
||||
- decode and encode headers
|
||||
|
|
@ -119,10 +119,10 @@ decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8
|
|||
|
||||
decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header
|
||||
decodeDeprecatedHeader size =
|
||||
runGetErr "deprecatedheader" $ do
|
||||
1 <- getWord8
|
||||
version <- getVersion
|
||||
return $ Header ProtocolType_DeprecatedHandshake version size
|
||||
runGetErr "deprecatedheader" $ do
|
||||
1 <- getWord8
|
||||
version <- getVersion
|
||||
return $ Header ProtocolType_DeprecatedHandshake version size
|
||||
|
||||
encodeHeader :: Header -> ByteString
|
||||
encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len)
|
||||
|
|
@ -137,74 +137,74 @@ encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len)
|
|||
-}
|
||||
decodeAlert :: Get (AlertLevel, AlertDescription)
|
||||
decodeAlert = do
|
||||
al <- getWord8
|
||||
ad <- getWord8
|
||||
case (valToType al, valToType ad) of
|
||||
(Just a, Just d) -> return (a, d)
|
||||
(Nothing, _) -> fail "cannot decode alert level"
|
||||
(_, Nothing) -> fail "cannot decode alert description"
|
||||
al <- getWord8
|
||||
ad <- getWord8
|
||||
case (valToType al, valToType ad) of
|
||||
(Just a, Just d) -> return (a, d)
|
||||
(Nothing, _) -> fail "cannot decode alert level"
|
||||
(_, Nothing) -> fail "cannot decode alert description"
|
||||
|
||||
decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)]
|
||||
decodeAlerts = runGetErr "alerts" $ loop
|
||||
where loop = do
|
||||
r <- remaining
|
||||
if r == 0
|
||||
then return []
|
||||
else liftM2 (:) decodeAlert loop
|
||||
where loop = do
|
||||
r <- remaining
|
||||
if r == 0
|
||||
then return []
|
||||
else liftM2 (:) decodeAlert loop
|
||||
|
||||
encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString
|
||||
encodeAlerts l = runPut $ mapM_ encodeAlert l
|
||||
where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad)
|
||||
where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad)
|
||||
|
||||
{- decode and encode HANDSHAKE -}
|
||||
decodeHandshakeHeader :: Get (HandshakeType, Bytes)
|
||||
decodeHandshakeHeader = do
|
||||
ty <- getHandshakeType
|
||||
content <- getOpaque24
|
||||
return (ty, content)
|
||||
ty <- getHandshakeType
|
||||
content <- getOpaque24
|
||||
return (ty, content)
|
||||
|
||||
decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)]
|
||||
decodeHandshakes b = runGetErr "handshakes" getAll b where
|
||||
getAll = do
|
||||
x <- decodeHandshakeHeader
|
||||
empty <- isEmpty
|
||||
if empty
|
||||
then return [x]
|
||||
else liftM ((:) x) getAll
|
||||
decodeHandshakes b = runGetErr "handshakes" getAll b
|
||||
where getAll = do
|
||||
x <- decodeHandshakeHeader
|
||||
empty <- isEmpty
|
||||
if empty
|
||||
then return [x]
|
||||
else liftM ((:) x) getAll
|
||||
|
||||
decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake
|
||||
decodeHandshake cp ty = runGetErr "handshake" $ case ty of
|
||||
HandshakeType_HelloRequest -> decodeHelloRequest
|
||||
HandshakeType_ClientHello -> decodeClientHello
|
||||
HandshakeType_ServerHello -> decodeServerHello
|
||||
HandshakeType_Certificate -> decodeCertificates
|
||||
HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp
|
||||
HandshakeType_CertRequest -> decodeCertRequest cp
|
||||
HandshakeType_ServerHelloDone -> decodeServerHelloDone
|
||||
HandshakeType_CertVerify -> decodeCertVerify cp
|
||||
HandshakeType_ClientKeyXchg -> decodeClientKeyXchg
|
||||
HandshakeType_Finished -> decodeFinished
|
||||
HandshakeType_NPN -> do
|
||||
unless (cParamsSupportNPN cp) $ fail "unsupported handshake type"
|
||||
decodeNextProtocolNegotiation
|
||||
HandshakeType_HelloRequest -> decodeHelloRequest
|
||||
HandshakeType_ClientHello -> decodeClientHello
|
||||
HandshakeType_ServerHello -> decodeServerHello
|
||||
HandshakeType_Certificate -> decodeCertificates
|
||||
HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp
|
||||
HandshakeType_CertRequest -> decodeCertRequest cp
|
||||
HandshakeType_ServerHelloDone -> decodeServerHelloDone
|
||||
HandshakeType_CertVerify -> decodeCertVerify cp
|
||||
HandshakeType_ClientKeyXchg -> decodeClientKeyXchg
|
||||
HandshakeType_Finished -> decodeFinished
|
||||
HandshakeType_NPN -> do
|
||||
unless (cParamsSupportNPN cp) $ fail "unsupported handshake type"
|
||||
decodeNextProtocolNegotiation
|
||||
|
||||
decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake
|
||||
decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where
|
||||
getDeprecated = do
|
||||
1 <- getWord8
|
||||
ver <- getVersion
|
||||
cipherSpecLen <- fromEnum <$> getWord16
|
||||
sessionIdLen <- fromEnum <$> getWord16
|
||||
challengeLen <- fromEnum <$> getWord16
|
||||
ciphers <- getCipherSpec cipherSpecLen
|
||||
session <- getSessionId sessionIdLen
|
||||
random <- getChallenge challengeLen
|
||||
let compressions = [0]
|
||||
return $ ClientHello ver random session ciphers compressions [] (Just b)
|
||||
decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b
|
||||
where getDeprecated = do
|
||||
1 <- getWord8
|
||||
ver <- getVersion
|
||||
cipherSpecLen <- fromEnum <$> getWord16
|
||||
sessionIdLen <- fromEnum <$> getWord16
|
||||
challengeLen <- fromEnum <$> getWord16
|
||||
ciphers <- getCipherSpec cipherSpecLen
|
||||
session <- getSessionId sessionIdLen
|
||||
random <- getChallenge challengeLen
|
||||
let compressions = [0]
|
||||
return $ ClientHello ver random session ciphers compressions [] (Just b)
|
||||
getCipherSpec len | len < 3 = return []
|
||||
getCipherSpec len = do
|
||||
[c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8
|
||||
([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3)
|
||||
[c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8
|
||||
([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3)
|
||||
getSessionId 0 = return $ Session Nothing
|
||||
getSessionId len = Session . Just <$> getBytes len
|
||||
getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32
|
||||
|
|
@ -215,29 +215,29 @@ decodeHelloRequest = return HelloRequest
|
|||
|
||||
decodeClientHello :: Get Handshake
|
||||
decodeClientHello = do
|
||||
ver <- getVersion
|
||||
random <- getClientRandom32
|
||||
session <- getSession
|
||||
ciphers <- getWords16
|
||||
compressions <- getWords8
|
||||
r <- remaining
|
||||
exts <- if hasHelloExtensions ver && r > 0
|
||||
then fmap fromIntegral getWord16 >>= getExtensions
|
||||
else return []
|
||||
return $ ClientHello ver random session ciphers compressions exts Nothing
|
||||
ver <- getVersion
|
||||
random <- getClientRandom32
|
||||
session <- getSession
|
||||
ciphers <- getWords16
|
||||
compressions <- getWords8
|
||||
r <- remaining
|
||||
exts <- if hasHelloExtensions ver && r > 0
|
||||
then fmap fromIntegral getWord16 >>= getExtensions
|
||||
else return []
|
||||
return $ ClientHello ver random session ciphers compressions exts Nothing
|
||||
|
||||
decodeServerHello :: Get Handshake
|
||||
decodeServerHello = do
|
||||
ver <- getVersion
|
||||
random <- getServerRandom32
|
||||
session <- getSession
|
||||
cipherid <- getWord16
|
||||
compressionid <- getWord8
|
||||
r <- remaining
|
||||
exts <- if hasHelloExtensions ver && r > 0
|
||||
then fmap fromIntegral getWord16 >>= getExtensions
|
||||
else return []
|
||||
return $ ServerHello ver random session cipherid compressionid exts
|
||||
ver <- getVersion
|
||||
random <- getServerRandom32
|
||||
session <- getSession
|
||||
cipherid <- getWord16
|
||||
compressionid <- getWord8
|
||||
r <- remaining
|
||||
exts <- if hasHelloExtensions ver && r > 0
|
||||
then fmap fromIntegral getWord16 >>= getExtensions
|
||||
else return []
|
||||
return $ ServerHello ver random session cipherid compressionid exts
|
||||
|
||||
decodeServerHelloDone :: Get Handshake
|
||||
decodeServerHelloDone = return ServerHelloDone
|
||||
|
|
@ -248,37 +248,36 @@ decodeCertificates = do
|
|||
case decodeCertificateChain certsRaw of
|
||||
Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)
|
||||
Right cc -> return $ Certificates cc
|
||||
where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert)
|
||||
where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert)
|
||||
|
||||
decodeFinished :: Get Handshake
|
||||
decodeFinished = Finished <$> (remaining >>= getBytes)
|
||||
|
||||
decodeNextProtocolNegotiation :: Get Handshake
|
||||
decodeNextProtocolNegotiation = do
|
||||
opaque <- getOpaque8
|
||||
_ <- getOpaque8 -- ignore padding
|
||||
return $ HsNextProtocolNegotiation opaque
|
||||
opaque <- getOpaque8
|
||||
_ <- getOpaque8 -- ignore padding
|
||||
return $ HsNextProtocolNegotiation opaque
|
||||
|
||||
getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm
|
||||
getSignatureHashAlgorithm = do
|
||||
h <- fromJust . valToType <$> getWord8
|
||||
s <- fromJust . valToType <$> getWord8
|
||||
return (h,s)
|
||||
h <- fromJust . valToType <$> getWord8
|
||||
s <- fromJust . valToType <$> getWord8
|
||||
return (h,s)
|
||||
|
||||
decodeCertRequest :: CurrentParams -> Get Handshake
|
||||
decodeCertRequest cp = do
|
||||
certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8
|
||||
certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8
|
||||
|
||||
sigHashAlgs <- if cParamsVersion cp >= TLS12
|
||||
then Just <$> (getWord16 >>= getSignatureHashAlgorithms)
|
||||
else return Nothing
|
||||
dNameLen <- getWord16
|
||||
-- FIXME: Decide whether to remove this check completely or to make it an option.
|
||||
-- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"
|
||||
dNames <- getList (fromIntegral dNameLen) getDName
|
||||
return $ CertRequest certTypes sigHashAlgs dNames
|
||||
where
|
||||
getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))
|
||||
sigHashAlgs <- if cParamsVersion cp >= TLS12
|
||||
then Just <$> (getWord16 >>= getSignatureHashAlgorithms)
|
||||
else return Nothing
|
||||
dNameLen <- getWord16
|
||||
-- FIXME: Decide whether to remove this check completely or to make it an option.
|
||||
-- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"
|
||||
dNames <- getList (fromIntegral dNameLen) getDName
|
||||
return $ CertRequest certTypes sigHashAlgs dNames
|
||||
where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))
|
||||
getDName = do
|
||||
dName <- getOpaque16
|
||||
when (B.length dName == 0) $ fail "certrequest: invalid DN length"
|
||||
|
|
@ -291,11 +290,11 @@ decodeCertRequest cp = do
|
|||
|
||||
decodeCertVerify :: CurrentParams -> Get Handshake
|
||||
decodeCertVerify cp = do
|
||||
mbHashSig <- if cParamsVersion cp >= TLS12
|
||||
then Just <$> getSignatureHashAlgorithm
|
||||
else return Nothing
|
||||
bs <- getOpaque16
|
||||
return $ CertVerify mbHashSig (CertVerifyData bs)
|
||||
mbHashSig <- if cParamsVersion cp >= TLS12
|
||||
then Just <$> getSignatureHashAlgorithm
|
||||
else return Nothing
|
||||
bs <- getOpaque16
|
||||
return $ CertVerify mbHashSig (CertVerifyData bs)
|
||||
|
||||
decodeClientKeyXchg :: Get Handshake
|
||||
decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes)
|
||||
|
|
@ -305,41 +304,41 @@ os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0
|
|||
|
||||
decodeServerKeyXchg_DH :: Get ServerDHParams
|
||||
decodeServerKeyXchg_DH = do
|
||||
p <- getOpaque16
|
||||
g <- getOpaque16
|
||||
y <- getOpaque16
|
||||
return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y }
|
||||
p <- getOpaque16
|
||||
g <- getOpaque16
|
||||
y <- getOpaque16
|
||||
return $ ServerDHParams { dh_p = os2ip p, dh_g = os2ip g, dh_Ys = os2ip y }
|
||||
|
||||
decodeServerKeyXchg_RSA :: Get ServerRSAParams
|
||||
decodeServerKeyXchg_RSA = do
|
||||
modulus <- getOpaque16
|
||||
expo <- getOpaque16
|
||||
return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo }
|
||||
modulus <- getOpaque16
|
||||
expo <- getOpaque16
|
||||
return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo }
|
||||
|
||||
decodeServerKeyXchg :: CurrentParams -> Get Handshake
|
||||
decodeServerKeyXchg cp = ServerKeyXchg <$> case cParamsKeyXchgType cp of
|
||||
CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA
|
||||
CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH
|
||||
CipherKeyExchange_DHE_RSA -> do
|
||||
dhparams <- decodeServerKeyXchg_DH
|
||||
signature <- getOpaque16
|
||||
return $ SKX_DHE_RSA dhparams (B.unpack signature)
|
||||
CipherKeyExchange_DHE_DSS -> do
|
||||
dhparams <- decodeServerKeyXchg_DH
|
||||
signature <- getOpaque16
|
||||
return $ SKX_DHE_DSS dhparams (B.unpack signature)
|
||||
_ -> do
|
||||
bs <- remaining >>= getBytes
|
||||
return $ SKX_Unknown bs
|
||||
CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA
|
||||
CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH
|
||||
CipherKeyExchange_DHE_RSA -> do
|
||||
dhparams <- decodeServerKeyXchg_DH
|
||||
signature <- getOpaque16
|
||||
return $ SKX_DHE_RSA dhparams (B.unpack signature)
|
||||
CipherKeyExchange_DHE_DSS -> do
|
||||
dhparams <- decodeServerKeyXchg_DH
|
||||
signature <- getOpaque16
|
||||
return $ SKX_DHE_DSS dhparams (B.unpack signature)
|
||||
_ -> do
|
||||
bs <- remaining >>= getBytes
|
||||
return $ SKX_Unknown bs
|
||||
|
||||
encodeHandshake :: Handshake -> ByteString
|
||||
encodeHandshake o =
|
||||
let content = runPut $ encodeHandshakeContent o in
|
||||
let len = fromIntegral $ B.length content in
|
||||
let header = case o of
|
||||
ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message
|
||||
_ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in
|
||||
B.concat [ header, content ]
|
||||
let content = runPut $ encodeHandshakeContent o in
|
||||
let len = fromIntegral $ B.length content in
|
||||
let header = case o of
|
||||
ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message
|
||||
_ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in
|
||||
B.concat [ header, content ]
|
||||
|
||||
encodeHandshakes :: [Handshake] -> ByteString
|
||||
encodeHandshakes hss = B.concat $ map encodeHandshake hss
|
||||
|
|
@ -350,67 +349,66 @@ encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len
|
|||
encodeHandshakeContent :: Handshake -> Put
|
||||
|
||||
encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do
|
||||
putBytes deprecated
|
||||
putBytes deprecated
|
||||
encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do
|
||||
putVersion version
|
||||
putClientRandom32 random
|
||||
putSession session
|
||||
putWords16 cipherIDs
|
||||
putWords8 compressionIDs
|
||||
putExtensions exts
|
||||
return ()
|
||||
putVersion version
|
||||
putClientRandom32 random
|
||||
putSession session
|
||||
putWords16 cipherIDs
|
||||
putWords8 compressionIDs
|
||||
putExtensions exts
|
||||
return ()
|
||||
|
||||
encodeHandshakeContent (ServerHello version random session cipherID compressionID exts) =
|
||||
putVersion version >> putServerRandom32 random >> putSession session
|
||||
>> putWord16 cipherID >> putWord8 compressionID
|
||||
>> putExtensions exts >> return ()
|
||||
putVersion version >> putServerRandom32 random >> putSession session
|
||||
>> putWord16 cipherID >> putWord8 compressionID
|
||||
>> putExtensions exts >> return ()
|
||||
|
||||
encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs)
|
||||
where (CertificateChainRaw certs) = encodeCertificateChain cc
|
||||
|
||||
encodeHandshakeContent (ClientKeyXchg content) = do
|
||||
putBytes content
|
||||
putBytes content
|
||||
|
||||
encodeHandshakeContent (ServerKeyXchg _) = do
|
||||
-- FIXME
|
||||
return ()
|
||||
-- FIXME
|
||||
return ()
|
||||
|
||||
encodeHandshakeContent (HelloRequest) = return ()
|
||||
encodeHandshakeContent (ServerHelloDone) = return ()
|
||||
|
||||
encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do
|
||||
putWords8 (map valOfType certTypes)
|
||||
case sigAlgs of
|
||||
Nothing -> return ()
|
||||
Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l
|
||||
encodeCertAuthorities certAuthorities
|
||||
where
|
||||
-- Convert a distinguished name to its DER encoding.
|
||||
encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn
|
||||
putWords8 (map valOfType certTypes)
|
||||
case sigAlgs of
|
||||
Nothing -> return ()
|
||||
Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l
|
||||
encodeCertAuthorities certAuthorities
|
||||
where -- Convert a distinguished name to its DER encoding.
|
||||
encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn
|
||||
|
||||
-- Encode a list of distinguished names.
|
||||
encodeCertAuthorities certAuths = do
|
||||
enc <- mapM encodeCA certAuths
|
||||
let totLength = sum $ map (((+) 2) . B.length) enc
|
||||
putWord16 (fromIntegral totLength)
|
||||
mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc
|
||||
-- Encode a list of distinguished names.
|
||||
encodeCertAuthorities certAuths = do
|
||||
enc <- mapM encodeCA certAuths
|
||||
let totLength = sum $ map (((+) 2) . B.length) enc
|
||||
putWord16 (fromIntegral totLength)
|
||||
mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc
|
||||
|
||||
encodeHandshakeContent (CertVerify mbHashSig (CertVerifyData c)) = do
|
||||
-- TLS 1.2 prepends the hash and signature algorithms to the
|
||||
-- signature.
|
||||
case mbHashSig of
|
||||
Nothing -> return ()
|
||||
Just (h, s) -> putWord16 $ (fromIntegral $ valOfType h) * 256 + (fromIntegral $ valOfType s)
|
||||
putWord16 (fromIntegral $ B.length c)
|
||||
putBytes c
|
||||
-- TLS 1.2 prepends the hash and signature algorithms to the
|
||||
-- signature.
|
||||
case mbHashSig of
|
||||
Nothing -> return ()
|
||||
Just (h, s) -> putWord16 $ (fromIntegral $ valOfType h) * 256 + (fromIntegral $ valOfType s)
|
||||
putWord16 (fromIntegral $ B.length c)
|
||||
putBytes c
|
||||
|
||||
|
||||
encodeHandshakeContent (Finished opaque) = putBytes opaque
|
||||
|
||||
encodeHandshakeContent (HsNextProtocolNegotiation protocol) = do
|
||||
putOpaque8 protocol
|
||||
putOpaque8 $ B.replicate paddingLen 0
|
||||
where paddingLen = 32 - ((B.length protocol + 2) `mod` 32)
|
||||
putOpaque8 protocol
|
||||
putOpaque8 $ B.replicate paddingLen 0
|
||||
where paddingLen = 32 - ((B.length protocol + 2) `mod` 32)
|
||||
|
||||
{- FIXME make sure it return error if not 32 available -}
|
||||
getRandom32 :: Get Bytes
|
||||
|
|
@ -433,10 +431,10 @@ putServerRandom32 (ServerRandom r) = putRandom32 r
|
|||
|
||||
getSession :: Get Session
|
||||
getSession = do
|
||||
len8 <- getWord8
|
||||
case fromIntegral len8 of
|
||||
0 -> return $ Session Nothing
|
||||
len -> Session . Just <$> getBytes len
|
||||
len8 <- getWord8
|
||||
case fromIntegral len8 of
|
||||
0 -> return $ Session Nothing
|
||||
len -> Session . Just <$> getBytes len
|
||||
|
||||
putSession :: Session -> Put
|
||||
putSession (Session Nothing) = putWord8 0
|
||||
|
|
@ -445,11 +443,11 @@ putSession (Session (Just s)) = putOpaque8 s
|
|||
getExtensions :: Int -> Get [ExtensionRaw]
|
||||
getExtensions 0 = return []
|
||||
getExtensions len = do
|
||||
extty <- getWord16
|
||||
extdatalen <- getWord16
|
||||
extdata <- getBytes $ fromIntegral extdatalen
|
||||
extxs <- getExtensions (len - fromIntegral extdatalen - 4)
|
||||
return $ (extty, extdata) : extxs
|
||||
extty <- getWord16
|
||||
extdatalen <- getWord16
|
||||
extdata <- getBytes $ fromIntegral extdatalen
|
||||
extxs <- getExtensions (len - fromIntegral extdatalen - 4)
|
||||
return $ (extty, extdata) : extxs
|
||||
|
||||
putExtension :: ExtensionRaw -> Put
|
||||
putExtension (ty, l) = putWord16 ty >> putOpaque16 l
|
||||
|
|
@ -464,8 +462,8 @@ putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es)
|
|||
|
||||
decodeChangeCipherSpec :: ByteString -> Either TLSError ()
|
||||
decodeChangeCipherSpec = runGetErr "changecipherspec" $ do
|
||||
x <- getWord8
|
||||
when (x /= 1) (fail "unknown change cipher spec content")
|
||||
x <- getWord8
|
||||
when (x /= 1) (fail "unknown change cipher spec content")
|
||||
|
||||
encodeChangeCipherSpec :: ByteString
|
||||
encodeChangeCipherSpec = runPut (putWord8 1)
|
||||
|
|
@ -473,7 +471,7 @@ encodeChangeCipherSpec = runPut (putWord8 1)
|
|||
-- rsa pre master secret
|
||||
decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes)
|
||||
decodePreMasterSecret = runGetErr "pre-master-secret" $ do
|
||||
liftM2 (,) getVersion (getBytes 46)
|
||||
liftM2 (,) getVersion (getBytes 46)
|
||||
|
||||
encodePreMasterSecret :: Version -> Bytes -> Bytes
|
||||
encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes)
|
||||
|
|
@ -485,16 +483,14 @@ type PRF = Bytes -> Bytes -> Int -> Bytes
|
|||
|
||||
generateMasterSecret_SSL :: Bytes -> ClientRandom -> ServerRandom -> Bytes
|
||||
generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =
|
||||
B.concat $ map (computeMD5) ["A","BB","CCC"]
|
||||
where
|
||||
computeMD5 label = MD5.hash $ B.concat [ premasterSecret, computeSHA1 label ]
|
||||
computeSHA1 label = SHA1.hash $ B.concat [ label, premasterSecret, c, s ]
|
||||
B.concat $ map (computeMD5) ["A","BB","CCC"]
|
||||
where computeMD5 label = MD5.hash $ B.concat [ premasterSecret, computeSHA1 label ]
|
||||
computeSHA1 label = SHA1.hash $ B.concat [ label, premasterSecret, c, s ]
|
||||
|
||||
generateMasterSecret_TLS :: PRF -> Bytes -> ClientRandom -> ServerRandom -> Bytes
|
||||
generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) =
|
||||
prf premasterSecret seed 48
|
||||
where
|
||||
seed = B.concat [ "master secret", c, s ]
|
||||
prf premasterSecret seed 48
|
||||
where seed = B.concat [ "master secret", c, s ]
|
||||
|
||||
generateMasterSecret :: Version -> Bytes -> ClientRandom -> ServerRandom -> Bytes
|
||||
generateMasterSecret SSL2 = generateMasterSecret_SSL
|
||||
|
|
@ -505,15 +501,14 @@ generateMasterSecret TLS12 = generateMasterSecret_TLS prf_SHA256
|
|||
|
||||
generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes
|
||||
generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize =
|
||||
prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ]
|
||||
prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ]
|
||||
|
||||
generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes
|
||||
generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize =
|
||||
B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels
|
||||
where
|
||||
labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ]
|
||||
computeMD5 label = MD5.hash $ B.concat [ mastersecret, computeSHA1 label ]
|
||||
computeSHA1 label = SHA1.hash $ B.concat [ label, mastersecret, s, c ]
|
||||
B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels
|
||||
where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ]
|
||||
computeMD5 label = MD5.hash $ B.concat [ mastersecret, computeSHA1 label ]
|
||||
computeSHA1 label = SHA1.hash $ B.concat [ label, mastersecret, s, c ]
|
||||
|
||||
generateKeyBlock :: Version -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes
|
||||
generateKeyBlock SSL2 = generateKeyBlock_SSL
|
||||
|
|
@ -524,32 +519,30 @@ generateKeyBlock TLS12 = generateKeyBlock_TLS prf_SHA256
|
|||
|
||||
generateFinished_TLS :: PRF -> Bytes -> Bytes -> HashCtx -> Bytes
|
||||
generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12
|
||||
where
|
||||
seed = B.concat [ label, hashFinal hashctx ]
|
||||
where seed = B.concat [ label, hashFinal hashctx ]
|
||||
|
||||
generateFinished_SSL :: Bytes -> Bytes -> HashCtx -> Bytes
|
||||
generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash]
|
||||
where
|
||||
md5hash = MD5.hash $ B.concat [ mastersecret, pad2, md5left ]
|
||||
sha1hash = SHA1.hash $ B.concat [ mastersecret, B.take 40 pad2, sha1left ]
|
||||
where md5hash = MD5.hash $ B.concat [ mastersecret, pad2, md5left ]
|
||||
sha1hash = SHA1.hash $ B.concat [ mastersecret, B.take 40 pad2, sha1left ]
|
||||
|
||||
lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1)
|
||||
$ foldl hashUpdate hashctx [sender,mastersecret]
|
||||
(md5left,sha1left) = B.splitAt 16 lefthash
|
||||
pad2 = B.replicate 48 0x5c
|
||||
pad1 = B.replicate 48 0x36
|
||||
lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1)
|
||||
$ foldl hashUpdate hashctx [sender,mastersecret]
|
||||
(md5left,sha1left) = B.splitAt 16 lefthash
|
||||
pad2 = B.replicate 48 0x5c
|
||||
pad1 = B.replicate 48 0x36
|
||||
|
||||
generateClientFinished :: Version -> Bytes -> HashCtx -> Bytes
|
||||
generateClientFinished ver
|
||||
| ver < TLS10 = generateFinished_SSL "CLNT"
|
||||
| ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "client finished"
|
||||
| otherwise = generateFinished_TLS prf_SHA256 "client finished"
|
||||
| ver < TLS10 = generateFinished_SSL "CLNT"
|
||||
| ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "client finished"
|
||||
| otherwise = generateFinished_TLS prf_SHA256 "client finished"
|
||||
|
||||
generateServerFinished :: Version -> Bytes -> HashCtx -> Bytes
|
||||
generateServerFinished ver
|
||||
| ver < TLS10 = generateFinished_SSL "SRVR"
|
||||
| ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "server finished"
|
||||
| otherwise = generateFinished_TLS prf_SHA256 "server finished"
|
||||
| ver < TLS10 = generateFinished_SSL "SRVR"
|
||||
| ver < TLS12 = generateFinished_TLS prf_MD5SHA1 "server finished"
|
||||
| otherwise = generateFinished_TLS prf_SHA256 "server finished"
|
||||
|
||||
generateCertificateVerify_SSL :: Bytes -> HashCtx -> Bytes
|
||||
generateCertificateVerify_SSL = generateFinished_SSL ""
|
||||
|
|
|
|||
Loading…
Reference in a new issue