{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}

module Network.TLS.IO (
    sendPacket12,
    sendPacket13,
    recvPacket12,
    recvPacket13,
    --
    isRecvComplete,
    checkValid,

    -- * Grouping multiple packets in the same flight
    PacketFlightM,
    runPacketFlight,
    loadPacket13,
) where

import Control.Exception (finally, throwIO)
import Control.Monad.Reader
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Data.IORef

import Network.TLS.Context.Internal
import Network.TLS.Hooks
import Network.TLS.IO.Decode
import Network.TLS.IO.Encode
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Record
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13

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

-- | Send one packet to the context
sendPacket12 :: Context -> Packet -> IO ()
sendPacket12 :: Context -> Packet -> IO ()
sendPacket12 ctx :: Context
ctx@Context{ctxRecordLayer :: ()
ctxRecordLayer = RecordLayer a
recordLayer} Packet
pkt = do
    -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed
    -- by an attacker. Hence, an empty packet is sent before a normal data packet, to
    -- prevent guessability.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Packet -> Bool
isNonNullAppData Packet
pkt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        withEmptyPacket <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Context -> IORef Bool
ctxNeedEmptyPacket Context
ctx
        when withEmptyPacket $
            writePacketBytes12 ctx recordLayer (AppData B.empty)
                >>= recordSendBytes recordLayer ctx

    Context -> RecordLayer a -> Packet -> IO a
forall bytes.
Monoid bytes =>
Context -> RecordLayer bytes -> Packet -> IO bytes
writePacketBytes12 Context
ctx RecordLayer a
recordLayer Packet
pkt IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RecordLayer a -> Context -> a -> IO ()
forall a. RecordLayer a -> Context -> a -> IO ()
recordSendBytes RecordLayer a
recordLayer Context
ctx
  where
    isNonNullAppData :: Packet -> Bool
isNonNullAppData (AppData ByteString
b) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
B.null ByteString
b
    isNonNullAppData Packet
_ = Bool
False

writePacketBytes12
    :: Monoid bytes
    => Context
    -> RecordLayer bytes
    -> Packet
    -> IO bytes
writePacketBytes12 :: forall bytes.
Monoid bytes =>
Context -> RecordLayer bytes -> Packet -> IO bytes
writePacketBytes12 Context
ctx RecordLayer bytes
recordLayer Packet
pkt = do
    Context -> (Logging -> IO ()) -> IO ()
withLog Context
ctx ((Logging -> IO ()) -> IO ()) -> (Logging -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Logging
logging -> Logging -> String -> IO ()
loggingPacketSent Logging
logging (Packet -> String
forall a. Show a => a -> String
show Packet
pkt)
    edataToSend <- Context
-> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
forall bytes.
Monoid bytes =>
Context
-> RecordLayer bytes -> Packet -> IO (Either TLSError bytes)
encodePacket12 Context
ctx RecordLayer bytes
recordLayer Packet
pkt
    either throwCore return edataToSend

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

sendPacket13 :: Context -> Packet13 -> IO ()
sendPacket13 :: Context -> Packet13 -> IO ()
sendPacket13 ctx :: Context
ctx@Context{ctxRecordLayer :: ()
ctxRecordLayer = RecordLayer a
recordLayer} Packet13
pkt =
    Context -> RecordLayer a -> Packet13 -> IO a
forall bytes.
Monoid bytes =>
Context -> RecordLayer bytes -> Packet13 -> IO bytes
writePacketBytes13 Context
ctx RecordLayer a
recordLayer Packet13
pkt IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RecordLayer a -> Context -> a -> IO ()
forall a. RecordLayer a -> Context -> a -> IO ()
recordSendBytes RecordLayer a
recordLayer Context
ctx

writePacketBytes13
    :: Monoid bytes
    => Context
    -> RecordLayer bytes
    -> Packet13
    -> IO bytes
writePacketBytes13 :: forall bytes.
Monoid bytes =>
Context -> RecordLayer bytes -> Packet13 -> IO bytes
writePacketBytes13 Context
ctx RecordLayer bytes
recordLayer Packet13
pkt = do
    Context -> (Logging -> IO ()) -> IO ()
withLog Context
ctx ((Logging -> IO ()) -> IO ()) -> (Logging -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Logging
logging -> Logging -> String -> IO ()
loggingPacketSent Logging
logging (Packet13 -> String
forall a. Show a => a -> String
show Packet13
pkt)
    edataToSend <- Context
-> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes)
forall bytes.
Monoid bytes =>
Context
-> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes)
encodePacket13 Context
ctx RecordLayer bytes
recordLayer Packet13
pkt
    either throwCore return edataToSend

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

-- | receive one packet from the context that contains 1 or
-- many messages (many only in case of handshake). if will returns a
-- TLSError if the packet is unexpected or malformed
recvPacket12 :: Context -> IO (Either TLSError Packet)
recvPacket12 :: Context -> IO (Either TLSError Packet)
recvPacket12 ctx :: Context
ctx@Context{ctxRecordLayer :: ()
ctxRecordLayer = RecordLayer a
recordLayer} = Int -> IO (Either TLSError Packet)
loop Int
0
  where
    lim :: Int
lim = Limit -> Int
limitHandshakeFragment (Limit -> Int) -> Limit -> Int
forall a b. (a -> b) -> a -> b
$ Shared -> Limit
sharedLimit (Shared -> Limit) -> Shared -> Limit
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx
    loop :: Int -> IO (Either TLSError Packet)
loop Int
count
        | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lim = do
            let err :: TLSError
err = String -> TLSError
Error_Packet String
"too many handshake fragment"
            Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
            Either TLSError Packet -> IO (Either TLSError Packet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError Packet -> IO (Either TLSError Packet))
-> Either TLSError Packet -> IO (Either TLSError Packet)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError Packet
forall a b. a -> Either a b
Left TLSError
err
    loop Int
count = do
        hrr <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
        erecord <- recordRecv12 recordLayer ctx
        case erecord of
            Left TLSError
err -> do
                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
                Either TLSError Packet -> IO (Either TLSError Packet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError Packet -> IO (Either TLSError Packet))
-> Either TLSError Packet -> IO (Either TLSError Packet)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError Packet
forall a b. a -> Either a b
Left TLSError
err
            Right Record Plaintext
record
                | Bool
hrr Bool -> Bool -> Bool
&& Record Plaintext -> Bool
forall a. Record a -> Bool
isCCS Record Plaintext
record -> Int -> IO (Either TLSError Packet)
loop (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                | Bool
otherwise -> do
                    pktRecv <- Context -> Record Plaintext -> IO (Either TLSError Packet)
decodePacket12 Context
ctx Record Plaintext
record
                    if isEmptyHandshake pktRecv
                        then do
                            logPacket ctx "Handshake fragment"
                            -- When a handshake record is fragmented
                            -- we continue receiving in order to feed
                            -- stHandshakeRecordCont
                            loop (count + 1)
                        else case pktRecv of
                            Right (Handshake [Handshake]
hss) -> do
                                pktRecv'@(Right pkt) <- Context
-> (Hooks -> IO (Either TLSError Packet))
-> IO (Either TLSError Packet)
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx ((Hooks -> IO (Either TLSError Packet))
 -> IO (Either TLSError Packet))
-> (Hooks -> IO (Either TLSError Packet))
-> IO (Either TLSError Packet)
forall a b. (a -> b) -> a -> b
$ \Hooks
hooks ->
                                    Packet -> Either TLSError Packet
forall a b. b -> Either a b
Right (Packet -> Either TLSError Packet)
-> ([Handshake] -> Packet) -> [Handshake] -> Either TLSError Packet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Handshake] -> Packet
Handshake ([Handshake] -> Either TLSError Packet)
-> IO [Handshake] -> IO (Either TLSError Packet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handshake -> IO Handshake) -> [Handshake] -> IO [Handshake]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Hooks -> Handshake -> IO Handshake
hookRecvHandshake Hooks
hooks) [Handshake]
hss
                                logPacket ctx $ show pkt
                                return pktRecv'
                            Right Packet
pkt -> do
                                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Packet -> String
forall a. Show a => a -> String
show Packet
pkt
                                Either TLSError Packet -> IO (Either TLSError Packet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either TLSError Packet
pktRecv
                            Left TLSError
err -> do
                                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
                                Either TLSError Packet -> IO (Either TLSError Packet)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either TLSError Packet
pktRecv

isCCS :: Record a -> Bool
isCCS :: forall a. Record a -> Bool
isCCS (Record ProtocolType
ProtocolType_ChangeCipherSpec Version
_ Fragment a
_) = Bool
True
isCCS Record a
_ = Bool
False

isEmptyHandshake :: Either TLSError Packet -> Bool
isEmptyHandshake :: Either TLSError Packet -> Bool
isEmptyHandshake (Right (Handshake [])) = Bool
True
isEmptyHandshake Either TLSError Packet
_ = Bool
False

logPacket :: Context -> String -> IO ()
logPacket :: Context -> String -> IO ()
logPacket Context
ctx String
msg = Context -> (Logging -> IO ()) -> IO ()
withLog Context
ctx ((Logging -> IO ()) -> IO ()) -> (Logging -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Logging
logging -> Logging -> String -> IO ()
loggingPacketRecv Logging
logging String
msg

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

recvPacket13 :: Context -> IO (Either TLSError Packet13)
recvPacket13 :: Context -> IO (Either TLSError Packet13)
recvPacket13 ctx :: Context
ctx@Context{ctxRecordLayer :: ()
ctxRecordLayer = RecordLayer a
recordLayer} = Int -> IO (Either TLSError Packet13)
loop Int
0
  where
    lim :: Int
lim = Limit -> Int
limitHandshakeFragment (Limit -> Int) -> Limit -> Int
forall a b. (a -> b) -> a -> b
$ Shared -> Limit
sharedLimit (Shared -> Limit) -> Shared -> Limit
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx
    loop :: Int -> IO (Either TLSError Packet13)
loop Int
count
        | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lim =
            Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError Packet13 -> IO (Either TLSError Packet13))
-> Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError Packet13
forall a b. a -> Either a b
Left (TLSError -> Either TLSError Packet13)
-> TLSError -> Either TLSError Packet13
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Packet String
"too many handshake fragment"
    loop Int
count = do
        erecord <- RecordLayer a -> Context -> IO (Either TLSError (Record Plaintext))
forall a.
RecordLayer a -> Context -> IO (Either TLSError (Record Plaintext))
recordRecv13 RecordLayer a
recordLayer Context
ctx
        case erecord of
            Left err :: TLSError
err@(Error_Protocol String
_ AlertDescription
BadRecordMac) -> do
                -- If the server decides to reject RTT0 data but accepts RTT1
                -- data, the server should skip all records for RTT0 data.
                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
                established <- Context -> IO Established
ctxEstablished Context
ctx
                case established of
                    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)
                            Int -> IO (Either TLSError Packet13)
loop (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    Established
_ -> Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError Packet13 -> IO (Either TLSError Packet13))
-> Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError Packet13
forall a b. a -> Either a b
Left TLSError
err
            Left TLSError
err -> do
                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
                Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TLSError Packet13 -> IO (Either TLSError Packet13))
-> Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a b. (a -> b) -> a -> b
$ TLSError -> Either TLSError Packet13
forall a b. a -> Either a b
Left TLSError
err
            Right Record Plaintext
record -> do
                pktRecv <- Context -> Record Plaintext -> IO (Either TLSError Packet13)
decodePacket13 Context
ctx Record Plaintext
record
                if isEmptyHandshake13 pktRecv
                    then do
                        logPacket ctx "Handshake fragment"
                        -- When a handshake record is fragmented we
                        -- continue receiving in order to feed
                        -- stHandshakeRecordCont13
                        loop (count + 1)
                    else do
                        case pktRecv of
                            Right (Handshake13 [Handshake13]
hss) -> do
                                pktRecv'@(Right pkt) <- Context
-> (Hooks -> IO (Either TLSError Packet13))
-> IO (Either TLSError Packet13)
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx ((Hooks -> IO (Either TLSError Packet13))
 -> IO (Either TLSError Packet13))
-> (Hooks -> IO (Either TLSError Packet13))
-> IO (Either TLSError Packet13)
forall a b. (a -> b) -> a -> b
$ \Hooks
hooks ->
                                    Packet13 -> Either TLSError Packet13
forall a b. b -> Either a b
Right (Packet13 -> Either TLSError Packet13)
-> ([Handshake13] -> Packet13)
-> [Handshake13]
-> Either TLSError Packet13
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Handshake13] -> Packet13
Handshake13 ([Handshake13] -> Either TLSError Packet13)
-> IO [Handshake13] -> IO (Either TLSError Packet13)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handshake13 -> IO Handshake13)
-> [Handshake13] -> IO [Handshake13]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Hooks -> Handshake13 -> IO Handshake13
hookRecvHandshake13 Hooks
hooks) [Handshake13]
hss
                                logPacket ctx $ show pkt
                                return pktRecv'
                            Right Packet13
pkt -> do
                                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Packet13 -> String
forall a. Show a => a -> String
show Packet13
pkt
                                Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either TLSError Packet13
pktRecv
                            Left TLSError
err -> do
                                Context -> String -> IO ()
logPacket Context
ctx (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> String
forall a. Show a => a -> String
show TLSError
err
                                Either TLSError Packet13 -> IO (Either TLSError Packet13)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either TLSError Packet13
pktRecv

isEmptyHandshake13 :: Either TLSError Packet13 -> Bool
isEmptyHandshake13 :: Either TLSError Packet13 -> Bool
isEmptyHandshake13 (Right (Handshake13 [])) = Bool
True
isEmptyHandshake13 Either TLSError Packet13
_ = Bool
False

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

isRecvComplete :: Context -> IO Bool
isRecvComplete :: Context -> IO Bool
isRecvComplete Context
ctx = Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt Bool -> IO Bool) -> TLSSt Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    cont <- (TLSState -> Maybe (GetContinuation (HandshakeType, ByteString)))
-> TLSSt (Maybe (GetContinuation (HandshakeType, ByteString)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TLSState -> Maybe (GetContinuation (HandshakeType, ByteString))
stHandshakeRecordCont
    cont13 <- gets stHandshakeRecordCont13
    return $ isNothing cont && isNothing cont13

checkValid :: Context -> IO ()
checkValid :: Context -> IO ()
checkValid Context
ctx = do
    established <- Context -> IO Established
ctxEstablished Context
ctx
    when (established == NotEstablished) $ throwIO ConnectionNotEstablished
    eofed <- ctxEOF ctx
    when eofed $ throwIO $ PostHandshake Error_EOF

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

type Builder b = [b] -> [b]

-- | State monad used to group several packets together and send them on wire as
-- single flight.  When packets are loaded in the monad, they are logged
-- immediately, update the context digest and transcript, but actual sending is
-- deferred.  Packets are sent all at once when the monadic computation ends
-- (normal termination but also if interrupted by an exception).
newtype PacketFlightM b a
    = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a)
    deriving ((forall a b. (a -> b) -> PacketFlightM b a -> PacketFlightM b b)
-> (forall a b. a -> PacketFlightM b b -> PacketFlightM b a)
-> Functor (PacketFlightM b)
forall a b. a -> PacketFlightM b b -> PacketFlightM b a
forall a b. (a -> b) -> PacketFlightM b a -> PacketFlightM b b
forall b a b. a -> PacketFlightM b b -> PacketFlightM b a
forall b a b. (a -> b) -> PacketFlightM b a -> PacketFlightM b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall b a b. (a -> b) -> PacketFlightM b a -> PacketFlightM b b
fmap :: forall a b. (a -> b) -> PacketFlightM b a -> PacketFlightM b b
$c<$ :: forall b a b. a -> PacketFlightM b b -> PacketFlightM b a
<$ :: forall a b. a -> PacketFlightM b b -> PacketFlightM b a
Functor, Functor (PacketFlightM b)
Functor (PacketFlightM b) =>
(forall a. a -> PacketFlightM b a)
-> (forall a b.
    PacketFlightM b (a -> b) -> PacketFlightM b a -> PacketFlightM b b)
-> (forall a b c.
    (a -> b -> c)
    -> PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b c)
-> (forall a b.
    PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b)
-> (forall a b.
    PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b a)
-> Applicative (PacketFlightM b)
forall b. Functor (PacketFlightM b)
forall a. a -> PacketFlightM b a
forall b a. a -> PacketFlightM b a
forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b a
forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
forall a b.
PacketFlightM b (a -> b) -> PacketFlightM b a -> PacketFlightM b b
forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b a
forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
forall b a b.
PacketFlightM b (a -> b) -> PacketFlightM b a -> PacketFlightM b b
forall a b c.
(a -> b -> c)
-> PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b c
forall b a b c.
(a -> b -> c)
-> PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall b a. a -> PacketFlightM b a
pure :: forall a. a -> PacketFlightM b a
$c<*> :: forall b a b.
PacketFlightM b (a -> b) -> PacketFlightM b a -> PacketFlightM b b
<*> :: forall a b.
PacketFlightM b (a -> b) -> PacketFlightM b a -> PacketFlightM b b
$cliftA2 :: forall b a b c.
(a -> b -> c)
-> PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b c
liftA2 :: forall a b c.
(a -> b -> c)
-> PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b c
$c*> :: forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
*> :: forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
$c<* :: forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b a
<* :: forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b a
Applicative, Applicative (PacketFlightM b)
Applicative (PacketFlightM b) =>
(forall a b.
 PacketFlightM b a -> (a -> PacketFlightM b b) -> PacketFlightM b b)
-> (forall a b.
    PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b)
-> (forall a. a -> PacketFlightM b a)
-> Monad (PacketFlightM b)
forall b. Applicative (PacketFlightM b)
forall a. a -> PacketFlightM b a
forall b a. a -> PacketFlightM b a
forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
forall a b.
PacketFlightM b a -> (a -> PacketFlightM b b) -> PacketFlightM b b
forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
forall b a b.
PacketFlightM b a -> (a -> PacketFlightM b b) -> PacketFlightM b b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall b a b.
PacketFlightM b a -> (a -> PacketFlightM b b) -> PacketFlightM b b
>>= :: forall a b.
PacketFlightM b a -> (a -> PacketFlightM b b) -> PacketFlightM b b
$c>> :: forall b a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
>> :: forall a b.
PacketFlightM b a -> PacketFlightM b b -> PacketFlightM b b
$creturn :: forall b a. a -> PacketFlightM b a
return :: forall a. a -> PacketFlightM b a
Monad, Monad (PacketFlightM b)
Monad (PacketFlightM b) =>
(forall a. String -> PacketFlightM b a)
-> MonadFail (PacketFlightM b)
forall b. Monad (PacketFlightM b)
forall a. String -> PacketFlightM b a
forall b a. String -> PacketFlightM b a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall b a. String -> PacketFlightM b a
fail :: forall a. String -> PacketFlightM b a
MonadFail, Monad (PacketFlightM b)
Monad (PacketFlightM b) =>
(forall a. IO a -> PacketFlightM b a) -> MonadIO (PacketFlightM b)
forall b. Monad (PacketFlightM b)
forall a. IO a -> PacketFlightM b a
forall b a. IO a -> PacketFlightM b a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall b a. IO a -> PacketFlightM b a
liftIO :: forall a. IO a -> PacketFlightM b a
MonadIO)

runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight :: forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight ctx :: Context
ctx@Context{ctxRecordLayer :: ()
ctxRecordLayer = RecordLayer a
recordLayer} (PacketFlightM ReaderT (RecordLayer a, IORef (Builder a)) IO a
f) = do
    ref <- Builder a -> IO (IORef (Builder a))
forall a. a -> IO (IORef a)
newIORef Builder a
forall a. a -> a
id
    runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref

sendPendingFlight
    :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO ()
sendPendingFlight :: forall b.
Monoid b =>
Context -> RecordLayer b -> IORef (Builder b) -> IO ()
sendPendingFlight Context
ctx RecordLayer b
recordLayer IORef (Builder b)
ref = do
    build <- IORef (Builder b) -> IO (Builder b)
forall a. IORef a -> IO a
readIORef IORef (Builder b)
ref
    let bss = Builder b
build []
    unless (null bss) $ recordSendBytes recordLayer ctx $ mconcat bss

loadPacket13 :: Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 :: forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx Packet13
pkt = ReaderT (RecordLayer b, IORef (Builder b)) IO ()
-> PacketFlightM b ()
forall b a.
ReaderT (RecordLayer b, IORef (Builder b)) IO a
-> PacketFlightM b a
PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO ()
 -> PacketFlightM b ())
-> ReaderT (RecordLayer b, IORef (Builder b)) IO ()
-> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ do
    (recordLayer, ref) <- ReaderT
  (RecordLayer b, IORef (Builder b))
  IO
  (RecordLayer b, IORef (Builder b))
forall r (m :: * -> *). MonadReader r m => m r
ask
    liftIO $ do
        bs <- writePacketBytes13 ctx recordLayer pkt
        modifyIORef ref (. (bs :))