{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Module      : Network.TLS.Context.Internal
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Context.Internal
    (
    -- * Context configuration
      ClientParams(..)
    , ServerParams(..)
    , defaultParamsClient
    , SessionID
    , SessionData(..)
    , MaxFragmentEnum(..)
    , Measurement(..)

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

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

    -- * Using context states
    , throwCore
    , failOnEitherError
    , usingState
    , usingState_
    , runTxState
    , runRxState
    , usingHState
    , getHState
    , saveHState
    , restoreHState
    , getStateRNG
    , tls13orLater
    , addCertRequest13
    , getCertRequest13
    , decideRecordVersion

    -- * Misc
    , HandshakeSync(..)
    ) where

import Network.TLS.Backend
import Network.TLS.Cipher
import Network.TLS.Compression (Compression)
import Network.TLS.Extension
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.State
import Network.TLS.Hooks
import Network.TLS.Imports
import Network.TLS.Measurement
import Network.TLS.Parameters
import Network.TLS.Record.Layer
import Network.TLS.Record.State
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Util

import Control.Concurrent.MVar
import Control.Exception (throwIO)
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Data.IORef
import Data.Tuple

-- | Information related to a running context, e.g. current cipher
data Information = Information
    { Information -> Version
infoVersion      :: Version
    , Information -> Cipher
infoCipher       :: Cipher
    , Information -> Compression
infoCompression  :: Compression
    , Information -> Maybe ByteString
infoMasterSecret :: Maybe ByteString
    , Information -> Bool
infoExtendedMasterSec   :: Bool
    , Information -> Maybe ClientRandom
infoClientRandom :: Maybe ClientRandom
    , Information -> Maybe ServerRandom
infoServerRandom :: Maybe ServerRandom
    , Information -> Maybe Group
infoNegotiatedGroup     :: Maybe Group
    , Information -> Maybe HandshakeMode13
infoTLS13HandshakeMode  :: Maybe HandshakeMode13
    , Information -> Bool
infoIsEarlyDataAccepted :: Bool
    } deriving (Int -> Information -> ShowS
[Information] -> ShowS
Information -> String
(Int -> Information -> ShowS)
-> (Information -> String)
-> ([Information] -> ShowS)
-> Show Information
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Information] -> ShowS
$cshowList :: [Information] -> ShowS
show :: Information -> String
$cshow :: Information -> String
showsPrec :: Int -> Information -> ShowS
$cshowsPrec :: Int -> Information -> ShowS
Show,Information -> Information -> Bool
(Information -> Information -> Bool)
-> (Information -> Information -> Bool) -> Eq Information
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Information -> Information -> Bool
$c/= :: Information -> Information -> Bool
== :: Information -> Information -> Bool
$c== :: Information -> Information -> Bool
Eq)

-- | A TLS Context keep tls specific state, parameters and backend information.
data Context = forall bytes . Monoid bytes => Context
    { Context -> Backend
ctxConnection       :: Backend   -- ^ return the backend object associated with this context
    , Context -> Supported
ctxSupported        :: Supported
    , Context -> Shared
ctxShared           :: Shared
    , Context -> MVar TLSState
ctxState            :: MVar TLSState
    , Context -> IORef Measurement
ctxMeasurement      :: IORef Measurement
    , Context -> IORef Bool
ctxEOF_             :: IORef Bool    -- ^ has the handle EOFed or not.
    , Context -> IORef Established
ctxEstablished_     :: IORef Established -- ^ has the handshake been done and been successful.
    , Context -> IORef Bool
ctxNeedEmptyPacket  :: IORef Bool    -- ^ empty packet workaround for CBC guessability.
    , Context -> IORef Bool
ctxSSLv2ClientHello :: IORef Bool    -- ^ enable the reception of compatibility SSLv2 client hello.
                                           -- the flag will be set to false regardless of its initial value
                                           -- after the first packet received.
    , Context -> Maybe Int
ctxFragmentSize     :: Maybe Int        -- ^ maximum size of plaintext fragments
    , Context -> MVar RecordState
ctxTxState          :: MVar RecordState -- ^ current tx state
    , Context -> MVar RecordState
ctxRxState          :: MVar RecordState -- ^ current rx state
    , Context -> MVar (Maybe HandshakeState)
ctxHandshake        :: MVar (Maybe HandshakeState) -- ^ optional handshake state
    , Context -> Context -> IO ()
ctxDoHandshake      :: Context -> IO ()
    , Context -> Context -> Handshake -> IO ()
ctxDoHandshakeWith  :: Context -> Handshake -> IO ()
    , Context -> Context -> IO Bool
ctxDoRequestCertificate :: Context -> IO Bool
    , Context -> Context -> Handshake13 -> IO ()
ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO ()
    , Context -> IORef Hooks
ctxHooks            :: IORef Hooks   -- ^ hooks for this context
    , Context -> MVar ()
ctxLockWrite        :: MVar ()       -- ^ lock to use for writing data (including updating the state)
    , Context -> MVar ()
ctxLockRead         :: MVar ()       -- ^ lock to use for reading data (including updating the state)
    , Context -> MVar ()
ctxLockState        :: MVar ()       -- ^ lock used during read/write when receiving and sending packet.
                                           -- it is usually nested in a write or read lock.
    , Context -> IORef [PendingAction]
ctxPendingActions   :: IORef [PendingAction]
    , Context -> IORef [Handshake13]
ctxCertRequests     :: IORef [Handshake13]  -- ^ pending PHA requests
    , Context -> String -> IO ()
ctxKeyLogger        :: String -> IO ()
    , ()
ctxRecordLayer      :: RecordLayer bytes
    , Context -> HandshakeSync
ctxHandshakeSync    :: HandshakeSync
    , Context -> Bool
ctxQUICMode         :: Bool
    }

data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ())
                                   (Context -> ServerState -> IO ())

updateRecordLayer :: Monoid bytes => RecordLayer bytes -> Context -> Context
updateRecordLayer :: RecordLayer bytes -> Context -> Context
updateRecordLayer RecordLayer bytes
recordLayer Context{Bool
Maybe Int
IORef Bool
IORef [Handshake13]
IORef [PendingAction]
IORef Measurement
IORef Hooks
IORef Established
MVar (Maybe HandshakeState)
MVar ()
MVar RecordState
MVar TLSState
Backend
RecordLayer bytes
Shared
Supported
HandshakeSync
String -> IO ()
Context -> IO Bool
Context -> IO ()
Context -> Handshake -> IO ()
Context -> Handshake13 -> IO ()
ctxQUICMode :: Bool
ctxHandshakeSync :: HandshakeSync
ctxRecordLayer :: RecordLayer bytes
ctxKeyLogger :: String -> IO ()
ctxCertRequests :: IORef [Handshake13]
ctxPendingActions :: IORef [PendingAction]
ctxLockState :: MVar ()
ctxLockRead :: MVar ()
ctxLockWrite :: MVar ()
ctxHooks :: IORef Hooks
ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO ()
ctxDoRequestCertificate :: Context -> IO Bool
ctxDoHandshakeWith :: Context -> Handshake -> IO ()
ctxDoHandshake :: Context -> IO ()
ctxHandshake :: MVar (Maybe HandshakeState)
ctxRxState :: MVar RecordState
ctxTxState :: MVar RecordState
ctxFragmentSize :: Maybe Int
ctxSSLv2ClientHello :: IORef Bool
ctxNeedEmptyPacket :: IORef Bool
ctxEstablished_ :: IORef Established
ctxEOF_ :: IORef Bool
ctxMeasurement :: IORef Measurement
ctxState :: MVar TLSState
ctxShared :: Shared
ctxSupported :: Supported
ctxConnection :: Backend
ctxQUICMode :: Context -> Bool
ctxHandshakeSync :: Context -> HandshakeSync
ctxRecordLayer :: ()
ctxKeyLogger :: Context -> String -> IO ()
ctxCertRequests :: Context -> IORef [Handshake13]
ctxPendingActions :: Context -> IORef [PendingAction]
ctxLockState :: Context -> MVar ()
ctxLockRead :: Context -> MVar ()
ctxLockWrite :: Context -> MVar ()
ctxHooks :: Context -> IORef Hooks
ctxDoPostHandshakeAuthWith :: Context -> Context -> Handshake13 -> IO ()
ctxDoRequestCertificate :: Context -> Context -> IO Bool
ctxDoHandshakeWith :: Context -> Context -> Handshake -> IO ()
ctxDoHandshake :: Context -> Context -> IO ()
ctxHandshake :: Context -> MVar (Maybe HandshakeState)
ctxRxState :: Context -> MVar RecordState
ctxTxState :: Context -> MVar RecordState
ctxFragmentSize :: Context -> Maybe Int
ctxSSLv2ClientHello :: Context -> IORef Bool
ctxNeedEmptyPacket :: Context -> IORef Bool
ctxEstablished_ :: Context -> IORef Established
ctxEOF_ :: Context -> IORef Bool
ctxMeasurement :: Context -> IORef Measurement
ctxState :: Context -> MVar TLSState
ctxShared :: Context -> Shared
ctxSupported :: Context -> Supported
ctxConnection :: Context -> Backend
..} =
    Context :: forall bytes.
Monoid bytes =>
Backend
-> Supported
-> Shared
-> MVar TLSState
-> IORef Measurement
-> IORef Bool
-> IORef Established
-> IORef Bool
-> IORef Bool
-> Maybe Int
-> MVar RecordState
-> MVar RecordState
-> MVar (Maybe HandshakeState)
-> (Context -> IO ())
-> (Context -> Handshake -> IO ())
-> (Context -> IO Bool)
-> (Context -> Handshake13 -> IO ())
-> IORef Hooks
-> MVar ()
-> MVar ()
-> MVar ()
-> IORef [PendingAction]
-> IORef [Handshake13]
-> (String -> IO ())
-> RecordLayer bytes
-> HandshakeSync
-> Bool
-> Context
Context { ctxRecordLayer :: RecordLayer bytes
ctxRecordLayer = RecordLayer bytes
recordLayer, Bool
Maybe Int
IORef Bool
IORef [Handshake13]
IORef [PendingAction]
IORef Measurement
IORef Hooks
IORef Established
MVar (Maybe HandshakeState)
MVar ()
MVar RecordState
MVar TLSState
Backend
Shared
Supported
HandshakeSync
String -> IO ()
Context -> IO Bool
Context -> IO ()
Context -> Handshake -> IO ()
Context -> Handshake13 -> IO ()
ctxQUICMode :: Bool
ctxHandshakeSync :: HandshakeSync
ctxKeyLogger :: String -> IO ()
ctxCertRequests :: IORef [Handshake13]
ctxPendingActions :: IORef [PendingAction]
ctxLockState :: MVar ()
ctxLockRead :: MVar ()
ctxLockWrite :: MVar ()
ctxHooks :: IORef Hooks
ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO ()
ctxDoRequestCertificate :: Context -> IO Bool
ctxDoHandshakeWith :: Context -> Handshake -> IO ()
ctxDoHandshake :: Context -> IO ()
ctxHandshake :: MVar (Maybe HandshakeState)
ctxRxState :: MVar RecordState
ctxTxState :: MVar RecordState
ctxFragmentSize :: Maybe Int
ctxSSLv2ClientHello :: IORef Bool
ctxNeedEmptyPacket :: IORef Bool
ctxEstablished_ :: IORef Established
ctxEOF_ :: IORef Bool
ctxMeasurement :: IORef Measurement
ctxState :: MVar TLSState
ctxShared :: Shared
ctxSupported :: Supported
ctxConnection :: Backend
ctxQUICMode :: Bool
ctxHandshakeSync :: HandshakeSync
ctxKeyLogger :: String -> IO ()
ctxCertRequests :: IORef [Handshake13]
ctxPendingActions :: IORef [PendingAction]
ctxLockState :: MVar ()
ctxLockRead :: MVar ()
ctxLockWrite :: MVar ()
ctxHooks :: IORef Hooks
ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO ()
ctxDoRequestCertificate :: Context -> IO Bool
ctxDoHandshakeWith :: Context -> Handshake -> IO ()
ctxDoHandshake :: Context -> IO ()
ctxHandshake :: MVar (Maybe HandshakeState)
ctxRxState :: MVar RecordState
ctxTxState :: MVar RecordState
ctxFragmentSize :: Maybe Int
ctxSSLv2ClientHello :: IORef Bool
ctxNeedEmptyPacket :: IORef Bool
ctxEstablished_ :: IORef Established
ctxEOF_ :: IORef Bool
ctxMeasurement :: IORef Measurement
ctxState :: MVar TLSState
ctxShared :: Shared
ctxSupported :: Supported
ctxConnection :: Backend
.. }

data Established = NotEstablished
                 | EarlyDataAllowed Int    -- remaining 0-RTT bytes allowed
                 | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip
                 | Established
                 deriving (Established -> Established -> Bool
(Established -> Established -> Bool)
-> (Established -> Established -> Bool) -> Eq Established
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Established -> Established -> Bool
$c/= :: Established -> Established -> Bool
== :: Established -> Established -> Bool
$c== :: Established -> Established -> Bool
Eq, Int -> Established -> ShowS
[Established] -> ShowS
Established -> String
(Int -> Established -> ShowS)
-> (Established -> String)
-> ([Established] -> ShowS)
-> Show Established
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Established] -> ShowS
$cshowList :: [Established] -> ShowS
show :: Established -> String
$cshow :: Established -> String
showsPrec :: Int -> Established -> ShowS
$cshowsPrec :: Int -> Established -> ShowS
Show)

data PendingAction
    = PendingAction Bool (Handshake13 -> IO ())
      -- ^ simple pending action
    | PendingActionHash Bool (ByteString -> Handshake13 -> IO ())
      -- ^ pending action taking transcript hash up to preceding message

updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx = IORef Measurement -> (Measurement -> Measurement) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef Measurement
ctxMeasurement Context
ctx)

withMeasure :: Context -> (Measurement -> IO a) -> IO a
withMeasure :: Context -> (Measurement -> IO a) -> IO a
withMeasure Context
ctx Measurement -> IO a
f = IORef Measurement -> IO Measurement
forall a. IORef a -> IO a
readIORef (Context -> IORef Measurement
ctxMeasurement Context
ctx) IO Measurement -> (Measurement -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Measurement -> IO a
f

-- | A shortcut for 'backendFlush . ctxConnection'.
contextFlush :: Context -> IO ()
contextFlush :: Context -> IO ()
contextFlush = Backend -> IO ()
backendFlush (Backend -> IO ()) -> (Context -> Backend) -> Context -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Backend
ctxConnection

-- | A shortcut for 'backendClose . ctxConnection'.
contextClose :: Context -> IO ()
contextClose :: Context -> IO ()
contextClose = Backend -> IO ()
backendClose (Backend -> IO ()) -> (Context -> Backend) -> Context -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Backend
ctxConnection

-- | Information about the current context
contextGetInformation :: Context -> IO (Maybe Information)
contextGetInformation :: Context -> IO (Maybe Information)
contextGetInformation Context
ctx = do
    Maybe Version
ver    <- Context -> TLSSt (Maybe Version) -> IO (Maybe Version)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Maybe Version) -> IO (Maybe Version))
-> TLSSt (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ (TLSState -> Maybe Version) -> TLSSt (Maybe Version)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TLSState -> Maybe Version
stVersion
    Maybe HandshakeState
hstate <- Context -> IO (Maybe HandshakeState)
forall (m :: * -> *).
MonadIO m =>
Context -> m (Maybe HandshakeState)
getHState Context
ctx
    let (Maybe ByteString
ms, Bool
ems, Maybe ClientRandom
cr, Maybe ServerRandom
sr, Maybe HandshakeMode13
hm13, Maybe Group
grp) =
            case Maybe HandshakeState
hstate of
                Just HandshakeState
st -> (HandshakeState -> Maybe ByteString
hstMasterSecret HandshakeState
st,
                            HandshakeState -> Bool
hstExtendedMasterSec HandshakeState
st,
                            ClientRandom -> Maybe ClientRandom
forall a. a -> Maybe a
Just (HandshakeState -> ClientRandom
hstClientRandom HandshakeState
st),
                            HandshakeState -> Maybe ServerRandom
hstServerRandom HandshakeState
st,
                            if Maybe Version
ver Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Maybe Version
forall a. a -> Maybe a
Just Version
TLS13 then HandshakeMode13 -> Maybe HandshakeMode13
forall a. a -> Maybe a
Just (HandshakeState -> HandshakeMode13
hstTLS13HandshakeMode HandshakeState
st) else Maybe HandshakeMode13
forall a. Maybe a
Nothing,
                            HandshakeState -> Maybe Group
hstNegotiatedGroup HandshakeState
st)
                Maybe HandshakeState
Nothing -> (Maybe ByteString
forall a. Maybe a
Nothing, Bool
False, Maybe ClientRandom
forall a. Maybe a
Nothing, Maybe ServerRandom
forall a. Maybe a
Nothing, Maybe HandshakeMode13
forall a. Maybe a
Nothing, Maybe Group
forall a. Maybe a
Nothing)
    (Maybe Cipher
cipher,Compression
comp) <- MVar RecordState -> IO RecordState
forall a. MVar a -> IO a
readMVar (Context -> MVar RecordState
ctxRxState Context
ctx) IO RecordState
-> (RecordState -> (Maybe Cipher, Compression))
-> IO (Maybe Cipher, Compression)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \RecordState
st -> (RecordState -> Maybe Cipher
stCipher RecordState
st, RecordState -> Compression
stCompression RecordState
st)
    let accepted :: Bool
accepted = case Maybe HandshakeState
hstate of
            Just HandshakeState
st -> HandshakeState -> RTT0Status
hstTLS13RTT0Status HandshakeState
st RTT0Status -> RTT0Status -> Bool
forall a. Eq a => a -> a -> Bool
== RTT0Status
RTT0Accepted
            Maybe HandshakeState
Nothing -> Bool
False
    case (Maybe Version
ver, Maybe Cipher
cipher) of
        (Just Version
v, Just Cipher
c) -> Maybe Information -> IO (Maybe Information)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Information -> IO (Maybe Information))
-> Maybe Information -> IO (Maybe Information)
forall a b. (a -> b) -> a -> b
$ Information -> Maybe Information
forall a. a -> Maybe a
Just (Information -> Maybe Information)
-> Information -> Maybe Information
forall a b. (a -> b) -> a -> b
$ Version
-> Cipher
-> Compression
-> Maybe ByteString
-> Bool
-> Maybe ClientRandom
-> Maybe ServerRandom
-> Maybe Group
-> Maybe HandshakeMode13
-> Bool
-> Information
Information Version
v Cipher
c Compression
comp Maybe ByteString
ms Bool
ems Maybe ClientRandom
cr Maybe ServerRandom
sr Maybe Group
grp Maybe HandshakeMode13
hm13 Bool
accepted
        (Maybe Version, Maybe Cipher)
_                -> Maybe Information -> IO (Maybe Information)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Information
forall a. Maybe a
Nothing

contextSend :: Context -> ByteString -> IO ()
contextSend :: Context -> ByteString -> IO ()
contextSend Context
c ByteString
b = Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
c (Int -> Measurement -> Measurement
addBytesSent (Int -> Measurement -> Measurement)
-> Int -> Measurement -> Measurement
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
b) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Backend -> ByteString -> IO ()
backendSend (Backend -> ByteString -> IO ()) -> Backend -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Backend
ctxConnection Context
c) ByteString
b

contextRecv :: Context -> Int -> IO ByteString
contextRecv :: Context -> Int -> IO ByteString
contextRecv Context
c Int
sz = Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
c (Int -> Measurement -> Measurement
addBytesReceived Int
sz) IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Backend -> Int -> IO ByteString
backendRecv (Backend -> Int -> IO ByteString)
-> Backend -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Context -> Backend
ctxConnection Context
c) Int
sz

ctxEOF :: Context -> IO Bool
ctxEOF :: Context -> IO Bool
ctxEOF Context
ctx = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Context -> IORef Bool
ctxEOF_ Context
ctx

ctxHasSSLv2ClientHello :: Context -> IO Bool
ctxHasSSLv2ClientHello :: Context -> IO Bool
ctxHasSSLv2ClientHello Context
ctx = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Context -> IORef Bool
ctxSSLv2ClientHello Context
ctx

ctxDisableSSLv2ClientHello :: Context -> IO ()
ctxDisableSSLv2ClientHello :: Context -> IO ()
ctxDisableSSLv2ClientHello Context
ctx = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef Bool
ctxSSLv2ClientHello Context
ctx) Bool
False

setEOF :: Context -> IO ()
setEOF :: Context -> IO ()
setEOF Context
ctx = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef Bool
ctxEOF_ Context
ctx) Bool
True

ctxEstablished :: Context -> IO Established
ctxEstablished :: Context -> IO Established
ctxEstablished Context
ctx = IORef Established -> IO Established
forall a. IORef a -> IO a
readIORef (IORef Established -> IO Established)
-> IORef Established -> IO Established
forall a b. (a -> b) -> a -> b
$ Context -> IORef Established
ctxEstablished_ Context
ctx

ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a
ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx Hooks -> IO a
f = IORef Hooks -> IO Hooks
forall a. IORef a -> IO a
readIORef (Context -> IORef Hooks
ctxHooks Context
ctx) IO Hooks -> (Hooks -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Hooks -> IO a
f

contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()
contextModifyHooks Context
ctx = IORef Hooks -> (Hooks -> Hooks) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Context -> IORef Hooks
ctxHooks Context
ctx)

setEstablished :: Context -> Established -> IO ()
setEstablished :: Context -> Established -> IO ()
setEstablished Context
ctx = IORef Established -> Established -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef Established
ctxEstablished_ Context
ctx)

withLog :: Context -> (Logging -> IO ()) -> IO ()
withLog :: Context -> (Logging -> IO ()) -> IO ()
withLog Context
ctx Logging -> IO ()
f = Context -> (Hooks -> IO ()) -> IO ()
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Logging -> IO ()
f (Logging -> IO ()) -> (Hooks -> Logging) -> Hooks -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hooks -> Logging
hookLogging)

throwCore :: MonadIO m => TLSError -> m a
throwCore :: TLSError -> m a
throwCore = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TLSError -> IO a) -> TLSError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLSError -> IO a
forall e a. Exception e => e -> IO a
throwIO

failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a
failOnEitherError :: m (Either TLSError a) -> m a
failOnEitherError m (Either TLSError a)
f = do
    Either TLSError a
ret <- m (Either TLSError a)
f
    case Either TLSError a
ret of
        Left TLSError
err -> TLSError -> m a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
err
        Right a
r  -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

usingState :: Context -> TLSSt a -> IO (Either TLSError a)
usingState :: Context -> TLSSt a -> IO (Either TLSError a)
usingState Context
ctx TLSSt a
f =
    MVar TLSState
-> (TLSState -> IO (TLSState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Context -> MVar TLSState
ctxState Context
ctx) ((TLSState -> IO (TLSState, Either TLSError a))
 -> IO (Either TLSError a))
-> (TLSState -> IO (TLSState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. (a -> b) -> a -> b
$ \TLSState
st ->
            let (Either TLSError a
a, TLSState
newst) = TLSSt a -> TLSState -> (Either TLSError a, TLSState)
forall a. TLSSt a -> TLSState -> (Either TLSError a, TLSState)
runTLSState TLSSt a
f TLSState
st
             in TLSState
newst TLSState
-> IO (TLSState, Either TLSError a)
-> IO (TLSState, Either TLSError a)
`seq` (TLSState, Either TLSError a) -> IO (TLSState, Either TLSError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TLSState
newst, Either TLSError a
a)

usingState_ :: Context -> TLSSt a -> IO a
usingState_ :: Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt a
f = IO (Either TLSError a) -> IO a
forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError (IO (Either TLSError a) -> IO a) -> IO (Either TLSError a) -> IO a
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt a -> IO (Either TLSError a)
forall a. Context -> TLSSt a -> IO (Either TLSError a)
usingState Context
ctx TLSSt a
f

usingHState :: MonadIO m => Context -> HandshakeM a -> m a
usingHState :: Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM a
f = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar (Maybe HandshakeState)
-> (Maybe HandshakeState -> IO (Maybe HandshakeState, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Context -> MVar (Maybe HandshakeState)
ctxHandshake Context
ctx) ((Maybe HandshakeState -> IO (Maybe HandshakeState, a)) -> IO a)
-> (Maybe HandshakeState -> IO (Maybe HandshakeState, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe HandshakeState
mst ->
    case Maybe HandshakeState
mst of
        Maybe HandshakeState
Nothing -> TLSError -> IO (Maybe HandshakeState, a)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (Maybe HandshakeState, a))
-> TLSError -> IO (Maybe HandshakeState, a)
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc String
"missing handshake"
        Just HandshakeState
st -> (Maybe HandshakeState, a) -> IO (Maybe HandshakeState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe HandshakeState, a) -> IO (Maybe HandshakeState, a))
-> (Maybe HandshakeState, a) -> IO (Maybe HandshakeState, a)
forall a b. (a -> b) -> a -> b
$ (a, Maybe HandshakeState) -> (Maybe HandshakeState, a)
forall a b. (a, b) -> (b, a)
swap (HandshakeState -> Maybe HandshakeState
forall a. a -> Maybe a
Just (HandshakeState -> Maybe HandshakeState)
-> (a, HandshakeState) -> (a, Maybe HandshakeState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeState -> HandshakeM a -> (a, HandshakeState)
forall a. HandshakeState -> HandshakeM a -> (a, HandshakeState)
runHandshake HandshakeState
st HandshakeM a
f)

getHState :: MonadIO m => Context -> m (Maybe HandshakeState)
getHState :: Context -> m (Maybe HandshakeState)
getHState Context
ctx = IO (Maybe HandshakeState) -> m (Maybe HandshakeState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HandshakeState) -> m (Maybe HandshakeState))
-> IO (Maybe HandshakeState) -> m (Maybe HandshakeState)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe HandshakeState) -> IO (Maybe HandshakeState)
forall a. MVar a -> IO a
readMVar (Context -> MVar (Maybe HandshakeState)
ctxHandshake Context
ctx)

saveHState :: Context -> IO (Saved (Maybe HandshakeState))
saveHState :: Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx = MVar (Maybe HandshakeState) -> IO (Saved (Maybe HandshakeState))
forall a. MVar a -> IO (Saved a)
saveMVar (Context -> MVar (Maybe HandshakeState)
ctxHandshake Context
ctx)

restoreHState :: Context
              -> Saved (Maybe HandshakeState)
              -> IO (Saved (Maybe HandshakeState))
restoreHState :: Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx = MVar (Maybe HandshakeState)
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
forall a. MVar a -> Saved a -> IO (Saved a)
restoreMVar (Context -> MVar (Maybe HandshakeState)
ctxHandshake Context
ctx)

decideRecordVersion :: Context -> IO (Version, Bool)
decideRecordVersion :: Context -> IO (Version, Bool)
decideRecordVersion Context
ctx = Context -> TLSSt (Version, Bool) -> IO (Version, Bool)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Version, Bool) -> IO (Version, Bool))
-> TLSSt (Version, Bool) -> IO (Version, Bool)
forall a b. (a -> b) -> a -> b
$ do
    Version
ver <- Version -> TLSSt Version
getVersionWithDefault ([Version] -> Version
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Version] -> Version) -> [Version] -> Version
forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
    Bool
hrr <- TLSSt Bool
getTLS13HRR
    -- For TLS 1.3, ver' is only used in ClientHello.
    -- The record version of the first ClientHello SHOULD be TLS 1.0.
    -- The record version of the second ClientHello MUST be TLS 1.2.
    let ver' :: Version
ver'
         | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13 = if Bool
hrr then Version
TLS12 else Version
TLS10
         | Bool
otherwise    = Version
ver
    (Version, Bool) -> TLSSt (Version, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
ver', Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13)

runTxState :: Context -> RecordM a -> IO (Either TLSError a)
runTxState :: Context -> RecordM a -> IO (Either TLSError a)
runTxState Context
ctx RecordM a
f = do
    (Version
ver, Bool
tls13) <- Context -> IO (Version, Bool)
decideRecordVersion Context
ctx
    let opt :: RecordOptions
opt = RecordOptions :: Version -> Bool -> RecordOptions
RecordOptions { recordVersion :: Version
recordVersion = Version
ver
                            , recordTLS13 :: Bool
recordTLS13   = Bool
tls13
                            }
    MVar RecordState
-> (RecordState -> IO (RecordState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Context -> MVar RecordState
ctxTxState Context
ctx) ((RecordState -> IO (RecordState, Either TLSError a))
 -> IO (Either TLSError a))
-> (RecordState -> IO (RecordState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. (a -> b) -> a -> b
$ \RecordState
st ->
        case RecordM a
-> RecordOptions -> RecordState -> Either TLSError (a, RecordState)
forall a.
RecordM a
-> RecordOptions -> RecordState -> Either TLSError (a, RecordState)
runRecordM RecordM a
f RecordOptions
opt RecordState
st of
            Left TLSError
err         -> (RecordState, Either TLSError a)
-> IO (RecordState, Either TLSError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordState
st, TLSError -> Either TLSError a
forall a b. a -> Either a b
Left TLSError
err)
            Right (a
a, RecordState
newSt) -> (RecordState, Either TLSError a)
-> IO (RecordState, Either TLSError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordState
newSt, a -> Either TLSError a
forall a b. b -> Either a b
Right a
a)

runRxState :: Context -> RecordM a -> IO (Either TLSError a)
runRxState :: Context -> RecordM a -> IO (Either TLSError a)
runRxState Context
ctx RecordM a
f = do
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    -- For 1.3, ver is just ignored. So, it is not necessary to convert ver.
    let opt :: RecordOptions
opt = RecordOptions :: Version -> Bool -> RecordOptions
RecordOptions { recordVersion :: Version
recordVersion = Version
ver
                            , recordTLS13 :: Bool
recordTLS13   = Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13
                            }
    MVar RecordState
-> (RecordState -> IO (RecordState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Context -> MVar RecordState
ctxRxState Context
ctx) ((RecordState -> IO (RecordState, Either TLSError a))
 -> IO (Either TLSError a))
-> (RecordState -> IO (RecordState, Either TLSError a))
-> IO (Either TLSError a)
forall a b. (a -> b) -> a -> b
$ \RecordState
st ->
        case RecordM a
-> RecordOptions -> RecordState -> Either TLSError (a, RecordState)
forall a.
RecordM a
-> RecordOptions -> RecordState -> Either TLSError (a, RecordState)
runRecordM RecordM a
f RecordOptions
opt RecordState
st of
            Left TLSError
err         -> (RecordState, Either TLSError a)
-> IO (RecordState, Either TLSError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordState
st, TLSError -> Either TLSError a
forall a b. a -> Either a b
Left TLSError
err)
            Right (a
a, RecordState
newSt) -> (RecordState, Either TLSError a)
-> IO (RecordState, Either TLSError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecordState
newSt, a -> Either TLSError a
forall a b. b -> Either a b
Right a
a)

getStateRNG :: Context -> Int -> IO ByteString
getStateRNG :: Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
n = Context -> TLSSt ByteString -> IO ByteString
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt ByteString -> IO ByteString)
-> TLSSt ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> TLSSt ByteString
genRandom Int
n

withReadLock :: Context -> IO a -> IO a
withReadLock :: Context -> IO a -> IO a
withReadLock Context
ctx IO a
f = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Context -> MVar ()
ctxLockRead Context
ctx) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
f)

withWriteLock :: Context -> IO a -> IO a
withWriteLock :: Context -> IO a -> IO a
withWriteLock Context
ctx IO a
f = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Context -> MVar ()
ctxLockWrite Context
ctx) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
f)

withRWLock :: Context -> IO a -> IO a
withRWLock :: Context -> IO a -> IO a
withRWLock Context
ctx IO a
f = Context -> IO a -> IO a
forall a. Context -> IO a -> IO a
withReadLock Context
ctx (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Context -> IO a -> IO a
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx IO a
f

withStateLock :: Context -> IO a -> IO a
withStateLock :: Context -> IO a -> IO a
withStateLock Context
ctx IO a
f = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Context -> MVar ()
ctxLockState Context
ctx) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
f)

tls13orLater :: MonadIO m => Context -> m Bool
tls13orLater :: Context -> m Bool
tls13orLater Context
ctx = do
    Either TLSError Version
ev <- IO (Either TLSError Version) -> m (Either TLSError Version)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either TLSError Version) -> m (Either TLSError Version))
-> IO (Either TLSError Version) -> m (Either TLSError Version)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt Version -> IO (Either TLSError Version)
forall a. Context -> TLSSt a -> IO (Either TLSError a)
usingState Context
ctx (TLSSt Version -> IO (Either TLSError Version))
-> TLSSt Version -> IO (Either TLSError Version)
forall a b. (a -> b) -> a -> b
$ Version -> TLSSt Version
getVersionWithDefault Version
TLS10 -- fixme
    Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case Either TLSError Version
ev of
               Left  TLSError
_ -> Bool
False
               Right Version
v -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13

addCertRequest13 :: Context -> Handshake13 -> IO ()
addCertRequest13 :: Context -> Handshake13 -> IO ()
addCertRequest13 Context
ctx Handshake13
certReq = IORef [Handshake13] -> ([Handshake13] -> [Handshake13]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Context -> IORef [Handshake13]
ctxCertRequests Context
ctx) (Handshake13
certReqHandshake13 -> [Handshake13] -> [Handshake13]
forall a. a -> [a] -> [a]
:)

getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13)
getCertRequest13 :: Context -> ByteString -> IO (Maybe Handshake13)
getCertRequest13 Context
ctx ByteString
context = do
    let ref :: IORef [Handshake13]
ref = Context -> IORef [Handshake13]
ctxCertRequests Context
ctx
    [Handshake13]
l <- IORef [Handshake13] -> IO [Handshake13]
forall a. IORef a -> IO a
readIORef IORef [Handshake13]
ref
    let ([Handshake13]
matched, [Handshake13]
others) = (Handshake13 -> Bool)
-> [Handshake13] -> ([Handshake13], [Handshake13])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(CertRequest13 ByteString
c [ExtensionRaw]
_) -> ByteString
context ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
c) [Handshake13]
l
    case [Handshake13]
matched of
        []          -> Maybe Handshake13 -> IO (Maybe Handshake13)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handshake13
forall a. Maybe a
Nothing
        (Handshake13
certReq:[Handshake13]
_) -> IORef [Handshake13] -> [Handshake13] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Handshake13]
ref [Handshake13]
others IO () -> IO (Maybe Handshake13) -> IO (Maybe Handshake13)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Handshake13 -> IO (Maybe Handshake13)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handshake13 -> Maybe Handshake13
forall a. a -> Maybe a
Just Handshake13
certReq)