{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Common (
handshakeFailed,
handleException,
unexpected,
newSession,
handshakeDone12,
ensureNullCompression,
ticketOrSessionID12,
sendCCSandFinished,
RecvState (..),
runRecvState,
runRecvStateHS,
recvPacketHandshake,
onRecvStateHandshake,
ensureRecvComplete,
processExtendedMainSecret,
getSessionData,
storePrivInfo,
isSupportedGroup,
checkSupportedGroup,
errorToAlert,
errorToAlertMessage,
expectFinished,
processCertificate,
setPeerRecordSizeLimit,
) where
import Control.Concurrent.MVar
import Control.Exception (IOException, fromException, handle, throwIO)
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Measurement
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Util
import Network.TLS.X509
handshakeFailed :: TLSError -> IO ()
handshakeFailed :: TLSError -> IO ()
handshakeFailed TLSError
err = TLSException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (TLSException -> IO ()) -> TLSException -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> TLSException
HandshakeFailed TLSError
err
handleException :: Context -> IO () -> IO ()
handleException :: Context -> IO () -> IO ()
handleException Context
ctx IO ()
f = IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException IO ()
f ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
exception -> do
let tlserror :: TLSError
tlserror = case SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
Just TLSException
e | Uncontextualized TLSError
e' <- TLSException
e -> TLSError
e'
Maybe TLSException
_ -> [Char] -> TLSError
Error_Misc (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exception)
established <- Context -> IO Established
ctxEstablished Context
ctx
setEstablished ctx NotEstablished
handle ignoreIOErr $ do
tls13 <- tls13orLater ctx
if tls13
then do
when (established == EarlyDataSending) $ clearTxRecordState ctx
when (tlserror /= Error_TCP_Terminate) $
sendPacket13 ctx $
Alert13 [errorToAlert tlserror]
else sendPacket12 ctx $ Alert [errorToAlert tlserror]
handshakeFailed tlserror
where
ignoreIOErr :: IOException -> IO ()
ignoreIOErr :: IOException -> IO ()
ignoreIOErr IOException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert :: TLSError -> (AlertLevel, AlertDescription)
errorToAlert (Error_Protocol [Char]
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Fatal, AlertDescription
ad)
errorToAlert (Error_Protocol_Warning [Char]
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Warning, AlertDescription
ad)
errorToAlert (Error_Packet_unexpected [Char]
_ [Char]
_) = (AlertLevel
AlertLevel_Fatal, AlertDescription
UnexpectedMessage)
errorToAlert (Error_Packet_Parsing [Char]
msg)
| [Char]
"invalid version" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
ProtocolVersion)
| [Char]
"request_update" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
IllegalParameter)
| Bool
otherwise = (AlertLevel
AlertLevel_Fatal, AlertDescription
DecodeError)
errorToAlert TLSError
_ = (AlertLevel
AlertLevel_Fatal, AlertDescription
InternalError)
errorToAlertMessage :: TLSError -> String
errorToAlertMessage :: TLSError -> [Char]
errorToAlertMessage (Error_Protocol [Char]
msg AlertDescription
_) = [Char]
msg
errorToAlertMessage (Error_Protocol_Warning [Char]
msg AlertDescription
_) = [Char]
msg
errorToAlertMessage (Error_Packet_unexpected [Char]
msg [Char]
_) = [Char]
msg
errorToAlertMessage (Error_Packet_Parsing [Char]
msg) = [Char]
msg
errorToAlertMessage TLSError
e = TLSError -> [Char]
forall a. Show a => a -> [Char]
show TLSError
e
unexpected :: MonadIO m => String -> Maybe String -> m a
unexpected :: forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
msg Maybe [Char]
expected =
TLSError -> m a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m a) -> TLSError -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> TLSError
Error_Packet_unexpected [Char]
msg ([Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" expected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) Maybe [Char]
expected)
newSession :: Context -> IO Session
newSession :: Context -> IO Session
newSession Context
ctx
| Supported -> Bool
supportedSession (Supported -> Bool) -> Supported -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx = Maybe Ticket -> Session
Session (Maybe Ticket -> Session)
-> (Ticket -> Maybe Ticket) -> Ticket -> Session
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticket -> Maybe Ticket
forall a. a -> Maybe a
Just (Ticket -> Session) -> IO Ticket -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Int -> IO Ticket
getStateRNG Context
ctx Int
32
| Bool
otherwise = Session -> IO Session
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Session -> IO Session) -> Session -> IO Session
forall a b. (a -> b) -> a -> b
$ Maybe Ticket -> Session
Session Maybe Ticket
forall a. Maybe a
Nothing
handshakeDone12 :: Context -> IO ()
handshakeDone12 :: Context -> IO ()
handshakeDone12 Context
ctx = do
MVar (Maybe HandshakeState)
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Context -> MVar (Maybe HandshakeState)
ctxHandshakeState Context
ctx) ((Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ())
-> (Maybe HandshakeState -> IO (Maybe HandshakeState)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
Maybe HandshakeState
Nothing -> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HandshakeState
forall a. Maybe a
Nothing
Just HandshakeState
hshake ->
Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HandshakeState -> IO (Maybe HandshakeState))
-> Maybe HandshakeState -> IO (Maybe HandshakeState)
forall a b. (a -> b) -> a -> b
$
HandshakeState -> Maybe HandshakeState
forall a. a -> Maybe a
Just
(Version -> ClientRandom -> HandshakeState
newEmptyHandshake (HandshakeState -> Version
hstClientVersion HandshakeState
hshake) (HandshakeState -> ClientRandom
hstClientRandom HandshakeState
hshake))
{ hstServerRandom = hstServerRandom hshake
, hstMainSecret = hstMainSecret hshake
, hstExtendedMainSecret = hstExtendedMainSecret hshake
, hstSupportedGroup = hstSupportedGroup hshake
}
Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx Measurement -> Measurement
resetBytesCounters
Context -> Established -> IO ()
setEstablished Context
ctx Established
Established
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendCCSandFinished
:: Context
-> Role
-> IO ()
sendCCSandFinished :: Context -> Role -> IO ()
sendCCSandFinished Context
ctx Role
role = do
Context -> Packet -> IO ()
sendPacket12 Context
ctx Packet
ChangeCipherSpec
Context -> IO ()
contextFlush Context
ctx
Context -> IO ()
enablePeerRecordLimit Context
ctx
verifyData <-
Ticket -> VerifyData
VerifyData
(Ticket -> VerifyData) -> IO Ticket -> IO VerifyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion IO Version -> (Version -> IO Ticket) -> IO Ticket
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Version
ver -> Context -> HandshakeM Ticket -> IO Ticket
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM Ticket -> IO Ticket) -> HandshakeM Ticket -> IO Ticket
forall a b. (a -> b) -> a -> b
$ Version -> Role -> HandshakeM Ticket
getHandshakeDigest Version
ver Role
role
)
sendPacket12 ctx (Handshake [Finished verifyData])
usingState_ ctx $ setVerifyDataForSend verifyData
contextFlush ctx
data RecvState m
= RecvStatePacket (Packet -> m (RecvState m))
| RecvStateHandshake (Handshake -> m (RecvState m))
| RecvStateDone
recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake Context
ctx = do
pkts <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
case pkts of
Right (Handshake [Handshake]
l) -> [Handshake] -> IO [Handshake]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Handshake]
l
Right x :: Packet
x@(AppData Ticket
_) -> do
established <- Context -> IO Established
ctxEstablished Context
ctx
case established of
EarlyDataNotAllowed Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
Context -> Established -> IO ()
setEstablished Context
ctx (Established -> IO ()) -> Established -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Context -> IO [Handshake]
recvPacketHandshake Context
ctx
Established
_ -> [Char] -> Maybe [Char] -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
x) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"handshake")
Right Packet
x -> [Char] -> Maybe [Char] -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
x) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"handshake")
Left TLSError
err -> TLSError -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
err
onRecvStateHandshake
:: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
_ RecvState IO
recvState [] = RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
onRecvStateHandshake Context
_ (RecvStatePacket Packet -> IO (RecvState IO)
f) [Handshake]
hms = Packet -> IO (RecvState IO)
f ([Handshake] -> Packet
Handshake [Handshake]
hms)
onRecvStateHandshake Context
ctx (RecvStateHandshake Handshake -> IO (RecvState IO)
f) (Handshake
x : [Handshake]
xs) = do
let finished :: Bool
finished = Handshake -> Bool
isFinished Handshake
x
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
finished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO ()
processHandshake12 Context
ctx Handshake
x
nstate <- Handshake -> IO (RecvState IO)
f Handshake
x
when finished $ processHandshake12 ctx x
onRecvStateHandshake ctx nstate xs
onRecvStateHandshake Context
_ RecvState IO
RecvStateDone [Handshake]
_xs = [Char] -> Maybe [Char] -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected [Char]
"spurious handshake" Maybe [Char]
forall a. Maybe a
Nothing
isFinished :: Handshake -> Bool
isFinished :: Handshake -> Bool
isFinished Finished{} = Bool
True
isFinished Handshake
_ = Bool
False
runRecvState :: Context -> RecvState IO -> IO ()
runRecvState :: Context -> RecvState IO -> IO ()
runRecvState Context
_ RecvState IO
RecvStateDone = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runRecvState Context
ctx (RecvStatePacket Packet -> IO (RecvState IO)
f) = Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx IO (Either TLSError Packet)
-> (Either TLSError Packet -> IO (RecvState IO))
-> IO (RecvState IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TLSError -> IO (RecvState IO))
-> (Packet -> IO (RecvState IO))
-> Either TLSError Packet
-> IO (RecvState IO)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TLSError -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore Packet -> IO (RecvState IO)
f IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx
runRecvState Context
ctx RecvState IO
iniState =
Context -> IO [Handshake]
recvPacketHandshake Context
ctx
IO [Handshake]
-> ([Handshake] -> IO (RecvState IO)) -> IO (RecvState IO)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
iniState
IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx
runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()
runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()
runRecvStateHS Context
ctx RecvState IO
iniState [Handshake]
hs = Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
iniState [Handshake]
hs IO (RecvState IO) -> (RecvState IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> RecvState IO -> IO ()
runRecvState Context
ctx
ensureRecvComplete :: MonadIO m => Context -> m ()
ensureRecvComplete :: forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx = do
complete <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Context -> IO Bool
isRecvComplete Context
ctx
unless complete $
throwCore $
Error_Protocol "received incomplete message at key change" UnexpectedMessage
processExtendedMainSecret
:: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret :: forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret Context
ctx Version
ver MessageType
msgt [ExtensionRaw]
exts
| Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
TLS10 = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
TLS12 = [Char] -> m Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"EMS processing is not compatible with TLS 1.3"
| EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
NoEMS = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise =
IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> IO Bool
-> (ExtendedMainSecret -> IO Bool)
-> IO Bool
forall a b.
Extension a =>
ExtensionID
-> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
lookupAndDecodeAndDo
ExtensionID
EID_ExtendedMainSecret
MessageType
msgt
[ExtensionRaw]
exts
IO Bool
nonExistAction
ExtendedMainSecret -> IO Bool
forall {m :: * -> *}. MonadIO m => ExtendedMainSecret -> m Bool
existAction
where
ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMainSecret (Supported -> EMSMode) -> Supported -> EMSMode
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
err :: [Char]
err = [Char]
"peer does not support Extended Main Secret"
nonExistAction :: IO Bool
nonExistAction =
if EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS
then TLSError -> IO Bool
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Bool) -> TLSError -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
err AlertDescription
HandshakeFailure
else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
existAction :: ExtendedMainSecret -> m Bool
existAction ExtendedMainSecret
ExtendedMainSecret = do
Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setExtendedMainSecret Bool
True
Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
getSessionData :: Context -> IO (Maybe SessionData)
getSessionData :: Context -> IO (Maybe SessionData)
getSessionData Context
ctx = do
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
sni <- usingState_ ctx getClientSNI
mms <- usingHState ctx $ gets hstMainSecret
ems <- usingHState ctx getExtendedMainSecret
cipher <- cipherID <$> usingHState ctx getPendingCipher
alpn <- usingState_ ctx getNegotiatedProtocol
let compression = CompressionID
0
flags = [SessionFlag
SessionEMS | Bool
ems]
case mms of
Maybe Ticket
Nothing -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
Just Ticket
ms ->
Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SessionData -> IO (Maybe SessionData))
-> Maybe SessionData -> IO (Maybe SessionData)
forall a b. (a -> b) -> a -> b
$
SessionData -> Maybe SessionData
forall a. a -> Maybe a
Just
SessionData
{ sessionVersion :: Version
sessionVersion = Version
ver
, sessionCipher :: Word16
sessionCipher = Word16
cipher
, sessionCompression :: CompressionID
sessionCompression = CompressionID
compression
, sessionClientSNI :: Maybe [Char]
sessionClientSNI = Maybe [Char]
sni
, sessionSecret :: Ticket
sessionSecret = Ticket
ms
, sessionGroup :: Maybe Group
sessionGroup = Maybe Group
forall a. Maybe a
Nothing
, sessionTicketInfo :: Maybe TLS13TicketInfo
sessionTicketInfo = Maybe TLS13TicketInfo
forall a. Maybe a
Nothing
, sessionALPN :: Maybe Ticket
sessionALPN = Maybe Ticket
alpn
, sessionMaxEarlyDataSize :: Int
sessionMaxEarlyDataSize = Int
0
, sessionFlags :: [SessionFlag]
sessionFlags = [SessionFlag]
flags
}
storePrivInfo
:: MonadIO m
=> Context
-> CertificateChain
-> PrivKey
-> m PubKey
storePrivInfo :: forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey = do
let c :: SignedExact Certificate
c = CertificateChain -> SignedExact Certificate
fromCC CertificateChain
cc
pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((PubKey, PrivKey) -> Bool
isDigitalSignaturePair (PubKey
pubkey, PrivKey
privkey)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
[Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"mismatched or unsupported private key pair" AlertDescription
InternalError
Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ (PubKey, PrivKey) -> HandshakeM ()
setPublicPrivateKeys (PubKey
pubkey, PrivKey
privkey)
PubKey -> m PubKey
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PubKey
pubkey
where
fromCC :: CertificateChain -> SignedExact Certificate
fromCC (CertificateChain (SignedExact Certificate
c : [SignedExact Certificate]
_)) = SignedExact Certificate
c
fromCC CertificateChain
_ = [Char] -> SignedExact Certificate
forall a. HasCallStack => [Char] -> a
error [Char]
"fromCC"
checkSupportedGroup :: Context -> Group -> IO ()
checkSupportedGroup :: Context -> Group -> IO ()
checkSupportedGroup Context
ctx Group
grp =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Group -> Bool
isSupportedGroup Context
ctx Group
grp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
let msg :: [Char]
msg = [Char]
"unsupported (EC)DHE group: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Group -> [Char]
forall a. Show a => a -> [Char]
show Group
grp
in TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
msg AlertDescription
IllegalParameter
isSupportedGroup :: Context -> Group -> Bool
isSupportedGroup :: Context -> Group -> Bool
isSupportedGroup Context
ctx Group
grp = Group
grp Group -> [Group] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
ensureNullCompression :: MonadIO m => CompressionID -> m ()
ensureNullCompression :: forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression =
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CompressionID
compression CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
/= Compression -> CompressionID
compressionID Compression
nullCompression) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
TLSError -> m ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m ()) -> TLSError -> m ()
forall a b. (a -> b) -> a -> b
$
[Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"compression is not allowed in TLS 1.3" AlertDescription
IllegalParameter
expectFinished :: Context -> Handshake -> IO (RecvState IO)
expectFinished :: Context -> Handshake -> IO (RecvState IO)
expectFinished Context
ctx (Finished VerifyData
verifyData) = do
Context -> VerifyData -> IO ()
processFinished Context
ctx VerifyData
verifyData
RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
forall (m :: * -> *). RecvState m
RecvStateDone
expectFinished Context
_ Handshake
p = [Char] -> Maybe [Char] -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake -> [Char]
forall a. Show a => a -> [Char]
show Handshake
p) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Handshake Finished")
processFinished :: Context -> VerifyData -> IO ()
processFinished :: Context -> VerifyData -> IO ()
processFinished Context
ctx VerifyData
verifyData = do
(cc, ver) <- Context -> TLSSt (Role, Version) -> IO (Role, Version)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Role, Version) -> IO (Role, Version))
-> TLSSt (Role, Version) -> IO (Role, Version)
forall a b. (a -> b) -> a -> b
$ (,) (Role -> Version -> (Role, Version))
-> TLSSt Role -> TLSSt (Version -> (Role, Version))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Role
getRole TLSSt (Version -> (Role, Version))
-> TLSSt Version -> TLSSt (Role, Version)
forall a b. TLSSt (a -> b) -> TLSSt a -> TLSSt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TLSSt Version
getVersion
expected <-
VerifyData <$> usingHState ctx (getHandshakeDigest ver $ invertRole cc)
when (expected /= verifyData) $ decryptError "cannot verify finished"
usingState_ ctx $ setVerifyDataForRecv verifyData
processCertificate :: Context -> Role -> CertificateChain -> IO ()
processCertificate :: Context -> Role -> CertificateChain -> IO ()
processCertificate Context
_ Role
ServerRole (CertificateChain []) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
processCertificate Context
_ Role
ClientRole (CertificateChain []) =
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"server certificate missing" AlertDescription
HandshakeFailure
processCertificate Context
ctx Role
_ (CertificateChain (SignedExact Certificate
c : [SignedExact Certificate]
_)) =
Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
where
pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
ticketOrSessionID12
:: Maybe Ticket -> Session -> Maybe SessionIDorTicket
ticketOrSessionID12 :: Maybe Ticket -> Session -> Maybe Ticket
ticketOrSessionID12 (Just Ticket
ticket) Session
_
| Ticket
ticket Ticket -> Ticket -> Bool
forall a. Eq a => a -> a -> Bool
/= Ticket
"" = Ticket -> Maybe Ticket
forall a. a -> Maybe a
Just (Ticket -> Maybe Ticket) -> Ticket -> Maybe Ticket
forall a b. (a -> b) -> a -> b
$ Ticket -> Ticket
B.copy Ticket
ticket
ticketOrSessionID12 Maybe Ticket
_ (Session (Just Ticket
sessionId)) = Ticket -> Maybe Ticket
forall a. a -> Maybe a
Just (Ticket -> Maybe Ticket) -> Ticket -> Maybe Ticket
forall a b. (a -> b) -> a -> b
$ Ticket -> Ticket
B.copy Ticket
sessionId
ticketOrSessionID12 Maybe Ticket
_ Session
_ = Maybe Ticket
forall a. Maybe a
Nothing
setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()
setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()
setPeerRecordSizeLimit Context
ctx Bool
tls13 (RecordSizeLimit Word16
n0) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
n0 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
64) (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
$
[Char] -> AlertDescription -> TLSError
Error_Protocol ([Char]
"too small recode size limit: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
n0) AlertDescription
IllegalParameter
let n1 :: Int
n1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n0
n2 :: Int
n2
| Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
protolim = Int
protolim
| Bool
otherwise = Int
n1
let lim :: Int
lim = if Bool
tls13 then Int
n2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
n2
Context -> Maybe Int -> IO ()
setPeerRecordLimit Context
ctx (Maybe Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
lim
where
protolim :: Int
protolim
| Bool
tls13 = Int
defaultRecordSizeLimit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
| Bool
otherwise = Int
defaultRecordSizeLimit