2012-04-20 15:37:47 +00:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, MultiParamTypeClasses, ExistentialQuantification, RankNTypes, CPP #-}
|
2010-09-09 21:47:19 +00:00
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.State
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
|
|
|
-- the State module contains calls related to state initialization/manipulation
|
|
|
|
-- which is use by the Receiving module and the Sending module.
|
|
|
|
--
|
|
|
|
module Network.TLS.State
|
2013-07-12 06:27:28 +00:00
|
|
|
( TLSState(..)
|
|
|
|
, TLSSt
|
|
|
|
, runTLSState
|
2013-07-18 06:19:05 +00:00
|
|
|
, HandshakeState(..)
|
2013-07-19 06:47:33 +00:00
|
|
|
, withHandshakeM
|
2013-07-12 06:27:28 +00:00
|
|
|
, newTLSState
|
|
|
|
, withTLSRNG
|
|
|
|
, updateVerifiedData
|
|
|
|
, finishHandshakeTypeMaterial
|
|
|
|
, finishHandshakeMaterial
|
|
|
|
, certVerifyHandshakeTypeMaterial
|
|
|
|
, certVerifyHandshakeMaterial
|
|
|
|
, setVersion
|
2013-07-13 07:03:25 +00:00
|
|
|
, getVersion
|
2013-07-12 06:27:28 +00:00
|
|
|
, setSecureRenegotiation
|
|
|
|
, getSecureRenegotiation
|
|
|
|
, setExtensionNPN
|
|
|
|
, getExtensionNPN
|
|
|
|
, setNegotiatedProtocol
|
|
|
|
, getNegotiatedProtocol
|
|
|
|
, setServerNextProtocolSuggest
|
|
|
|
, getServerNextProtocolSuggest
|
|
|
|
, getClientCertificateChain
|
|
|
|
, setClientCertificateChain
|
|
|
|
, getVerifiedData
|
|
|
|
, setSession
|
|
|
|
, getSession
|
|
|
|
, getSessionData
|
|
|
|
, isSessionResuming
|
|
|
|
, isClientContext
|
|
|
|
, startHandshakeClient
|
|
|
|
, getHandshakeDigest
|
|
|
|
, endHandshake
|
2013-07-28 06:32:44 +00:00
|
|
|
-- * random
|
|
|
|
, genRandom
|
|
|
|
, withRNG
|
2013-07-12 06:27:28 +00:00
|
|
|
) where
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-02-20 08:37:19 +00:00
|
|
|
import Data.Maybe (isNothing)
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Struct
|
|
|
|
import Network.TLS.Crypto
|
2013-07-18 06:19:05 +00:00
|
|
|
import Network.TLS.Handshake.State
|
2013-07-13 07:03:25 +00:00
|
|
|
import Network.TLS.RNG
|
2013-07-21 09:16:01 +00:00
|
|
|
import Network.TLS.Types (Role(..))
|
2010-09-26 09:34:47 +00:00
|
|
|
import qualified Data.ByteString as B
|
2010-09-09 21:47:19 +00:00
|
|
|
import Control.Monad
|
2011-03-01 20:01:40 +00:00
|
|
|
import Control.Monad.State
|
|
|
|
import Control.Monad.Error
|
2012-12-05 07:47:17 +00:00
|
|
|
import Crypto.Random.API
|
2013-05-19 07:05:46 +00:00
|
|
|
import Data.X509 (CertificateChain)
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-11 08:03:33 +00:00
|
|
|
data TLSState = TLSState
|
2013-07-19 06:05:37 +00:00
|
|
|
{ stHandshake :: !(Maybe HandshakeState)
|
2013-07-12 06:27:28 +00:00
|
|
|
, stSession :: Session
|
|
|
|
, stSessionResuming :: Bool
|
|
|
|
, stSecureRenegotiation :: Bool -- RFC 5746
|
|
|
|
, stClientVerifiedData :: Bytes -- RFC 5746
|
|
|
|
, stServerVerifiedData :: Bytes -- RFC 5746
|
|
|
|
, stExtensionNPN :: Bool -- NPN draft extension
|
|
|
|
, stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol
|
|
|
|
, stServerNextProtocolSuggest :: Maybe [B.ByteString]
|
|
|
|
, stClientCertificateChain :: Maybe CertificateChain
|
2013-07-24 16:35:57 +00:00
|
|
|
, stRandomGen :: StateRNG
|
2013-07-25 20:53:32 +00:00
|
|
|
, stVersion :: Version
|
|
|
|
, stClientContext :: Role
|
2013-07-12 06:27:28 +00:00
|
|
|
} deriving (Show)
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
newtype TLSSt a = TLSSt { runTLSSt :: ErrorT TLSError (State TLSState) a }
|
2013-07-12 06:27:28 +00:00
|
|
|
deriving (Monad, MonadError TLSError)
|
2011-03-01 20:01:40 +00:00
|
|
|
|
|
|
|
instance Functor TLSSt where
|
2013-07-12 06:27:28 +00:00
|
|
|
fmap f = TLSSt . fmap f . runTLSSt
|
2011-03-01 20:01:40 +00:00
|
|
|
|
|
|
|
instance MonadState TLSState TLSSt where
|
2013-07-12 06:27:28 +00:00
|
|
|
put x = TLSSt (lift $ put x)
|
|
|
|
get = TLSSt (lift get)
|
2012-04-20 15:37:47 +00:00
|
|
|
#if MIN_VERSION_mtl(2,1,0)
|
2013-07-12 06:27:28 +00:00
|
|
|
state f = TLSSt (lift $ state f)
|
2012-04-20 15:37:47 +00:00
|
|
|
#endif
|
2011-03-01 20:01:40 +00:00
|
|
|
|
|
|
|
runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState)
|
|
|
|
runTLSState f st = runState (runErrorT (runTLSSt f)) st
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-21 09:16:01 +00:00
|
|
|
newTLSState :: CPRG g => g -> Role -> TLSState
|
2013-07-11 08:03:33 +00:00
|
|
|
newTLSState rng clientContext = TLSState
|
2013-07-12 06:27:28 +00:00
|
|
|
{ stHandshake = Nothing
|
|
|
|
, stSession = Session Nothing
|
|
|
|
, stSessionResuming = False
|
|
|
|
, stSecureRenegotiation = False
|
|
|
|
, stClientVerifiedData = B.empty
|
|
|
|
, stServerVerifiedData = B.empty
|
|
|
|
, stExtensionNPN = False
|
|
|
|
, stNegotiatedProtocol = Nothing
|
|
|
|
, stServerNextProtocolSuggest = Nothing
|
|
|
|
, stClientCertificateChain = Nothing
|
2013-07-24 16:35:57 +00:00
|
|
|
, stRandomGen = StateRNG rng
|
2013-07-25 20:53:32 +00:00
|
|
|
, stVersion = TLS10
|
|
|
|
, stClientContext = clientContext
|
2013-07-12 06:27:28 +00:00
|
|
|
}
|
2013-07-11 08:03:33 +00:00
|
|
|
|
2013-07-21 09:16:01 +00:00
|
|
|
updateVerifiedData :: MonadState TLSState m => Role -> Bytes -> m ()
|
2011-06-07 06:41:31 +00:00
|
|
|
updateVerifiedData sending bs = do
|
2013-07-12 06:27:28 +00:00
|
|
|
cc <- isClientContext
|
|
|
|
if cc /= sending
|
|
|
|
then modify (\st -> st { stServerVerifiedData = bs })
|
|
|
|
else modify (\st -> st { stClientVerifiedData = bs })
|
2011-06-07 06:41:31 +00:00
|
|
|
|
2010-09-09 21:47:19 +00:00
|
|
|
finishHandshakeTypeMaterial :: HandshakeType -> Bool
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_ClientHello = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_ServerHello = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_Certificate = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_HelloRequest = False
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True
|
|
|
|
finishHandshakeTypeMaterial HandshakeType_CertRequest = True
|
2012-07-17 15:33:11 +00:00
|
|
|
finishHandshakeTypeMaterial HandshakeType_CertVerify = True
|
2010-09-09 21:47:19 +00:00
|
|
|
finishHandshakeTypeMaterial HandshakeType_Finished = True
|
2012-02-07 21:24:30 +00:00
|
|
|
finishHandshakeTypeMaterial HandshakeType_NPN = True
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
finishHandshakeMaterial :: Handshake -> Bool
|
|
|
|
finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake
|
|
|
|
|
2012-07-16 14:19:48 +00:00
|
|
|
certVerifyHandshakeTypeMaterial :: HandshakeType -> Bool
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_ServerHelloDone = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_Finished = False
|
|
|
|
certVerifyHandshakeTypeMaterial HandshakeType_NPN = False
|
|
|
|
|
|
|
|
certVerifyHandshakeMaterial :: Handshake -> Bool
|
|
|
|
certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake
|
|
|
|
|
2011-12-20 07:38:35 +00:00
|
|
|
getSessionData :: MonadState TLSState m => m (Maybe SessionData)
|
2012-10-30 04:46:19 +00:00
|
|
|
getSessionData = get >>= \st -> return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st)
|
2013-07-12 06:27:28 +00:00
|
|
|
where wrapSessionData st masterSecret = do
|
|
|
|
return $ SessionData
|
2013-07-25 20:53:32 +00:00
|
|
|
{ sessionVersion = stVersion st
|
2013-08-01 07:05:03 +00:00
|
|
|
, sessionCipher = undefined -- cipherID $ fromJust "cipher" $ stCipher $ stTxState $ st
|
2013-07-12 06:27:28 +00:00
|
|
|
, sessionSecret = masterSecret
|
|
|
|
}
|
2011-12-20 07:38:35 +00:00
|
|
|
|
|
|
|
setSession :: MonadState TLSState m => Session -> Bool -> m ()
|
|
|
|
setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming })
|
|
|
|
|
|
|
|
getSession :: MonadState TLSState m => m Session
|
|
|
|
getSession = gets stSession
|
|
|
|
|
|
|
|
isSessionResuming :: MonadState TLSState m => m Bool
|
|
|
|
isSessionResuming = gets stSessionResuming
|
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
setVersion :: MonadState TLSState m => Version -> m ()
|
2013-07-25 20:53:32 +00:00
|
|
|
setVersion ver = modify (\st -> st { stVersion = ver })
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-13 07:03:25 +00:00
|
|
|
getVersion :: MonadState TLSState m => m Version
|
2013-07-25 20:53:32 +00:00
|
|
|
getVersion = gets stVersion
|
2013-07-13 07:03:25 +00:00
|
|
|
|
2011-06-07 07:13:43 +00:00
|
|
|
setSecureRenegotiation :: MonadState TLSState m => Bool -> m ()
|
|
|
|
setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b })
|
|
|
|
|
|
|
|
getSecureRenegotiation :: MonadState TLSState m => m Bool
|
2012-10-30 04:46:19 +00:00
|
|
|
getSecureRenegotiation = gets stSecureRenegotiation
|
2011-06-07 07:13:43 +00:00
|
|
|
|
2012-02-12 18:59:19 +00:00
|
|
|
setExtensionNPN :: MonadState TLSState m => Bool -> m ()
|
|
|
|
setExtensionNPN b = modify (\st -> st { stExtensionNPN = b })
|
2012-02-08 09:20:28 +00:00
|
|
|
|
2012-02-12 18:59:19 +00:00
|
|
|
getExtensionNPN :: MonadState TLSState m => m Bool
|
2012-10-30 04:46:19 +00:00
|
|
|
getExtensionNPN = gets stExtensionNPN
|
2012-02-08 09:20:28 +00:00
|
|
|
|
2012-02-12 18:59:19 +00:00
|
|
|
setNegotiatedProtocol :: MonadState TLSState m => B.ByteString -> m ()
|
|
|
|
setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s })
|
2012-02-08 09:20:28 +00:00
|
|
|
|
2012-02-12 18:59:19 +00:00
|
|
|
getNegotiatedProtocol :: MonadState TLSState m => m (Maybe B.ByteString)
|
2012-10-30 04:46:19 +00:00
|
|
|
getNegotiatedProtocol = gets stNegotiatedProtocol
|
2012-02-08 09:20:28 +00:00
|
|
|
|
2012-02-16 08:05:46 +00:00
|
|
|
setServerNextProtocolSuggest :: MonadState TLSState m => [B.ByteString] -> m ()
|
|
|
|
setServerNextProtocolSuggest ps = modify (\st -> st { stServerNextProtocolSuggest = Just ps})
|
|
|
|
|
|
|
|
getServerNextProtocolSuggest :: MonadState TLSState m => m (Maybe [B.ByteString])
|
|
|
|
getServerNextProtocolSuggest = get >>= return . stServerNextProtocolSuggest
|
|
|
|
|
2013-05-19 07:05:46 +00:00
|
|
|
setClientCertificateChain :: MonadState TLSState m => CertificateChain -> m ()
|
2012-07-16 12:36:44 +00:00
|
|
|
setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Just s })
|
|
|
|
|
2013-05-19 07:05:46 +00:00
|
|
|
getClientCertificateChain :: MonadState TLSState m => m (Maybe CertificateChain)
|
2012-10-30 04:46:19 +00:00
|
|
|
getClientCertificateChain = gets stClientCertificateChain
|
2012-07-16 12:36:44 +00:00
|
|
|
|
2013-07-24 05:50:56 +00:00
|
|
|
getVerifiedData :: MonadState TLSState m => Role -> m Bytes
|
|
|
|
getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData)
|
2011-06-07 07:13:43 +00:00
|
|
|
|
2013-07-21 09:16:01 +00:00
|
|
|
isClientContext :: MonadState TLSState m => m Role
|
2013-07-25 20:53:32 +00:00
|
|
|
isClientContext = gets stClientContext
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
startHandshakeClient :: MonadState TLSState m => Version -> ClientRandom -> m ()
|
2010-09-09 21:47:19 +00:00
|
|
|
startHandshakeClient ver crand = do
|
2013-07-12 06:27:28 +00:00
|
|
|
-- FIXME check if handshake is already not null
|
|
|
|
let initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256
|
|
|
|
chs <- get >>= return . stHandshake
|
|
|
|
when (isNothing chs) $
|
|
|
|
modify (\st -> st { stHandshake = Just $ newEmptyHandshake ver crand initCtx })
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2013-07-19 06:47:33 +00:00
|
|
|
withHandshakeM :: MonadState TLSState m => HandshakeM a -> m a
|
|
|
|
withHandshakeM f =
|
|
|
|
get >>= \st -> case stHandshake st of
|
|
|
|
Nothing -> fail "handshake missing"
|
|
|
|
Just hst -> do let (a, nhst) = runHandshake hst f
|
|
|
|
put (st { stHandshake = Just nhst })
|
|
|
|
return a
|
|
|
|
|
2011-03-01 20:01:40 +00:00
|
|
|
endHandshake :: MonadState TLSState m => m ()
|
|
|
|
endHandshake = modify (\st -> st { stHandshake = Nothing })
|
2013-07-13 07:03:25 +00:00
|
|
|
|
|
|
|
genRandom :: Int -> TLSSt Bytes
|
2013-07-24 16:35:57 +00:00
|
|
|
genRandom n = do
|
|
|
|
st <- get
|
|
|
|
case withTLSRNG (stRandomGen st) (genRandomBytes n) of
|
|
|
|
(bytes, rng') -> put (st { stRandomGen = rng' }) >> return bytes
|
2013-07-28 06:32:44 +00:00
|
|
|
|
|
|
|
withRNG :: (forall g . CPRG g => g -> (a, g)) -> TLSSt a
|
|
|
|
withRNG f = do
|
|
|
|
st <- get
|
|
|
|
let (a,rng') = withTLSRNG (stRandomGen st) f
|
|
|
|
put (st { stRandomGen = rng' })
|
|
|
|
return a
|