{-# 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 :: forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
eof forall a b. (a -> b) -> a -> b
$ forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$
if Bool
tls13 then
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [(AlertLevel, AlertDescription)] -> Packet13
Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]
else
Context -> Packet -> IO ()
sendPacket Context
ctx 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 :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
getNegotiatedProtocol Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
S.getNegotiatedProtocol
getClientSNI :: MonadIO m => Context -> m (Maybe HostName)
getClientSNI :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe HostName)
getClientSNI Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
S.getClientSNI
sendData :: MonadIO m => Context -> L.ByteString -> m ()
sendData :: forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
ctx ByteString
dataToSend = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
let sendP :: ByteString -> IO ()
sendP
| Bool
tls13 = Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet13
AppData13
| Bool
otherwise = Context -> Packet -> IO ()
sendPacket Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet
AppData
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
Context -> IO ()
checkValid Context
ctx
let len :: Maybe Int
len = Context -> Maybe Int
ctxFragmentSize Context
ctx
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 :: forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
forall a. Context -> IO a -> IO a
withReadLock Context
ctx 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 Context
ctx = do
Either TLSError Packet
pkt <- Context -> IO (Either TLSError Packet)
recvPacket Context
ctx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *).
Monad m =>
(TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError 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{}]) =
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
ch 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]) =
forall (m :: * -> *). MonadIO m => Context -> Handshake -> m ()
handshakeWith Context
ctx Handshake
hr 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " forall a. [a] -> [a] -> [a]
++ 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 (AppData ByteString
"") = Context -> IO ByteString
recvData1 Context
ctx
process (AppData ByteString
x) = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
process Packet
p = let reason :: HostName
reason = HostName
"unexpected message " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Packet
p in
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 = forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet -> IO ()
sendPacket Context
ctx 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
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *).
Monad m =>
(TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
forall e a. Exception e => e -> IO a
E.throwIO (Bool -> HostName -> TLSError -> TLSException
Terminated Bool
True (HostName
"received fatal error: " forall a. [a] -> [a] -> [a]
++ 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
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 forall a. Ord a => a -> a -> Bool
<= Int
maxSize -> do
Context -> Established -> IO ()
setEstablished Context
ctx forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataAllowed (Int
maxSize forall a. Num a => a -> a -> a
- Int
chunkLen)
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
| Bool
otherwise ->
let reason :: HostName
reason = HostName
"early data overflow" in
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 forall a. Ord a => a -> a -> Bool
> Int
0 -> do
Context -> Established -> IO ()
setEstablished Context
ctx forall a b. (a -> b) -> a -> b
$ Int -> Established
EarlyDataNotAllowed (Int
n forall a. Num a => a -> a -> a
- Int
1)
Context -> IO ByteString
recvData13 Context
ctx
| Bool
otherwise ->
let reason :: HostName
reason = HostName
"early data deprotect overflow" in
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
Established
Established -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
Established
NotEstablished -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 = do
Established
established <- Context -> IO Established
ctxEstablished Context
ctx
if Established
established forall a. Eq a => a -> a -> Bool
/= Established
Established then
Context -> IO ByteString
recvData13 Context
ctx
else do
let reason :: HostName
reason = HostName
"CSS after Finished"
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
process Packet13
p = let reason :: HostName
reason = HostName
"unexpected message " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Packet13
p in
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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loopHandshake13 (ClientHello13{}:[Handshake13]
_) = do
let reason :: HostName
reason = HostName
"Client hello is not allowed"
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
label [ExtensionRaw]
exts:[Handshake13]
hs) = do
Role
role <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.isClientContext
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role forall a. Eq a => a -> a -> Bool
== Role
ClientRole) forall a b. (a -> b) -> a -> b
$
let reason :: HostName
reason = HostName
"Session ticket is allowed for client only"
in forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
Just BaseSecret ResumptionSecret
resumptionMasterSecret <- 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTNewSessionTicket of
Just (EarlyDataIndication (Just Second
ms)) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 Second
ms
Maybe EarlyDataIndication
_ -> Int
0
life7d :: Second
life7d = forall a. Ord a => a -> a -> a
min Second
life Second
604800
TLS13TicketInfo
tinfo <- Second
-> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Second
life7d (forall a b. b -> Either a b
Right Second
add) 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 forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
label' SessionData
sdata
[Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
loopHandshake13 (KeyUpdate13 KeyUpdate
mode:[Handshake13]
hs) = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$ do
let reason :: HostName
reason = HostName
"KeyUpdate is not allowed for QUIC"
forall {a}.
TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
Established
established <- Context -> IO Established
ctxEstablished Context
ctx
if Established
established 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 forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyUpdate
mode forall a. Eq a => a -> a -> Bool
== KeyUpdate
UpdateRequested) forall a b. (a -> b) -> a -> b
$ forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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 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"
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) =
forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
loopHandshake13 (h :: Handshake13
h@Certificate13{}:[Handshake13]
hs) =
forall (m :: * -> *). MonadIO m => Context -> Handshake13 -> m ()
postHandshakeAuthWith Context
ctx Handshake13
h 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> HostName
show Handshake13
h in
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
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ Context -> IO () -> IO ()
handleException Context
ctx forall a b. (a -> b) -> a -> b
$
case PendingAction
action of
PendingAction Bool
needAligned Handshake13 -> IO ()
pa -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needAligned forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {a}. Foldable t => t a -> IO ()
checkAlignment [Handshake13]
hs
ByteString
d <- 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 = forall a.
Context
-> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO a
terminateWithWriteLock Context
ctx (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
complete Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
hs) forall a b. (a -> b) -> a -> b
$
let reason :: HostName
reason = HostName
"received message not aligned with record boundary"
in 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 Context
ctx = forall a. IO a -> (SomeException -> IO a) -> IO a
catchException (forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx) (\SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)
-> TLSError -> m B.ByteString
onError :: forall (m :: * -> *).
Monad m =>
(TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString)
-> TLSError -> m ByteString
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
_ TLSError
Error_EOF =
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
onError TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err = let (AlertLevel
lvl,AlertDescription
ad) = TLSError -> (AlertLevel, AlertDescription)
errorToAlert TLSError
err
in TLSError
-> AlertLevel -> AlertDescription -> HostName -> m ByteString
terminate TLSError
err AlertLevel
lvl AlertDescription
ad (TLSError -> HostName
errorToAlertMessage TLSError
err)
terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ())
-> TLSError -> AlertLevel -> AlertDescription -> String -> IO a
terminateWithWriteLock :: forall a.
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 <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
case Session
session of
Session Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Session (Just ByteString
sid) -> SessionManager -> ByteString -> IO ()
sessionInvalidate (Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
sid
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([(AlertLevel, AlertDescription)] -> IO ()
send [(AlertLevel
level, AlertDescription
desc)]) (\SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
Context -> IO ()
setEOF Context
ctx
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' :: forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData' Context
ctx = [ByteString] -> ByteString
L.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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
"" 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 (forall a. ByteString -> AnyTrafficSecret a
AnyTrafficSecret ByteString
applicationSecretN1)
data KeyUpdateRequest = OneWay
| TwoWay
deriving (KeyUpdateRequest -> KeyUpdateRequest -> Bool
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 -> ShowS
[KeyUpdateRequest] -> ShowS
KeyUpdateRequest -> HostName
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
showList :: [KeyUpdateRequest] -> ShowS
$cshowList :: [KeyUpdateRequest] -> ShowS
show :: KeyUpdateRequest -> HostName
$cshow :: KeyUpdateRequest -> HostName
showsPrec :: Int -> KeyUpdateRequest -> ShowS
$cshowsPrec :: Int -> KeyUpdateRequest -> ShowS
Show)
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: forall (m :: * -> *).
MonadIO m =>
Context -> KeyUpdateRequest -> m Bool
updateKey Context
ctx KeyUpdateRequest
way = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tls13 forall a b. (a -> b) -> a -> b
$ do
let req :: KeyUpdate
req = case KeyUpdateRequest
way of
KeyUpdateRequest
OneWay -> KeyUpdate
UpdateNotRequested
KeyUpdateRequest
TwoWay -> KeyUpdate
UpdateRequested
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx forall a b. (a -> b) -> a -> b
$ do
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx 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 forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
tls13