-- | Writing a message straight into packet buffers, a packet at a time.  This
-- module alone owns a packet's storage and its framing.  A producer writes
-- ordinary 'BB.Builder's, except the bulk row writer and the scalar parameter
-- path, which poke a value held in memory ('unsafeWriteSized').
--
-- A packet's storage stays private until its last write.  The writer then lets
-- go of it, and only then is it the 'B.ByteString' a sink receives, so no
-- 'B.ByteString' ever refers to memory that is still being written.  What
-- belongs in front of a packet, such as an SMP header, is the sink's to send
-- beside it.
module Hmssql.Tds.PacketWriter
  ( PacketSink
  , inSource, withSourceScope, PacketWriter, runPacketWriter, runPacketWriterWith, writeBytes, writeBuilder
  , unsafeWriteSized
  ) where

import Control.Exception (onException)
import Data.Bits ((.&.), (.|.), complement)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Extra as BB
import qualified Data.ByteString.Internal as BI
import Data.IORef
import Data.Word (Word8)
import Foreign.ForeignPtr (ForeignPtr)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (Ptr, plusPtr)
import Hmssql.Tds.Context
import Hmssql.Tds.Packet

-- | Where a message's complete TDS packets go, in order.  Each is immutable
-- and belongs to the sink: the writer keeps no reference to it.
type PacketSink = B.ByteString -> IO ()

payloadOffset :: Int
payloadOffset :: Int
payloadOffset = Int
headerLength

newStorage :: Int -> IO (ForeignPtr Word8)
newStorage :: Int -> IO (ForeignPtr Word8)
newStorage Int
n = Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BI.mallocByteString (Int
payloadOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

-- Open holds storage, bytes used, packet serial and allocated capacity.
-- Only the first packet can have storage smaller than the negotiated payload.
-- The state is an IORef because producers write over many calls with their own
-- code in between, such as a parameter's source, so no one callback spans a
-- packet's life.  That mutability stays behind 'writeBytes' and 'writeBuilder'.
data PacketState = Open !(ForeignPtr Word8) !Int !Int !Int | Closed

-- | The writer of one message: the packet being filled, and where the complete
-- packets go.
data PacketWriter = PacketWriter
  { PacketWriter -> Int
payloadSize :: !Int
  , PacketWriter -> PacketState -> Bool -> IO ()
emitPacket :: PacketState -> Bool -> IO ()
  , PacketWriter -> forall a. IO a -> IO a
inSource :: forall a. IO a -> IO a
    -- ^ The scope a parameter's source runs in ('withSourceScope').
  , PacketWriter -> IORef PacketState
packetState :: !(IORef PacketState)
  }

-- | Run a producer with a writer for a message of this packet type.  Each
-- packet goes to the sink as it fills, and the last when the producer returns.
runPacketWriter :: TdsContext -> PacketType -> PacketSink -> (PacketWriter -> IO a) -> IO a
runPacketWriter :: forall a.
TdsContext
-> PacketType -> PacketSink -> (PacketWriter -> IO a) -> IO a
runPacketWriter TdsContext
ctx PacketType
ptype = TdsContext
-> PacketType
-> PacketStatus
-> PacketSink
-> (PacketWriter -> IO a)
-> IO a
forall a.
TdsContext
-> PacketType
-> PacketStatus
-> PacketSink
-> (PacketWriter -> IO a)
-> IO a
runPacketWriterWith TdsContext
ctx PacketType
ptype (Word8 -> PacketStatus
PacketStatus Word8
0)

-- | 'runPacketWriter' with extra status bits, which go on every packet, except
-- that RESETCONNECTION goes on the first alone.  Every packet but the last is
-- full.
runPacketWriterWith :: TdsContext -> PacketType -> PacketStatus -> PacketSink -> (PacketWriter -> IO a) -> IO a
runPacketWriterWith :: forall a.
TdsContext
-> PacketType
-> PacketStatus
-> PacketSink
-> (PacketWriter -> IO a)
-> IO a
runPacketWriterWith TdsContext
ctx PacketType
ptype PacketStatus
extra PacketSink
sink PacketWriter -> IO a
produce = do
  let capacity :: Int
capacity = TdsContext -> Int
packetPayloadSize TdsContext
ctx
      -- Most requests are far smaller than a packet.  Starting small saves a
      -- 4 KiB or 8 KiB allocation per request, and costs one copy when a
      -- message outgrows it ('makeRoom').
      initial :: Int
initial = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
256 Int
capacity
      emit :: PacketState -> Bool -> IO ()
emit PacketState
Closed Bool
_ = IO ()
forall a. IO a
writerEnded
      emit (Open ForeignPtr Word8
fp Int
used Int
serial Int
_) Bool
final = do
        let status :: PacketStatus
status = (if Bool
final then PacketStatus
statusEndOfMessage else Word8 -> PacketStatus
PacketStatus Word8
0) PacketStatus -> PacketStatus -> PacketStatus
forall a. Bits a => a -> a -> a
.|.
              (if Int
serial Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then PacketStatus
extra else PacketStatus
extra PacketStatus -> PacketStatus -> PacketStatus
forall a. Bits a => a -> a -> a
.&. PacketStatus -> PacketStatus
forall a. Bits a => a -> a
complement PacketStatus
statusResetConnection)
        -- The last write to this storage: the caller has already replaced or
        -- closed the writer's state, so nothing can reach it after the freeze.
        ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p ->
          Ptr Word8 -> PacketType -> PacketStatus -> Int -> Word8 -> IO ()
pokePacketHeader Ptr Word8
p PacketType
ptype PacketStatus
status (Int
headerLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
used) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
serial)
        PacketSink
sink (ForeignPtr Word8 -> Int -> ByteString
BI.BS ForeignPtr Word8
fp (Int
headerLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
used))
  state <- Int -> IO (ForeignPtr Word8)
newStorage Int
initial IO (ForeignPtr Word8)
-> (ForeignPtr Word8 -> IO (IORef PacketState))
-> IO (IORef PacketState)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ForeignPtr Word8
fp -> PacketState -> IO (IORef PacketState)
forall a. a -> IO (IORef a)
newIORef (ForeignPtr Word8 -> Int -> Int -> Int -> PacketState
Open ForeignPtr Word8
fp Int
0 Int
1 Int
initial)
  let writer = Int
-> (PacketState -> Bool -> IO ())
-> (forall a. IO a -> IO a)
-> IORef PacketState
-> PacketWriter
PacketWriter Int
capacity PacketState -> Bool -> IO ()
emit IO a -> IO a
forall a. a -> a
forall a. IO a -> IO a
id IORef PacketState
state
      finish = do
        final <- PacketWriter -> IO PacketState
readOpen PacketWriter
writer
        writeIORef state Closed
        emit final True
  (do result <- produce writer
      finish
      pure result) `onException` writeIORef state Closed

readOpen :: PacketWriter -> IO PacketState
readOpen :: PacketWriter -> IO PacketState
readOpen PacketWriter
writer = IORef PacketState -> IO PacketState
forall a. IORef a -> IO a
readIORef (PacketWriter -> IORef PacketState
packetState PacketWriter
writer) IO PacketState -> (PacketState -> IO PacketState) -> IO PacketState
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  PacketState
Closed -> IO PacketState
forall a. IO a
writerEnded
  PacketState
state -> PacketState -> IO PacketState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PacketState
state

writerEnded :: IO a
writerEnded :: forall a. IO a
writerEnded = [Char] -> IO a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"Hmssql.Tds.PacketWriter: a writer used after its message ended"

-- Grow the initial buffer or emit a full packet and start its successor.
makeRoom :: PacketWriter -> PacketState -> IO ()
makeRoom :: PacketWriter -> PacketState -> IO ()
makeRoom PacketWriter
_ PacketState
Closed = IO ()
forall a. IO a
writerEnded
makeRoom PacketWriter
writer old :: PacketState
old@(Open ForeignPtr Word8
previous Int
used Int
serial Int
capacity) = do
  let full :: Int
full = PacketWriter -> Int
payloadSize PacketWriter
writer
  fp <- Int -> IO (ForeignPtr Word8)
newStorage Int
full
  if capacity < full then do
    -- Small requests never need a full packet allocation. Growing before
    -- emission still makes every non-final packet exactly the negotiated size.
    BI.unsafeWithForeignPtr previous $ \Ptr Word8
src -> ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst ->
      Ptr (ZonkAny 0) -> Ptr (ZonkAny 0) -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr Word8
dst Ptr Word8 -> Int -> Ptr (ZonkAny 0)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOffset) (Ptr Word8
src Ptr Word8 -> Int -> Ptr (ZonkAny 0)
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOffset) Int
used
    writeIORef (packetState writer) (Open fp used serial full)
  else do
    writeIORef (packetState writer) (Open fp 0 (serial + 1) full)
    emitPacket writer old False

-- | Copy bytes into the message, across packets as needed.  Nothing of the
-- source is kept once it has been copied, and a full packet goes to the sink
-- when the next byte arrives.
writeBytes :: PacketWriter -> B.ByteString -> IO ()
writeBytes :: PacketWriter -> PacketSink
writeBytes PacketWriter
writer = PacketSink
go
  where
    go :: PacketSink
go ByteString
bytes | ByteString -> Bool
B.null ByteString
bytes = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go ByteString
bytes = PacketWriter -> IO PacketState
readOpen PacketWriter
writer IO PacketState -> (PacketState -> 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
>>= \case
      PacketState
Closed -> IO ()
forall a. IO a
writerEnded
      state :: PacketState
state@(Open ForeignPtr Word8
fp Int
used Int
serial Int
capacity)
        | Int
used Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
capacity -> PacketWriter -> PacketState -> IO ()
makeRoom PacketWriter
writer PacketState
state IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PacketSink
go ByteString
bytes
        | Bool
otherwise -> do
            let n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
capacity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
used) (ByteString -> Int
B.length ByteString
bytes)
            ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst -> case ByteString
bytes of
              BI.BS ForeignPtr Word8
src Int
_ -> ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
src ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p ->
                Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr Word8
dst Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
payloadOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
used)) Ptr Word8
p Int
n
            IORef PacketState -> PacketState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PacketWriter -> IORef PacketState
packetState PacketWriter
writer) (ForeignPtr Word8 -> Int -> Int -> Int -> PacketState
Open ForeignPtr Word8
fp (Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int
serial Int
capacity)
            PacketSink
go (Int -> ByteString -> ByteString
B.drop Int
n ByteString
bytes)

-- | Write exactly @n@ bytes by poking them: straight into the current packet when they
-- fit, and otherwise staged in a buffer of their own and copied as 'writeBytes' copies.
-- The action must write all @n@ bytes from the pointer it is given, read nothing there,
-- and keep no reference to it.  This is for the two producers that compute a
-- write's size and its pokes from one description of a value: the bulk row
-- writer, and the scalar parameter path in "Hmssql.Tds.Parameter".
unsafeWriteSized :: PacketWriter -> Int -> (Ptr Word8 -> IO ()) -> IO ()
unsafeWriteSized :: PacketWriter -> Int -> (Ptr Word8 -> IO ()) -> IO ()
unsafeWriteSized PacketWriter
writer Int
n Ptr Word8 -> IO ()
poke = PacketWriter -> IO PacketState
readOpen PacketWriter
writer IO PacketState -> (PacketState -> 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
>>= \case
  Open ForeignPtr Word8
fp Int
used Int
serial Int
capacity | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
capacity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
used -> do
    ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> IO ()
poke (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
payloadOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
used))
    IORef PacketState -> PacketState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PacketWriter -> IORef PacketState
packetState PacketWriter
writer) (ForeignPtr Word8 -> Int -> Int -> Int -> PacketState
Open ForeignPtr Word8
fp (Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int
serial Int
capacity)
  PacketState
state -> PacketWriter -> PacketState -> Int -> (Ptr Word8 -> IO ()) -> IO ()
writeSizedSlow PacketWriter
writer PacketState
state Int
n Ptr Word8 -> IO ()
poke
{-# INLINE unsafeWriteSized #-}

-- The small first buffer grows before anything else, as in 'writeBuilder', so that a
-- row splits across packets only where the message really exceeds a packet.
writeSizedSlow :: PacketWriter -> PacketState -> Int -> (Ptr Word8 -> IO ()) -> IO ()
writeSizedSlow :: PacketWriter -> PacketState -> Int -> (Ptr Word8 -> IO ()) -> IO ()
writeSizedSlow PacketWriter
writer PacketState
state Int
n Ptr Word8 -> IO ()
poke = case PacketState
state of
  PacketState
Closed -> IO ()
forall a. IO a
writerEnded
  Open ForeignPtr Word8
_ Int
_ Int
_ Int
capacity
    | Int
capacity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< PacketWriter -> Int
payloadSize PacketWriter
writer -> PacketWriter -> PacketState -> IO ()
makeRoom PacketWriter
writer PacketState
state IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PacketWriter -> Int -> (Ptr Word8 -> IO ()) -> IO ()
unsafeWriteSized PacketWriter
writer Int
n Ptr Word8 -> IO ()
poke
    | Bool
otherwise -> Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BI.create Int
n Ptr Word8 -> IO ()
poke IO ByteString -> PacketSink -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PacketWriter -> PacketSink
writeBytes PacketWriter
writer
{-# NOINLINE writeSizedSlow #-}

-- | Run a 'BB.Builder' into the packets.  A primitive that needs more
-- contiguous room than the packet has left is written to a small buffer of
-- its own, whose bytes fill the current packet and continue in the next, and
-- a chunk the builder inserts goes through 'writeBytes'.
writeBuilder :: PacketWriter -> BB.Builder -> IO ()
writeBuilder :: PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
writer = (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go ((Ptr Word8 -> Int -> IO (Int, Next)) -> IO ())
-> (Builder -> Ptr Word8 -> Int -> IO (Int, Next))
-> Builder
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Ptr Word8 -> Int -> IO (Int, Next)
BB.runBuilder
  where
    go :: (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go Ptr Word8 -> Int -> IO (Int, Next)
build = PacketWriter -> IO PacketState
readOpen PacketWriter
writer IO PacketState -> (PacketState -> 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
>>= \case
      PacketState
Closed -> IO ()
forall a. IO a
writerEnded
      Open ForeignPtr Word8
fp Int
used Int
serial Int
capacity -> do
            let room :: Int
room = Int
capacity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
used
            (written, next) <- ForeignPtr Word8 -> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next))
-> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO (Int, Next)
build (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
payloadOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
used)) Int
room
            writeIORef (packetState writer) (Open fp (used + written) serial capacity)
            continue capacity (room - written) next
    continue :: Int -> Int -> Next -> IO ()
continue Int
_ Int
_ Next
BB.Done = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    continue Int
_ Int
_ (BB.Chunk ByteString
bytes Ptr Word8 -> Int -> IO (Int, Next)
next) = PacketWriter -> PacketSink
writeBytes PacketWriter
writer ByteString
bytes IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go Ptr Word8 -> Int -> IO (Int, Next)
next
    -- A Builder primitive asks for contiguous room.  The small first buffer
    -- grows before anything else happens, so that a request's fields split
    -- across packets only where the message really exceeds a packet.
    continue Int
capacity Int
room (BB.More Int
needed Ptr Word8 -> Int -> IO (Int, Next)
next)
      | Int
room Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
needed = (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go Ptr Word8 -> Int -> IO (Int, Next)
next
      | Int
needed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= PacketWriter -> Int
payloadSize PacketWriter
writer Bool -> Bool -> Bool
&& (Int
room Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
capacity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< PacketWriter -> Int
payloadSize PacketWriter
writer) =
          PacketWriter -> IO PacketState
readOpen PacketWriter
writer IO PacketState -> (PacketState -> 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
>>= PacketWriter -> PacketState -> IO ()
makeRoom PacketWriter
writer IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go Ptr Word8 -> Int -> IO (Int, Next)
next
      | Bool
otherwise = do
          let size :: Int
size = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
64 Int
needed
          fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BI.mallocByteString Int
size
          (written, after) <- BI.unsafeWithForeignPtr fp $ \Ptr Word8
p -> Ptr Word8 -> Int -> IO (Int, Next)
next Ptr Word8
p Int
size
          writeBytes writer (BI.BS fp written)
          case after of
            Next
BB.Done -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            BB.Chunk ByteString
bytes Ptr Word8 -> Int -> IO (Int, Next)
k -> PacketWriter -> PacketSink
writeBytes PacketWriter
writer ByteString
bytes IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go Ptr Word8 -> Int -> IO (Int, Next)
k
            BB.More Int
count Ptr Word8 -> Int -> IO (Int, Next)
k -> (Ptr Word8 -> Int -> IO (Int, Next)) -> IO ()
go (Int
-> (Ptr Word8 -> Int -> IO (Int, Next))
-> Ptr Word8
-> Int
-> IO (Int, Next)
checked Int
count Ptr Word8 -> Int -> IO (Int, Next)
k)
    -- The continuation of a staged primitive may ask for more room than the
    -- packet has.  Rather than run it short, hand its request back to the
    -- @More@ case above, which stages it in turn.
    checked :: Int
-> (Ptr Word8 -> Int -> IO (Int, Next))
-> Ptr Word8
-> Int
-> IO (Int, Next)
checked Int
needed Ptr Word8 -> Int -> IO (Int, Next)
next Ptr Word8
p Int
room
      | Int
room Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
needed = Ptr Word8 -> Int -> IO (Int, Next)
next Ptr Word8
p Int
room
      | Bool
otherwise = (Int, Next) -> IO (Int, Next)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int -> (Ptr Word8 -> Int -> IO (Int, Next)) -> Next
BB.More Int
needed Ptr Word8 -> Int -> IO (Int, Next)
next)

-- | Run the writer's sources in this scope, which is how the connection refuses
-- a request made from inside a parameter's source.
withSourceScope :: (forall a. IO a -> IO a) -> PacketWriter -> PacketWriter
withSourceScope :: (forall a. IO a -> IO a) -> PacketWriter -> PacketWriter
withSourceScope forall a. IO a -> IO a
scope PacketWriter
writer = PacketWriter
writer { inSource = scope }