{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Server.TLS12 (
recvClientSecondFlight12,
) where
import Control.Monad.State.Strict (gets)
import qualified Data.ByteString as B
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Packet hiding (getSession)
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types
import Network.TLS.X509 hiding (Certificate)
recvClientSecondFlight12
:: ServerParams
-> Context
-> Maybe SessionData
-> IO ()
recvClientSecondFlight12 :: ServerParams -> Context -> Maybe SessionData -> IO ()
recvClientSecondFlight12 ServerParams
sparams Context
ctx Maybe SessionData
resumeSessionData = do
case Maybe SessionData
resumeSessionData of
Maybe SessionData
Nothing -> do
ServerParams -> Context -> IO ()
recvClientCCC ServerParams
sparams Context
ctx
Maybe ByteString
mticket <- Context -> IO (Maybe ByteString)
sessionEstablished Context
ctx
case Maybe ByteString
mticket of
Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
ticket -> do
let life :: Second
life = Int -> Second
forall {a} {a}. (Num a, Integral a) => a -> a
adjustLifetime (Int -> Second) -> Int -> Second
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [Second -> ByteString -> Handshake
NewSessionTicket Second
life ByteString
ticket]
Context -> Role -> IO ()
sendCCSandFinished Context
ctx Role
ServerRole
Just SessionData
_ -> do
Maybe ByteString
_ <- Context -> IO (Maybe ByteString)
sessionEstablished Context
ctx
Context -> IO ()
recvCCSandFinished Context
ctx
Context -> IO ()
handshakeDone12 Context
ctx
where
adjustLifetime :: a -> a
adjustLifetime a
i
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = a
0
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
604800 = a
604800
| Bool
otherwise = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
sessionEstablished :: Context -> IO (Maybe Ticket)
sessionEstablished :: Context -> IO (Maybe ByteString)
sessionEstablished Context
ctx = do
Session
session <- Context -> TLSSt Session -> IO Session
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
case Session
session of
Session (Just ByteString
sessionId) -> do
Maybe SessionData
sessionData <- Context -> IO (Maybe SessionData)
getSessionData Context
ctx
let sessionId' :: ByteString
sessionId' = ByteString -> ByteString
B.copy ByteString
sessionId
SessionManager
-> ByteString -> SessionData -> IO (Maybe ByteString)
sessionEstablish
(Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx)
ByteString
sessionId'
(Maybe SessionData -> SessionData
forall a. HasCallStack => Maybe a -> a
fromJust Maybe SessionData
sessionData)
Session
_ -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
recvClientCCC :: ServerParams -> Context -> IO ()
recvClientCCC :: ServerParams -> Context -> IO ()
recvClientCCC ServerParams
sparams Context
ctx = Context -> RecvState IO -> IO ()
runRecvState Context
ctx ((Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake Handshake -> IO (RecvState IO)
expectClientCertificate)
where
expectClientCertificate :: Handshake -> IO (RecvState IO)
expectClientCertificate (Certificate CertificateChain
certs) = do
ServerParams -> Context -> CertificateChain -> IO ()
clientCertificate ServerParams
sparams Context
ctx CertificateChain
certs
Context -> Role -> CertificateChain -> IO ()
processCertificate Context
ctx Role
ServerRole CertificateChain
certs
RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake ((Handshake -> IO (RecvState IO)) -> RecvState IO)
-> (Handshake -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Bool -> Handshake -> IO (RecvState IO)
expectClientKeyExchange Bool
True
expectClientCertificate Handshake
p = Bool -> Handshake -> IO (RecvState IO)
expectClientKeyExchange Bool
False Handshake
p
expectClientKeyExchange :: Bool -> Handshake -> IO (RecvState IO)
expectClientKeyExchange Bool
followedCertVerify (ClientKeyXchg ClientKeyXchgAlgorithmData
ckx) = do
Context -> ClientKeyXchgAlgorithmData -> IO ()
processClientKeyXchg Context
ctx ClientKeyXchgAlgorithmData
ckx
if Bool
followedCertVerify
then RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake Handshake -> IO (RecvState IO)
expectCertificateVerify
else RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStatePacket ((Packet -> IO (RecvState IO)) -> RecvState IO)
-> (Packet -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Context -> Packet -> IO (RecvState IO)
expectChangeCipherSpec Context
ctx
expectClientKeyExchange Bool
_ Handshake
p = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake -> String
forall a. Show a => a -> String
show Handshake
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"client key exchange")
expectCertificateVerify :: Handshake -> IO (RecvState IO)
expectCertificateVerify (CertVerify DigitallySigned
dsig) = do
CertificateChain
certs <- Context -> String -> IO CertificateChain
forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"change cipher message expected"
Version
usedVersion <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
ByteString
msgs <- Context -> HandshakeM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM ByteString -> IO ByteString)
-> HandshakeM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> HandshakeM [ByteString] -> HandshakeM ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeM [ByteString]
getHandshakeMessages
PubKey
pubKey <- Context -> HandshakeM PubKey -> IO PubKey
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
Version -> PubKey -> IO ()
forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
usedVersion PubKey
pubKey
Bool
verif <- Context
-> Version -> PubKey -> ByteString -> DigitallySigned -> IO Bool
checkCertificateVerify Context
ctx Version
usedVersion PubKey
pubKey ByteString
msgs DigitallySigned
dsig
ServerParams -> Context -> CertificateChain -> Bool -> IO ()
processClientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStatePacket ((Packet -> IO (RecvState IO)) -> RecvState IO)
-> (Packet -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Context -> Packet -> IO (RecvState IO)
expectChangeCipherSpec Context
ctx
expectCertificateVerify Handshake
p = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake -> String
forall a. Show a => a -> String
show Handshake
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"client certificate verify")
expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO)
expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO)
expectChangeCipherSpec Context
ctx Packet
ChangeCipherSpec = do
RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake ((Handshake -> IO (RecvState IO)) -> RecvState IO)
-> (Handshake -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO (RecvState IO)
expectFinished Context
ctx
expectChangeCipherSpec Context
_ Packet
p = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet -> String
forall a. Show a => a -> String
show Packet
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"change cipher")
processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO ()
processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO ()
processClientKeyXchg Context
ctx (CKX_RSA ByteString
encryptedPreMain) = do
(Version
rver, Role
role, ByteString
random) <- Context
-> TLSSt (Version, Role, ByteString)
-> IO (Version, Role, ByteString)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Version, Role, ByteString)
-> IO (Version, Role, ByteString))
-> TLSSt (Version, Role, ByteString)
-> IO (Version, Role, ByteString)
forall a b. (a -> b) -> a -> b
$ do
(,,) (Version -> Role -> ByteString -> (Version, Role, ByteString))
-> TLSSt Version
-> TLSSt (Role -> ByteString -> (Version, Role, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Version
getVersion TLSSt (Role -> ByteString -> (Version, Role, ByteString))
-> TLSSt Role -> TLSSt (ByteString -> (Version, Role, ByteString))
forall a b. TLSSt (a -> b) -> TLSSt a -> TLSSt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TLSSt Role
getRole TLSSt (ByteString -> (Version, Role, ByteString))
-> TLSSt ByteString -> TLSSt (Version, Role, ByteString)
forall a b. TLSSt (a -> b) -> TLSSt a -> TLSSt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TLSSt ByteString
genRandom Int
48
Either KxError ByteString
ePreMain <- Context -> ByteString -> IO (Either KxError ByteString)
decryptRSA Context
ctx ByteString
encryptedPreMain
ByteString
mainSecret <- Context -> HandshakeM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM ByteString -> IO ByteString)
-> HandshakeM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
Version
expectedVer <- (HandshakeState -> Version) -> HandshakeM Version
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Version
hstClientVersion
case Either KxError ByteString
ePreMain of
Left KxError
_ -> Version -> Role -> ByteString -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role ByteString
random
Right ByteString
preMain -> case ByteString -> Either TLSError (Version, ByteString)
decodePreMainSecret ByteString
preMain of
Left TLSError
_ -> Version -> Role -> ByteString -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role ByteString
random
Right (Version
ver, ByteString
_)
| Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
expectedVer -> Version -> Role -> ByteString -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role ByteString
random
| Bool
otherwise -> Version -> Role -> ByteString -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role ByteString
preMain
Context -> MainSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MainSecret
MainSecret ByteString
mainSecret)
processClientKeyXchg Context
ctx (CKX_DH DHPublic
clientDHValue) = do
Version
rver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
Role
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
ServerDHParams
serverParams <- Context -> HandshakeM ServerDHParams -> IO ServerDHParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerDHParams
getServerDHParams
let params :: DHParams
params = ServerDHParams -> DHParams
serverDHParamsToParams ServerDHParams
serverParams
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DHParams -> Integer -> Bool
dhValid DHParams
params (Integer -> Bool) -> Integer -> Bool
forall a b. (a -> b) -> a -> b
$ DHPublic -> Integer
dhUnwrapPublic DHPublic
clientDHValue) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"invalid client public key" AlertDescription
IllegalParameter
DHPrivate
dhpriv <- Context -> HandshakeM DHPrivate -> IO DHPrivate
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM DHPrivate
getDHPrivate
let preMain :: DHKey
preMain = DHParams -> DHPrivate -> DHPublic -> DHKey
dhGetShared DHParams
params DHPrivate
dhpriv DHPublic
clientDHValue
ByteString
mainSecret <- Context -> HandshakeM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM ByteString -> IO ByteString)
-> HandshakeM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Version -> Role -> DHKey -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role DHKey
preMain
Context -> MainSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MainSecret
MainSecret ByteString
mainSecret)
processClientKeyXchg Context
ctx (CKX_ECDH ByteString
bytes) = do
ServerECDHParams Group
grp GroupPublic
_ <- Context -> HandshakeM ServerECDHParams -> IO ServerECDHParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerECDHParams
getServerECDHParams
case Group -> ByteString -> Either CryptoError GroupPublic
decodeGroupPublic Group
grp ByteString
bytes of
Left CryptoError
_ ->
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"client public key cannot be decoded" AlertDescription
IllegalParameter
Right GroupPublic
clipub -> do
GroupPrivate
srvpri <- Context -> HandshakeM GroupPrivate -> IO GroupPrivate
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM GroupPrivate
getGroupPrivate
case GroupPublic -> GroupPrivate -> Maybe GroupKey
groupGetShared GroupPublic
clipub GroupPrivate
srvpri of
Just GroupKey
preMain -> do
Version
rver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
Role
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
ByteString
mainSecret <- Context -> HandshakeM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM ByteString -> IO ByteString)
-> HandshakeM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Version -> Role -> GroupKey -> HandshakeM ByteString
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM ByteString
setMainSecretFromPre Version
rver Role
role GroupKey
preMain
Context -> MainSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MainSecret
MainSecret ByteString
mainSecret)
Maybe GroupKey
Nothing ->
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol String
"cannot generate a shared secret on ECDH" AlertDescription
IllegalParameter
processClientCertVerify
:: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
processClientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
processClientCertVerify ServerParams
_sparams Context
ctx CertificateChain
certs Bool
True = do
Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
processClientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
False = do
Bool
res <- ServerHooks -> IO Bool
onUnverifiedClientCert (ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
if Bool
res
then do
Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
else String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"verification failed"
recvCCSandFinished :: Context -> IO ()
recvCCSandFinished :: Context -> IO ()
recvCCSandFinished Context
ctx = Context -> RecvState IO -> IO ()
runRecvState Context
ctx (RecvState IO -> IO ()) -> RecvState IO -> IO ()
forall a b. (a -> b) -> a -> b
$ (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStatePacket ((Packet -> IO (RecvState IO)) -> RecvState IO)
-> (Packet -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Context -> Packet -> IO (RecvState IO)
expectChangeCipherSpec Context
ctx