{-# LANGUAGE OverloadedStrings #-}

module Network.TLS.Context (
    -- * Context configuration
    TLSParams,

    -- * Context object and accessor
    Context (..),
    Hooks (..),
    Established (..),
    PendingRecv (..),
    RecordLayer (..),
    ctxEOF,
    ctxEstablished,
    withLog,
    ctxWithHooks,
    contextModifyHooks,
    setEOF,
    setEstablished,
    contextFlush,
    contextClose,
    contextSend,
    contextRecv,
    updateMeasure,
    withMeasure,
    withReadLock,
    tryWithReadLock,
    withWriteLock,
    withStateLock,
    withRWLock,

    -- * information
    Information (..),
    contextGetInformation,

    -- * New contexts
    contextNew,

    -- * Context hooks
    contextHookSetHandshakeRecv,
    contextHookSetHandshake13Recv,
    contextHookSetCertificateRecv,
    contextHookSetLogging,

    -- * Using context states
    throwCore,
    usingState,
    usingState_,
    runTxRecordState,
    runRxRecordState,
    usingHState,
    getHState,
    getStateRNG,
    tls13orLater,
    getTLSUnique,
    getTLSExporter,
    getTLSServerEndPoint,
    getFinished,
    getPeerFinished,
    TLS13State (..),
    getTLS13State,
    modifyTLS13State,
    setMyRecordLimit,
    enableMyRecordLimit,
    getMyRecordLimit,
    checkMyRecordLimit,
    setPeerRecordLimit,
    enablePeerRecordLimit,
    getPeerRecordLimit,
    checkPeerRecordLimit,
    newRecordLimitRef,
) where

import Control.Concurrent.MVar
import Control.Monad.State.Strict
import Data.IORef

import Network.TLS.Backend
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Handshake (
    handshakeClient,
    handshakeClientWith,
    handshakeServer,
    handshakeServerWith,
 )
import Network.TLS.Handshake.State13
import Network.TLS.Hooks
import Network.TLS.Imports
import Network.TLS.KeySchedule
import Network.TLS.Measurement
import Network.TLS.Packet
import Network.TLS.Parameters
import Network.TLS.PostHandshake (
    postHandshakeAuthClientWith,
    requestCertificateServer,
 )
import Network.TLS.RNG
import Network.TLS.Record.Recv
import Network.TLS.Record.Send
import Network.TLS.Record.State
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types (
    Role (..),
    TranscriptHash (..),
    defaultRecordSizeLimit,
 )
import Network.TLS.X509

class TLSParams a where
    getTLSCommonParams :: a -> CommonParams
    getTLSRole :: a -> Role
    doHandshake :: a -> Context -> IO ()
    doHandshakeWith :: a -> Context -> HandshakeR -> IO ()
    doRequestCertificate :: a -> Context -> IO Bool
    doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO ()

instance TLSParams ClientParams where
    getTLSCommonParams :: ClientParams -> CommonParams
getTLSCommonParams ClientParams
cparams =
        ( ClientParams -> Supported
clientSupported ClientParams
cparams
        , ClientParams -> Shared
clientShared ClientParams
cparams
        , ClientParams -> DebugParams
clientDebug ClientParams
cparams
        )
    getTLSRole :: ClientParams -> Role
getTLSRole ClientParams
_ = Role
ClientRole
    doHandshake :: ClientParams -> Context -> IO ()
doHandshake = ClientParams -> Context -> IO ()
handshakeClient
    doHandshakeWith :: ClientParams -> Context -> HandshakeR -> IO ()
doHandshakeWith = ClientParams -> Context -> HandshakeR -> IO ()
handshakeClientWith
    doRequestCertificate :: ClientParams -> Context -> IO Bool
doRequestCertificate ClientParams
_ Context
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    doPostHandshakeAuthWith :: ClientParams -> Context -> Handshake13 -> IO ()
doPostHandshakeAuthWith = ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith

instance TLSParams ServerParams where
    getTLSCommonParams :: ServerParams -> CommonParams
getTLSCommonParams ServerParams
sparams =
        ( ServerParams -> Supported
serverSupported ServerParams
sparams
        , ServerParams -> Shared
serverShared ServerParams
sparams
        , ServerParams -> DebugParams
serverDebug ServerParams
sparams
        )
    getTLSRole :: ServerParams -> Role
getTLSRole ServerParams
_ = Role
ServerRole
    doHandshake :: ServerParams -> Context -> IO ()
doHandshake = ServerParams -> Context -> IO ()
handshakeServer
    doHandshakeWith :: ServerParams -> Context -> HandshakeR -> IO ()
doHandshakeWith = ServerParams -> Context -> HandshakeR -> IO ()
handshakeServerWith
    doRequestCertificate :: ServerParams -> Context -> IO Bool
doRequestCertificate = ServerParams -> Context -> IO Bool
requestCertificateServer
    doPostHandshakeAuthWith :: ServerParams -> Context -> Handshake13 -> IO ()
doPostHandshakeAuthWith = \ServerParams
_ Context
_ Handshake13
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | create a new context using the backend and parameters specified.
contextNew
    :: (MonadIO m, HasBackend backend, TLSParams params)
    => backend
    -- ^ Backend abstraction with specific method to interact with the connection type.
    -> params
    -- ^ Parameters of the context.
    -> m Context
contextNew :: forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew backend
backend params
params = IO Context -> m Context
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Context -> m Context) -> IO Context -> m Context
forall a b. (a -> b) -> a -> b
$ do
    backend -> IO ()
forall a. HasBackend a => a -> IO ()
initializeBackend backend
backend

    let (Supported
supported, Shared
shared, DebugParams
debug) = params -> CommonParams
forall a. TLSParams a => a -> CommonParams
getTLSCommonParams params
params

    seed <- case DebugParams -> Maybe Seed
debugSeed DebugParams
debug of
        Maybe Seed
Nothing -> do
            seed <- IO Seed
forall (randomly :: * -> *). MonadRandom randomly => randomly Seed
seedNew
            debugPrintSeed debug seed
            return seed
        Just Seed
determ -> Seed -> IO Seed
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Seed
determ
    let rng = Seed -> StateRNG
newStateRNG Seed
seed

    let role = params -> Role
forall a. TLSParams a => a -> Role
getTLSRole params
params
        st = StateRNG -> Role -> TLSState
newTLSState StateRNG
rng Role
role

    tlsstate <- newMVar st
    eof <- newIORef False
    established <- newIORef NotEstablished
    stats <- newIORef newMeasurement
    needEmptyPacket <- newIORef False
    hooks <- newIORef defaultHooks
    tx <- newMVar newRecordState
    rx <- newMVar newRecordState
    hs <- newMVar Nothing
    recvActionsRef <- newIORef []
    sendActionRef <- newIORef Nothing
    locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar ()
    st13ref <- newIORef defaultTLS13State
    mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit
    peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit
    hpkeref <- newIORef Nothing
    let roleParams =
            RoleParams
                { doHandshake_ :: Context -> IO ()
doHandshake_ = params -> Context -> IO ()
forall a. TLSParams a => a -> Context -> IO ()
doHandshake params
params
                , doHandshakeWith_ :: Context -> HandshakeR -> IO ()
doHandshakeWith_ = params -> Context -> HandshakeR -> IO ()
forall a. TLSParams a => a -> Context -> HandshakeR -> IO ()
doHandshakeWith params
params
                , doRequestCertificate_ :: Context -> IO Bool
doRequestCertificate_ = params -> Context -> IO Bool
forall a. TLSParams a => a -> Context -> IO Bool
doRequestCertificate params
params
                , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO ()
doPostHandshakeAuthWith_ = params -> Context -> Handshake13 -> IO ()
forall a. TLSParams a => a -> Context -> Handshake13 -> IO ()
doPostHandshakeAuthWith params
params
                }

    let ctx =
            Context
                { ctxBackend :: Backend
ctxBackend = backend -> Backend
forall a. HasBackend a => a -> Backend
getBackend backend
backend
                , ctxShared :: Shared
ctxShared = Shared
shared
                , ctxSupported :: Supported
ctxSupported = Supported
supported
                , ctxDebug :: DebugParams
ctxDebug = DebugParams
debug
                , ctxTLSState :: MVar TLSState
ctxTLSState = MVar TLSState
tlsstate
                , ctxMyRecordLimit :: IORef RecordLimit
ctxMyRecordLimit = IORef RecordLimit
mylimref
                , ctxPeerRecordLimit :: IORef RecordLimit
ctxPeerRecordLimit = IORef RecordLimit
peerlimref
                , ctxTxRecordState :: MVar RecordState
ctxTxRecordState = MVar RecordState
tx
                , ctxRxRecordState :: MVar RecordState
ctxRxRecordState = MVar RecordState
rx
                , ctxHandshakeState :: MVar (Maybe HandshakeState)
ctxHandshakeState = MVar (Maybe HandshakeState)
hs
                , ctxRoleParams :: RoleParams
ctxRoleParams = RoleParams
roleParams
                , ctxMeasurement :: IORef Measurement
ctxMeasurement = IORef Measurement
stats
                , ctxEOF_ :: IORef Bool
ctxEOF_ = IORef Bool
eof
                , ctxEstablished_ :: IORef Established
ctxEstablished_ = IORef Established
established
                , ctxNeedEmptyPacket :: IORef Bool
ctxNeedEmptyPacket = IORef Bool
needEmptyPacket
                , ctxHooks :: IORef Hooks
ctxHooks = IORef Hooks
hooks
                , ctxLocks :: Locks
ctxLocks = Locks
locks
                , ctxPendingRecvActions :: IORef [PendingRecvAction]
ctxPendingRecvActions = IORef [PendingRecvAction]
recvActionsRef
                , ctxPendingSendAction :: IORef (Maybe (Context -> IO ()))
ctxPendingSendAction = IORef (Maybe (Context -> IO ()))
sendActionRef
                , ctxRecordLayer :: RecordLayer ByteString
ctxRecordLayer = RecordLayer ByteString
recordLayer
                , ctxHandshakeSync :: HandshakeSync
ctxHandshakeSync = (Context -> ClientState -> IO ())
-> (Context -> ServerState -> IO ()) -> HandshakeSync
HandshakeSync Context -> ClientState -> IO ()
forall {m :: * -> *} {p} {p}. Monad m => p -> p -> m ()
syncNoOp Context -> ServerState -> IO ()
forall {m :: * -> *} {p} {p}. Monad m => p -> p -> m ()
syncNoOp
                , ctxQUICMode :: Bool
ctxQUICMode = Bool
False
                , ctxTLS13State :: IORef TLS13State
ctxTLS13State = IORef TLS13State
st13ref
                , ctxHPKE :: IORef (Maybe (HPKEF, Int))
ctxHPKE = IORef (Maybe (HPKEF, Int))
hpkeref
                }

        syncNoOp p
_ p
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        recordLayer =
            RecordLayer
                { recordEncode12 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)
recordEncode12 = Context -> Record Plaintext -> IO (Either TLSError ByteString)
encodeRecord12
                , recordEncode13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)
recordEncode13 = Context -> Record Plaintext -> IO (Either TLSError ByteString)
encodeRecord13
                , recordSendBytes :: Context -> ByteString -> IO ()
recordSendBytes = Context -> ByteString -> IO ()
sendBytes
                , recordRecv12 :: Context -> IO (Either TLSError (Record Plaintext))
recordRecv12 = Context -> IO (Either TLSError (Record Plaintext))
recvRecord12
                , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext))
recordRecv13 = Context -> IO (Either TLSError (Record Plaintext))
recvRecord13
                }

    return ctx

contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
contextHookSetHandshakeRecv Context
context Handshake -> IO Handshake
f =
    Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks Context
context (\Hooks
hooks -> Hooks
hooks{hookRecvHandshake = f})

contextHookSetHandshake13Recv
    :: Context -> (Handshake13 -> IO Handshake13) -> IO ()
contextHookSetHandshake13Recv :: Context -> (Handshake13 -> IO Handshake13) -> IO ()
contextHookSetHandshake13Recv Context
context Handshake13 -> IO Handshake13
f =
    Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks Context
context (\Hooks
hooks -> Hooks
hooks{hookRecvHandshake13 = f})

contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO ()
contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO ()
contextHookSetCertificateRecv Context
context CertificateChain -> IO ()
f =
    Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks Context
context (\Hooks
hooks -> Hooks
hooks{hookRecvCertificates = f})

contextHookSetLogging :: Context -> Logging -> IO ()
contextHookSetLogging :: Context -> Logging -> IO ()
contextHookSetLogging Context
context Logging
loggingCallbacks =
    Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks Context
context (\Hooks
hooks -> Hooks
hooks{hookLogging = loggingCallbacks})

{-# DEPRECATED getFinished "Use getTLSUnique instead" #-}

-- | Getting TLS Finished sent to peer.
getFinished :: Context -> IO (Maybe VerifyData)
getFinished :: Context -> IO (Maybe VerifyData)
getFinished Context
ctx = Context -> TLSSt (Maybe VerifyData) -> IO (Maybe VerifyData)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe VerifyData)
getMyVerifyData

{-# DEPRECATED getPeerFinished "Use getTLSUnique instead" #-}

-- | Getting TLS Finished received from peer.
getPeerFinished :: Context -> IO (Maybe VerifyData)
getPeerFinished :: Context -> IO (Maybe VerifyData)
getPeerFinished Context
ctx = Context -> TLSSt (Maybe VerifyData) -> IO (Maybe VerifyData)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe VerifyData)
getPeerVerifyData

-- | Getting the "tls-unique" channel binding for TLS 1.2 (RFC5929).
--   For TLS 1.3, 'Nothing' is returned.
--   'supportedExtendedMainSecret' must be 'RequireEMS'
--   But in general, it is highly recommended to upgrade to TLS 1.3
--   and use the "tls-exporter" channel binding via 'getTLSExporter'.
getTLSUnique :: Context -> IO (Maybe ByteString)
getTLSUnique :: Context -> IO (Maybe ByteString)
getTLSUnique Context
ctx = do
    -- Nothing rather than error before a version has been negotiated: this
    -- can be called on a context whose handshake has not run, and it already
    -- answers with Maybe.
    mver <- IO (Maybe Version) -> IO (Maybe Version)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe Version) -> IO (Maybe Version)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Version)
getVersionMaybe
    if mver == Just TLS12
        then do
            mx <- usingState_ ctx getFirstVerifyData
            case mx of
                Maybe VerifyData
Nothing -> 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
                Just (VerifyData ByteString
verifyData) -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
verifyData
        else return Nothing

-- | Getting the "tls-exporter" channel binding for TLS 1.3 (RFC9266).
--   For TLS 1.2, 'Nothing' is returned.
getTLSExporter :: Context -> IO (Maybe ByteString)
getTLSExporter :: Context -> IO (Maybe ByteString)
getTLSExporter Context
ctx = do
    -- As in 'getTLSUnique'.
    mver <- IO (Maybe Version) -> IO (Maybe Version)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe Version) -> IO (Maybe Version)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Version)
getVersionMaybe
    if mver == Just TLS13
        then exporter ctx "EXPORTER-Channel-Binding" "" 32
        else return Nothing

exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString)
exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString)
exporter Context
ctx ByteString
label ByteString
context Int
outlen = do
    msecret <- Context -> TLSSt (Maybe Secret) -> IO (Maybe Secret)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Secret)
getTLS13ExporterSecret
    mcipher <- failOnEitherError $ runRxRecordState ctx $ gets stCipher
    return $ case (msecret, mcipher) of
        (Just Secret
secret, Just Cipher
cipher) ->
            let h :: Hash
h = Cipher -> Hash
cipherHash Cipher
cipher
                secret' :: Secret
secret' = Hash -> Secret -> ByteString -> TranscriptHash -> Secret
deriveSecret Hash
h Secret
secret ByteString
label (TranscriptHash -> Secret) -> TranscriptHash -> Secret
forall a b. (a -> b) -> a -> b
$ ByteString -> TranscriptHash
TranscriptHash ByteString
""
                label' :: ByteString
label' = ByteString
"exporter"
                value' :: ByteString
value' = Hash -> ByteString -> ByteString
forall ba. (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba
hash Hash
h ByteString
context
                key :: ByteString
key = Hash -> Secret -> ByteString -> ByteString -> Int -> ByteString
forall ba.
(ByteArray ba, ByteArrayAccess ba) =>
Hash -> Secret -> ByteString -> ByteString -> Int -> ba
hkdfExpandLabel Hash
h Secret
secret' ByteString
label' ByteString
value' Int
outlen
             in ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
key
        (Maybe Secret, Maybe Cipher)
_ -> Maybe ByteString
forall a. Maybe a
Nothing

-- | Getting the "tls-server-end-point" channel binding for TLS 1.2
--   (RFC5929).  For 1.3, there is no specifications for how to create
--   it.  In this implementation, a certificate chain without
--   extensions is hashed like TLS 1.2.
getTLSServerEndPoint :: Context -> IO (Maybe ByteString)
getTLSServerEndPoint :: Context -> IO (Maybe ByteString)
getTLSServerEndPoint Context
ctx = do
    mcc <- Context
-> TLSSt (Maybe CertificateChain) -> IO (Maybe CertificateChain)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe CertificateChain)
getServerCertificateChain
    case mcc of
        Maybe CertificateChain
Nothing -> 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
        Just CertificateChain
cc -> do
            (usedHash, _, _, _) <- Context -> IO (Hash, Cipher, CryptLevel, Secret)
getRxRecordState Context
ctx
            return $ Just $ hash usedHash $ encodeCertificate cc