2013-07-18 06:19:05 +00:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Handshake.State
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
|
|
|
module Network.TLS.Handshake.State
|
|
|
|
( HandshakeState(..)
|
|
|
|
, ClientCertRequestData
|
|
|
|
, HandshakeM
|
|
|
|
, newEmptyHandshake
|
2013-07-19 06:47:33 +00:00
|
|
|
, runHandshake
|
2013-07-20 06:18:16 +00:00
|
|
|
-- * key accessors
|
2013-07-19 06:47:54 +00:00
|
|
|
, setPublicKey
|
|
|
|
, setPrivateKey
|
2013-12-28 15:17:42 +00:00
|
|
|
, getLocalPrivateKey
|
|
|
|
, getRemotePublicKey
|
2013-12-11 08:39:25 +00:00
|
|
|
, setServerDHParams
|
2013-07-20 06:18:16 +00:00
|
|
|
-- * cert accessors
|
|
|
|
, setClientCertSent
|
|
|
|
, getClientCertSent
|
|
|
|
, setCertReqSent
|
|
|
|
, getCertReqSent
|
|
|
|
, setClientCertChain
|
|
|
|
, getClientCertChain
|
|
|
|
, setClientCertRequest
|
|
|
|
, getClientCertRequest
|
2013-07-20 07:21:15 +00:00
|
|
|
-- * digest accessors
|
|
|
|
, addHandshakeMessage
|
|
|
|
, updateHandshakeDigest
|
|
|
|
, getHandshakeMessages
|
2013-07-23 07:39:52 +00:00
|
|
|
, getHandshakeDigest
|
2013-07-23 05:36:42 +00:00
|
|
|
-- * master secret
|
|
|
|
, setMasterSecret
|
|
|
|
, setMasterSecretFromPre
|
2013-07-23 07:30:13 +00:00
|
|
|
-- * misc accessor
|
2013-12-11 08:39:25 +00:00
|
|
|
, getPendingCipher
|
2013-12-03 07:17:27 +00:00
|
|
|
, setServerHelloParameters
|
2013-07-18 06:19:05 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import Network.TLS.Util
|
|
|
|
import Network.TLS.Struct
|
2013-07-22 07:35:53 +00:00
|
|
|
import Network.TLS.Record.State
|
2013-07-18 06:19:05 +00:00
|
|
|
import Network.TLS.Packet
|
|
|
|
import Network.TLS.Crypto
|
2013-07-22 07:35:53 +00:00
|
|
|
import Network.TLS.Cipher
|
|
|
|
import Network.TLS.Compression
|
2013-07-23 05:36:42 +00:00
|
|
|
import Network.TLS.Types
|
2013-12-11 08:36:35 +00:00
|
|
|
import Control.Applicative (Applicative, (<$>))
|
2013-07-18 06:19:05 +00:00
|
|
|
import Control.Monad.State
|
|
|
|
import Data.X509 (CertificateChain)
|
|
|
|
|
2013-12-28 15:17:42 +00:00
|
|
|
data HandshakeKeyState = HandshakeKeyState
|
|
|
|
{ hksRemotePublicKey :: !(Maybe PubKey)
|
|
|
|
, hksLocalPrivateKey :: !(Maybe PrivKey)
|
|
|
|
} deriving (Show)
|
|
|
|
|
2013-07-18 06:19:05 +00:00
|
|
|
data HandshakeState = HandshakeState
|
2013-07-18 06:34:05 +00:00
|
|
|
{ hstClientVersion :: !(Version)
|
|
|
|
, hstClientRandom :: !ClientRandom
|
|
|
|
, hstServerRandom :: !(Maybe ServerRandom)
|
|
|
|
, hstMasterSecret :: !(Maybe Bytes)
|
2013-12-28 15:17:42 +00:00
|
|
|
, hstKeyState :: !HandshakeKeyState
|
2013-12-11 08:39:25 +00:00
|
|
|
, hstServerDHParams :: !(Maybe ServerDHParams)
|
|
|
|
, hstDHPrivate :: !(Maybe DHPrivate)
|
2013-12-03 07:17:27 +00:00
|
|
|
, hstHandshakeDigest :: !(Either [Bytes] HashCtx)
|
2013-07-18 06:34:05 +00:00
|
|
|
, hstHandshakeMessages :: [Bytes]
|
|
|
|
, hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received
|
|
|
|
, hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent
|
|
|
|
, hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent
|
|
|
|
, hstClientCertChain :: !(Maybe CertificateChain)
|
2013-07-27 07:32:27 +00:00
|
|
|
, hstPendingTxState :: Maybe RecordState
|
|
|
|
, hstPendingRxState :: Maybe RecordState
|
2013-07-22 07:35:53 +00:00
|
|
|
, hstPendingCipher :: Maybe Cipher
|
|
|
|
, hstPendingCompression :: Compression
|
2013-07-18 06:19:05 +00:00
|
|
|
} deriving (Show)
|
|
|
|
|
|
|
|
type ClientCertRequestData = ([CertificateType],
|
|
|
|
Maybe [(HashAlgorithm, SignatureAlgorithm)],
|
|
|
|
[DistinguishedName])
|
|
|
|
|
2013-07-19 06:46:09 +00:00
|
|
|
newtype HandshakeM a = HandshakeM { runHandshakeM :: State HandshakeState a }
|
2013-12-11 08:36:35 +00:00
|
|
|
deriving (Functor, Applicative, Monad)
|
2013-07-18 06:19:05 +00:00
|
|
|
|
|
|
|
instance MonadState HandshakeState HandshakeM where
|
2013-07-19 06:46:09 +00:00
|
|
|
put x = HandshakeM (put x)
|
|
|
|
get = HandshakeM (get)
|
2013-07-18 06:19:05 +00:00
|
|
|
#if MIN_VERSION_mtl(2,1,0)
|
2013-07-19 06:46:09 +00:00
|
|
|
state f = HandshakeM (state f)
|
2013-07-18 06:19:05 +00:00
|
|
|
#endif
|
|
|
|
|
|
|
|
-- create a new empty handshake state
|
2013-12-03 07:17:27 +00:00
|
|
|
newEmptyHandshake :: Version -> ClientRandom -> HandshakeState
|
|
|
|
newEmptyHandshake ver crand = HandshakeState
|
2013-07-18 06:34:05 +00:00
|
|
|
{ hstClientVersion = ver
|
|
|
|
, hstClientRandom = crand
|
|
|
|
, hstServerRandom = Nothing
|
|
|
|
, hstMasterSecret = Nothing
|
2013-12-28 15:17:42 +00:00
|
|
|
, hstKeyState = HandshakeKeyState Nothing Nothing
|
2013-12-11 08:39:25 +00:00
|
|
|
, hstServerDHParams = Nothing
|
|
|
|
, hstDHPrivate = Nothing
|
2013-12-03 07:17:27 +00:00
|
|
|
, hstHandshakeDigest = Left []
|
2013-07-18 06:34:05 +00:00
|
|
|
, hstHandshakeMessages = []
|
|
|
|
, hstClientCertRequest = Nothing
|
|
|
|
, hstClientCertSent = False
|
|
|
|
, hstCertReqSent = False
|
|
|
|
, hstClientCertChain = Nothing
|
2013-07-22 07:35:53 +00:00
|
|
|
, hstPendingTxState = Nothing
|
|
|
|
, hstPendingRxState = Nothing
|
|
|
|
, hstPendingCipher = Nothing
|
|
|
|
, hstPendingCompression = nullCompression
|
2013-07-18 06:19:05 +00:00
|
|
|
}
|
2013-07-19 06:47:33 +00:00
|
|
|
|
|
|
|
runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState)
|
|
|
|
runHandshake hst f = runState (runHandshakeM f) hst
|
2013-07-19 06:47:54 +00:00
|
|
|
|
|
|
|
setPublicKey :: PubKey -> HandshakeM ()
|
2013-12-28 15:17:42 +00:00
|
|
|
setPublicKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) })
|
|
|
|
where setPK hks = hks { hksRemotePublicKey = Just pk }
|
2013-07-19 06:47:54 +00:00
|
|
|
|
|
|
|
setPrivateKey :: PrivKey -> HandshakeM ()
|
2013-12-28 15:17:42 +00:00
|
|
|
setPrivateKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) })
|
|
|
|
where setPK hks = hks { hksLocalPrivateKey = Just pk }
|
2013-07-19 06:47:54 +00:00
|
|
|
|
2013-12-28 15:17:42 +00:00
|
|
|
getRemotePublicKey :: HandshakeM PubKey
|
|
|
|
getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . hstKeyState)
|
2013-12-11 08:39:25 +00:00
|
|
|
|
2013-12-28 15:17:42 +00:00
|
|
|
getLocalPrivateKey :: HandshakeM PrivKey
|
|
|
|
getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState)
|
2013-07-19 06:47:54 +00:00
|
|
|
|
2013-12-28 15:17:42 +00:00
|
|
|
setServerDHParams :: ServerDHParams -> HandshakeM ()
|
|
|
|
setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp })
|
2013-07-20 06:18:16 +00:00
|
|
|
|
|
|
|
setCertReqSent :: Bool -> HandshakeM ()
|
|
|
|
setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b })
|
|
|
|
|
|
|
|
getCertReqSent :: HandshakeM Bool
|
|
|
|
getCertReqSent = gets hstCertReqSent
|
|
|
|
|
|
|
|
setClientCertSent :: Bool -> HandshakeM ()
|
|
|
|
setClientCertSent b = modify (\hst -> hst { hstClientCertSent = b })
|
|
|
|
|
|
|
|
getClientCertSent :: HandshakeM Bool
|
|
|
|
getClientCertSent = gets hstClientCertSent
|
|
|
|
|
|
|
|
setClientCertChain :: CertificateChain -> HandshakeM ()
|
|
|
|
setClientCertChain b = modify (\hst -> hst { hstClientCertChain = Just b })
|
|
|
|
|
|
|
|
getClientCertChain :: HandshakeM (Maybe CertificateChain)
|
|
|
|
getClientCertChain = gets hstClientCertChain
|
|
|
|
|
|
|
|
setClientCertRequest :: ClientCertRequestData -> HandshakeM ()
|
|
|
|
setClientCertRequest d = modify (\hst -> hst { hstClientCertRequest = Just d })
|
|
|
|
|
|
|
|
getClientCertRequest :: HandshakeM (Maybe ClientCertRequestData)
|
|
|
|
getClientCertRequest = gets hstClientCertRequest
|
|
|
|
|
2013-12-11 08:39:25 +00:00
|
|
|
getPendingCipher :: HandshakeM Cipher
|
|
|
|
getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher
|
|
|
|
|
2013-07-20 07:21:15 +00:00
|
|
|
addHandshakeMessage :: Bytes -> HandshakeM ()
|
|
|
|
addHandshakeMessage content = modify $ \hs -> hs { hstHandshakeMessages = content : hstHandshakeMessages hs}
|
|
|
|
|
|
|
|
getHandshakeMessages :: HandshakeM [Bytes]
|
|
|
|
getHandshakeMessages = gets (reverse . hstHandshakeMessages)
|
|
|
|
|
|
|
|
updateHandshakeDigest :: Bytes -> HandshakeM ()
|
2013-12-03 07:17:27 +00:00
|
|
|
updateHandshakeDigest content = modify $ \hs -> hs
|
|
|
|
{ hstHandshakeDigest = case hstHandshakeDigest hs of
|
|
|
|
Left bytes -> Left (content:bytes)
|
|
|
|
Right hashCtx -> Right $ hashUpdate hashCtx content }
|
2013-07-23 05:36:42 +00:00
|
|
|
|
2013-07-23 07:39:52 +00:00
|
|
|
getHandshakeDigest :: Version -> Role -> HandshakeM Bytes
|
|
|
|
getHandshakeDigest ver role = gets gen
|
2013-12-03 07:17:27 +00:00
|
|
|
where gen hst = case hstHandshakeDigest hst of
|
|
|
|
Right hashCtx ->
|
|
|
|
let msecret = fromJust "master secret" $ hstMasterSecret hst
|
|
|
|
in generateFinish ver msecret hashCtx
|
|
|
|
Left _ ->
|
|
|
|
error "un-initialized handshake digest"
|
2013-07-23 07:39:52 +00:00
|
|
|
generateFinish | role == ClientRole = generateClientFinished
|
|
|
|
| otherwise = generateServerFinished
|
|
|
|
|
2013-11-29 10:45:05 +00:00
|
|
|
-- | Generate the master secret from the pre master secret.
|
|
|
|
setMasterSecretFromPre :: Version -- ^ chosen transmission version
|
|
|
|
-> Role -- ^ the role (Client or Server) of the generating side
|
|
|
|
-> Bytes -- ^ the pre master secret
|
|
|
|
-> HandshakeM ()
|
2013-07-23 05:36:42 +00:00
|
|
|
setMasterSecretFromPre ver role premasterSecret = do
|
|
|
|
secret <- genSecret <$> get
|
|
|
|
setMasterSecret ver role secret
|
|
|
|
where genSecret hst = generateMasterSecret ver
|
|
|
|
premasterSecret
|
|
|
|
(hstClientRandom hst)
|
|
|
|
(fromJust "server random" $ hstServerRandom hst)
|
|
|
|
|
|
|
|
-- | Set master secret and as a side effect generate the key block
|
|
|
|
-- with all the right parameters, and setup the pending tx/rx state.
|
|
|
|
setMasterSecret :: Version -> Role -> Bytes -> HandshakeM ()
|
|
|
|
setMasterSecret ver role masterSecret = modify $ \hst ->
|
|
|
|
let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role
|
|
|
|
in hst { hstMasterSecret = Just masterSecret
|
|
|
|
, hstPendingTxState = Just pendingTx
|
|
|
|
, hstPendingRxState = Just pendingRx }
|
|
|
|
|
2013-07-27 07:32:27 +00:00
|
|
|
computeKeyBlock :: HandshakeState -> Bytes -> Version -> Role -> (RecordState, RecordState)
|
2013-07-23 05:36:42 +00:00
|
|
|
computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx)
|
|
|
|
where cipher = fromJust "cipher" $ hstPendingCipher hst
|
|
|
|
keyblockSize = cipherKeyBlockSize cipher
|
|
|
|
|
|
|
|
bulk = cipherBulk cipher
|
|
|
|
digestSize = hashSize $ cipherHash cipher
|
|
|
|
keySize = bulkKeySize bulk
|
|
|
|
ivSize = bulkIVSize bulk
|
|
|
|
kb = generateKeyBlock ver (hstClientRandom hst)
|
|
|
|
(fromJust "server random" $ hstServerRandom hst)
|
|
|
|
masterSecret keyblockSize
|
|
|
|
|
|
|
|
(cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) =
|
|
|
|
fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize)
|
|
|
|
|
|
|
|
cstClient = CryptState { cstKey = cWriteKey
|
|
|
|
, cstIV = cWriteIV
|
|
|
|
, cstMacSecret = cMACSecret }
|
|
|
|
cstServer = CryptState { cstKey = sWriteKey
|
|
|
|
, cstIV = sWriteIV
|
|
|
|
, cstMacSecret = sMACSecret }
|
|
|
|
msClient = MacState { msSequence = 0 }
|
|
|
|
msServer = MacState { msSequence = 0 }
|
|
|
|
|
2013-07-27 07:32:27 +00:00
|
|
|
pendingTx = RecordState
|
2013-07-23 05:36:42 +00:00
|
|
|
{ stCryptState = if cc == ClientRole then cstClient else cstServer
|
|
|
|
, stMacState = if cc == ClientRole then msClient else msServer
|
|
|
|
, stCipher = Just cipher
|
|
|
|
, stCompression = hstPendingCompression hst
|
|
|
|
}
|
2013-07-27 07:32:27 +00:00
|
|
|
pendingRx = RecordState
|
2013-07-23 05:36:42 +00:00
|
|
|
{ stCryptState = if cc == ClientRole then cstServer else cstClient
|
|
|
|
, stMacState = if cc == ClientRole then msServer else msClient
|
|
|
|
, stCipher = Just cipher
|
|
|
|
, stCompression = hstPendingCompression hst
|
|
|
|
}
|
2013-07-23 07:30:13 +00:00
|
|
|
|
2013-12-03 07:17:27 +00:00
|
|
|
setServerHelloParameters :: Version -- ^ chosen version
|
|
|
|
-> ServerRandom
|
|
|
|
-> Cipher
|
|
|
|
-> Compression
|
|
|
|
-> HandshakeM ()
|
|
|
|
setServerHelloParameters ver sran cipher compression = do
|
|
|
|
modify $ \hst -> hst
|
|
|
|
{ hstServerRandom = Just sran
|
|
|
|
, hstPendingCipher = Just cipher
|
|
|
|
, hstPendingCompression = compression
|
|
|
|
, hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst
|
|
|
|
}
|
|
|
|
where initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256
|
|
|
|
updateDigest (Left bytes) = Right $ foldl hashUpdate initCtx $ reverse bytes
|
|
|
|
updateDigest (Right _) = error "cannot initialize digest with another digest"
|