{-# OPTIONS_HADDOCK not-home #-}

-- | What "Hmssql.Query" and "Hmssql.BatchQuery" share beyond the types of
-- "Hmssql.Query.Types": encoding a query into its @sp_executesql@ call,
-- reading a response step by step, decoding result sets from a reader, and
-- packing statements into messages.  Applications use "Hmssql.Query",
-- which re-exports 'readStep', 'drainResponse' and 'paramNameProblem';
-- nothing here is stable.
module Hmssql.Query.Internal where

import Control.Exception
import Control.Applicative ((<|>))
import Control.Monad (foldM)
import qualified Data.ByteString as B
import Data.IORef
import qualified Data.List as List
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (absurd)
import Streaming (Of (..), Stream, effect)
import qualified Streaming.Internal as SI

import Hmssql.Connection.Internal
import Hmssql.Decoding
import Hmssql.Encoding
import Hmssql.Errors
import Hmssql.Query.Lexer (isVariableChar)
import Hmssql.Query.Types
import Hmssql.SqlValue
import Hmssql.Tds.Parameter (paramValueProblem)
import Hmssql.Tds.Client
import Hmssql.Tds.Context
import Hmssql.Tds.Packet
import Hmssql.Tds.Primitives (Collation (..))
import Hmssql.Tds.Token
import Hmssql.Tds.TypeInfo
import qualified Hmssql.Tds.Utf16 as Utf16

------------------------------------------------------------------------------
-- Encoding queries

-- | The @sp_executesql@ call of a statement with its parameters named.
executeSqlRpc :: Text -> [(Text, EncodedParam)] -> RpcRequest
executeSqlRpc :: Text -> [(Text, EncodedParam)] -> RpcRequest
executeSqlRpc Text
sql [(Text, EncodedParam)]
named = RpcProc -> Word16 -> [RpcParam] -> RpcRequest
RpcRequest RpcProc
procSpExecuteSql Word16
0 ([RpcParam] -> RpcRequest) -> [RpcParam] -> RpcRequest
forall a b. (a -> b) -> a -> b
$ case [(Text, EncodedParam)]
named of
  [] -> [Text -> RpcParam
textParam Text
sql]
  [(Text, EncodedParam)]
_ -> Text -> RpcParam
textParam Text
sql RpcParam -> [RpcParam] -> [RpcParam]
forall a. a -> [a] -> [a]
: [(Text, EncodedParam)] -> RpcParam
declarationParam [(Text, EncodedParam)]
named RpcParam -> [RpcParam] -> [RpcParam]
forall a. a -> [a] -> [a]
: [(Text, EncodedParam)] -> [RpcParam]
valueParams [(Text, EncodedParam)]
named

-- | An @nvarchar(max)@ parameter of @sp_executesql@'s own: the statement,
-- or the declaration.
textParam :: Text -> RpcParam
textParam :: Text -> RpcParam
textParam Text
t = Text -> Word8 -> TypeInfo -> ParamValue -> RpcParam
RpcParam Text
"" Word8
0 (Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)) (RawBytes -> ParamValue
ParamBytes (ByteString -> RawBytes
forall a. a -> Maybe a
Just (Text -> ByteString
Utf16.encodeUtf16LE Text
t)))

-- | @\@params@: the parameters' names and types, @\@p1 int,\@p2
-- nvarchar(4000)@, written as UTF-16LE straight into one buffer.
declarationParam :: [(Text, EncodedParam)] -> RpcParam
declarationParam :: [(Text, EncodedParam)] -> RpcParam
declarationParam [(Text, EncodedParam)]
named = Text -> RpcParam
textParam (Text -> [Text] -> Text
T.intercalate Text
"," [Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeInfo -> Text
typeInfoSqlName TypeInfo
ti | (Text
name, (TypeInfo
ti, ParamValue
_)) <- [(Text, EncodedParam)]
named])

valueParams :: [(Text, EncodedParam)] -> [RpcParam]
valueParams :: [(Text, EncodedParam)] -> [RpcParam]
valueParams [(Text, EncodedParam)]
named = [Text -> Word8 -> TypeInfo -> ParamValue -> RpcParam
RpcParam Text
name Word8
0 TypeInfo
ti ParamValue
v | (Text
name, (TypeInfo
ti, ParamValue
v)) <- [(Text, EncodedParam)]
named]

-- | A query's text and its parameters, encoded, checked and named, or why
-- it can't be sent.
encodeQuery :: TdsContext -> Query -> Either String (Text, [(Text, EncodedParam)])
encodeQuery :: TdsContext -> Query -> Either [Char] (Text, [(Text, EncodedParam)])
encodeQuery TdsContext
ctx Query
q = do
  ([Char] -> Either [Char] (ZonkAny 2))
-> Maybe [Char] -> Either [Char] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> Either [Char] (ZonkAny 2)
forall a b. a -> Either a b
Left (Int -> [Fragment] -> Maybe [Char]
fragmentsProblem (Query -> Int
queryPositional Query
q) [Fragment]
frags)
  named <- TdsContext -> [QueryParam] -> Either [Char] [(Text, EncodedParam)]
encodeQueryParams TdsContext
ctx (Query -> [QueryParam]
queryParams Query
q)
  pure (sql, named)
  where
    -- Flattened once, for the check and the text.
    frags :: [Fragment]
frags = Query -> [Fragment]
queryFragments Query
q
    sql :: Text
sql = [Fragment] -> Text
renderFragments [Fragment]
frags

-- | Parameters encoded, checked and named: the positional ones @pN by
-- their position among the positional ones.
encodeQueryParams :: TdsContext -> [QueryParam] -> Either String [(Text, EncodedParam)]
encodeQueryParams :: TdsContext -> [QueryParam] -> Either [Char] [(Text, EncodedParam)]
encodeQueryParams TdsContext
ctx = \case
  [] -> [(Text, EncodedParam)] -> Either [Char] [(Text, EncodedParam)]
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  [QueryParam]
params -> do
    named <- Int -> [QueryParam] -> Either [Char] [(Text, EncodedParam)]
encodeAll Int
1 [QueryParam]
params
    checkDuplicates [name | (QueryParam given _, (name, _)) <- zip params named, not (T.null given)]
    pure named
  where
    encodeAll :: Int -> [QueryParam] -> Either String [(Text, EncodedParam)]
    encodeAll :: Int -> [QueryParam] -> Either [Char] [(Text, EncodedParam)]
encodeAll Int
_ [] = [(Text, EncodedParam)] -> Either [Char] [(Text, EncodedParam)]
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    encodeAll !Int
i (QueryParam Text
given TdsContext -> Either [Char] EncodedParam
enc : [QueryParam]
ps)
      | Text -> Bool
T.null Text
given = do
          (ti, v) <- TdsContext -> Either [Char] EncodedParam
enc TdsContext
ctx
          let name = Int -> Text
positionalName Int
i
          mapM_ Left (valueProblems name ti v)
          ((name, (ti, v)) :) <$> encodeAll (i + 1) ps
      | Bool
otherwise = do
          (ti, v) <- TdsContext -> Either [Char] EncodedParam
enc TdsContext
ctx
          mapM_ Left (reservedNameProblem given <|> paramNameProblem given <|> rpcParamProblem (RpcParam given 0 ti v))
          ((given, (ti, v)) :) <$> encodeAll i ps
    -- 'rpcParamProblem' without the name's length check, which a
    -- positional name passes.
    valueProblems :: Text -> TypeInfo -> ParamValue -> Maybe [Char]
valueProblems Text
name TypeInfo
ti ParamValue
v = (([Char]
"parameter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": ") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (TypeInfo -> Maybe [Char]
typeInfoProblem TypeInfo
ti Maybe [Char] -> Maybe [Char] -> Maybe [Char]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TypeInfo -> ParamValue -> Maybe [Char]
paramValueProblem TypeInfo
ti ParamValue
v)
    checkDuplicates :: [Text] -> Either [Char] ()
checkDuplicates = Set Text -> [Text] -> Either [Char] ()
go Set Text
forall a. Set a
Set.empty
    go :: Set Text -> [Text] -> Either [Char] ()
go Set Text
_ [] = () -> Either [Char] ()
forall a. a -> Either [Char] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go Set Text
seen (Text
n : [Text]
ns)
      | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
key Set Text
seen = [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ()) -> [Char] -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char]
"duplicate parameter name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
n
      | Bool
otherwise = Set Text -> [Text] -> Either [Char] ()
go (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
key Set Text
seen) [Text]
ns
      where key :: Text
key = Text -> Text
T.toCaseFold Text
n

-- | @\@p@ and the number.
positionalName :: Int -> Text
positionalName :: Int -> Text
positionalName = Int -> Text
placeholderText

-- | A named parameter can't be called @\@pN@: that is how the positional
-- parameters are named.
reservedNameProblem :: Text -> Maybe String
reservedNameProblem :: Text -> Maybe [Char]
reservedNameProblem Text
name = case Text -> Maybe (Char, Text)
T.uncons Text
name of
  Just (Char
'@', Text
rest)
    | Just (Char
p, Text
digits) <- Text -> Maybe (Char, Text)
T.uncons Text
rest, Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
|| Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'P'
    , Bool -> Bool
not (Text -> Bool
T.null Text
digits), (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9') Text
digits ->
        [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"parameter name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is reserved for the positional parameters (@p1, @p2, ...)"
  Maybe (Char, Text)
_ -> Maybe [Char]
forall a. Maybe a
Nothing

-- | Why a parameter name can't be used, if it can't: it must be a T-SQL
-- variable name, @\@@ followed by one or more letters, combining marks,
-- decimal digits, @\@@, @#@, @$@ or @_@ (Unicode ones included, but only
-- from the Basic Multilingual Plane: SQL Server rejects surrogates in
-- identifiers).  The query functions' parameter names are spliced into the
-- @sp_executesql@ declaration, where anything else (a space, a comma, a
-- parenthesis, a comment) would change what is declared.  'callProcedure'
-- doesn't use this check: its parameter names are sent as data, and the
-- server reports the ones it can't match.  SQL Server itself accepts a few
-- more names (a bare @\@@, and ignores format characters such as U+200D
-- and trailing spaces in RPC parameter names), and rejects some letters
-- added in recent Unicode versions; it enforces its 128-character limit
-- itself.
paramNameProblem :: Text -> Maybe String
paramNameProblem :: Text -> Maybe [Char]
paramNameProblem Text
name = case Text -> Maybe (Char, Text)
T.uncons Text
name of
  Just (Char
'@', Text
rest) | Bool -> Bool
not (Text -> Bool
T.null Text
rest), (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
variableChar Text
rest -> Maybe [Char]
forall a. Maybe a
Nothing
  Maybe (Char, Text)
_ -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
    [Char]
"parameter name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a T-SQL variable name"
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (@ followed by letters, digits, @, #, $ or _)"
  where
    variableChar :: Char -> Bool
variableChar = Char -> Bool
isVariableChar

------------------------------------------------------------------------------
-- Reading responses

-- | The next thing in the response ('nextStep'), with the rows decoded
-- by the given function: a batch of rows, a token other than a row or
-- a nonfatal ERROR (withheld), or 'StepEnd', which throws the withheld error (or
-- 'SevereError') instead if there was one.  A response that ends with
-- the connection closed after an error (by the server, as after a
-- severity 20 error, or by a failed transport) throws that error; after
-- 'Hmssql.Connection.close', the 'ConnectionClosed' that every use of the
-- connection gets.  (The withheld error is the reader's, not a stream's:
-- a stream run again from a step before the error would otherwise report
-- an error it hadn't seen.)
--
-- A fatal ERROR is thrown by the common token reader immediately and
-- leaves the connection broken.
--
-- Reading one statement of a batch query ('respBatch'): the statement's
-- DONEPROC is returned and then 'StepEnd', for as long as the statement
-- stays the current one; an ERROR token isn't withheld but ends the batch
-- ('scopeFail'), and the response's end throws 'SevereError' for a
-- failed DONE but never a withheld error, which there is none of.
readStep :: ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep :: forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep = Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r.
Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepUsing Bool
False

-- 'readStep' with each batch's rows in reverse order.  Only 'readFirstResultSet'
-- uses it, and wraps each batch as a 'ReversedBatch' at once, so that no
-- streaming or token-level caller sees a 'RowBatch' out of order.
readStepReversed :: ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepReversed :: forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepReversed = Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r.
Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepUsing Bool
True

readStepUsing :: Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepUsing :: forall r.
Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepUsing Bool
reversed rr :: ResponseReader
rr@ResponseReader{Maybe Text
Maybe BatchScope
IORef Bool
IORef (Maybe Done)
IORef (Maybe ServerMessage)
IORef (Maybe Token)
ActiveResponse
Connection
respBatch :: ResponseReader -> Maybe BatchScope
respConn :: Connection
respActive :: ActiveResponse
respFirstError :: IORef (Maybe ServerMessage)
respFailedDone :: IORef (Maybe Done)
respPushback :: IORef (Maybe Token)
respStatement :: Maybe Text
respEnded :: IORef Bool
respBatch :: Maybe BatchScope
respActive :: ResponseReader -> ActiveResponse
respConn :: ResponseReader -> Connection
respEnded :: ResponseReader -> IORef Bool
respFailedDone :: ResponseReader -> IORef (Maybe Done)
respFirstError :: ResponseReader -> IORef (Maybe ServerMessage)
respPushback :: ResponseReader -> IORef (Maybe Token)
respStatement :: ResponseReader -> Maybe Text
..} RowRead r
decodeRow = IO (ResponseStep r) -> IO (ResponseStep r)
forall {a}. IO a -> IO a
withStatement (IO (ResponseStep r) -> IO (ResponseStep r))
-> IO (ResponseStep r) -> IO (ResponseStep r)
forall a b. (a -> b) -> a -> b
$ case Maybe BatchScope
respBatch of
  Maybe BatchScope
Nothing -> IORef (Maybe Token) -> IO (Maybe Token)
forall a. IORef a -> IO a
readIORef IORef (Maybe Token)
respPushback IO (Maybe Token)
-> (Maybe Token -> IO (ResponseStep r)) -> IO (ResponseStep r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Token
tok -> IORef (Maybe Token) -> Maybe Token -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Token)
respPushback Maybe Token
forall a. Maybe a
Nothing IO () -> IO (ResponseStep r) -> IO (ResponseStep r)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> ResponseStep r
forall r. Token -> ResponseStep r
StepToken Token
tok)
    Maybe Token
Nothing -> do
      r <- IO (ResponseStep r) -> IO (Either SomeException (ResponseStep r))
forall e a. Exception e => IO a -> IO (Either e a)
try ((if Bool
reversed then Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
forall r.
Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
nextStepReversed else Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
forall r.
Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
nextStep) Connection
respConn ActiveResponse
respActive RowRead r
decodeRow)
      case r of
        Left SomeException
e
          | SomeException -> Bool
closedByServer SomeException
e -> IORef (Maybe ServerMessage) -> IO (Maybe ServerMessage)
forall a. IORef a -> IO a
readIORef IORef (Maybe ServerMessage)
respFirstError IO (Maybe ServerMessage)
-> (Maybe ServerMessage -> IO (ResponseStep r))
-> IO (ResponseStep r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just ServerMessage
err -> SqlServerError -> IO (ResponseStep r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ServerMessage -> Maybe Text -> SqlServerError
SqlServerError ServerMessage
err Maybe Text
respStatement)
              Maybe ServerMessage
Nothing -> SomeException -> IO (ResponseStep r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
          | Bool
otherwise -> SomeException -> IO (ResponseStep r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
        Right ResponseStep r
StepEnd -> do
          IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
respEnded Bool
True
          firstErr <- IORef (Maybe ServerMessage) -> IO (Maybe ServerMessage)
forall a. IORef a -> IO a
readIORef IORef (Maybe ServerMessage)
respFirstError
          failedDone <- readIORef respFailedDone
          case (firstErr, failedDone) of
            (Just ServerMessage
err, Maybe Done
_) -> SqlServerError -> IO (ResponseStep r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ServerMessage -> Maybe Text -> SqlServerError
SqlServerError ServerMessage
err Maybe Text
respStatement)
            (Maybe ServerMessage
Nothing, Just Done
d) -> Connection -> Done -> Maybe Text -> IO (ResponseStep r)
forall a. Connection -> Done -> Maybe Text -> IO a
throwSevere Connection
respConn Done
d Maybe Text
respStatement
            (Maybe ServerMessage
Nothing, Maybe Done
Nothing) -> ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseStep r
forall r. ResponseStep r
StepEnd
        Right (StepToken (TError ServerMessage
msg)) -> do
          IORef (Maybe ServerMessage)
-> (Maybe ServerMessage -> Maybe ServerMessage) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Maybe ServerMessage)
respFirstError (Maybe ServerMessage -> Maybe ServerMessage -> Maybe ServerMessage
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ServerMessage -> Maybe ServerMessage
forall a. a -> Maybe a
Just ServerMessage
msg)
          Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r.
Bool -> ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepUsing Bool
reversed ResponseReader
rr RowRead r
decodeRow
        Right step :: ResponseStep r
step@(StepToken Token
tok) -> do
          Token -> IO ()
noteFailedDone Token
tok
          ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseStep r
step
        Right ResponseStep r
step -> ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseStep r
step
  Just BatchScope
scope -> do
    ended <- Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (BatchScope -> IORef Bool
scopeEnded BatchScope
scope) IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
respEnded
    if ended
      then pure StepEnd
      else readIORef respPushback >>= \case
        Just Token
tok -> IORef (Maybe Token) -> Maybe Token -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Token)
respPushback Maybe Token
forall a. Maybe a
Nothing IO () -> IO (ResponseStep r) -> IO (ResponseStep r)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BatchScope -> Token -> IO (ResponseStep r)
forall {r}. BatchScope -> Token -> IO (ResponseStep r)
statementToken BatchScope
scope Token
tok
        Maybe Token
Nothing -> (if Bool
reversed then Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
forall r.
Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
nextStepReversed else Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
forall r.
Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
nextStep) Connection
respConn ActiveResponse
respActive RowRead r
decodeRow IO (ResponseStep r)
-> (ResponseStep r -> IO (ResponseStep r)) -> IO (ResponseStep r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          ResponseStep r
StepEnd -> do
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
respEnded Bool
True
            IORef (Maybe Done) -> IO (Maybe Done)
forall a. IORef a -> IO a
readIORef IORef (Maybe Done)
respFailedDone IO (Maybe Done)
-> (Maybe Done -> IO (ResponseStep r)) -> IO (ResponseStep r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just Done
d -> do
                stmt <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (BatchScope -> IORef Text
scopeStatement BatchScope
scope)
                throwSevere respConn d (Just stmt)
              Maybe Done
Nothing -> ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseStep r
forall r. ResponseStep r
StepEnd
          StepToken (TError ServerMessage
msg) -> do
            IORef (Maybe ServerMessage)
-> (Maybe ServerMessage -> Maybe ServerMessage) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Maybe ServerMessage)
respFirstError (Maybe ServerMessage -> Maybe ServerMessage -> Maybe ServerMessage
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ServerMessage -> Maybe ServerMessage
forall a. a -> Maybe a
Just ServerMessage
msg)
            BatchScope -> ServerMessage -> IO Void
scopeFail BatchScope
scope ServerMessage
msg IO Void -> (Void -> IO (ResponseStep r)) -> IO (ResponseStep r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Void -> IO (ResponseStep r)
forall a. Void -> a
absurd
          StepToken Token
tok -> BatchScope -> Token -> IO (ResponseStep r)
forall {r}. BatchScope -> Token -> IO (ResponseStep r)
statementToken BatchScope
scope Token
tok
          ResponseStep r
step -> ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseStep r
step
  where
    -- Fatal ERRORs throw in the common token reader, before they reach
    -- scopeFail. The request names the batch's last statement, but this
    -- reader knows which statement is being consumed.
    withStatement :: IO a -> IO a
withStatement IO a
act = IO a
act IO a -> (SqlServerError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SqlServerError
err :: SqlServerError) -> do
      stmt <- IO (Maybe Text)
-> (BatchScope -> IO (Maybe Text))
-> Maybe BatchScope
-> IO (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
respStatement) ((Text -> Maybe Text) -> IO Text -> IO (Maybe Text)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Text
forall a. a -> Maybe a
Just (IO Text -> IO (Maybe Text))
-> (BatchScope -> IO Text) -> BatchScope -> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (IORef Text -> IO Text)
-> (BatchScope -> IORef Text) -> BatchScope -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchScope -> IORef Text
scopeStatement) Maybe BatchScope
respBatch
      throwIO err { sqlErrorStatement = stmt }
    closedByServer :: SomeException -> Bool
closedByServer SomeException
e = case SomeException -> Maybe ConnectionClosed
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (ConnectionClosedBy CloseReason
reason) -> Bool -> Bool
not (CloseReason -> Bool
byClient CloseReason
reason)
      Maybe ConnectionClosed
_ -> Bool
False
    byClient :: CloseReason -> Bool
byClient = \case
      CloseReason
ClosedByClient -> Bool
True
      CloseReason
_ -> Bool
False
    statementToken :: BatchScope -> Token -> IO (ResponseStep r)
statementToken BatchScope
scope Token
tok = do
      Token -> IO ()
noteFailedDone Token
tok
      case Token
tok of
        TDoneProc Done
_ -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (BatchScope -> IORef Bool
scopeEnded BatchScope
scope) Bool
True
        Token
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      ResponseStep r -> IO (ResponseStep r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> ResponseStep r
forall r. Token -> ResponseStep r
StepToken Token
tok)
    noteFailedDone :: Token -> IO ()
noteFailedDone Token
tok = (Done -> IO ()) -> Maybe Done -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Done
d -> IORef (Maybe Done) -> (Maybe Done -> Maybe Done) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Maybe Done)
respFailedDone (Maybe Done -> Maybe Done -> Maybe Done
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Done -> Maybe Done
forall a. a -> Maybe a
Just Done
d)) (Token -> Maybe Done
flagged Token
tok)
    -- A DONE flagged as failed.
    flagged :: Token -> Maybe Done
flagged = \case
      TDone Done
d | Done -> Bool
failed Done
d -> Done -> Maybe Done
forall a. a -> Maybe a
Just Done
d
      TDoneProc Done
d | Done -> Bool
failed Done
d -> Done -> Maybe Done
forall a. a -> Maybe a
Just Done
d
      TDoneInProc Done
d | Done -> Bool
failed Done
d -> Done -> Maybe Done
forall a. a -> Maybe a
Just Done
d
      Token
_ -> Maybe Done
forall a. Maybe a
Nothing
    failed :: Done -> Bool
failed Done
d = Done -> Bool
doneError Done
d Bool -> Bool -> Bool
|| Done -> Bool
doneServerError Done
d

-- | Skip the rows without decoding them.  A row before the first COLMETADATA
-- is a 'ProtocolError', since there are no columns to skip it by, so the
-- result-set loops need no state for that case.
ignoreRows :: RowRead ()
ignoreRows :: RowRead ()
ignoreRows = RowRead ()
discardRows

-- | Read the rest of the response and discard it.  The withheld error,
-- if any, is thrown at the end.  Nothing to do once the end has been
-- read.
drainResponse :: ResponseReader -> IO ()
drainResponse :: ResponseReader -> IO ()
drainResponse ResponseReader
resp = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (ResponseReader -> IORef Bool
respEnded ResponseReader
resp) IO Bool -> (Bool -> 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
  Bool
True -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Bool
False -> ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
drainingRows IO (ResponseStep ()) -> (ResponseStep () -> 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
    ResponseStep ()
StepEnd -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ResponseStep ()
_ -> ResponseReader -> IO ()
drainResponse ResponseReader
resp

-- | Yield the rows of a batch, then continue.  Before each row, the
-- response must still be the current one ('checkCurrent'): the rows of
-- a batch are read from the connection together, but a stream whose
-- response was superseded by a later request (or canceled, or drained)
-- throws 'ResultAbandoned' at the next row it is asked for, not after
-- the rows it already had.
yieldRows :: ResponseReader -> [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
yieldRows :: forall r.
ResponseReader -> [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
yieldRows ResponseReader
resp = [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
forall {a} {r}. [a] -> Stream (Of a) IO r -> Stream (Of a) IO r
go
  where
    -- Built from the constructors: 'S.yield' and '>>' cost a bind and
    -- its closures per row on top of the step.
    go :: [a] -> Stream (Of a) IO r -> Stream (Of a) IO r
go [] Stream (Of a) IO r
rest = Stream (Of a) IO r
rest
    go (a
r : [a]
rs) Stream (Of a) IO r
rest = IO (Stream (Of a) IO r) -> Stream (Of a) IO r
forall (f :: * -> *) (m :: * -> *) r.
m (Stream f m r) -> Stream f m r
SI.Effect (IO (Stream (Of a) IO r) -> Stream (Of a) IO r)
-> IO (Stream (Of a) IO r) -> Stream (Of a) IO r
forall a b. (a -> b) -> a -> b
$ do
      Connection -> ActiveResponse -> IO ()
checkCurrent (ResponseReader -> Connection
respConn ResponseReader
resp) (ResponseReader -> ActiveResponse
respActive ResponseReader
resp)
      let !next :: Stream (Of a) IO r
next = [a] -> Stream (Of a) IO r -> Stream (Of a) IO r
go [a]
rs Stream (Of a) IO r
rest
      Stream (Of a) IO r -> IO (Stream (Of a) IO r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Of a (Stream (Of a) IO r) -> Stream (Of a) IO r
forall (f :: * -> *) (m :: * -> *) r.
f (Stream f m r) -> Stream f m r
SI.Step (a
r a -> Stream (Of a) IO r -> Of a (Stream (Of a) IO r)
forall a b. a -> b -> Of a b
:> Stream (Of a) IO r
next))

------------------------------------------------------------------------------
-- The first result set

-- | How to turn a result set's columns into a per-row decoding function.
type RowCompiler r = TdsContext -> [ColumnInfo] -> Either DecodeError (CompiledRow r)

compilerFor :: RowDecoder r -> RowCompiler r
compilerFor :: forall r. RowDecoder r -> RowCompiler r
compilerFor = RowDecoder r
-> TdsContext -> [ColumnInfo] -> Either DecodeError (CompiledRow r)
forall r. RowDecoder r -> RowCompiler r
compileRowDecoder

-- | A 'RowDecoderMonadic' runs per row (later fields may depend on earlier
-- values). The completed decoder must consume every column; prefixes may
-- be composed inside it. An empty result set cannot be checked this way.
compilerForM :: RowDecoderMonadic r -> RowCompiler r
compilerForM :: forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec TdsContext
ctx [ColumnInfo]
cols = CompiledRow r -> Either DecodeError (CompiledRow r)
forall a b. b -> Either a b
Right (RowDecoderMonadic r -> TdsContext -> [ColumnInfo] -> CompiledRow r
forall a.
RowDecoderMonadic a -> TdsContext -> [ColumnInfo] -> CompiledRow a
compileMonadicRowDecoder RowDecoderMonadic r
dec TdsContext
ctx [ColumnInfo]
cols)

-- | How 'queryMulti' and 'callProcedure' decode: every column as a
-- 'SqlValue', with the decoders compiled once per result set.
sqlRowCompiler :: RowCompiler SqlRow
sqlRowCompiler :: RowCompiler SqlRow
sqlRowCompiler TdsContext
ctx [ColumnInfo]
cols = RowDecoder SqlRow -> RowCompiler SqlRow
forall r. RowDecoder r -> RowCompiler r
compileRowDecoder ([ColumnInfo] -> RowDecoder SqlRow
sqlRowDecoderFor [ColumnInfo]
cols) TdsContext
ctx [ColumnInfo]
cols

-- | Skip to the first result set: its decoder, compiled, or 'Nothing' if
-- the response has none.  On a compile failure the rest of the response
-- is drained before the error is thrown.
firstResultSet :: RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
firstResultSet :: forall r. RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
firstResultSet RowCompiler r
compile ResponseReader
resp = do
  ctx <- Connection -> IO TdsContext
connectionContext (ResponseReader -> Connection
respConn ResponseReader
resp)
  let go = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO (Maybe (RowRead r)))
-> IO (Maybe (RowRead r))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ResponseStep ()
StepEnd -> Maybe (RowRead r) -> IO (Maybe (RowRead r))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RowRead r)
forall a. Maybe a
Nothing
        StepToken (TColMetaData [ColumnInfo]
cols) -> case RowCompiler r
compile TdsContext
ctx [ColumnInfo]
cols of
          Left DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO (Maybe (RowRead r)) -> IO (Maybe (RowRead r))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO (Maybe (RowRead r))
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
          Right CompiledRow r
decode -> RowRead r -> Maybe (RowRead r)
forall a. a -> Maybe a
Just (RowRead r -> Maybe (RowRead r))
-> IO (RowRead r) -> IO (Maybe (RowRead r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> CompiledRow r -> IO (RowRead r)
forall a. Int -> CompiledRow a -> IO (RowRead a)
newRowRead (Connection -> Int
connValueAllocAhead (ResponseReader -> Connection
respConn ResponseReader
resp)) CompiledRow r
decode
        ResponseStep ()
_ -> IO (Maybe (RowRead r))
go
  go

-- | Whether a token ends the result set whose rows are being read.
endsResultSet :: Token -> Bool
endsResultSet :: Token -> Bool
endsResultSet = \case
  TColMetaData [ColumnInfo]
_ -> Bool
True
  TDone Done
_ -> Bool
True
  TDoneProc Done
_ -> Bool
True
  TDoneInProc Done
_ -> Bool
True
  Token
_ -> Bool
False

-- | Fold over the rows of the first result set, a batch at a time, then
-- drain the rest of the response.  A row that doesn't decode drains the
-- rest of the response before its 'DecodeError' is thrown.  Before each
-- call of the step, the response must still be the current one
-- ('checkCurrent', as a 'queryS' stream checks before each row): a step
-- that abandons it (by making another request on the connection, or
-- closing it) is the last to run, and the fold throws 'ResultAbandoned'
-- rather than run the steps for the rest of the batch it had.
foldFirstResultSet :: RowCompiler r -> ResponseReader -> a -> (a -> r -> IO a) -> IO a
foldFirstResultSet :: forall r a.
RowCompiler r -> ResponseReader -> a -> (a -> r -> IO a) -> IO a
foldFirstResultSet RowCompiler r
compile ResponseReader
resp a
z a -> r -> IO a
step = RowCompiler r -> ResponseReader -> a -> (a -> [r] -> IO a) -> IO a
forall r a.
RowCompiler r -> ResponseReader -> a -> (a -> [r] -> IO a) -> IO a
foldBatches RowCompiler r
compile ResponseReader
resp a
z ((a -> [r] -> IO a) -> IO a) -> (a -> [r] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  (a -> r -> IO a) -> a -> [r] -> IO a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((a -> r -> IO a) -> a -> [r] -> IO a)
-> (a -> r -> IO a) -> a -> [r] -> IO a
forall a b. (a -> b) -> a -> b
$ \a
acc r
r -> do
    Connection -> ActiveResponse -> IO ()
checkCurrent (ResponseReader -> Connection
respConn ResponseReader
resp) (ResponseReader -> ActiveResponse
respActive ResponseReader
resp)
    a -> r -> IO a
step a
acc r
r

-- | 'foldFirstResultSet' a batch (the rows of one packet) at a time.
foldBatches :: RowCompiler r -> ResponseReader -> a -> (a -> [r] -> IO a) -> IO a
foldBatches :: forall r a.
RowCompiler r -> ResponseReader -> a -> (a -> [r] -> IO a) -> IO a
foldBatches = (ResponseReader -> RowRead r -> IO (ResponseStep r))
-> RowCompiler r
-> ResponseReader
-> a
-> (a -> [r] -> IO a)
-> IO a
forall r a.
(ResponseReader -> RowRead r -> IO (ResponseStep r))
-> RowCompiler r
-> ResponseReader
-> a
-> (a -> [r] -> IO a)
-> IO a
foldBatchesUsing ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep

foldBatchesUsing :: (ResponseReader -> RowRead r -> IO (ResponseStep r)) -> RowCompiler r -> ResponseReader -> a -> (a -> [r] -> IO a) -> IO a
foldBatchesUsing :: forall r a.
(ResponseReader -> RowRead r -> IO (ResponseStep r))
-> RowCompiler r
-> ResponseReader
-> a
-> (a -> [r] -> IO a)
-> IO a
foldBatchesUsing ResponseReader -> RowRead r -> IO (ResponseStep r)
readBatch RowCompiler r
compile ResponseReader
resp a
z a -> [r] -> IO a
step =
  RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
forall r. RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
firstResultSet RowCompiler r
compile ResponseReader
resp IO (Maybe (RowRead r)) -> (Maybe (RowRead r) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (RowRead r)
Nothing -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z
    Just RowRead r
decode -> do
      let go :: a -> IO a
go !a
acc = ResponseReader -> RowRead r -> IO (ResponseStep r)
readBatch ResponseReader
resp RowRead r
decode IO (ResponseStep r) -> (ResponseStep r -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            StepRows (RowBatch [r]
rows Maybe DecodeError
failed) -> do
              acc' <- a -> [r] -> IO a
step a
acc [r]
rows
              case failed of
                Maybe DecodeError
Nothing -> a -> IO a
go a
acc'
                Just DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
            StepToken Token
tok
              | Token -> Bool
endsResultSet Token
tok -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
              | Bool
otherwise -> a -> IO a
go a
acc
            ResponseStep r
StepEnd -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
      a -> IO a
go a
z

-- | The rows of the first result set, decoded, and the rest of the
-- response drained.
readFirstResultSet :: RowCompiler r -> ResponseReader -> IO [r]
readFirstResultSet :: forall r. RowCompiler r -> ResponseReader -> IO [r]
readFirstResultSet RowCompiler r
compile ResponseReader
resp = [ReversedBatch r] -> [r]
forall r. [ReversedBatch r] -> [r]
joinReversedBatches ([ReversedBatch r] -> [r]) -> IO [ReversedBatch r] -> IO [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (ResponseReader -> RowRead r -> IO (ResponseStep r))
-> RowCompiler r
-> ResponseReader
-> [ReversedBatch r]
-> ([ReversedBatch r] -> [r] -> IO [ReversedBatch r])
-> IO [ReversedBatch r]
forall r a.
(ResponseReader -> RowRead r -> IO (ResponseStep r))
-> RowCompiler r
-> ResponseReader
-> a
-> (a -> [r] -> IO a)
-> IO a
foldBatchesUsing ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStepReversed RowCompiler r
compile ResponseReader
resp [] (\[ReversedBatch r]
acc [r]
rows -> [ReversedBatch r] -> IO [ReversedBatch r]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([r] -> ReversedBatch r
forall r. [r] -> ReversedBatch r
ReversedBatch [r]
rows ReversedBatch r -> [ReversedBatch r] -> [ReversedBatch r]
forall a. a -> [a] -> [a]
: [ReversedBatch r]
acc))

-- The rows of one packet, last first.  A collected result is then reversed once,
-- where it was reversed per packet and copied again as the packets were joined:
-- one cons cell per row less, 23 MB (14.3%) over 100 queries of 10,000 @int@
-- and @bigint@ rows, for the same maximum residency (GHC 9.12.4, 2026-11-04).
newtype ReversedBatch r = ReversedBatch [r]

joinReversedBatches :: [ReversedBatch r] -> [r]
joinReversedBatches :: forall r. [ReversedBatch r] -> [r]
joinReversedBatches = ([r] -> ReversedBatch r -> [r]) -> [r] -> [ReversedBatch r] -> [r]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\[r]
acc (ReversedBatch [r]
rows) -> ([r] -> r -> [r]) -> [r] -> [r] -> [r]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((r -> [r] -> [r]) -> [r] -> r -> [r]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [r]
acc [r]
rows) []

-- | Rows of the first result set, decoded, a batch (the rows of one
-- packet) per effect; then the given action, which reads the rest of the
-- response ('drainResponse' for a query of its own).
streamFirstResultSet :: RowCompiler r -> ResponseReader -> IO () -> Stream (Of r) IO ()
streamFirstResultSet :: forall r.
RowCompiler r -> ResponseReader -> IO () -> Stream (Of r) IO ()
streamFirstResultSet RowCompiler r
compile ResponseReader
resp IO ()
finish = IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream (Of r) IO ()) -> Stream (Of r) IO ())
-> IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall a b. (a -> b) -> a -> b
$ RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
forall r. RowCompiler r -> ResponseReader -> IO (Maybe (RowRead r))
firstResultSet RowCompiler r
compile ResponseReader
resp IO (Maybe (RowRead r))
-> (Maybe (RowRead r) -> IO (Stream (Of r) IO ()))
-> IO (Stream (Of r) 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
  Maybe (RowRead r)
Nothing -> IO ()
finish IO () -> IO (Stream (Of r) IO ()) -> IO (Stream (Of r) IO ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream (Of r) IO ()
forall a. a -> Stream (Of r) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Just RowRead r
decode -> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RowRead r -> Stream (Of r) IO ()
forall {r}. RowRead r -> Stream (Of r) IO ()
rows RowRead r
decode)
  where
    rows :: RowRead r -> Stream (Of r) IO ()
rows RowRead r
decode = IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream (Of r) IO ()) -> Stream (Of r) IO ())
-> IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall a b. (a -> b) -> a -> b
$ ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead r
decode IO (ResponseStep r)
-> (ResponseStep r -> IO (Stream (Of r) IO ()))
-> IO (Stream (Of r) 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
      StepRows (RowBatch [r]
batch Maybe DecodeError
failed) -> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream (Of r) IO () -> IO (Stream (Of r) IO ()))
-> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a b. (a -> b) -> a -> b
$ ResponseReader -> [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
forall r.
ResponseReader -> [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
yieldRows ResponseReader
resp [r]
batch (Stream (Of r) IO () -> Stream (Of r) IO ())
-> Stream (Of r) IO () -> Stream (Of r) IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe DecodeError
failed of
        Maybe DecodeError
Nothing -> RowRead r -> Stream (Of r) IO ()
rows RowRead r
decode
        Just DecodeError
err -> IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO (Stream (Of r) IO ()) -> IO (Stream (Of r) IO ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO (Stream (Of r) IO ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err)
      StepToken Token
tok
        | Token -> Bool
endsResultSet Token
tok -> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO ()
finish IO () -> IO (Stream (Of r) IO ()) -> IO (Stream (Of r) IO ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream (Of r) IO ()
forall a. a -> Stream (Of r) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())))
        | Bool
otherwise -> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RowRead r -> Stream (Of r) IO ()
rows RowRead r
decode)
      ResponseStep r
StepEnd -> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO (Stream (Of r) IO ()) -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO ()
finish IO () -> IO (Stream (Of r) IO ()) -> IO (Stream (Of r) IO ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream (Of r) IO () -> IO (Stream (Of r) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream (Of r) IO ()
forall a. a -> Stream (Of r) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())))

------------------------------------------------------------------------------
-- Several statements in one request

-- | How to encode each item of a list as a statement: its text and its
-- RPC, or why it can't be sent.  The state is what one item passes on to
-- the next.
type StatementEncoder s a = TdsContext -> s -> a -> Either String (Text, RpcRequest, s)

-- | A 'Query' as its @sp_executesql@ call.
queryStatement :: StatementEncoder () Query
queryStatement :: StatementEncoder () Query
queryStatement TdsContext
ctx () Query
q = do
  (sql, named) <- TdsContext -> Query -> Either [Char] (Text, [(Text, EncodedParam)])
encodeQuery TdsContext
ctx Query
q
  let !rpc = Text -> [(Text, EncodedParam)] -> RpcRequest
executeSqlRpc Text
sql [(Text, EncodedParam)]
named
  pure (sql, rpc, ())

-- | One message of statements.  It is named by its last statement's text
-- ('busyStatements'): the statement a 'Hmssql.BatchQuery.batchQueryS'
-- stream reads, which is what a message left unfinished is.
statementsRequest :: [(Text, RpcRequest)] -> IO Request
statementsRequest :: [(Text, RpcRequest)] -> IO Request
statementsRequest [(Text, RpcRequest)]
stmts = (\TdsContext -> PacketWriter -> IO ()
body -> PacketType
-> (TdsContext -> PacketWriter -> IO ()) -> Maybe Text -> Request
Request PacketType
PTRpc TdsContext -> PacketWriter -> IO ()
body Maybe Text
lastText) ((TdsContext -> PacketWriter -> IO ()) -> Request)
-> IO (TdsContext -> PacketWriter -> IO ()) -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RpcRequest] -> IO (TdsContext -> PacketWriter -> IO ())
newRpcWriter (((Text, RpcRequest) -> RpcRequest)
-> [(Text, RpcRequest)] -> [RpcRequest]
forall a b. (a -> b) -> [a] -> [b]
map (Text, RpcRequest) -> RpcRequest
forall a b. (a, b) -> b
snd [(Text, RpcRequest)]
stmts)
  where
    lastText :: Maybe Text
lastText = case [(Text, RpcRequest)]
stmts of
      [] -> Maybe Text
forall a. Maybe a
Nothing
      [(Text, RpcRequest)]
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$! (Text, RpcRequest) -> Text
forall a b. (a, b) -> a
fst ([(Text, RpcRequest)] -> (Text, RpcRequest)
forall a. HasCallStack => [a] -> a
List.last [(Text, RpcRequest)]
stmts)

-- | About how many bytes of statements 'runStatements' sends per message.
statementMessageBytes :: Int
statementMessageBytes :: Int
statementMessageBytes = Int
1048576

-- | The statements of the next message, encoded (with the text of each),
-- how many there are, the items after them and the encoder's state; or
-- why one can't be sent.  @i@ is the position of the first in the
-- caller's list.
takeStatements :: StatementEncoder s a -> TdsContext -> s -> Int -> [a] -> Either String ([(Text, RpcRequest)], Int, [a], s)
takeStatements :: forall s a.
StatementEncoder s a
-> TdsContext
-> s
-> Int
-> [a]
-> Either [Char] ([(Text, RpcRequest)], Int, [a], s)
takeStatements StatementEncoder s a
encode TdsContext
ctx s
s0 Int
i0 = Int
-> Int
-> s
-> [(Text, RpcRequest)]
-> [a]
-> Either [Char] ([(Text, RpcRequest)], Int, [a], s)
go Int
i0 Int
0 s
s0 []
  where
    go :: Int
-> Int
-> s
-> [(Text, RpcRequest)]
-> [a]
-> Either [Char] ([(Text, RpcRequest)], Int, [a], s)
go !Int
i !Int
size s
s [(Text, RpcRequest)]
acc = \case
      a
a : [a]
as | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
statementMessageBytes -> do
        (sql, rpc, s') <- ([Char] -> Either [Char] (Text, RpcRequest, s))
-> ((Text, RpcRequest, s) -> Either [Char] (Text, RpcRequest, s))
-> Either [Char] (Text, RpcRequest, s)
-> Either [Char] (Text, RpcRequest, s)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\[Char]
e -> [Char] -> Either [Char] (Text, RpcRequest, s)
forall a b. a -> Either a b
Left ([Char]
"statement " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (from 0): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e)) (Text, RpcRequest, s) -> Either [Char] (Text, RpcRequest, s)
forall a b. b -> Either a b
Right (StatementEncoder s a
encode TdsContext
ctx s
s a
a)
        go (i + 1) (size + rpcSize rpc) s' ((sql, rpc) : acc) as
      [a]
as -> ([(Text, RpcRequest)], Int, [a], s)
-> Either [Char] ([(Text, RpcRequest)], Int, [a], s)
forall a b. b -> Either a b
Right ([(Text, RpcRequest)] -> [(Text, RpcRequest)]
forall a. [a] -> [a]
reverse [(Text, RpcRequest)]
acc, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i0, [a]
as, s
s)
    -- About the size of the RPC as written.
    rpcSize :: RpcRequest -> Int
rpcSize (RpcRequest RpcProc
_ Word16
_ [RpcParam]
params) = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [RpcParam -> Int
paramSize RpcParam
p | RpcParam
p <- [RpcParam]
params]
    paramSize :: RpcParam -> Int
paramSize (RpcParam Text
name Word8
_ TypeInfo
_ ParamValue
v) = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Text -> Int
T.length Text
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case ParamValue
v of ParamBytes RawBytes
b -> Int -> (ByteString -> Int) -> RawBytes -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
B.length RawBytes
b; ParamValue
_ -> Int
statementMessageBytes

------------------------------------------------------------------------------
-- Rows and result sets

-- | The batches, newest first, as one list in order: one list cell per
-- row, and none for the last batch, which is the list's tail as it is.
joinBatches :: [[r]] -> [r]
joinBatches :: forall r. [[r]] -> [r]
joinBatches = \case
  [] -> []
  [r]
newest : [[r]]
older -> [r] -> [[r]] -> [r]
forall {a}. [a] -> [[a]] -> [a]
go [r]
newest [[r]]
older
  where
    go :: [a] -> [[a]] -> [a]
go [a]
acc = \case
      [] -> [a]
acc
      [a]
b : [[a]]
bs -> [a] -> [[a]] -> [a]
go ([a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
prependTo [a]
b [a]
acc) [[a]]
bs
    prependTo :: [a] -> [a] -> [a]
prependTo [a]
b [a]
acc = case [a]
b of
      [] -> [a]
acc
      a
x : [a]
xs -> let !rest :: [a]
rest = [a] -> [a] -> [a]
prependTo [a]
xs [a]
acc in a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest

exactlyOne :: [r] -> IO r
exactlyOne :: forall r. [r] -> IO r
exactlyOne = \case
  [r
r] -> r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
  [r]
rs -> UnexpectedResult -> IO r
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UnexpectedResult -> IO r) -> UnexpectedResult -> IO r
forall a b. (a -> b) -> a -> b
$ [Char] -> UnexpectedResult
UnexpectedResult ([Char] -> UnexpectedResult) -> [Char] -> UnexpectedResult
forall a b. (a -> b) -> a -> b
$ [Char]
"expected exactly one row, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([r] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [r]
rs)

atMostOne :: [r] -> IO (Maybe r)
atMostOne :: forall r. [r] -> IO (Maybe r)
atMostOne = \case
  [] -> Maybe r -> IO (Maybe r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe r
forall a. Maybe a
Nothing
  [r
r] -> Maybe r -> IO (Maybe r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> Maybe r
forall a. a -> Maybe a
Just r
r)
  [r]
rs -> UnexpectedResult -> IO (Maybe r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UnexpectedResult -> IO (Maybe r))
-> UnexpectedResult -> IO (Maybe r)
forall a b. (a -> b) -> a -> b
$ [Char] -> UnexpectedResult
UnexpectedResult ([Char] -> UnexpectedResult) -> [Char] -> UnexpectedResult
forall a b. (a -> b) -> a -> b
$ [Char]
"expected at most one row, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([r] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [r]
rs)

-- | Every result set the reader has left, each decoded by the compiler.
readResultSets :: RowCompiler r -> ResponseReader -> IO [ResultSet r]
readResultSets :: forall r. RowCompiler r -> ResponseReader -> IO [ResultSet r]
readResultSets RowCompiler r
compile ResponseReader
resp = do
  ctx <- Connection -> IO TdsContext
connectionContext (ResponseReader -> Connection
respConn ResponseReader
resp)
  -- The common skipper rejects rows before metadata. Within a set, its
  -- decoder travels with its columns. Completed sets and row batches
  -- accumulate newest first, and are joined only when a set ends.
  let beforeFirst = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO [ResultSet r]) -> IO [ResultSet r]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ResponseStep ()
StepEnd -> [ResultSet r] -> IO [ResultSet r]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        StepToken (TColMetaData [ColumnInfo]
cols) -> [ResultSet r] -> [ColumnInfo] -> IO [ResultSet r]
startSet [] [ColumnInfo]
cols
        ResponseStep ()
_ -> IO [ResultSet r]
beforeFirst
      startSet [ResultSet r]
sets [ColumnInfo]
cols = case RowCompiler r
compile TdsContext
ctx [ColumnInfo]
cols of
        Left DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO [ResultSet r] -> IO [ResultSet r]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO [ResultSet r]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
        Right CompiledRow r
compiled -> do
          decode <- Int -> CompiledRow r -> IO (RowRead r)
forall a. Int -> CompiledRow a -> IO (RowRead a)
newRowRead (Connection -> Int
connValueAllocAhead (ResponseReader -> Connection
respConn ResponseReader
resp)) CompiledRow r
compiled
          inSet sets cols decode []
      inSet [ResultSet r]
sets [ColumnInfo]
cols RowRead r
decode [[r]]
batches = ResponseReader -> RowRead r -> IO (ResponseStep r)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead r
decode IO (ResponseStep r)
-> (ResponseStep r -> IO [ResultSet r]) -> IO [ResultSet r]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ResponseStep r
StepEnd -> [ResultSet r] -> IO [ResultSet r]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ResultSet r] -> [ResultSet r]
forall a. [a] -> [a]
reverse ([ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
forall {r}. [ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
flush [ResultSet r]
sets [ColumnInfo]
cols [[r]]
batches))
        StepToken (TColMetaData [ColumnInfo]
next) -> [ResultSet r] -> [ColumnInfo] -> IO [ResultSet r]
startSet ([ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
forall {r}. [ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
flush [ResultSet r]
sets [ColumnInfo]
cols [[r]]
batches) [ColumnInfo]
next
        StepToken Token
_ -> [ResultSet r]
-> [ColumnInfo] -> RowRead r -> [[r]] -> IO [ResultSet r]
inSet [ResultSet r]
sets [ColumnInfo]
cols RowRead r
decode [[r]]
batches
        StepRows (RowBatch [r]
rows Maybe DecodeError
failed) -> case Maybe DecodeError
failed of
          Just DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO [ResultSet r] -> IO [ResultSet r]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO [ResultSet r]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
          Maybe DecodeError
Nothing -> [ResultSet r]
-> [ColumnInfo] -> RowRead r -> [[r]] -> IO [ResultSet r]
inSet [ResultSet r]
sets [ColumnInfo]
cols RowRead r
decode ([r]
rows [r] -> [[r]] -> [[r]]
forall a. a -> [a] -> [a]
: [[r]]
batches)
      flush [ResultSet r]
sets [ColumnInfo]
cols [[r]]
batches = [ColumnInfo] -> [r] -> ResultSet r
forall r. [ColumnInfo] -> [r] -> ResultSet r
ResultSet [ColumnInfo]
cols ([[r]] -> [r]
forall r. [[r]] -> [r]
joinBatches [[r]]
batches) ResultSet r -> [ResultSet r] -> [ResultSet r]
forall a. a -> [a] -> [a]
: [ResultSet r]
sets
  beforeFirst

-- | Run the decoder over what the reader has left, then drain the rest.
readResultSetsWith :: ResultSets a -> ResponseReader -> IO a
readResultSetsWith :: forall a. ResultSets a -> ResponseReader -> IO a
readResultSetsWith ResultSets a
sets ResponseReader
resp = do
  ctx <- Connection -> IO TdsContext
connectionContext (ResponseReader -> Connection
respConn ResponseReader
resp)
  a <- runResultSets sets ctx resp
  drainResponse resp
  pure a