{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.TLS.Handshake.Common (
    handshakeFailed,
    handleException,
    unexpected,
    newSession,
    handshakeDone12,
    ensureNullCompression,
    ticketOrSessionID12,

    -- * sending packets
    sendCCSandFinished,

    -- * receiving packets
    RecvState (..),
    runRecvState,
    runRecvStateHS,
    recvPacketHandshake,
    onRecvStateHandshake,
    ensureRecvComplete,
    processExtendedMainSecret,
    extensionLookup,
    getSessionData,
    storePrivInfo,
    isSupportedGroup,
    checkSupportedGroup,
    errorToAlert,
    errorToAlertMessage,
    expectFinished,
    processCertificate,
) 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. 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
    -- If the error was an Uncontextualized TLSException, we replace the
    -- context with HandshakeFailed. If it's anything else, we convert
    -- it to a string and wrap it with Error_Misc and HandshakeFailed.
    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
_ -> String -> TLSError
Error_Misc (SomeException -> String
forall a. Show a => a -> String
show SomeException
exception)
    Established
established <- Context -> IO Established
ctxEstablished Context
ctx
    Context -> Established -> IO ()
setEstablished Context
ctx Established
NotEstablished
    (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO ()
ignoreIOErr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
        if Bool
tls13
            then do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
EarlyDataSending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
clearTxRecordState Context
ctx
                Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
tlserror]
            else Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet
Alert [TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
tlserror]
    TLSError -> IO ()
handshakeFailed TLSError
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 String
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Fatal, AlertDescription
ad)
errorToAlert (Error_Protocol_Warning String
_ AlertDescription
ad) = (AlertLevel
AlertLevel_Warning, AlertDescription
ad)
errorToAlert (Error_Packet_unexpected String
_ String
_) = (AlertLevel
AlertLevel_Fatal, AlertDescription
UnexpectedMessage)
errorToAlert (Error_Packet_Parsing String
msg)
    | String
"invalid version" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
ProtocolVersion)
    | String
"request_update" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg = (AlertLevel
AlertLevel_Fatal, AlertDescription
IllegalParameter)
    | Bool
otherwise = (AlertLevel
AlertLevel_Fatal, AlertDescription
DecodeError)
errorToAlert TLSError
_ = (AlertLevel
AlertLevel_Fatal, AlertDescription
InternalError)

-- | Return the message that a TLS endpoint can add to its local log for the
-- specified library error.
errorToAlertMessage :: TLSError -> String
errorToAlertMessage :: TLSError -> String
errorToAlertMessage (Error_Protocol String
msg AlertDescription
_) = String
msg
errorToAlertMessage (Error_Protocol_Warning String
msg AlertDescription
_) = String
msg
errorToAlertMessage (Error_Packet_unexpected String
msg String
_) = String
msg
errorToAlertMessage (Error_Packet_Parsing String
msg) = String
msg
errorToAlertMessage TLSError
e = TLSError -> String
forall a. Show a => a -> String
show TLSError
e

unexpected :: MonadIO m => String -> Maybe String -> m a
unexpected :: forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
msg Maybe String
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
$ String -> String -> TLSError
Error_Packet_unexpected String
msg (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
" expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) Maybe String
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

-- | when a new handshake is done, wrap up & clean up.
handshakeDone12 :: Context -> IO ()
handshakeDone12 :: Context -> IO ()
handshakeDone12 Context
ctx = do
    -- forget most handshake data and reset bytes counters.
    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
    -- mark the secure connection up and running.
    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
    Ticket
verifyData <-
        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
    Context -> Packet -> IO ()
sendPacket12 Context
ctx ([Handshake] -> Packet
Handshake [Ticket -> Handshake
Finished Ticket
verifyData])
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ticket -> TLSSt ()
setVerifyDataForSend Ticket
verifyData
    Context -> IO ()
contextFlush Context
ctx

data RecvState m
    = RecvStatePacket (Packet -> m (RecvState m)) -- CCS is not Handshake
    | RecvStateHandshake (Handshake -> m (RecvState m))
    | RecvStateDone

recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake :: Context -> IO [Handshake]
recvPacketHandshake Context
ctx = do
    Either TLSError Packet
pkts <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
    case Either TLSError Packet
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
            -- If a TLS13 server decides to reject RTT0 data, the server should
            -- skip records for RTT0 data up to the maximum limit.
            Established
established <- Context -> IO Established
ctxEstablished Context
ctx
            case Established
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
_ -> String -> Maybe String -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet -> String
forall a. Show a => a -> String
show Packet
x) (String -> Maybe String
forall a. a -> Maybe a
Just String
"handshake")
        Right Packet
x -> String -> Maybe String -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet -> String
forall a. Show a => a -> String
show Packet
x) (String -> Maybe String
forall a. a -> Maybe a
Just String
"handshake")
        Left TLSError
err -> TLSError -> IO [Handshake]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
err

-- | process a list of handshakes message in the recv state machine.
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
    RecvState IO
nstate <- Handshake -> IO (RecvState IO)
f Handshake
x
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
finished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO ()
processHandshake12 Context
ctx Handshake
x
    Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx RecvState IO
nstate [Handshake]
xs
onRecvStateHandshake Context
_ RecvState IO
RecvStateDone [Handshake]
_xs = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected String
"spurious handshake" Maybe String
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
    Bool
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
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
complete (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
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"received incomplete message at key change" AlertDescription
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 = String -> m Bool
forall a. HasCallStack => String -> a
error String
"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 =
        case ExtensionID -> [ExtensionRaw] -> Maybe Ticket
extensionLookup ExtensionID
EID_ExtendedMainSecret [ExtensionRaw]
exts Maybe Ticket
-> (Ticket -> Maybe ExtendedMainSecret) -> Maybe ExtendedMainSecret
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> Ticket -> Maybe ExtendedMainSecret
forall a. Extension a => MessageType -> Ticket -> Maybe a
extensionDecode MessageType
msgt of
            Just ExtendedMainSecret
ExtendedMainSecret -> Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (Bool -> HandshakeM ()
setExtendedMainSecret Bool
True) m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Maybe ExtendedMainSecret
Nothing
                | EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS -> TLSError -> m Bool
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m Bool) -> TLSError -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> AlertDescription -> TLSError
Error_Protocol String
err AlertDescription
HandshakeFailure
                | Bool
otherwise -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMainSecret (Context -> Supported
ctxSupported Context
ctx)
    err :: String
err = String
"peer does not support Extended Main Secret"

getSessionData :: Context -> IO (Maybe SessionData)
getSessionData :: Context -> IO (Maybe SessionData)
getSessionData Context
ctx = do
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Maybe String
sni <- Context -> TLSSt (Maybe String) -> IO (Maybe String)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe String)
getClientSNI
    Maybe Ticket
mms <- Context -> HandshakeM (Maybe Ticket) -> IO (Maybe Ticket)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM (Maybe Ticket) -> IO (Maybe Ticket))
-> HandshakeM (Maybe Ticket) -> IO (Maybe Ticket)
forall a b. (a -> b) -> a -> b
$ (HandshakeState -> Maybe Ticket) -> HandshakeM (Maybe Ticket)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Maybe Ticket
hstMainSecret
    Bool
ems <- Context -> HandshakeM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getExtendedMainSecret
    CipherID
cipher <- Cipher -> CipherID
cipherID (Cipher -> CipherID) -> IO Cipher -> IO CipherID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    Maybe Ticket
alpn <- Context -> TLSSt (Maybe Ticket) -> IO (Maybe Ticket)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Ticket)
getNegotiatedProtocol
    let compression :: CompressionID
compression = CompressionID
0
        flags :: [SessionFlag]
flags = [SessionFlag
SessionEMS | Bool
ems]
    case Maybe Ticket
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 :: CipherID
sessionCipher = CipherID
cipher
                        , sessionCompression :: CompressionID
sessionCompression = CompressionID
compression
                        , sessionClientSNI :: Maybe String
sessionClientSNI = Maybe String
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
                        }

extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe Ticket
extensionLookup ExtensionID
toFind =
    (ExtensionRaw -> Ticket) -> Maybe ExtensionRaw -> Maybe Ticket
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ExtensionRaw ExtensionID
_ Ticket
content) -> Ticket
content)
        (Maybe ExtensionRaw -> Maybe Ticket)
-> ([ExtensionRaw] -> Maybe ExtensionRaw)
-> [ExtensionRaw]
-> Maybe Ticket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtensionRaw -> Bool) -> [ExtensionRaw] -> Maybe ExtensionRaw
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(ExtensionRaw ExtensionID
eid Ticket
_) -> ExtensionID
eid ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
toFind)

-- | Store the specified keypair.  Whether the public key and private key
-- actually match is left for the peer to discover.  We're not presently
-- burning  CPU to detect that misconfiguration.  We verify only that the
-- types of keys match and that it does not include an algorithm that would
-- not be safe.
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
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"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
_ = String -> SignedExact Certificate
forall a. HasCallStack => String -> a
error String
"fromCC"

-- verify that the group selected by the peer is supported in the local
-- configuration
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 :: String
msg = String
"unsupported (EC)DHE group: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Group -> String
forall a. Show a => a -> String
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
$ String -> AlertDescription -> TLSError
Error_Protocol String
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
$
            String -> AlertDescription -> TLSError
Error_Protocol String
"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 Ticket
verifyData) = do
    Context -> Ticket -> IO ()
processFinished Context
ctx Ticket
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 = 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
"Handshake Finished")

processFinished :: Context -> VerifyData -> IO ()
processFinished :: Context -> Ticket -> IO ()
processFinished Context
ctx Ticket
verifyData = do
    (Role
cc, Version
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
    Ticket
expected <- 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 -> HandshakeM Ticket) -> Role -> HandshakeM Ticket
forall a b. (a -> b) -> a -> b
$ Role -> Role
invertRole Role
cc
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ticket
expected Ticket -> Ticket -> Bool
forall a. Eq a => a -> a -> Bool
/= Ticket
verifyData) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"cannot verify finished"
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ticket -> TLSSt ()
setVerifyDataForRecv Ticket
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
$ String -> AlertDescription -> TLSError
Error_Protocol String
"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

-- TLS 1.2 distinguishes session ID and session ticket.  session
-- ticket. Session ticket is prioritized over session ID.
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