{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
module Network.TLS.Core
(
sendPacket
, recvPacket
, bye
, handshake
, getNegotiatedProtocol
, getClientSNI
, 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
bye :: MonadIO m => Context -> m ()
bye :: Context -> m ()
bye ctx :: 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
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)]
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
getNegotiatedProtocol :: Context -> m (Maybe ByteString)
getNegotiatedProtocol ctx :: 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
getClientSNI :: MonadIO m => Context -> m (Maybe HostName)
getClientSNI :: Context -> m (Maybe HostName)
getClientSNI ctx :: 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 :: MonadIO m => Context -> L.ByteString -> m ()
sendData :: Context -> ByteString -> m ()
sendData ctx :: Context
ctx dataToSend :: 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
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)
recvData :: MonadIO m => Context -> m B.ByteString
recvData :: Context -> m ByteString
recvData ctx :: 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
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 ctx :: 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_Warning, 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_Fatal, desc :: 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 ("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 ("remote side fatal error", Bool
True, AlertDescription
desc)))
process (AppData "") = Context -> IO ByteString
recvData1 Context
ctx
process (AppData x :: ByteString
x) = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
process p :: Packet
p = let reason :: HostName
reason = "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 ctx :: 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_Warning, 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_Fatal, desc :: 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 ("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 ("remote side fatal error", Bool
True, AlertDescription
desc)))
process (Handshake13 hs :: [Handshake13]
hs) = do
[Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
Context -> IO ByteString
recvData13 Context
ctx
process (AppData13 "") = Context -> IO ByteString
recvData13 Context
ctx
process (AppData13 x :: 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 maxSize :: 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 = "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 n :: Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
- 1)
Context -> IO ByteString
recvData13 Context
ctx
| Bool
otherwise ->
let reason :: HostName
reason = "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 -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
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 ("data at not-established", Bool
True, AlertDescription
UnexpectedMessage)
process ChangeCipherSpec13 = Context -> IO ByteString
recvData13 Context
ctx
process p :: Packet13
p = let reason :: HostName
reason = "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{}:_) = do
let reason :: HostName
reason = "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
loopHandshake13 (NewSessionTicket13 life :: Second
life add :: Second
add nonce :: ByteString
nonce label :: ByteString
label exts :: [ExtensionRaw]
exts:hs :: [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 = "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
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 resumptionMasterSecret :: 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
(_, usedCipher :: Cipher
usedCipher, _, _) <- 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 ms :: 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
_ -> 0
life7d :: Second
life7d = Second -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life 604800
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
[Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
loopHandshake13 (KeyUpdate13 mode :: KeyUpdate
mode:hs :: [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 = "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
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
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 = "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{}:hs :: [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{}:hs :: [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:hs :: [Handshake13]
hs) = do
Maybe PendingAction
mPendingAction <- Context -> IO (Maybe PendingAction)
popPendingAction Context
ctx
case Maybe PendingAction
mPendingAction of
Nothing -> let reason :: HostName
reason = "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 action :: PendingAction
action -> do
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 needAligned :: Bool
needAligned pa :: 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 needAligned :: Bool
needAligned pa :: 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 hs :: 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 = "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
tryBye :: Context -> IO ()
tryBye :: Context -> IO ()
tryBye ctx :: 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) (\_ -> () -> 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 _ Error_EOF =
ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
onError terminate :: TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate err :: TLSError
err@(Error_Protocol (reason :: HostName
reason,fatal :: Bool
fatal,desc :: 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 terminate :: TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate err :: 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 ctx :: Context
ctx send :: [(AlertLevel, AlertDescription)] -> IO ()
send err :: TLSError
err level :: AlertLevel
level desc :: AlertDescription
desc reason :: HostName
reason = do
Session
session <- Context -> TLSSt Session -> IO Session
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
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 Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Session (Just sid :: 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)]) (\_ -> () -> 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" #-}
recvData' :: MonadIO m => Context -> m L.ByteString
recvData' :: Context -> m ByteString
recvData' ctx :: 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 ctx :: Context
ctx getState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState setState :: Context
-> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()
setState = do
(usedHash :: Hash
usedHash, usedCipher :: Cipher
usedCipher, level :: CryptLevel
level, applicationSecretN :: 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 ("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 "traffic upd" "" (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)
data KeyUpdateRequest = OneWay
| TwoWay
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)
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: Context -> KeyUpdateRequest -> m Bool
updateKey ctx :: Context
ctx way :: 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
OneWay -> KeyUpdate
UpdateNotRequested
TwoWay -> KeyUpdate
UpdateRequested
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