{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
-- |
-- Module      : Network.TLS.Core
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Core
    (
    -- * Internal packet sending and receiving
      sendPacket
    , recvPacket

    -- * Initialisation and Termination of context
    , bye
    , handshake

    -- * Application Layer Protocol Negotiation
    , getNegotiatedProtocol

    -- * Server Name Indication
    , getClientSNI

    -- * High level API
    , sendData
    , recvData
    , recvData'
    , updateKey
    , KeyUpdateRequest(..)
    , requestCertificate
    ) where

import Network.TLS.Cipher
import Network.TLS.Context
import Network.TLS.Crypto
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.State (getSession)
import Network.TLS.Parameters
import Network.TLS.IO
import Network.TLS.Session
import Network.TLS.Handshake
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.PostHandshake
import Network.TLS.KeySchedule
import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret)
import Network.TLS.Util (catchException, mapChunks_)
import Network.TLS.Extension
import qualified Network.TLS.State as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import           Control.Monad (unless, when)
import qualified Control.Exception as E

import Control.Monad.State.Strict

-- | notify the context that this side wants to close connection.
-- this is important that it is called before closing the handle, otherwise
-- the session might not be resumable (for version < TLS1.2).
--
-- this doesn't actually close the handle
bye :: MonadIO m => Context -> m ()
bye :: Context -> m ()
bye Context
ctx = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Although setEOF is always protected by the read lock, here we don't try
    -- to wrap ctxEOF with it, so that function bye can still be called
    -- concurrently to a blocked recvData.
    Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
eof (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        if Bool
tls13 then
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]
          else
            Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet
Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]

-- | If the ALPN extensions have been used, this will
-- return get the protocol agreed upon.
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
getNegotiatedProtocol :: Context -> m (Maybe ByteString)
getNegotiatedProtocol Context
ctx = IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe ByteString) -> IO (Maybe ByteString)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
S.getNegotiatedProtocol

-- | If the Server Name Indication extension has been used, return the
-- hostname specified by the client.
getClientSNI :: MonadIO m => Context -> m (Maybe HostName)
getClientSNI :: Context -> m (Maybe HostName)
getClientSNI Context
ctx = IO (Maybe HostName) -> m (Maybe HostName)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HostName) -> m (Maybe HostName))
-> IO (Maybe HostName) -> m (Maybe HostName)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
S.getClientSNI

-- | sendData sends a bunch of data.
-- It will automatically chunk data to acceptable packet size
sendData :: MonadIO m => Context -> L.ByteString -> m ()
sendData :: Context -> ByteString -> m ()
sendData Context
ctx ByteString
dataToSend = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    let sendP :: ByteString -> IO ()
sendP
          | Bool
tls13     = Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ())
-> (ByteString -> Packet13) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet13
AppData13
          | Bool
otherwise = Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ()) -> (ByteString -> Packet) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet
AppData
    Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Context -> IO ()
checkValid Context
ctx
        -- All chunks are protected with the same write lock because we don't
        -- want to interleave writes from other threads in the middle of our
        -- possibly large write.
        let len :: Maybe Int
len = Context -> Maybe Int
ctxFragmentSize Context
ctx
        (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Int -> (ByteString -> IO ()) -> ByteString -> IO ()
forall (m :: * -> *) a.
Monad m =>
Maybe Int -> (ByteString -> m a) -> ByteString -> m ()
mapChunks_ Maybe Int
len ByteString -> IO ()
sendP) (ByteString -> [ByteString]
L.toChunks ByteString
dataToSend)

-- | Get data out of Data packet, and automatically renegotiate if a Handshake
-- ClientHello is received.  An empty result means EOF.
recvData :: MonadIO m => Context -> m B.ByteString
recvData :: Context -> m ByteString
recvData Context
ctx = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Context -> IO ByteString -> IO ByteString
forall a. Context -> IO a -> IO a
withReadLock Context
ctx (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        Context -> IO ()
checkValid Context
ctx
        -- We protect with a read lock both reception and processing of the
        -- packet, because don't want another thread to receive a new packet
        -- before this one has been fully processed.
        --
        -- Even when recvData1/recvData13 loops, we only need to call function
        -- checkValid once.  Since we hold the read lock, no concurrent call
        -- will impact the validity of the context.
        if Bool
tls13 then Context -> IO ByteString
recvData13 Context
ctx else Context -> IO ByteString
recvData1 Context
ctx

recvData1 :: Context -> IO B.ByteString
recvData1 :: Context -> IO ByteString
recvData1 Context
ctx = do
    Either TLSError Packet
pkt <- Context -> IO (Either TLSError Packet)
recvPacket Context
ctx
    (TLSError -> IO ByteString)
-> (Packet -> IO ByteString)
-> Either TLSError Packet
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TLSError
 -> AlertLevel -> AlertDescription -> HostName -> IO ByteString)
-> TLSError -> IO ByteString
forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate) Packet -> IO ByteString
process Either TLSError Packet
pkt
  where process :: Packet -> IO ByteString
process (Handshake [ch :: Handshake
ch@ClientHello{}]) =
            Context -> Handshake -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
ch IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData1 Context
ctx
        process (Handshake [hr :: Handshake
hr@Handshake
HelloRequest]) =
            Context -> Handshake -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
hr IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData1 Context
ctx

        process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
        process (Alert [(AlertLevel
AlertLevel_Fatal, AlertDescription
desc)]) = do
            Context -> IO ()
setEOF Context
ctx
            TLSException -> IO ByteString
forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ AlertDescription -> HostName
forall a. Show a => a -> HostName
show AlertDescription
desc) ((HostName, Bool, AlertDescription) -> TLSError
Error_Protocol (HostName
"remote side fatal error", Bool
True, AlertDescription
desc)))

        -- when receiving empty appdata, we just retry to get some data.
        process (AppData ByteString
"") = Context -> IO ByteString
recvData1 Context
ctx
        process (AppData ByteString
x)  = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
        process Packet
p            = let reason :: HostName
reason = HostName
"unexpected message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Packet -> HostName
forall a. Show a => a -> HostName
show Packet
p in
                               TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

        terminate :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate = Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ())
-> ([(AlertLevel, AlertDescription)] -> Packet)
-> [(AlertLevel, AlertDescription)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AlertLevel, AlertDescription)] -> Packet
Alert)

recvData13 :: Context -> IO B.ByteString
recvData13 :: Context -> IO ByteString
recvData13 Context
ctx = do
    Either TLSError Packet13
pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
    (TLSError -> IO ByteString)
-> (Packet13 -> IO ByteString)
-> Either TLSError Packet13
-> IO ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TLSError
 -> AlertLevel -> AlertDescription -> HostName -> IO ByteString)
-> TLSError -> IO ByteString
forall (m :: * -> *).
Monad m =>
(TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate) Packet13 -> IO ByteString
process Either TLSError Packet13
pkt
  where process :: Packet13 -> IO ByteString
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
        process (Alert13 [(AlertLevel
AlertLevel_Fatal, AlertDescription
desc)]) = do
            Context -> IO ()
setEOF Context
ctx
            TLSException -> IO ByteString
forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ AlertDescription -> HostName
forall a. Show a => a -> HostName
show AlertDescription
desc) ((HostName, Bool, AlertDescription) -> TLSError
Error_Protocol (HostName
"remote side fatal error", Bool
True, AlertDescription
desc)))
        process (Handshake13 [Handshake13]
hs) = do
            [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
            Context -> IO ByteString
recvData13 Context
ctx
        -- when receiving empty appdata, we just retry to get some data.
        process (AppData13 ByteString
"") = Context -> IO ByteString
recvData13 Context
ctx
        process (AppData13 ByteString
x) = do
            let chunkLen :: Int
chunkLen = ByteString -> Int
C8.length ByteString
x
            Established
established <- Context -> IO Established
ctxEstablished Context
ctx
            case Established
established of
              EarlyDataAllowed Int
maxSize
                | Int
chunkLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxSize -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx (Established -> IO ()) -> Established -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataAllowed (Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
chunkLen)
                    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
                | Bool
otherwise ->
                    let reason :: HostName
reason = HostName
"early data overflow" in
                    TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
              EarlyDataNotAllowed Int
n
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     -> do
                    Context -> Established -> IO ()
setEstablished Context
ctx (Established -> IO ()) -> Established -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                    Context -> IO ByteString
recvData13 Context
ctx -- ignore "x"
                | Bool
otherwise ->
                    let reason :: HostName
reason = HostName
"early data deprotect overflow" in
                    TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
              Established
Established         -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
              Established
NotEstablished      -> TLSError -> IO ByteString
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ByteString) -> TLSError -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (HostName, Bool, AlertDescription) -> TLSError
Error_Protocol (HostName
"data at not-established", Bool
True, AlertDescription
UnexpectedMessage)
        process Packet13
ChangeCipherSpec13 = Context -> IO ByteString
recvData13 Context
ctx
        process Packet13
p             = let reason :: HostName
reason = HostName
"unexpected message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Packet13 -> HostName
forall a. Show a => a -> HostName
show Packet13
p in
                                TLSError
-> AlertLevel -> AlertDescription -> HostName -> IO ByteString
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

        loopHandshake13 :: [Handshake13] -> IO ()
loopHandshake13 [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loopHandshake13 (ClientHello13{}:[Handshake13]
_) = do
            let reason :: HostName
reason = HostName
"Client hello is not allowed"
            TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        -- fixme: some implementations send multiple NST at the same time.
        -- Only the first one is used at this moment.
        loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
label [ExtensionRaw]
exts:[Handshake13]
hs) = do
            Role
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.isClientContext
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
ClientRole) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                let reason :: HostName
reason = HostName
"Session ticket is allowed for client only"
                 in TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            -- This part is similar to handshake code, so protected with
            -- read+write locks (which is also what we use for all calls to the
            -- session manager).
            Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Just BaseSecret ResumptionSecret
resumptionMasterSecret <- Context
-> HandshakeM (Maybe (BaseSecret ResumptionSecret))
-> IO (Maybe (BaseSecret ResumptionSecret))
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret ResumptionSecret))
getTLS13ResumptionSecret
                (Hash
_, Cipher
usedCipher, CryptLevel
_, ByteString
_) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxState Context
ctx
                let choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
                    psk :: ByteString
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionMasterSecret ByteString
nonce
                    maxSize :: Int
maxSize = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EarlyData [ExtensionRaw]
exts Maybe ByteString
-> (ByteString -> Maybe EarlyDataIndication)
-> Maybe EarlyDataIndication
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe EarlyDataIndication
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTNewSessionTicket of
                        Just (EarlyDataIndication (Just Second
ms)) -> Second -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Second -> Int) -> Second -> Int
forall a b. (a -> b) -> a -> b
$ Second -> Second
forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 Second
ms
                        Maybe EarlyDataIndication
_                                    -> Int
0
                    life7d :: Second
life7d = Second -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800  -- 7 days max
                TLS13TicketInfo
tinfo <- Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life7d (Second -> Either Context Second
forall a b. b -> Either a b
Right Second
add) Maybe Millisecond
forall a. Maybe a
Nothing
                SessionData
sdata <- Context
-> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize ByteString
psk
                let !label' :: ByteString
label' = ByteString -> ByteString
B.copy ByteString
label
                SessionManager -> ByteString -> SessionData -> IO ()
sessionEstablish (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
label' SessionData
sdata
                -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"
            [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (KeyUpdate13 KeyUpdate
mode:[Handshake13]
hs) = do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
ctxQUICMode Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let reason :: HostName
reason = HostName
"KeyUpdate is not allowed for QUIC"
                TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
            [Handshake13] -> IO ()
forall (t :: * -> *) a. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
            Established
established <- Context -> IO Established
ctxEstablished Context
ctx
            -- Though RFC 8446 Sec 4.6.3 does not clearly says,
            -- unidirectional key update is legal.
            -- So, we don't have to check if this key update is corresponding
            -- to key update (update_requested) which we sent.
            if Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
Established then do
                Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getRxState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState
                -- Write lock wraps both actions because we don't want another
                -- packet to be sent by another thread before the Tx state is
                -- updated.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyUpdate
mode KeyUpdate -> KeyUpdate -> Bool
forall a. Eq a => a -> a -> Bool
== KeyUpdate
UpdateRequested) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [KeyUpdate -> Handshake13
KeyUpdate13 KeyUpdate
UpdateNotRequested]
                    Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState
                [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
              else do
                let reason :: HostName
reason = HostName
"received key update before established"
                TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
        loopHandshake13 (h :: Handshake13
h@CertRequest13{}:[Handshake13]
hs) =
            Context -> Handshake13 -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (h :: Handshake13
h@Certificate13{}:[Handshake13]
hs) =
            Context -> Handshake13 -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
        loopHandshake13 (Handshake13
h:[Handshake13]
hs) = do
            Maybe PendingAction
mPendingAction <- Context -> IO (Maybe PendingAction)
popPendingAction Context
ctx
            case Maybe PendingAction
mPendingAction of
                Maybe PendingAction
Nothing -> let reason :: HostName
reason = HostName
"unexpected handshake message " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Handshake13 -> HostName
forall a. Show a => a -> HostName
show Handshake13
h in
                           TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
                Just PendingAction
action -> do
                    -- Pending actions are executed with read+write locks, just
                    -- like regular handshake code.
                    Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
handleException Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        case PendingAction
action of
                            PendingAction Bool
needAligned Handshake13 -> IO ()
pa -> do
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> IO ()
forall (t :: * -> *) a. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
                                Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handshake13 -> IO ()
pa Handshake13
h
                            PendingActionHash Bool
needAligned ByteString -> Handshake13 -> IO ()
pa -> do
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> IO ()
forall (t :: * -> *) a. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
                                ByteString
d <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
                                Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
                                ByteString -> Handshake13 -> IO ()
pa ByteString
d Handshake13
h
                    [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs

        terminate :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate = Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ())
-> ([(AlertLevel, AlertDescription)] -> Packet13)
-> [(AlertLevel, AlertDescription)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AlertLevel, AlertDescription)] -> Packet13
Alert13)

        checkAlignment :: t a -> IO ()
checkAlignment t a
hs = do
            Bool
complete <- Context -> IO Bool
isRecvComplete Context
ctx
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
complete Bool -> Bool -> Bool
&& t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
hs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                let reason :: HostName
reason = HostName
"received message not aligned with record boundary"
                 in TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason

-- the other side could have close the connection already, so wrap
-- this in a try and ignore all exceptions
tryBye :: Context -> IO ()
tryBye :: Context -> IO ()
tryBye Context
ctx = IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException (Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx) (\SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)
                   -> TLSError -> m B.ByteString
onError :: (TLSError
 -> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
_ TLSError
Error_EOF = -- Not really an error.
            ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate err :: TLSError
err@(Error_Protocol (HostName
reason,Bool
fatal,AlertDescription
desc)) =
    TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err (if Bool
fatal then AlertLevel
AlertLevel_Fatal else AlertLevel
AlertLevel_Warning) AlertDescription
desc HostName
reason
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err =
    TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err AlertLevel
AlertLevel_Fatal AlertDescription
InternalError (TLSError -> HostName
forall a. Show a => a -> HostName
show TLSError
err)

terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ())
                       -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a
terminateWithWriteLock :: Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx [(AlertLevel, AlertDescription)] -> IO ()
send TLSError
err AlertLevel
level AlertDescription
desc HostName
reason = do
    Session
session <- Context -> TLSSt Session -> IO Session
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
    -- Session manager is always invoked with read+write locks, so we merge this
    -- with the alert packet being emitted.
    Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        case Session
session of
            Session Maybe ByteString
Nothing    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Session (Just ByteString
sid) -> SessionManager -> ByteString -> IO ()
sessionInvalidate (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
sid
        IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([(AlertLevel, AlertDescription)] -> IO ()
send [(AlertLevel
level, AlertDescription
desc)]) (\SomeException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    Context -> IO ()
setEOF Context
ctx
    TLSException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
False HostName
reason TLSError
err)


{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}
-- | same as recvData but returns a lazy bytestring.
recvData' :: MonadIO m => Context -> m L.ByteString
recvData' :: Context -> m ByteString
recvData' Context
ctx = [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[]) (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> m ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx

keyUpdate :: Context
          -> (Context -> IO (Hash,Cipher,CryptLevel,C8.ByteString))
          -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
          -> IO ()
keyUpdate :: Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState = do
    (Hash
usedHash, Cipher
usedCipher, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level CryptLevel -> CryptLevel -> Bool
forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (HostName, Bool, AlertDescription) -> TLSError
Error_Protocol (HostName
"tried key update without application traffic secret", Bool
True, AlertDescription
InternalError)
    let applicationSecretN1 :: ByteString
applicationSecretN1 = Hash -> ByteString -> ByteString -> ByteString -> Int -> ByteString
hkdfExpandLabel Hash
usedHash ByteString
applicationSecretN ByteString
"traffic upd" ByteString
"" (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash -> Int
hashDigestSize Hash
usedHash
    Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState Context
ctx Hash
usedHash Cipher
usedCipher (ByteString -> AnyTrafficSecret ApplicationSecret
forall a. ByteString -> AnyTrafficSecret a
AnyTrafficSecret ByteString
applicationSecretN1)

-- | How to update keys in TLS 1.3
data KeyUpdateRequest = OneWay -- ^ Unidirectional key update
                      | TwoWay -- ^ Bidirectional key update (normal case)
                      deriving (KeyUpdateRequest -> KeyUpdateRequest -> Bool
(KeyUpdateRequest -> KeyUpdateRequest -> Bool)
-> (KeyUpdateRequest -> KeyUpdateRequest -> Bool)
-> Eq KeyUpdateRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
$c/= :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
$c== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
Eq, Int -> KeyUpdateRequest -> HostName -> HostName
[KeyUpdateRequest] -> HostName -> HostName
KeyUpdateRequest -> HostName
(Int -> KeyUpdateRequest -> HostName -> HostName)
-> (KeyUpdateRequest -> HostName)
-> ([KeyUpdateRequest] -> HostName -> HostName)
-> Show KeyUpdateRequest
forall a.
(Int -> a -> HostName -> HostName)
-> (a -> HostName) -> ([a] -> HostName -> HostName) -> Show a
showList :: [KeyUpdateRequest] -> HostName -> HostName
$cshowList :: [KeyUpdateRequest] -> HostName -> HostName
show :: KeyUpdateRequest -> HostName
$cshow :: KeyUpdateRequest -> HostName
showsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
$cshowsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
Show)

-- | Updating appication traffic secrets for TLS 1.3.
--   If this API is called for TLS 1.3, 'True' is returned.
--   Otherwise, 'False' is returned.
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: Context -> KeyUpdateRequest -> m Bool
updateKey Context
ctx KeyUpdateRequest
way = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tls13 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let req :: KeyUpdate
req = case KeyUpdateRequest
way of
                KeyUpdateRequest
OneWay -> KeyUpdate
UpdateNotRequested
                KeyUpdateRequest
TwoWay -> KeyUpdate
UpdateRequested
        -- Write lock wraps both actions because we don't want another packet to
        -- be sent by another thread before the Tx state is updated.
        Context -> IO () -> IO ()
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [KeyUpdate -> Handshake13
KeyUpdate13 KeyUpdate
req]
            Context
-> (Context -> IO (Hash, Cipher, CryptLevel, ByteString))
-> (Context
    -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())
-> IO ()
keyUpdate Context
ctx Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxState Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
tls13