{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.TLS.Core (
sendPacket12,
recvPacket12,
bye,
handshake,
getNegotiatedProtocol,
getClientSNI,
sendData,
recvData,
recvData',
updateKey,
KeyUpdateRequest (..),
requestCertificate,
) where
import qualified Control.Exception as E
import Control.Monad (unless, void, when)
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import Data.IORef
import System.Timeout
import Network.TLS.Cipher
import Network.TLS.Context
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.KeySchedule
import Network.TLS.Parameters
import Network.TLS.PostHandshake
import Network.TLS.Session
import Network.TLS.State (getRole, getSession)
import qualified Network.TLS.State as S
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types (
AnyTrafficSecret (..),
ApplicationSecret,
HostName,
Role (..),
)
import Network.TLS.Util (catchException, mapChunks_)
handshake :: MonadIO m => Context -> m ()
handshake :: forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx = do
Context -> m ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake_ Context
ctx
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
tls13 <- tls13orLater ctx
sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx
when (role == ClientRole && tls13 && sentClientCert) $ do
rtt <- getRTT ctx
mdat <- timeout rtt $ recvData13 ctx
case mdat of
Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
dat -> Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stPendingRecvData = Just dat}
rttFactor :: Int
rttFactor :: Int
rttFactor = Int
3
getRTT :: Context -> IO Int
getRTT :: Context -> IO Int
getRTT Context
ctx = do
rtt <- TLS13State -> Millisecond
tls13stRTT (TLS13State -> Millisecond) -> IO TLS13State -> IO Millisecond
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
let rtt' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Millisecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
rtt) Int
10
return (rtt' * rttFactor * 1000)
bye :: MonadIO m => Context -> m ()
bye :: forall (m :: * -> *). MonadIO m => Context -> m ()
bye Context
ctx = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
eof <- Context -> IO Bool
ctxEOF Context
ctx
tls13 <- tls13orLater ctx
when (tls13 && not eof) $ do
role <- usingState_ ctx getRole
if role == ClientRole
then do
withWriteLock ctx $ sendCFifNecessary ctx
let chk = TLS13State -> Bool
tls13stRecvNST (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
recvNST <- chk
unless recvNST $ do
rtt <- getRTT ctx
void $ timeout rtt $ recvHS13 ctx chk
else do
let chk = TLS13State -> Bool
tls13stRecvCF (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
recvCF <- chk
unless recvCF $ do
let rtt = Int
1000000
void $ timeout rtt $ recvHS13 ctx chk
bye_ ctx
bye_ :: MonadIO m => Context -> m ()
bye_ :: forall (m :: * -> *). MonadIO m => Context -> m ()
bye_ Context
ctx = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
eof <- Context -> IO Bool
ctxEOF Context
ctx
tls13 <- tls13orLater ctx
unless eof $
withWriteLock ctx $
if tls13
then sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]
else sendPacket12 ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
getNegotiatedProtocol :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe ByteString)
getNegotiatedProtocol Context
ctx = IO (Maybe ByteString) -> m (Maybe ByteString)
forall a. IO a -> m a
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 :: forall (m :: * -> *). MonadIO m => Context -> m (Maybe HostName)
getClientSNI Context
ctx = IO (Maybe HostName) -> m (Maybe HostName)
forall a. IO a -> m a
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
sendCFifNecessary :: Context -> IO ()
sendCFifNecessary :: Context -> IO ()
sendCFifNecessary Context
ctx = do
st <- Context -> IO TLS13State
getTLS13State Context
ctx
let recvSF = TLS13State -> Bool
tls13stRecvSF TLS13State
st
sentCF = TLS13State -> Bool
tls13stSentCF TLS13State
st
when (recvSF && not sentCF) $ do
msend <- readIORef (ctxPendingSendAction ctx)
case msend of
Maybe (Context -> IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Context -> IO ()
sendAction -> do
Context -> IO ()
sendAction Context
ctx
IORef (Maybe (Context -> IO ()))
-> Maybe (Context -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef (Maybe (Context -> IO ()))
ctxPendingSendAction Context
ctx) Maybe (Context -> IO ())
forall a. Maybe a
Nothing
sendData :: MonadIO m => Context -> L.ByteString -> m ()
sendData :: forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
sendData Context
_ ByteString
"" = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendData Context
ctx ByteString
dataToSend = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
let sendP ByteString
bs
| Bool
tls13 = do
Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Packet13
AppData13 ByteString
bs
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
getRole
sentCF <- tls13stSentCF <$> getTLS13State ctx
rtt0 <- tls13st0RTT <$> getTLS13State ctx
when (role == ClientRole && rtt0 && not sentCF) $
modifyTLS13State ctx $
\TLS13State
st -> TLS13State
st{tls13stPendingSentData = tls13stPendingSentData st . (bs :)}
| Bool
otherwise = Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Packet
AppData ByteString
bs
when tls13 $ withWriteLock ctx $ sendCFifNecessary ctx
withWriteLock ctx $ do
checkValid ctx
let len = Context -> Maybe Int
ctxFragmentSize Context
ctx
mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend)
recvData :: MonadIO m => Context -> m B.ByteString
recvData :: forall (m :: * -> *). MonadIO m => Context -> m ByteString
recvData Context
ctx = IO ByteString -> m ByteString
forall a. IO a -> m a
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
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
withReadLock ctx $ do
checkValid ctx
if tls13 then recvData13 ctx else recvData12 ctx
recvData12 :: Context -> IO B.ByteString
recvData12 :: Context -> IO ByteString
recvData12 Context
ctx = do
pkt <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
either (onError terminate12) process 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData12 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ByteString
recvData12 Context
ctx
process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
UserCanceled)]) = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
process (Alert [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall a. a -> IO a
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. (HasCallStack, 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 -> AlertDescription -> TLSError
Error_Protocol HostName
"remote side fatal error" AlertDescription
desc)
)
process (AppData ByteString
"") = Context -> IO ByteString
recvData12 Context
ctx
process (AppData ByteString
x) = ByteString -> IO ByteString
forall a. a -> IO a
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
terminate12 (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
terminate12 :: TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate12 = 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 ()
sendPacket12 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
mdat <- TLS13State -> Maybe ByteString
tls13stPendingRecvData (TLS13State -> Maybe ByteString)
-> IO TLS13State -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
case mdat of
Maybe ByteString
Nothing -> do
pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
either (onError (terminate13 ctx)) process pkt
Just ByteString
dat -> do
Context -> (TLS13State -> TLS13State) -> IO ()
modifyTLS13State Context
ctx ((TLS13State -> TLS13State) -> IO ())
-> (TLS13State -> TLS13State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TLS13State
st -> TLS13State
st{tls13stPendingRecvData = Nothing}
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
dat
where
process :: Packet13 -> IO ByteString
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
UserCanceled)]) = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall a. a -> IO a
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. (HasCallStack, 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 -> AlertDescription -> TLSError
Error_Protocol HostName
"remote side fatal error" 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 <- Context -> IO Established
ctxEstablished Context
ctx
case 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
| Bool
otherwise ->
let reason :: HostName
reason = HostName
"early data overflow"
in Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (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
| Bool
otherwise ->
let reason :: HostName
reason = HostName
"early data deprotect overflow"
in Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
Established
Established -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
Established
_ -> 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 -> AlertDescription -> TLSError
Error_Protocol HostName
"data at not-established" AlertDescription
UnexpectedMessage
process Packet13
ChangeCipherSpec13 = do
established <- Context -> IO Established
ctxEstablished Context
ctx
if established /= Established
then recvData13 ctx
else do
let reason = HostName
"CSS after Finished"
terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
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 Context
-> TLSError
-> AlertLevel
-> AlertDescription
-> HostName
-> IO ByteString
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
loopHandshake13 :: [Handshake13] -> IO ()
loopHandshake13 [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
ticket [ExtensionRaw]
exts : [Handshake13]
hs) = do
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.getRole
unless (role == ClientRole) $
let reason = HostName
"Session ticket is allowed for client only"
in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
withWriteLock ctx $ do
Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret
(_, usedCipher, _, _) <- getTxRecordState ctx
let choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret ByteString
nonce
maxSize = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_EarlyData [ExtensionRaw]
exts
Maybe ByteString
-> (ByteString -> Maybe EarlyDataIndication)
-> Maybe EarlyDataIndication
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800
tinfo <- createTLS13TicketInfo life7d (Right add) Nothing
sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk
let ticket' = ByteString -> ByteString
B.copy ByteString
ticket
void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata
modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13stRecvNST = True}
loopHandshake13 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"
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
established <- Context -> IO Established
ctxEstablished Context
ctx
if established == Established
then do
keyUpdate ctx getRxRecordState setRxRecordState
when (mode == UpdateRequested) $ withWriteLock ctx $ do
sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]
keyUpdate ctx getTxRecordState setTxRecordState
loopHandshake13 hs
else do
let reason = HostName
"received key update before established"
terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
loopHandshake13 (h :: Handshake13
h@CertRequest13{} : [Handshake13]
hs) =
Context -> Handshake13 -> IO ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 ()
postHandshakeAuthWith Context
ctx Handshake13
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
loopHandshake13 (Handshake13
h : [Handshake13]
hs) = do
rtt0 <- TLS13State -> Bool
tls13st0RTT (TLS13State -> Bool) -> IO TLS13State -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
when rtt0 $ case h of
ServerHello13 ServerRandom
srand Session
_ CipherID
_ [ExtensionRaw]
_ ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerRandom -> Bool
isHelloRetryRequest ServerRandom
srand) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Context -> IO ()
clearTxRecordState Context
ctx
let reason :: HostName
reason = HostName
"HRR is not allowed for 0-RTT"
in Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO ()
forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx (HostName -> TLSError
Error_Misc HostName
reason) AlertLevel
AlertLevel_Fatal AlertDescription
UnexpectedMessage HostName
reason
Handshake13
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cont <- popAction ctx h hs
when cont $ loopHandshake13 hs
recvHS13 :: Context -> IO Bool -> IO ()
recvHS13 :: Context -> IO Bool -> IO ()
recvHS13 Context
ctx IO Bool
breakLoop = do
pkt <- Context -> IO (Either TLSError Packet13)
recvPacket13 Context
ctx
either (\TLSError
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) process pkt
where
process :: Packet13 -> IO ()
process (Alert13 [(AlertLevel
AlertLevel_Warning, AlertDescription
CloseNotify)]) = Context -> IO ()
tryBye Context
ctx IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> IO ()
setEOF Context
ctx
process (Alert13 [(AlertLevel
AlertLevel_Fatal, AlertDescription
_desc)]) = Context -> IO ()
setEOF Context
ctx
process (Handshake13 [Handshake13]
hs) = do
[Handshake13] -> IO ()
loopHandshake13 [Handshake13]
hs
stop <- IO Bool
breakLoop
unless stop $ recvHS13 ctx breakLoop
process Packet13
_ = Context -> IO Bool -> IO ()
recvHS13 Context
ctx IO Bool
breakLoop
loopHandshake13 :: [Handshake13] -> IO ()
loopHandshake13 [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loopHandshake13 (NewSessionTicket13 Second
life Second
add ByteString
nonce ByteString
ticket [ExtensionRaw]
exts : [Handshake13]
hs) = do
role <- Context -> TLSSt Role -> IO Role
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Role
S.getRole
unless (role == ClientRole) $
let reason = HostName
"Session ticket is allowed for client only"
in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
withWriteLock ctx $ do
Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret
(_, usedCipher, _, _) <- getTxRecordState ctx
let choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionSecret ByteString
nonce
maxSize = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_EarlyData [ExtensionRaw]
exts
Maybe ByteString
-> (ByteString -> Maybe EarlyDataIndication)
-> Maybe EarlyDataIndication
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 -> Second -> Second
forall a. Ord a => a -> a -> a
min Second
life Second
604800
tinfo <- createTLS13TicketInfo life7d (Right add) Nothing
sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk
let ticket' = ByteString -> ByteString
B.copy ByteString
ticket
void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata
modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13stRecvNST = True}
loopHandshake13 hs
loopHandshake13 (Handshake13
h : [Handshake13]
hs) = do
cont <- Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction Context
ctx Handshake13
h [Handshake13]
hs
when cont $ loopHandshake13 hs
terminate13
:: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a
terminate13 :: forall a.
Context
-> TLSError -> AlertLevel -> AlertDescription -> HostName -> IO a
terminate13 Context
ctx = 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)
popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool
popAction Context
ctx Handshake13
h [Handshake13]
hs = do
mPendingRecvAction <- Context -> IO (Maybe PendingRecvAction)
popPendingRecvAction Context
ctx
case mPendingRecvAction of
Maybe PendingRecvAction
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just PendingRecvAction
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
$ do
case PendingRecvAction
action of
PendingRecvAction 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
$ Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
Handshake13 -> IO ()
pa Handshake13
h
PendingRecvActionHash 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
$ Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
hs
d <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
processHandshake13 ctx h
pa d h
Context -> IO ()
sendCFifNecessary Context
ctx
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkAlignment :: Context -> [Handshake13] -> IO ()
checkAlignment :: Context -> [Handshake13] -> IO ()
checkAlignment Context
ctx [Handshake13]
_hs = do
complete <- Context -> IO Bool
isRecvComplete Context
ctx
unless complete $ do
let reason = HostName
"received message not aligned with record boundary"
terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
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 a. a -> IO a
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 =
ByteString -> m ByteString
forall a. a -> m a
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 = Context -> IO a -> IO a
forall a. Context -> IO a -> IO a
withWriteLock Context
ctx (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
unless tls13 $ do
session <- usingState_ ctx getSession
withWriteLock ctx $ do
case session of
Session Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
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
catchException (send [(level, desc)]) (\SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
setEOF ctx
E.throwIO (Terminated False reason 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 ([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
(usedHash, usedCipher, level, applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getState Context
ctx
unless (level == CryptApplicationSecret) $
throwCore $
Error_Protocol
"tried key update without application traffic secret"
InternalError
let 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
setState ctx usedHash usedCipher (AnyTrafficSecret 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
$c== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
== :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
$c/= :: KeyUpdateRequest -> KeyUpdateRequest -> Bool
/= :: 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
$cshowsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
showsPrec :: Int -> KeyUpdateRequest -> HostName -> HostName
$cshow :: KeyUpdateRequest -> HostName
show :: KeyUpdateRequest -> HostName
$cshowList :: [KeyUpdateRequest] -> HostName -> HostName
showList :: [KeyUpdateRequest] -> HostName -> HostName
Show)
updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
updateKey :: forall (m :: * -> *).
MonadIO m =>
Context -> KeyUpdateRequest -> m Bool
updateKey Context
ctx KeyUpdateRequest
way = IO Bool -> m Bool
forall a. IO a -> m a
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
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
when tls13 $ do
let req = case KeyUpdateRequest
way of
KeyUpdateRequest
OneWay -> KeyUpdate
UpdateNotRequested
KeyUpdateRequest
TwoWay -> KeyUpdate
UpdateRequested
withWriteLock ctx $ do
sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]
keyUpdate ctx getTxRecordState setTxRecordState
return tls13