{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.QUIC.Handshake where

import qualified Control.Exception as E
import Data.List (intersect)
import qualified Network.TLS as TLS
import Network.TLS.QUIC

import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Connector
import Network.QUIC.Crypto
import Network.QUIC.Imports
import Network.QUIC.Info
import Network.QUIC.Logger
import Network.QUIC.Parameters
import Network.QUIC.Qlog
import Network.QUIC.Recovery
import Network.QUIC.TLS
import Network.QUIC.Types

----------------------------------------------------------------

newtype HndState = HndState
    { HndState -> Int
hsRecvCnt :: Int -- number of 'recv' calls since last 'send'
    }

newHndStateRef :: IO (IORef HndState)
newHndStateRef :: IO (IORef HndState)
newHndStateRef = HndState -> IO (IORef HndState)
forall a. a -> IO (IORef a)
newIORef HndState{hsRecvCnt :: Int
hsRecvCnt = Int
0}

sendCompleted :: IORef HndState -> IO ()
sendCompleted :: IORef HndState -> IO ()
sendCompleted IORef HndState
hsr = IORef HndState -> (HndState -> HndState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'' IORef HndState
hsr ((HndState -> HndState) -> IO ())
-> (HndState -> HndState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HndState
hs -> HndState
hs{hsRecvCnt = 0}

recvCompleted :: IORef HndState -> IO Int
recvCompleted :: IORef HndState -> IO Int
recvCompleted IORef HndState
hsr = IORef HndState -> (HndState -> (HndState, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HndState
hsr ((HndState -> (HndState, Int)) -> IO Int)
-> (HndState -> (HndState, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \HndState
hs ->
    let cnt :: Int
cnt = HndState -> Int
hsRecvCnt HndState
hs in (HndState
hs{hsRecvCnt = cnt + 1}, Int
cnt)

rxLevelChanged :: IORef HndState -> IO ()
rxLevelChanged :: IORef HndState -> IO ()
rxLevelChanged = IORef HndState -> IO ()
sendCompleted

----------------------------------------------------------------

sendCryptoData :: Connection -> Output -> IO ()
sendCryptoData :: Connection -> Output -> IO ()
sendCryptoData = Connection -> Output -> IO ()
putOutput

recvCryptoData :: Connection -> IO Crypto
recvCryptoData :: Connection -> IO Crypto
recvCryptoData = Connection -> IO Crypto
takeCrypto

recvTLS
    :: Connection
    -> IORef HndState
    -> CryptLevel
    -> IO (Either TLS.TLSError ByteString)
recvTLS :: Connection
-> IORef HndState -> CryptLevel -> IO (Either TLSError ByteString)
recvTLS Connection
conn IORef HndState
hsr CryptLevel
level =
    case CryptLevel
level of
        CryptLevel
CryptInitial -> EncryptionLevel -> IO (Either TLSError ByteString)
go EncryptionLevel
InitialLevel
        CryptLevel
CryptMainSecret -> String -> IO (Either TLSError ByteString)
forall {b}. String -> IO (Either TLSError b)
failure String
"QUIC does not receive data < TLS 1.3"
        CryptLevel
CryptEarlySecret -> String -> IO (Either TLSError ByteString)
forall {b}. String -> IO (Either TLSError b)
failure String
"QUIC does not send early data with TLS library"
        CryptLevel
CryptHandshakeSecret -> EncryptionLevel -> IO (Either TLSError ByteString)
go EncryptionLevel
HandshakeLevel
        CryptLevel
CryptApplicationSecret -> EncryptionLevel -> IO (Either TLSError ByteString)
go EncryptionLevel
RTT1Level
  where
    failure :: String -> IO (Either TLSError b)
failure = Either TLSError b -> IO (Either TLSError b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError b -> IO (Either TLSError b))
-> (String -> Either TLSError b)
-> String
-> IO (Either TLSError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLSError -> Either TLSError b
forall a b. a -> Either a b
Left (TLSError -> Either TLSError b)
-> (String -> TLSError) -> String -> Either TLSError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TLSError
internalError

    go :: EncryptionLevel -> IO (Either TLSError ByteString)
go EncryptionLevel
expected = do
        InpHandshake EncryptionLevel
actual ByteString
bs <- Connection -> IO Crypto
recvCryptoData Connection
conn
        if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
""
            then
                Either TLSError ByteString -> IO (Either TLSError ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError ByteString -> IO (Either TLSError ByteString))
-> Either TLSError ByteString -> IO (Either TLSError ByteString)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError ByteString
forall a b. a -> Either a b
Left TLSError
TLS.Error_EOF
            else
                if EncryptionLevel
actual EncryptionLevel -> EncryptionLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= EncryptionLevel
expected
                    then
                        String -> IO (Either TLSError ByteString)
forall {b}. String -> IO (Either TLSError b)
failure (String -> IO (Either TLSError ByteString))
-> String -> IO (Either TLSError ByteString)
forall a b. (a -> b) -> a -> b
$
                            String
"encryption level mismatch: expected "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ EncryptionLevel -> String
forall a. Show a => a -> String
show EncryptionLevel
expected
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ EncryptionLevel -> String
forall a. Show a => a -> String
show EncryptionLevel
actual
                    else do
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
forall a. Connector a => a -> Bool
isClient Connection
conn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Int
n <- IORef HndState -> IO Int
recvCompleted IORef HndState
hsr
                            -- Sending ACKs for three times rule
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                Connection -> Output -> IO ()
sendCryptoData Connection
conn (Output -> IO ()) -> Output -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    EncryptionLevel -> [Frame] -> Output
OutControl EncryptionLevel
HandshakeLevel []
                        Either TLSError ByteString -> IO (Either TLSError ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError ByteString -> IO (Either TLSError ByteString))
-> Either TLSError ByteString -> IO (Either TLSError ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either TLSError ByteString
forall a b. b -> Either a b
Right ByteString
bs

sendTLS :: Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO ()
sendTLS :: Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO ()
sendTLS Connection
conn IORef HndState
hsr [(CryptLevel, ByteString)]
x = do
    ((CryptLevel, ByteString) -> IO (EncryptionLevel, ByteString))
-> [(CryptLevel, ByteString)] -> IO [(EncryptionLevel, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CryptLevel, ByteString) -> IO (EncryptionLevel, ByteString)
forall {b}. (CryptLevel, b) -> IO (EncryptionLevel, b)
convertLevel [(CryptLevel, ByteString)]
x IO [(EncryptionLevel, ByteString)]
-> ([(EncryptionLevel, ByteString)] -> 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
>>= Connection -> Output -> IO ()
sendCryptoData Connection
conn (Output -> IO ())
-> ([(EncryptionLevel, ByteString)] -> Output)
-> [(EncryptionLevel, ByteString)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(EncryptionLevel, ByteString)] -> Output
OutHandshake
    IORef HndState -> IO ()
sendCompleted IORef HndState
hsr
  where
    convertLevel :: (CryptLevel, b) -> IO (EncryptionLevel, b)
convertLevel (CryptLevel
CryptInitial, b
bs) = (EncryptionLevel, b) -> IO (EncryptionLevel, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncryptionLevel
InitialLevel, b
bs)
    convertLevel (CryptLevel
CryptMainSecret, b
_) = String -> IO (EncryptionLevel, b)
forall a. String -> IO a
errorTLS String
"QUIC does not send data < TLS 1.3"
    convertLevel (CryptLevel
CryptEarlySecret, b
_) = String -> IO (EncryptionLevel, b)
forall a. String -> IO a
errorTLS String
"QUIC does not receive early data with TLS library"
    convertLevel (CryptLevel
CryptHandshakeSecret, b
bs) = (EncryptionLevel, b) -> IO (EncryptionLevel, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncryptionLevel
HandshakeLevel, b
bs)
    convertLevel (CryptLevel
CryptApplicationSecret, b
bs) = (EncryptionLevel, b) -> IO (EncryptionLevel, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EncryptionLevel
RTT1Level, b
bs)

internalError :: String -> TLS.TLSError
internalError :: String -> TLSError
internalError String
msg = String -> AlertDescription -> TLSError
TLS.Error_Protocol String
msg AlertDescription
TLS.InternalError

----------------------------------------------------------------

handshakeClient :: ClientConfig -> Connection -> AuthCIDs -> IO (IO ())
handshakeClient :: ClientConfig -> Connection -> AuthCIDs -> IO (IO ())
handshakeClient ClientConfig
conf Connection
conn AuthCIDs
myAuthCIDs = do
    Connection -> (Parameters, String) -> IO ()
forall q. KeepQlog q => q -> (Parameters, String) -> IO ()
qlogParamsSet Connection
conn (ClientConfig -> Parameters
ccParameters ClientConfig
conf, String
"local") -- fixme
    ClientConfig
-> Connection -> AuthCIDs -> Version -> IORef HndState -> IO ()
handshakeClient' ClientConfig
conf Connection
conn AuthCIDs
myAuthCIDs (Version -> IORef HndState -> IO ())
-> IO Version -> IO (IORef HndState -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Version
getVersion Connection
conn IO (IORef HndState -> IO ()) -> IO (IORef HndState) -> IO (IO ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (IORef HndState)
newHndStateRef

handshakeClient'
    :: ClientConfig -> Connection -> AuthCIDs -> Version -> IORef HndState -> IO ()
handshakeClient' :: ClientConfig
-> Connection -> AuthCIDs -> Version -> IORef HndState -> IO ()
handshakeClient' ClientConfig
conf Connection
conn AuthCIDs
myAuthCIDs Version
ver IORef HndState
hsr = IO ()
handshaker
  where
    handshaker :: IO ()
handshaker =
        QUICCallbacks
-> ClientConfig
-> Version
-> AuthCIDs
-> SessionEstablish
-> Bool
-> IO ()
clientHandshaker QUICCallbacks
qc ClientConfig
conf Version
ver AuthCIDs
myAuthCIDs SessionEstablish
setter Bool
use0RTT
            IO () -> (TLSException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` Connection -> TLSException -> IO ()
sendCCTLSError Connection
conn
    qc :: QUICCallbacks
qc =
        QUICCallbacks
            { quicSend :: [(CryptLevel, ByteString)] -> IO ()
quicSend = Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO ()
sendTLS Connection
conn IORef HndState
hsr
            , quicRecv :: CryptLevel -> IO (Either TLSError ByteString)
quicRecv = Connection
-> IORef HndState -> CryptLevel -> IO (Either TLSError ByteString)
recvTLS Connection
conn IORef HndState
hsr
            , quicInstallKeys :: Context -> KeyScheduleEvent -> IO ()
quicInstallKeys = Context -> KeyScheduleEvent -> IO ()
installKeysClient
            , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO ()
quicNotifyExtensions = Connection -> Context -> [ExtensionRaw] -> IO ()
setPeerParams Connection
conn
            , quicDone :: Context -> IO ()
quicDone = Context -> IO ()
forall {p}. p -> IO ()
done
            }
    setter :: SessionEstablish
setter = Connection -> SessionEstablish
setResumptionSession Connection
conn
    installKeysClient :: Context -> KeyScheduleEvent -> IO ()
installKeysClient Context
_ctx (InstallEarlyKeys Maybe EarlySecretInfo
Nothing) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    installKeysClient Context
_ctx (InstallEarlyKeys (Just (EarlySecretInfo Cipher
cphr ClientTrafficSecret EarlySecret
cts))) = do
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
RTT0Level Cipher
cphr
        Connection
-> EncryptionLevel -> TrafficSecrets EarlySecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
RTT0Level (ClientTrafficSecret EarlySecret
cts, ByteString -> ServerTrafficSecret EarlySecret
forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
"")
        Connection -> IO ()
setConnection0RTTReady Connection
conn
    installKeysClient Context
_ctx (InstallHandshakeKeys (HandshakeSecretInfo Cipher
cphr TrafficSecrets HandshakeSecret
tss)) = do
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
HandshakeLevel Cipher
cphr
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
RTT1Level Cipher
cphr
        Connection
-> EncryptionLevel -> TrafficSecrets HandshakeSecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
HandshakeLevel TrafficSecrets HandshakeSecret
tss
        Connection -> EncryptionLevel -> IO ()
setEncryptionLevel Connection
conn EncryptionLevel
HandshakeLevel
        IORef HndState -> IO ()
rxLevelChanged IORef HndState
hsr
    installKeysClient Context
ctx (InstallApplicationKeys appSecInf :: ApplicationSecretInfo
appSecInf@(ApplicationSecretInfo TrafficSecrets ApplicationSecret
tss)) = do
        Connection -> Context -> ApplicationSecretInfo -> IO ()
storeNegotiated Connection
conn Context
ctx ApplicationSecretInfo
appSecInf
        Connection -> TrafficSecrets ApplicationSecret -> IO ()
initializeCoder1RTT Connection
conn TrafficSecrets ApplicationSecret
tss
        Connection -> EncryptionLevel -> IO ()
setEncryptionLevel Connection
conn EncryptionLevel
RTT1Level
        IORef HndState -> IO ()
rxLevelChanged IORef HndState
hsr
        Connection -> IO ()
setConnection1RTTReady Connection
conn
        CIDInfo
cidInfo <- Connection -> IO CIDInfo
getNewMyCID Connection
conn
        Connection -> Output -> IO ()
putOutput Connection
conn (Output -> IO ()) -> Output -> IO ()
forall a b. (a -> b) -> a -> b
$ [(EncryptionLevel, ByteString)] -> Output
OutHandshake [] -- for h3spec testing
        Connection -> EncryptionLevel -> [Frame] -> IO ()
sendFrames Connection
conn EncryptionLevel
RTT1Level [CIDInfo -> Int -> Frame
NewConnectionID CIDInfo
cidInfo Int
0]
    done :: p -> IO ()
done p
_ctx = do
        -- Validating Chosen Version
        Maybe VersionInfo
mPeerVerInfo <- Parameters -> Maybe VersionInfo
versionInformation (Parameters -> Maybe VersionInfo)
-> IO Parameters -> IO (Maybe VersionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Parameters
getPeerParameters Connection
conn
        case Maybe VersionInfo
mPeerVerInfo of
            Maybe VersionInfo
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just VersionInfo
peerVerInfo -> do
                Version
hdrVer <- Connection -> IO Version
getVersion Connection
conn
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
hdrVer Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= VersionInfo -> Version
chosenVersion VersionInfo
peerVerInfo) IO ()
sendCCVNError
        ConnectionInfo
info <- Connection -> IO ConnectionInfo
getConnectionInfo Connection
conn
        Connection -> DebugLogger
connDebugLog Connection
conn DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ ConnectionInfo -> Builder
forall a. Show a => a -> Builder
bhow ConnectionInfo
info
    use0RTT :: Bool
use0RTT = ClientConfig -> Bool
ccUse0RTT ClientConfig
conf

----------------------------------------------------------------

handshakeServer
    :: ServerConfig -> Connection -> AuthCIDs -> StatelessResetToken -> IO (IO ())
handshakeServer :: ServerConfig
-> Connection -> AuthCIDs -> StatelessResetToken -> IO (IO ())
handshakeServer ServerConfig
conf Connection
conn AuthCIDs
myAuthCIDs StatelessResetToken
srt =
    ServerConfig
-> Connection
-> Version
-> IORef HndState
-> IORef Parameters
-> IO ()
handshakeServer' ServerConfig
conf Connection
conn
        (Version -> IORef HndState -> IORef Parameters -> IO ())
-> IO Version -> IO (IORef HndState -> IORef Parameters -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Version
getVersion Connection
conn
        IO (IORef HndState -> IORef Parameters -> IO ())
-> IO (IORef HndState) -> IO (IORef Parameters -> IO ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (IORef HndState)
newHndStateRef
        IO (IORef Parameters -> IO ())
-> IO (IORef Parameters) -> IO (IO ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parameters -> IO (IORef Parameters)
forall a. a -> IO (IORef a)
newIORef Parameters
params
  where
    params :: Parameters
params =
        (AuthCIDs -> Parameters -> Parameters
setCIDsToParameters AuthCIDs
myAuthCIDs (Parameters -> Parameters) -> Parameters -> Parameters
forall a b. (a -> b) -> a -> b
$ ServerConfig -> Parameters
scParameters ServerConfig
conf)
            { statelessResetToken = Just srt
            }

handshakeServer'
    :: ServerConfig
    -> Connection
    -> Version
    -> IORef HndState
    -> IORef Parameters
    -> IO ()
handshakeServer' :: ServerConfig
-> Connection
-> Version
-> IORef HndState
-> IORef Parameters
-> IO ()
handshakeServer' ServerConfig
conf Connection
conn Version
ver IORef HndState
hsRef IORef Parameters
paramRef = IO ()
handshaker
  where
    handshaker :: IO ()
handshaker =
        QUICCallbacks -> ServerConfig -> Version -> IO Parameters -> IO ()
serverHandshaker QUICCallbacks
qc ServerConfig
conf Version
ver IO Parameters
getParams
            IO () -> (TLSException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` Connection -> TLSException -> IO ()
sendCCTLSError Connection
conn
    qc :: QUICCallbacks
qc =
        QUICCallbacks
            { quicSend :: [(CryptLevel, ByteString)] -> IO ()
quicSend = Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO ()
sendTLS Connection
conn IORef HndState
hsRef
            , quicRecv :: CryptLevel -> IO (Either TLSError ByteString)
quicRecv = Connection
-> IORef HndState -> CryptLevel -> IO (Either TLSError ByteString)
recvTLS Connection
conn IORef HndState
hsRef
            , quicInstallKeys :: Context -> KeyScheduleEvent -> IO ()
quicInstallKeys = Context -> KeyScheduleEvent -> IO ()
installKeysServer
            , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO ()
quicNotifyExtensions = Connection -> Context -> [ExtensionRaw] -> IO ()
setPeerParams Connection
conn
            , quicDone :: Context -> IO ()
quicDone = Context -> IO ()
done
            }
    installKeysServer :: Context -> KeyScheduleEvent -> IO ()
installKeysServer Context
_ctx (InstallEarlyKeys Maybe EarlySecretInfo
Nothing) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    installKeysServer Context
_ctx (InstallEarlyKeys (Just (EarlySecretInfo Cipher
cphr ClientTrafficSecret EarlySecret
cts))) = do
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
RTT0Level Cipher
cphr
        Connection
-> EncryptionLevel -> TrafficSecrets EarlySecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
RTT0Level (ClientTrafficSecret EarlySecret
cts, ByteString -> ServerTrafficSecret EarlySecret
forall a. ByteString -> ServerTrafficSecret a
ServerTrafficSecret ByteString
"")
        Connection -> IO ()
setConnection0RTTReady Connection
conn
    installKeysServer Context
_ctx (InstallHandshakeKeys (HandshakeSecretInfo Cipher
cphr TrafficSecrets HandshakeSecret
tss)) = do
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
HandshakeLevel Cipher
cphr
        Connection -> EncryptionLevel -> Cipher -> IO ()
setCipher Connection
conn EncryptionLevel
RTT1Level Cipher
cphr
        Connection
-> EncryptionLevel -> TrafficSecrets HandshakeSecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
HandshakeLevel TrafficSecrets HandshakeSecret
tss
        Connection -> EncryptionLevel -> IO ()
setEncryptionLevel Connection
conn EncryptionLevel
HandshakeLevel
        IORef HndState -> IO ()
rxLevelChanged IORef HndState
hsRef
    installKeysServer Context
ctx (InstallApplicationKeys appSecInf :: ApplicationSecretInfo
appSecInf@(ApplicationSecretInfo TrafficSecrets ApplicationSecret
tss)) = do
        Connection -> Context -> ApplicationSecretInfo -> IO ()
storeNegotiated Connection
conn Context
ctx ApplicationSecretInfo
appSecInf
        Connection -> TrafficSecrets ApplicationSecret -> IO ()
initializeCoder1RTT Connection
conn TrafficSecrets ApplicationSecret
tss
    -- will switch to RTT1Level after client Finished
    -- is received and verified
    done :: Context -> IO ()
done Context
ctx = do
        Connection -> EncryptionLevel -> IO ()
setEncryptionLevel Connection
conn EncryptionLevel
RTT1Level
        Context -> IO (Maybe CertificateChain)
TLS.getClientCertificateChain Context
ctx IO (Maybe CertificateChain)
-> (Maybe CertificateChain -> 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
>>= Connection -> Maybe CertificateChain -> IO ()
setCertificateChain Connection
conn
        Connection -> Microseconds -> IO () -> IO ()
fire Connection
conn (Int -> Microseconds
Microseconds Int
100000) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let ldcc :: LDCC
ldcc = Connection -> LDCC
connLDCC Connection
conn
            Bool
discarded0 <- LDCC -> EncryptionLevel -> IO Bool
getAndSetPacketNumberSpaceDiscarded LDCC
ldcc EncryptionLevel
RTT0Level
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
discarded0 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> EncryptionLevel -> IO ()
dropSecrets Connection
conn EncryptionLevel
RTT0Level
            Bool
discarded1 <- LDCC -> EncryptionLevel -> IO Bool
getAndSetPacketNumberSpaceDiscarded LDCC
ldcc EncryptionLevel
HandshakeLevel
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
discarded1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Connection -> EncryptionLevel -> IO ()
dropSecrets Connection
conn EncryptionLevel
HandshakeLevel
                LDCC -> EncryptionLevel -> IO ()
onPacketNumberSpaceDiscarded (Connection -> LDCC
connLDCC Connection
conn) EncryptionLevel
HandshakeLevel
            Connection -> EncryptionLevel -> IO ()
clearCryptoStream Connection
conn EncryptionLevel
HandshakeLevel
            Connection -> EncryptionLevel -> IO ()
clearCryptoStream Connection
conn EncryptionLevel
RTT1Level
        Connection -> IO ()
setConnection1RTTReady Connection
conn
        Connection -> IO ()
setConnectionEstablished Connection
conn
        Connection -> IO ConnectionInfo
getConnectionInfo Connection
conn IO ConnectionInfo -> (ConnectionInfo -> 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
>>= Hooks -> ConnectionInfo -> IO ()
onConnectionEstablished (Connection -> Hooks
connHooks Connection
conn)
        --        sendFrames conn RTT1Level [HandshakeDone]
        --
        ConnectionInfo
info <- Connection -> IO ConnectionInfo
getConnectionInfo Connection
conn
        Connection -> DebugLogger
connDebugLog Connection
conn DebugLogger -> DebugLogger
forall a b. (a -> b) -> a -> b
$ ConnectionInfo -> Builder
forall a. Show a => a -> Builder
bhow ConnectionInfo
info
    getParams :: IO Parameters
getParams = do
        Parameters
params <- IORef Parameters -> IO Parameters
forall a. IORef a -> IO a
readIORef IORef Parameters
paramRef
        VersionInfo
verInfo <- Connection -> IO VersionInfo
getVersionInfo Connection
conn
        Parameters -> IO Parameters
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Parameters
params{versionInformation = Just verInfo}

----------------------------------------------------------------

setPeerParams :: Connection -> TLS.Context -> [ExtensionRaw] -> IO ()
setPeerParams :: Connection -> Context -> [ExtensionRaw] -> IO ()
setPeerParams Connection
conn Context
_ctx [ExtensionRaw]
peerExts = do
    ExtensionID
tpId <- Version -> ExtensionID
extensionIDForTtransportParameter (Version -> ExtensionID) -> IO Version -> IO ExtensionID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Version
getVersion Connection
conn
    case ExtensionID -> [ExtensionRaw] -> Maybe ExtensionRaw
forall {t :: * -> *}.
Foldable t =>
ExtensionID -> t ExtensionRaw -> Maybe ExtensionRaw
getTP ExtensionID
tpId [ExtensionRaw]
peerExts of
        Maybe ExtensionRaw
Nothing ->
            Connection -> AlertDescription -> ReasonPhrase -> IO ()
sendCCTLSAlert Connection
conn AlertDescription
TLS.MissingExtension ReasonPhrase
"QUIC transport parameters are mssing"
        Just (ExtensionRaw ExtensionID
_ ByteString
bs) -> ByteString -> IO ()
setPP ByteString
bs
  where
    getTP :: ExtensionID -> t ExtensionRaw -> Maybe ExtensionRaw
getTP ExtensionID
n = (ExtensionRaw -> Bool) -> t ExtensionRaw -> Maybe ExtensionRaw
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(ExtensionRaw ExtensionID
extid ByteString
_) -> ExtensionID
extid ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
n)
    setPP :: ByteString -> IO ()
setPP ByteString
bs = case ByteString -> Maybe Parameters
decodeParameters ByteString
bs of
        Maybe Parameters
Nothing -> IO ()
sendCCParamError
        Just Parameters
params -> do
            Parameters -> IO ()
checkAuthCIDs Parameters
params
            Parameters -> IO ()
checkInvalid Parameters
params
            Parameters -> IO ()
setParams Parameters
params
            Connection -> (Parameters, String) -> IO ()
forall q. KeepQlog q => q -> (Parameters, String) -> IO ()
qlogParamsSet Connection
conn (Parameters
params, String
"remote")
            if Connection -> Bool
forall a. Connector a => a -> Bool
isClient Connection
conn
                then
                    Connection -> Parameters -> IO ()
setResumptionParameters Connection
conn Parameters
params
                else
                    Maybe VersionInfo -> IO ()
serverVersionNegotiation (Maybe VersionInfo -> IO ()) -> Maybe VersionInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe VersionInfo
versionInformation Parameters
params

    checkAuthCIDs :: Parameters -> IO ()
checkAuthCIDs Parameters
params = do
        AuthCIDs
peerAuthCIDs <- Connection -> IO AuthCIDs
getPeerAuthCIDs Connection
conn
        Maybe CID -> Maybe CID -> IO ()
forall {a}. Eq a => Maybe a -> Maybe a -> IO ()
ensure (Parameters -> Maybe CID
initialSourceConnectionId Parameters
params) (Maybe CID -> IO ()) -> Maybe CID -> IO ()
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
initSrcCID AuthCIDs
peerAuthCIDs
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
forall a. Connector a => a -> Bool
isClient Connection
conn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe CID -> Maybe CID -> IO ()
forall {a}. Eq a => Maybe a -> Maybe a -> IO ()
ensure (Parameters -> Maybe CID
originalDestinationConnectionId Parameters
params) (Maybe CID -> IO ()) -> Maybe CID -> IO ()
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
origDstCID AuthCIDs
peerAuthCIDs
            Maybe CID -> Maybe CID -> IO ()
forall {a}. Eq a => Maybe a -> Maybe a -> IO ()
ensure (Parameters -> Maybe CID
retrySourceConnectionId Parameters
params) (Maybe CID -> IO ()) -> Maybe CID -> IO ()
forall a b. (a -> b) -> a -> b
$ AuthCIDs -> Maybe CID
retrySrcCID AuthCIDs
peerAuthCIDs
    ensure :: Maybe a -> Maybe a -> IO ()
ensure Maybe a
_ Maybe a
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ensure Maybe a
v0 Maybe a
v1
        | Maybe a
v0 Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
v1 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = IO ()
sendCCParamError
    checkInvalid :: Parameters -> IO ()
checkInvalid Parameters
params = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Parameters -> Int
maxUdpPayloadSize Parameters
params Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1200) IO ()
sendCCParamError
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Parameters -> Int
ackDelayExponent Parameters
params Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20) IO ()
sendCCParamError
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Parameters -> Milliseconds
maxAckDelay Parameters
params Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
>= Milliseconds
2 Milliseconds -> Int -> Milliseconds
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
14 :: Int)) IO ()
sendCCParamError
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Parameters -> Int
activeConnectionIdLimit Parameters
params Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) IO ()
sendCCParamError
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
forall a. Connector a => a -> Bool
isServer Connection
conn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CID -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CID -> Bool) -> Maybe CID -> Bool
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe CID
originalDestinationConnectionId Parameters
params) IO ()
sendCCParamError
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe ByteString
preferredAddress Parameters
params) IO ()
sendCCParamError
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CID -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CID -> Bool) -> Maybe CID -> Bool
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe CID
retrySourceConnectionId Parameters
params) IO ()
sendCCParamError
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe StatelessResetToken -> Bool
forall a. Maybe a -> Bool
isJust (Maybe StatelessResetToken -> Bool)
-> Maybe StatelessResetToken -> Bool
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe StatelessResetToken
statelessResetToken Parameters
params) IO ()
sendCCParamError
        let vi :: VersionInfo
vi = case Parameters -> Maybe VersionInfo
versionInformation Parameters
params of
                Maybe VersionInfo
Nothing -> Version -> [Version] -> VersionInfo
VersionInfo Version
Version1 [Version
Version1]
                Just VersionInfo
vi0 -> VersionInfo
vi0
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VersionInfo
vi VersionInfo -> VersionInfo -> Bool
forall a. Eq a => a -> a -> Bool
== VersionInfo
brokenVersionInfo) IO ()
sendCCParamError
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
Negotiation Version -> [Version] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` VersionInfo -> [Version]
otherVersions VersionInfo
vi) IO ()
sendCCParamError
        -- Always False for servers
        Bool
isICVN <- Connection -> IO Bool
getIncompatibleVN Connection
conn
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isICVN (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            -- Validating Other Version fields.
            VersionInfo
verInfo <- Connection -> IO VersionInfo
getVersionInfo Connection
conn
            let myVer :: Version
myVer = VersionInfo -> Version
chosenVersion VersionInfo
verInfo
                myVers :: [Version]
myVers = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Bool
isGreasingVersion) ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ VersionInfo -> [Version]
otherVersions VersionInfo
verInfo
                peerVers :: [Version]
peerVers = VersionInfo -> [Version]
otherVersions VersionInfo
vi
            case [Version]
myVers [Version] -> [Version] -> [Version]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Version]
peerVers of
                Version
ver : [Version]
_ | Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
myVer -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [Version]
_ -> IO ()
sendCCVNError

    setParams :: Parameters -> IO ()
setParams Parameters
params = do
        Connection -> Parameters -> IO ()
setPeerParameters Connection
conn Parameters
params
        (StatelessResetToken -> IO ())
-> Maybe StatelessResetToken -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> StatelessResetToken -> IO ()
setPeerStatelessResetToken Connection
conn) (Maybe StatelessResetToken -> IO ())
-> Maybe StatelessResetToken -> IO ()
forall a b. (a -> b) -> a -> b
$ Parameters -> Maybe StatelessResetToken
statelessResetToken Parameters
params
        Connection -> Int -> IO ()
setTxMaxData Connection
conn (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Parameters -> Int
initialMaxData Parameters
params
        -- My 'maxIdleTimeout' is already set 'minIdleTimeout'
        -- This selects the minimum of mine and peer's.
        Connection -> Microseconds -> IO ()
setMinIdleTimeout Connection
conn (Microseconds -> IO ()) -> Microseconds -> IO ()
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Microseconds
milliToMicro (Milliseconds -> Microseconds) -> Milliseconds -> Microseconds
forall a b. (a -> b) -> a -> b
$ Parameters -> Milliseconds
maxIdleTimeout Parameters
params
        LDCC -> Microseconds -> IO ()
setMaxAckDaley (Connection -> LDCC
connLDCC Connection
conn) (Microseconds -> IO ()) -> Microseconds -> IO ()
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Microseconds
milliToMicro (Milliseconds -> Microseconds) -> Milliseconds -> Microseconds
forall a b. (a -> b) -> a -> b
$ Parameters -> Milliseconds
maxAckDelay Parameters
params
        Connection -> Int -> IO ()
setTxMaxStreams Connection
conn (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Parameters -> Int
initialMaxStreamsBidi Parameters
params
        Connection -> Int -> IO ()
setTxUniMaxStreams Connection
conn (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Parameters -> Int
initialMaxStreamsUni Parameters
params

    serverVersionNegotiation :: Maybe VersionInfo -> IO ()
serverVersionNegotiation Maybe VersionInfo
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    serverVersionNegotiation (Just VersionInfo
peerVerInfo) = do
        VersionInfo
myVerInfo <- Connection -> IO VersionInfo
getVersionInfo Connection
conn
        let clientVer :: Version
clientVer = VersionInfo -> Version
chosenVersion VersionInfo
myVerInfo
            myVers :: [Version]
myVers = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Bool
isGreasingVersion) ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ VersionInfo -> [Version]
otherVersions VersionInfo
myVerInfo
            peerVers :: [Version]
peerVers = VersionInfo -> [Version]
otherVersions VersionInfo
peerVerInfo
        -- Server's preference should be preferred.
        case [Version]
myVers [Version] -> [Version] -> [Version]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Version]
peerVers of
            vers :: [Version]
vers@(Version
serverVer : [Version]
_)
                | Version
clientVer Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
serverVer -> do
                    Connection -> VersionInfo -> IO ()
setVersionInfo Connection
conn (VersionInfo -> IO ()) -> VersionInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> [Version] -> VersionInfo
VersionInfo Version
serverVer [Version]
vers
                    CID
dcid <- Connection -> IO CID
getClientDstCID Connection
conn
                    Connection
-> EncryptionLevel -> TrafficSecrets InitialSecret -> IO ()
forall a.
Connection -> EncryptionLevel -> TrafficSecrets a -> IO ()
initializeCoder Connection
conn EncryptionLevel
InitialLevel (TrafficSecrets InitialSecret -> IO ())
-> TrafficSecrets InitialSecret -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> CID -> TrafficSecrets InitialSecret
initialSecrets Version
serverVer CID
dcid
                    Connection -> Debug -> IO ()
forall q. KeepQlog q => q -> Debug -> IO ()
qlogDebug Connection
conn (Debug -> IO ()) -> Debug -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> Debug
Debug LogStr
"Version changed"
            [Version]
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

storeNegotiated :: Connection -> TLS.Context -> ApplicationSecretInfo -> IO ()
storeNegotiated :: Connection -> Context -> ApplicationSecretInfo -> IO ()
storeNegotiated Connection
conn Context
ctx ApplicationSecretInfo
appSecInf = do
    Maybe ByteString
appPro <- Context -> IO (Maybe ByteString)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
TLS.getNegotiatedProtocol Context
ctx
    Maybe Information
minfo <- Context -> IO (Maybe Information)
TLS.contextGetInformation Context
ctx
    let mode :: HandshakeMode13
mode = HandshakeMode13 -> Maybe HandshakeMode13 -> HandshakeMode13
forall a. a -> Maybe a -> a
fromMaybe HandshakeMode13
FullHandshake (Maybe Information
minfo Maybe Information
-> (Information -> Maybe HandshakeMode13) -> Maybe HandshakeMode13
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Information -> Maybe HandshakeMode13
TLS.infoTLS13HandshakeMode)
    Connection
-> HandshakeMode13
-> Maybe ByteString
-> ApplicationSecretInfo
-> IO ()
setNegotiated Connection
conn HandshakeMode13
mode Maybe ByteString
appPro ApplicationSecretInfo
appSecInf

----------------------------------------------------------------

sendCCParamError :: IO ()
sendCCParamError :: IO ()
sendCCParamError = InternalControl -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InternalControl
WrongTransportParameter

sendCCVNError :: IO ()
sendCCVNError :: IO ()
sendCCVNError = InternalControl -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO InternalControl
WrongVersionInformation

sendCCTLSError :: Connection -> TLS.TLSException -> IO ()
sendCCTLSError :: Connection -> TLSException -> IO ()
sendCCTLSError Connection
conn (TLS.HandshakeFailed (TLS.Error_Misc String
"WrongTransportParameter")) = Connection -> TransportError -> ReasonPhrase -> IO ()
closeConnection Connection
conn TransportError
TransportParameterError ReasonPhrase
"Transport parameter error"
sendCCTLSError Connection
conn (TLS.HandshakeFailed (TLS.Error_Misc String
"WrongVersionInformation")) = Connection -> TransportError -> ReasonPhrase -> IO ()
closeConnection Connection
conn TransportError
VersionNegotiationError ReasonPhrase
"Version negotiation error"
sendCCTLSError Connection
conn TLSException
e = Connection -> TransportError -> ReasonPhrase -> IO ()
closeConnection Connection
conn TransportError
err ReasonPhrase
msg
  where
    tlserr :: TLSError
tlserr = TLSException -> TLSError
getErrorCause TLSException
e
    err :: TransportError
err = AlertDescription -> TransportError
cryptoError (AlertDescription -> TransportError)
-> AlertDescription -> TransportError
forall a b. (a -> b) -> a -> b
$ TLSError -> AlertDescription
errorToAlertDescription TLSError
tlserr
    msg :: ReasonPhrase
msg = String -> ReasonPhrase
shortpack (String -> ReasonPhrase) -> String -> ReasonPhrase
forall a b. (a -> b) -> a -> b
$ TLSError -> String
errorToAlertMessage TLSError
tlserr

sendCCTLSAlert :: Connection -> TLS.AlertDescription -> ReasonPhrase -> IO ()
sendCCTLSAlert :: Connection -> AlertDescription -> ReasonPhrase -> IO ()
sendCCTLSAlert Connection
conn AlertDescription
a ReasonPhrase
msg = Connection -> TransportError -> ReasonPhrase -> IO ()
closeConnection Connection
conn (AlertDescription -> TransportError
cryptoError AlertDescription
a) ReasonPhrase
msg

getErrorCause :: TLS.TLSException -> TLS.TLSError
getErrorCause :: TLSException -> TLSError
getErrorCause (TLS.Terminated Bool
_ String
_ TLSError
e) = TLSError
e
getErrorCause (TLS.HandshakeFailed TLSError
e) = TLSError
e
getErrorCause (TLS.PostHandshake TLSError
e) = TLSError
e
getErrorCause (TLS.Uncontextualized TLSError
e) = TLSError
e
getErrorCause TLSException
e =
    let msg :: String
msg = String
"unexpected TLS exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TLSException -> String
forall a. Show a => a -> String
show TLSException
e
     in String -> AlertDescription -> TLSError
TLS.Error_Protocol String
msg AlertDescription
TLS.InternalError