{-# LANGUAGE MagicHash #-}
-- | Building queries, running them and reading their results.
--
-- Every function takes a 'Connection' and a 'Query': SQL text with its
-- parameters, built as described under "Hmssql.Query#g:building".  A query
-- with no parameters is sent as a plain SQL batch; one with parameters is
-- sent via @sp_executesql@, with the positional parameters as @\@p1@,
-- @\@p2@, ... and the named ones by name.
--
-- The functions differ in what they make of the response:
--
-- * 'execute': the number of rows affected; 'execute_' discards the count.
-- * 'query': the rows of the first result set, as a list; 'query1' and
--   'queryMay' for exactly one and at most one row.
-- * 'queryS': the rows of the first result set as a 'Stream', read from
--   the socket as they are consumed; 'queryFold' folds over them as they
--   arrive.
-- * 'queryCells': each row as a stream of cells, and each cell as a stream of
--   bytes, for a value too large to hold in memory.
-- * 'queryResultSets': several result sets, each into its own row type;
--   'queryMulti': every result set, as 'SqlRow's.
-- * 'callProcedure': a stored procedure by RPC, with its output parameters
--   and return status.
--
-- The plain functions decode with the row type's 'FromSqlRow' instance;
-- the @With@ variants take a 'RowDecoder', and the @MWith@ variants a
-- 'RowDecoderMonadic', which runs per row and can look at the columns.
-- Both forms must consume the whole row. Monadic decoders cannot check
-- an empty result set, since no decoder runs for it.
--
-- A 'queryS' stream must be consumed before another request is made on
-- the same connection; a newer request cancels the pending one, and the
-- old stream then throws 'ResultAbandoned' (see 'queryS').  On a MARS
-- connection ('Hmssql.Connection.connectMars') it needn't be: several
-- responses can be open at once, and 'withQueryS' gives a stream that is
-- canceled when its scope ends.
--
-- Several statements in one round trip, each with its own result, are
-- "Hmssql.BatchQuery"; many rows into one table, "Hmssql.BulkCopy".
module Hmssql.Query
  ( -- * Building queries #building#
    -- | The simplest query is a string literal (with @OverloadedStrings@),
    -- sent as a plain batch:
    --
    -- > execute conn "CREATE TABLE #t (i int)"
    --
    -- Parameters travel with the text, never inside it.  Either write the
    -- SQL in the @sp_executesql@ style, referring to the parameters of a
    -- 'ToSqlRow' value as @\@p1@, @\@p2@, ... (or by name, with
    -- 'NamedParams'):
    --
    -- > query conn (mkQuery "SELECT name FROM sys.tables WHERE schema_id = @p1" (Only (1 :: Int)))
    --
    -- or compose the query from pieces, each carrying its own parameters,
    -- with '<>':
    --
    -- > query conn ("SELECT name FROM sys.tables WHERE schema_id = " <> param (1 :: Int)
    -- >             <> " AND name LIKE " <> param ("t%" :: Text))
    --
    -- The two styles mix freely; placeholders are renumbered as queries
    -- are concatenated, so a query built from parts refers to its
    -- parameters correctly however it was assembled.  Identifiers that
    -- come from data go through 'escapeIdentifier'; 'rawSql' splices text
    -- as it is, for SQL assembled at runtime.
    --
    -- A query with no parameters is sent as a SQL batch (statements such
    -- as @CREATE PROCEDURE@ and @SET@ options that must outlive the
    -- request need that); a query with parameters is sent as an
    -- @sp_executesql@ call, whose body runs in its own scope.
    Query
  , mkQuery
  , rawSql
  , param
  , namedParam
  , escapeIdentifier
  , queryText

    -- * Statements
  , execute
  , execute_

    -- * Queries
  , query
  , query1
  , query1With
  , queryMay
  , queryMayWith
  , queryWith
  , queryMWith

    -- * Folding queries
  , queryFold
  , queryFoldWith

    -- * Streaming queries #streaming#
    -- | 'queryS' and 'withQueryS' give the rows as a 'Stream' from the @streaming@
    -- package.  Rows are read from the socket as you pull them, so memory doesn't grow
    -- with the result:
    --
    -- > import qualified Streaming.Prelude as S
    -- >
    -- > withQueryS conn "SELECT id, name FROM dbo.customer" $ \rows ->
    -- >   S.mapM_ (\(i :: Int64, name :: Text) -> T.putStrLn (T.pack (show i) <> " " <> name)) rows
    --
    -- Each row is still read whole.  To stream a large value within a row, see
    -- "Hmssql.Decoding#g:streaming".
  , queryS
  , querySWith
  , querySMWith
  , withQueryS
  , withQuerySWith
  , withQuerySMWith

    -- * Streaming cells #cells#
    -- | 'queryCells' and 'withQueryCells' give nested streams: rows of cells, and cells
    -- of bytes.  They let what you read in one column decide what to do with a later
    -- one.  Here, each row's first column names the file for its second, using @toFile@
    -- from "Hmssql.Decoding#g:streaming":
    --
    -- > import Streaming (inspect)
    -- >
    -- > withQueryCells conn "SELECT name, payload FROM dbo.documents" $ \_ rows ->
    -- >   let nextRow remaining = inspect remaining >>= \case
    -- >         Left () -> pure ()
    -- >         Right row -> do
    -- >           Right nameCell <- inspect row
    -- >           (Right name, afterName) <- cellDecoded (fieldDecoder @FilePath) nameCell
    -- >           Right payloadCell <- inspect afterName
    -- >           (Right (), afterPayload) <- cellDecoded (streamField (toFile name)) payloadCell
    -- >           Left more <- inspect afterPayload
    -- >           nextRow more
    -- >    in nextRow rows
    --
    -- When each column can be handled without the others, a field decoder is simpler
    -- and faster ("Hmssql.Decoding#g:streaming").
  , Cell (..), CellValue (..), RowCells, queryCells, withQueryCells
  , cellDecoded, cellText, skipCell

    -- * Several result sets
  , ResultSets
  , resultSet
  , resultSetWith
  , resultSetMWith
  , skipResultSet
  , queryResultSets
  , ResultSet (..)
  , queryMulti
  , queryMultiWith
  , queryMultiMWith

    -- * Stored procedures
  , callProcedure
  , ProcParam (..)
  , inParam
  , outParam
  , rawInParam
  , rawOutParam
  , ProcResult (..)
  , decodeReturnValue

    -- * Several statements in one request
  , executeMany
  , executeStatements
  , StatementOutcome (..)
  , executeManyOutcomes
  , executeStatementsOutcomes

    -- * Low level
    -- | Requests and responses as the query functions see them, for code
    -- that reads a response token by token.  Nothing here is needed to
    -- use the functions above.  The constructors of 'Request',
    -- 'ResponseStep' and 'RowBatch' are in "Hmssql.Query.Types".
  , Request, bytesBody
  , queryRequest
  , queryRequestFor
  , executeStatementsRequestsFor
  , batchRequest
  , executeSqlRequest
  , rpcRequest
  , paramNameProblem
  , responseS
  , ResponseReader
  , startResponse
  , cancelResponse
  , responseReader
  , affectedRows
  , readStep
  , drainResponse
  , RowBatch
  , ResponseStep
  ) where

import Control.Exception
import Control.Applicative ((<|>))
import Control.Monad (void, when)
import qualified Data.ByteString as B
import Data.Int (Int32, Int64)
import Data.Bits ((.&.))
import Data.IORef
import Data.List (sortOn)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Streaming (Of (..), Stream, effect)
import qualified Streaming as Streaming
import Hmssql.Internal.Derived
import qualified Hmssql.Tds.Parser as P
import qualified Hmssql.Tds.Value as V
import qualified Streaming.Prelude as S

import Hmssql.Connection.Internal
import Hmssql.Decoding
import Hmssql.Encoding
import Hmssql.Errors
import Hmssql.Query.Internal
import Hmssql.Query.Lexer (lexPlaceholders)
import Hmssql.Query.Types
import Hmssql.SqlValue
import Hmssql.Tds.Client
import Hmssql.Tds.Context
import Hmssql.Tds.Packet
import Hmssql.Tds.PacketWriter (writeBuilder)
import Hmssql.Tds.Primitives (putDecimal, readDecimal, runPutSized)
import Hmssql.Tds.Token
import Hmssql.Tds.TypeInfo

------------------------------------------------------------------------------
-- Building queries

-- | SQL text with its parameters.  The parameters are those of the
-- 'ToSqlRow' value: a tuple, a record with a derived instance, an
-- 'Data.Tuple.Only.Only' for a single parameter, a list of 'SqlParam', or
-- 'NamedParams'.  In the text, @\@p1@, @\@p2@, ... refer to the positional
-- parameters and @\@name@ to the named ones.
--
-- > mkQuery "UPDATE dbo.customer SET email = @p1 WHERE id = @p2" (email, customerId)
--
-- @\@pN@, in either case, is a placeholder wherever it appears outside a
-- string literal, a quoted identifier or a comment, even where the SQL
-- means something else by it.  So a variable of that name, as in
-- @DECLARE \@p1 int@, can't be used in a 'mkQuery' text; use another name.
-- A placeholder that refers to no parameter makes sending the query throw
-- 'Hmssql.Errors.EncodeError'.
--
-- A string literal (@OverloadedStrings@) is the same as
-- @'mkQuery' text ()@ for text without placeholders.
--
-- The text is lexed once per application of 'mkQuery' to it, not once per
-- set of parameter values.  With a literal, the lexing floats out to the
-- top level when 'mkQuery' is inlined, so the text is lexed once per
-- program run however many times the query is built with new parameters.
mkQuery :: ToSqlRow p => Text -> p -> Query
mkQuery :: forall p. ToSqlRow p => Text -> p -> Query
mkQuery Text
text = \p
params -> [Fragment]
-> [(Text, TdsContext -> Either String EncodedParam)] -> Query
paramsQuery [Fragment]
frags (RowEncoder p
-> p -> [(Text, TdsContext -> Either String EncodedParam)]
forall a.
RowEncoder a
-> a -> [(Text, TdsContext -> Either String EncodedParam)]
encodeParams RowEncoder p
forall a. ToSqlRow a => RowEncoder a
rowEncoder p
params)
  where
    frags :: [Fragment]
frags = Text -> [Fragment]
lexPlaceholders Text
text
{-# INLINE mkQuery #-}

-- The query of 'mkQuery''s lexed text and parameters, out of line: inlined, each
-- application of 'mkQuery' had its own loop making the 'QueryParam's.  A function
-- applying 'mkQuery' to a literal and one to four parameters was 356 to 460 bytes of
-- object code, and is 288 to 414, of which about 260 are the literal and its lexing.
paramsQuery :: [Fragment] -> [(Text, TdsContext -> Either String EncodedParam)] -> Query
paramsQuery :: [Fragment]
-> [(Text, TdsContext -> Either String EncodedParam)] -> Query
paramsQuery [Fragment]
frags [(Text, TdsContext -> Either String EncodedParam)]
params = [Fragment] -> [QueryParam] -> Query
piece [Fragment]
frags [Text -> (TdsContext -> Either String EncodedParam) -> QueryParam
QueryParam Text
name TdsContext -> Either String EncodedParam
enc | (Text
name, TdsContext -> Either String EncodedParam
enc) <- [(Text, TdsContext -> Either String EncodedParam)]
params]
{-# OPAQUE paramsQuery #-}

-- | Text spliced into the query as it is, with no parameters; a string
-- literal gives the same.  Nothing in it is parsed, so a @\@p1@ in it is
-- left to the server.  For text that comes from data, use 'param',
-- 'namedParam' or 'escapeIdentifier' instead.
rawSql :: Text -> Query
rawSql :: Text -> Query
rawSql Text
t = [Fragment] -> [QueryParam] -> Query
piece [Text -> Fragment
Static Text
t | Bool -> Bool
not (Text -> Bool
T.null Text
t)] []

-- | A positional parameter: a placeholder in the text, and the value sent
-- with the query.
--
-- > "WHERE id = " <> param (42 :: Int)
param :: ToSqlField a => a -> Query
param :: forall a. ToSqlField a => a -> Query
param a
a = [Fragment] -> [QueryParam] -> Query
piece [Int -> Fragment
Placeholder Int
1] [Text -> (TdsContext -> Either String EncodedParam) -> QueryParam
QueryParam Text
"" (\TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a)]

-- | A named parameter: @\@name@ in the text, and the value sent with the
-- query.  The leading @\@@ is optional.  The name must be a T-SQL variable
-- name (see 'paramNameProblem'), and not of the form @\@pN@, which is
-- reserved for the positional parameters.  A query that uses one name for
-- two parameters can't be sent, and throws 'Hmssql.Errors.EncodeError'.
--
-- > "OFFSET " <> namedParam "skip" (100 :: Int) <> " ROWS"
namedParam :: ToSqlField a => Text -> a -> Query
namedParam :: forall a. ToSqlField a => Text -> a -> Query
namedParam Text
name a
a = [Fragment] -> [QueryParam] -> Query
piece [Text -> Fragment
Static Text
name'] [Text -> (TdsContext -> Either String EncodedParam) -> QueryParam
QueryParam Text
name' (\TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a)]
  where
    name' :: Text
name' = if Text
"@" Text -> Text -> Bool
`T.isPrefixOf` Text
name then Text
name else Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

-- | An identifier (a table or column name from data, say) quoted with
-- brackets: @[name]@, with @]@ doubled.
--
-- > "SELECT " <> escapeIdentifier col <> " FROM " <> escapeIdentifier table
escapeIdentifier :: Text -> Query
escapeIdentifier :: Text -> Query
escapeIdentifier Text
name = Text -> Query
rawSql (Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"]" Text
"]]" Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")

------------------------------------------------------------------------------
-- Requests

-- | A SQL batch: the text as it is, no parameters.
batchRequest :: Text -> Request
batchRequest :: Text -> Request
batchRequest Text
sql = PacketType
-> (TdsContext -> PacketWriter -> IO ()) -> Maybe Text -> Request
Request PacketType
PTSqlBatch (\TdsContext
ctx PacketWriter
writer -> do
  (String -> IO (ZonkAny 3)) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EncodeError -> IO (ZonkAny 3)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO (ZonkAny 3))
-> (String -> EncodeError) -> String -> IO (ZonkAny 3)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EncodeError
EncodeError) (TdsContext -> Text -> Maybe String
sqlBatchProblem TdsContext
ctx Text
sql)
  PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
writer (TdsContext -> Text -> Builder
sqlBatchBuilder TdsContext
ctx Text
sql)) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sql)

-- | @sp_executesql \@stmt, \@params, \@p1, \@p2, ...@
--
-- Parameters with an empty name are called @\@pN@ after their 1-based position
-- in the list.  The names are spliced into the @\@params@ declaration as
-- given, so check them with 'paramNameProblem' first (the query functions
-- do).  With no parameters, @\@params@ is left out.
executeSqlRequest :: Text -> [(Text, EncodedParam)] -> IO Request
executeSqlRequest :: Text -> [(Text, EncodedParam)] -> IO Request
executeSqlRequest Text
sql [(Text, EncodedParam)]
params = Text -> [RpcRequest] -> IO Request
checkedRpcRequest Text
sql [Text -> [(Text, EncodedParam)] -> RpcRequest
executeSqlRpc Text
sql ([(Text, EncodedParam)] -> [(Text, EncodedParam)]
resolveParamNames [(Text, EncodedParam)]
params)]

executeSqlRequestWith :: Text -> [(Text, EncodedParam)] -> IO Request
executeSqlRequestWith :: Text -> [(Text, EncodedParam)] -> IO Request
executeSqlRequestWith Text
sql [(Text, EncodedParam)]
named = do
  body <- [RpcRequest] -> IO (TdsContext -> PacketWriter -> IO ())
newRpcWriter [Text -> [(Text, EncodedParam)] -> RpcRequest
executeSqlRpc Text
sql [(Text, EncodedParam)]
named]
  pure (Request PTRpc body (Just sql))

resolveParamNames :: [(Text, EncodedParam)] -> [(Text, EncodedParam)]
resolveParamNames :: [(Text, EncodedParam)] -> [(Text, EncodedParam)]
resolveParamNames [(Text, EncodedParam)]
params =
  [ (if Text -> Bool
T.null Text
name then Int -> Text
placeholderText Int
i else Text
name, EncodedParam
p)
  | (Int
i, (Text
name, EncodedParam
p)) <- [Int] -> [(Text, EncodedParam)] -> [(Int, (Text, EncodedParam))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [(Text, EncodedParam)]
params
  ]

-- | An RPC call of the named procedure with these parameters, as
-- 'callProcedure' sends it. Invalid parameters throw EncodeError before
-- the request is constructed.
rpcRequest :: Text -> [RpcParam] -> IO Request
rpcRequest :: Text -> [RpcParam] -> IO Request
rpcRequest Text
procName [RpcParam]
params = Text -> [RpcRequest] -> IO Request
checkedRpcRequest Text
procName [RpcProc -> Word16 -> [RpcParam] -> RpcRequest
RpcRequest (Text -> RpcProc
RpcProcName Text
procName) Word16
0 [RpcParam]
params]

checkedRpcRequest :: Text -> [RpcRequest] -> IO Request
checkedRpcRequest :: Text -> [RpcRequest] -> IO Request
checkedRpcRequest Text
label [RpcRequest]
requests = do
  (RpcRequest -> IO ()) -> [RpcRequest] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> IO (ZonkAny 2)) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EncodeError -> IO (ZonkAny 2)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO (ZonkAny 2))
-> (String -> EncodeError) -> String -> IO (ZonkAny 2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EncodeError
EncodeError) (Maybe String -> IO ())
-> (RpcRequest -> Maybe String) -> RpcRequest -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcRequest -> Maybe String
rpcRequestProblem) [RpcRequest]
requests
  body <- [RpcRequest] -> IO (TdsContext -> PacketWriter -> IO ())
newRpcWriter [RpcRequest]
requests
  pure (Request PTRpc body (Just label))

-- | The request a query is sent as: a SQL batch when it has no parameters,
-- otherwise @sp_executesql@ with the parameters encoded for the connection.
-- Throws 'EncodeError' for a value that can't be encoded, a placeholder
-- with no parameter ('Hmssql.Query.Types.queryProblem'), a name that
-- isn't a T-SQL variable name ('paramNameProblem') or is of the reserved
-- form @\@pN@, or a name used twice (SQL Server identifiers are
-- case-insensitive, so @\@a@ and @\@A@ are one name).  Nothing is sent.
queryRequest :: Connection -> Query -> IO Request
queryRequest :: Connection -> Query -> IO Request
queryRequest Connection
conn Query
q = do
  ctx <- Connection -> IO TdsContext
connectionContext Connection
conn
  queryRequestFor ctx q

-- | 'queryRequest' for a connection with this context, without the
-- connection.  It throws 'EncodeError' as 'queryRequest' does.  A request with
-- a lazy or streamed parameter can be sent only once.
queryRequestFor :: TdsContext -> Query -> IO Request
-- Each parameter is checked here, as it is encoded ('rpcParamProblem'), so
-- the request is written without checking again.  The positional names
-- (@\@p1@, @\@p2@, ...) need no name checks: they are valid, and distinct
-- from each other and from every name 'reservedNameProblem' lets through.
queryRequestFor :: TdsContext -> Query -> IO Request
queryRequestFor TdsContext
ctx Query
q = do
  (sql, named) <- (String -> IO (Text, [(Text, EncodedParam)]))
-> ((Text, [(Text, EncodedParam)])
    -> IO (Text, [(Text, EncodedParam)]))
-> Either String (Text, [(Text, EncodedParam)])
-> IO (Text, [(Text, EncodedParam)])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EncodeError -> IO (Text, [(Text, EncodedParam)])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO (Text, [(Text, EncodedParam)]))
-> (String -> EncodeError)
-> String
-> IO (Text, [(Text, EncodedParam)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EncodeError
EncodeError) (Text, [(Text, EncodedParam)]) -> IO (Text, [(Text, EncodedParam)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TdsContext -> Query -> Either String (Text, [(Text, EncodedParam)])
encodeQuery TdsContext
ctx Query
q)
  case named of
    [] -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Request
batchRequest Text
sql)
    [(Text, EncodedParam)]
_ -> Text -> [(Text, EncodedParam)] -> IO Request
executeSqlRequestWith Text
sql [(Text, EncodedParam)]
named

------------------------------------------------------------------------------
-- Responses

-- | Send a request and start reading its response.
startResponse :: Connection -> Request -> IO ResponseReader
startResponse :: Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request{Maybe Text
PacketType
TdsContext -> PacketWriter -> IO ()
requestPacketType :: PacketType
requestBody :: TdsContext -> PacketWriter -> IO ()
requestStatement :: Maybe Text
requestBody :: Request -> TdsContext -> PacketWriter -> IO ()
requestPacketType :: Request -> PacketType
requestStatement :: Request -> Maybe Text
..} = do
  ar <- Connection
-> Maybe Text
-> PacketType
-> (TdsContext -> PacketWriter -> IO ())
-> IO ActiveResponse
startRequestFor Connection
conn Maybe Text
requestStatement PacketType
requestPacketType TdsContext -> PacketWriter -> IO ()
requestBody
  responseReader conn ar requestStatement

-- | 'startResponse', for an action that reads the response to its end: if
-- it throws instead, the response is canceled ('readingToEnd') rather
-- than left open.
withResponse :: Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse :: forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req ResponseReader -> IO a
act = ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  -- Masked from the send to the handler's installation, so that an
  -- interruption can't come between them and leave the response open.
  resp <- Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request
req
  readingToEnd conn (respActive resp) (restore (act resp))

-- | Cancel one response: if it hasn't been read to its end, the
-- statement is canceled on the server and the rest of the response
-- discarded, as 'Hmssql.Connection.cancelActiveStatement' does for every
-- response of the connection.  It returns once the response is over on
-- the server, so the statement's locks are released by then (a round
-- trip, unless the response had fully arrived).  Nothing happens if the
-- response was already read to its end or canceled, or the connection is
-- closed or broken.  Reading on from the reader, or from a stream of it,
-- throws 'ResultAbandoned'.
cancelResponse :: ResponseReader -> IO ()
cancelResponse :: ResponseReader -> IO ()
cancelResponse ResponseReader{Maybe Text
Maybe BatchScope
IORef Bool
IORef (Maybe Done)
IORef (Maybe ServerMessage)
IORef (Maybe Token)
ActiveResponse
Connection
respActive :: ResponseReader -> ActiveResponse
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
respBatch :: ResponseReader -> Maybe BatchScope
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
..} = do
  Connection -> ActiveResponse -> IO ()
cancelActiveResponse Connection
respConn ActiveResponse
respActive
  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
respEnded Bool
True

-- | The cursor of a response started another way
-- ('Hmssql.Connection.Internal.startStreamingRequest'), with the
-- statement's text for its error messages.
responseReader :: Connection -> ActiveResponse -> Maybe Text -> IO ResponseReader
responseReader :: Connection -> ActiveResponse -> Maybe Text -> IO ResponseReader
responseReader Connection
conn ActiveResponse
ar Maybe Text
stmt =
  Connection
-> ActiveResponse
-> IORef (Maybe ServerMessage)
-> IORef (Maybe Done)
-> IORef (Maybe Token)
-> Maybe Text
-> IORef Bool
-> Maybe BatchScope
-> ResponseReader
ResponseReader Connection
conn ActiveResponse
ar (IORef (Maybe ServerMessage)
 -> IORef (Maybe Done)
 -> IORef (Maybe Token)
 -> Maybe Text
 -> IORef Bool
 -> Maybe BatchScope
 -> ResponseReader)
-> IO (IORef (Maybe ServerMessage))
-> IO
     (IORef (Maybe Done)
      -> IORef (Maybe Token)
      -> Maybe Text
      -> IORef Bool
      -> Maybe BatchScope
      -> ResponseReader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ServerMessage -> IO (IORef (Maybe ServerMessage))
forall a. a -> IO (IORef a)
newIORef Maybe ServerMessage
forall a. Maybe a
Nothing IO
  (IORef (Maybe Done)
   -> IORef (Maybe Token)
   -> Maybe Text
   -> IORef Bool
   -> Maybe BatchScope
   -> ResponseReader)
-> IO (IORef (Maybe Done))
-> IO
     (IORef (Maybe Token)
      -> Maybe Text -> IORef Bool -> Maybe BatchScope -> ResponseReader)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Done -> IO (IORef (Maybe Done))
forall a. a -> IO (IORef a)
newIORef Maybe Done
forall a. Maybe a
Nothing IO
  (IORef (Maybe Token)
   -> Maybe Text -> IORef Bool -> Maybe BatchScope -> ResponseReader)
-> IO (IORef (Maybe Token))
-> IO
     (Maybe Text -> IORef Bool -> Maybe BatchScope -> ResponseReader)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Token -> IO (IORef (Maybe Token))
forall a. a -> IO (IORef a)
newIORef Maybe Token
forall a. Maybe a
Nothing IO (Maybe Text -> IORef Bool -> Maybe BatchScope -> ResponseReader)
-> IO (Maybe Text)
-> IO (IORef Bool -> Maybe BatchScope -> ResponseReader)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
stmt IO (IORef Bool -> Maybe BatchScope -> ResponseReader)
-> IO (IORef Bool) -> IO (Maybe BatchScope -> ResponseReader)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False IO (Maybe BatchScope -> ResponseReader)
-> IO (Maybe BatchScope) -> IO ResponseReader
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe BatchScope -> IO (Maybe BatchScope)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BatchScope
forall a. Maybe a
Nothing

-- | Send a request and stream the response tokens, a low-level view of a
-- response: every row as a 'TRow' (see "Hmssql.Tds.Value"), and the other
-- tokens, in order.  ERROR tokens are withheld and rethrown as
-- 'SqlServerError' once the response is complete, so the connection is
-- never left mid-message.  A DONE (DONE, DONEPROC or DONEINPROC) flagged
-- DONE_ERROR or DONE_SRVERROR in a response with no ERROR token is thrown
-- as 'SevereError' at the end, likewise: the server failed the request
-- without a message (as when the session was killed).
responseS :: Connection -> Request -> IO (Stream (Of Token) IO ())
responseS :: Connection -> Request -> IO (Stream (Of Token) IO ())
responseS Connection
conn Request
req = ResponseReader -> Stream (Of Token) IO ()
go (ResponseReader -> Stream (Of Token) IO ())
-> IO ResponseReader -> IO (Stream (Of Token) IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request
req
  where
    go :: ResponseReader -> Stream (Of Token) IO ()
go ResponseReader
resp = IO (Stream (Of Token) IO ()) -> Stream (Of Token) IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream (Of Token) IO ()) -> Stream (Of Token) IO ())
-> IO (Stream (Of Token) IO ()) -> Stream (Of Token) IO ()
forall a b. (a -> b) -> a -> b
$ ResponseReader -> RowRead Row -> IO (ResponseStep Row)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead Row
wholeRows IO (ResponseStep Row)
-> (ResponseStep Row -> IO (Stream (Of Token) IO ()))
-> IO (Stream (Of Token) 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 Row
StepEnd -> Stream (Of Token) IO () -> IO (Stream (Of Token) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream (Of Token) IO ()
forall a. a -> Stream (Of Token) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      StepToken Token
tok -> Stream (Of Token) IO () -> IO (Stream (Of Token) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> Stream (Of Token) IO ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield Token
tok Stream (Of Token) IO ()
-> Stream (Of Token) IO () -> Stream (Of Token) IO ()
forall a b.
Stream (Of Token) IO a
-> Stream (Of Token) IO b -> Stream (Of Token) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ResponseReader -> Stream (Of Token) IO ()
go ResponseReader
resp)
      StepRows (RowBatch [Row]
rows Maybe DecodeError
_) -> Stream (Of Token) IO () -> IO (Stream (Of Token) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseReader
-> [Token] -> Stream (Of Token) IO () -> Stream (Of Token) IO ()
forall r.
ResponseReader -> [r] -> Stream (Of r) IO () -> Stream (Of r) IO ()
yieldRows ResponseReader
resp ((Row -> Token) -> [Row] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Row -> Token
TRow [Row]
rows) (ResponseReader -> Stream (Of Token) IO ()
go ResponseReader
resp))

-- | 'streamFirstResultSet' of a request of its own.
firstResultSetS :: RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
firstResultSetS :: forall r.
RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
firstResultSetS RowCompiler r
compile Connection
conn Request
req = do
  resp <- Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request
req
  pure (streamFirstResultSet compile resp (drainResponse resp))

-- | Sum of the row counts reported by DONE tokens, reading the response
-- to its end.
affectedRows :: ResponseReader -> IO Int64
affectedRows :: ResponseReader -> IO Int64
affectedRows ResponseReader
resp = Int64 -> IO Int64
go Int64
0
  where
    go :: Int64 -> IO Int64
go !Int64
acc = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ()) -> (ResponseStep () -> IO Int64) -> IO Int64
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 -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
acc
      StepToken Token
tok -> Int64 -> IO Int64
go (Int64
acc Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Token -> Int64
countOf Token
tok)
      StepRows RowBatch ()
_ -> Int64 -> IO Int64
go Int64
acc
    countOf :: Token -> Int64
countOf = \case
      TDone Done
d -> Done -> Int64
forall {b}. Num b => Done -> b
fromDone Done
d
      TDoneProc Done
d -> Done -> Int64
forall {b}. Num b => Done -> b
fromDone Done
d
      TDoneInProc Done
d -> Done -> Int64
forall {b}. Num b => Done -> b
fromDone Done
d
      Token
_ -> Int64
0
    fromDone :: Done -> b
fromDone Done
d = if Done -> Bool
doneHasCount Done
d then Word64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Done -> Word64
doneRowCount Done
d) else b
0

------------------------------------------------------------------------------
-- Statements

-- | Run a statement, or a batch of them, and return the number of rows
-- affected, which is the sum of the counts the server reports.  Any
-- result sets are read and discarded.
execute :: Connection -> Query -> IO Int64
execute :: Connection -> Query -> IO Int64
execute Connection
conn Query
q = Connection -> IO Int64 -> IO Int64
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request -> (Request -> IO Int64) -> IO Int64
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
req -> Connection -> Request -> (ResponseReader -> IO Int64) -> IO Int64
forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req ResponseReader -> IO Int64
affectedRows

-- | Run a statement as 'execute' does, and discard the row count.  The
-- whole response is still read, and a server error is still thrown.
execute_ :: Connection -> Query -> IO ()
execute_ :: Connection -> Query -> IO ()
execute_ Connection
conn Query
q = IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Connection -> Query -> IO Int64
execute Connection
conn Query
q)
-- This and the other functions that only adapt another's result are out of line,
-- so that a use is a call rather than a call and its continuation (about 60 bytes
-- of object code each).
{-# NOINLINE execute_ #-}

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

-- | Run several statements in one request, which is one round trip, and
-- return the number of rows each affected, in order, as 'execute' would
-- return it.  Each statement is sent as its own @sp_executesql@ call, all
-- in one RPC message.  That includes a statement with no parameters, so a
-- @SET@ option it sets or a @#temp@ table it creates lasts only until it
-- returns; send such statements with 'execute'.  For many rows of one
-- statement, 'executeMany' is the same with the text read once.  To know
-- which statements failed, use 'executeStatementsOutcomes'.
--
-- The server runs the statements in order.  If some fail, the whole
-- response is still read, and then 'SqlServerError' is thrown for the
-- first that failed.  __Statements after a failed one may have run__: an
-- error that only ends its statement (a constraint violation, say) lets
-- the server go on; one that aborts the batch (@THROW@, a conversion
-- error, a deadlock, any error under @SET XACT_ABORT ON@) ends the
-- request there.  For all-or-nothing, run it inside
-- 'Hmssql.Transaction.withTransaction'.
--
-- A statement that can't be sent (see 'queryRequest') throws
-- 'EncodeError' naming its position, before its message is sent.  A long
-- list goes out in messages of about 1 MiB, each read before the next is
-- sent, so memory stays bounded; the split changes nothing else.
-- Interrupted, it cancels the running statement; the statements before
-- it have run.  An empty list returns @[]@ without a round trip.
executeStatements :: Connection -> [Query] -> IO [Int64]
executeStatements :: Connection -> [Query] -> IO [Int64]
executeStatements Connection
conn [Query]
qs = StatementEncoder () Query
-> () -> Connection -> [Query] -> IO Statements
forall s a.
StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements StatementEncoder () Query
queryStatement () Connection
conn [Query]
qs IO Statements -> (Statements -> IO [Int64]) -> IO [Int64]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Statements -> IO [Int64]
countsOf

-- | The counts, or the first failure thrown.
countsOf :: Statements -> IO [Int64]
countsOf :: Statements -> IO [Int64]
countsOf (Statements [StatementOutcome]
outcomes Maybe (Text, ServerMessage)
failure) = case Maybe (Text, ServerMessage)
failure of
  Just (Text
sql, ServerMessage
err) -> SqlServerError -> IO [Int64]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ServerMessage -> Maybe Text -> SqlServerError
SqlServerError ServerMessage
err (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sql))
  Maybe (Text, ServerMessage)
Nothing -> (StatementOutcome -> IO Int64) -> [StatementOutcome] -> IO [Int64]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StatementOutcome -> IO Int64
counted [StatementOutcome]
outcomes
  where
    counted :: StatementOutcome -> IO Int64
counted = \case
      StatementDone Int64
n -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n
      -- Only after an error, or 'runStatements' throws.
      StatementOutcome
_ -> ProtocolError -> IO Int64
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ProtocolError -> IO Int64) -> ProtocolError -> IO Int64
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"executeStatements: a statement didn't run, but no error was reported"

-- | Run one statement text once for each row of parameters, all in one
-- request, and return the number of rows each affected, in order.  The
-- text refers to a row's parameters as a 'mkQuery' text does, with
-- @\@p1@, @\@p2@, ..., and a row is any 'ToSqlRow' value.
--
-- > executeMany conn "INSERT INTO item (id, name) VALUES (@p1, @p2)" [(1 :: Int, "one" :: Text), (2, "two")]
--
-- Each row is its own @sp_executesql@ call, with the text and the
-- parameter declaration shared (read and encoded once, not per row), so
-- the server compiles the statement once and reuses the plan.  It is
-- @'executeStatements' conn (map ('mkQuery' sql) rows)@ with that
-- sharing, and everything 'executeStatements' says about round trips,
-- errors, transactions and interruption applies: statements after a
-- failed row may have run, so use 'Hmssql.Transaction.withTransaction'
-- for all or nothing, or 'executeManyOutcomes' to see which rows failed.
-- For a large load into one table, 'Hmssql.BulkCopy.bulkInsert' is
-- faster.
executeMany :: ToSqlRow p => Connection -> Text -> [p] -> IO [Int64]
executeMany :: forall p. ToSqlRow p => Connection -> Text -> [p] -> IO [Int64]
executeMany Connection
conn Text
sql [p]
rows = StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
-> Maybe ([(Text, TypeInfo)], RpcParam)
-> Connection
-> [p]
-> IO Statements
forall s a.
StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements ([Fragment]
-> Text
-> RpcParam
-> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
forall p.
ToSqlRow p =>
[Fragment]
-> Text
-> RpcParam
-> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
rowStatement [Fragment]
frags Text
text RpcParam
stmt) Maybe ([(Text, TypeInfo)], RpcParam)
forall a. Maybe a
Nothing Connection
conn [p]
rows IO Statements -> (Statements -> IO [Int64]) -> IO [Int64]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Statements -> IO [Int64]
countsOf
  where
    frags :: [Fragment]
frags = Text -> [Fragment]
lexPlaceholders Text
sql
    text :: Text
text = [Fragment] -> Text
renderFragments [Fragment]
frags
    stmt :: RpcParam
stmt = Text -> RpcParam
textParam Text
text
-- Out of line, with 'executeManyOutcomes', so that a use is a call.  A row's
-- encoder is then an unknown call once per row, beside encoding the row's RPC.
{-# NOINLINE executeMany #-}

-- | 'executeStatements', returning what happened to each statement instead of
-- throwing the first failure: the statements' outcomes, one for each, in
-- order.  A failed statement's error is its 'StatementFailed'; the
-- statements after one that aborted the batch are 'StatementNotRun'.
-- Nothing else changes: an 'EncodeError', a 'SevereError', an
-- interruption and a connection that fails are thrown as by
-- 'executeStatements', and so is an error that closes the connection (severity
-- 20 or more), as 'SqlServerError'.
executeStatementsOutcomes :: Connection -> [Query] -> IO [StatementOutcome]
executeStatementsOutcomes :: Connection -> [Query] -> IO [StatementOutcome]
executeStatementsOutcomes Connection
conn [Query]
qs = Statements -> [StatementOutcome]
outcomesOf (Statements -> [StatementOutcome])
-> IO Statements -> IO [StatementOutcome]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatementEncoder () Query
-> () -> Connection -> [Query] -> IO Statements
forall s a.
StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements StatementEncoder () Query
queryStatement () Connection
conn [Query]
qs

-- | 'executeMany' with each row's outcome, as 'executeStatementsOutcomes': the
-- way to tell which rows failed.
--
-- > outcomes <- executeManyOutcomes conn "INSERT INTO item (id, name) VALUES (@p1, @p2)" rows
-- > let failed = [(row, msgText err) | (row, StatementFailed err) <- zip rows outcomes]
executeManyOutcomes :: ToSqlRow p => Connection -> Text -> [p] -> IO [StatementOutcome]
executeManyOutcomes :: forall p.
ToSqlRow p =>
Connection -> Text -> [p] -> IO [StatementOutcome]
executeManyOutcomes Connection
conn Text
sql [p]
rows = Statements -> [StatementOutcome]
outcomesOf (Statements -> [StatementOutcome])
-> IO Statements -> IO [StatementOutcome]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
-> Maybe ([(Text, TypeInfo)], RpcParam)
-> Connection
-> [p]
-> IO Statements
forall s a.
StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements ([Fragment]
-> Text
-> RpcParam
-> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
forall p.
ToSqlRow p =>
[Fragment]
-> Text
-> RpcParam
-> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
rowStatement [Fragment]
frags Text
text RpcParam
stmt) Maybe ([(Text, TypeInfo)], RpcParam)
forall a. Maybe a
Nothing Connection
conn [p]
rows
  where
    frags :: [Fragment]
frags = Text -> [Fragment]
lexPlaceholders Text
sql
    text :: Text
text = [Fragment] -> Text
renderFragments [Fragment]
frags
    stmt :: RpcParam
stmt = Text -> RpcParam
textParam Text
text
{-# NOINLINE executeManyOutcomes #-}

outcomesOf :: Statements -> [StatementOutcome]
outcomesOf :: Statements -> [StatementOutcome]
outcomesOf (Statements [StatementOutcome]
outcomes Maybe (Text, ServerMessage)
_) = [StatementOutcome]
outcomes

-- | What happened to one statement of 'executeStatementsOutcomes' or
-- 'executeManyOutcomes'.
data StatementOutcome
  = StatementDone !Int64
    -- ^ It ran, and affected this many rows (what 'execute' would return).
  | StatementFailed !ServerMessage
    -- ^ It failed with this error (the first, if it reported several).
  | StatementNotRun
    -- ^ The request ended before it ran: a statement before it aborted
    -- the batch (with @THROW@, a conversion error, a deadlock, or any
    -- error under @XACT_ABORT@).

instance Show StatementOutcome where
  showsPrec :: Int -> StatementOutcome -> ShowS
showsPrec Int
p = \case
    StatementDone Int64
a -> Int -> Addr# -> Int64 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"StatementDone"# Int64
a
    StatementFailed ServerMessage
a -> Int -> Addr# -> ServerMessage -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"StatementFailed"# ServerMessage
a
    StatementOutcome
StatementNotRun -> String -> ShowS
showString String
"StatementNotRun"
  {-# OPAQUE showsPrec #-}

instance Eq StatementOutcome where
  StatementOutcome
x == :: StatementOutcome -> StatementOutcome -> Bool
== StatementOutcome
y = case (StatementOutcome
x, StatementOutcome
y) of
    (StatementDone Int64
a, StatementDone Int64
a') -> Int64
a Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
a'
    (StatementFailed ServerMessage
a, StatementFailed ServerMessage
a') -> ServerMessage -> ServerMessage -> Bool
forall a. Eq a => a -> a -> Bool
eq ServerMessage
a ServerMessage
a'
    (StatementOutcome
StatementNotRun, StatementOutcome
StatementNotRun) -> Bool
True
    (StatementOutcome, StatementOutcome)
_ -> Bool
False
  {-# OPAQUE (==) #-}

-- | The outcome of each statement, in order, and the first failure with
-- its statement's text.
data Statements = Statements [StatementOutcome] !(Maybe (Text, ServerMessage))

-- | A row of parameters for one statement text: the lexed text, rendered,
-- and its @\@stmt@ parameter are shared by every row, and the
-- @\@params@ declaration by a row whose parameters' names and types are
-- those of the row before (the state).
rowStatement :: ToSqlRow p => [Fragment] -> Text -> RpcParam -> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
rowStatement :: forall p.
ToSqlRow p =>
[Fragment]
-> Text
-> RpcParam
-> StatementEncoder (Maybe ([(Text, TypeInfo)], RpcParam)) p
rowStatement [Fragment]
frags Text
sql RpcParam
stmt TdsContext
ctx Maybe ([(Text, TypeInfo)], RpcParam)
prev p
row = do
  let params :: [QueryParam]
params = [Text -> (TdsContext -> Either String EncodedParam) -> QueryParam
QueryParam Text
name TdsContext -> Either String EncodedParam
enc | (Text
name, TdsContext -> Either String EncodedParam
enc) <- RowEncoder p
-> p -> [(Text, TdsContext -> Either String EncodedParam)]
forall a.
RowEncoder a
-> a -> [(Text, TdsContext -> Either String EncodedParam)]
encodeParams RowEncoder p
forall a. ToSqlRow a => RowEncoder a
rowEncoder p
row]
  (String -> Either String (ZonkAny 1))
-> Maybe String -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Either String (ZonkAny 1)
forall a b. a -> Either a b
Left (Int -> [Fragment] -> Maybe String
fragmentsProblem ([()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | QueryParam Text
name TdsContext -> Either String EncodedParam
_ <- [QueryParam]
params, Text -> Bool
T.null Text
name]) [Fragment]
frags)
  named <- TdsContext -> [QueryParam] -> Either String [(Text, EncodedParam)]
encodeQueryParams TdsContext
ctx [QueryParam]
params
  case named of
    [] -> (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
-> Either
     String (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
sql, RpcProc -> Word16 -> [RpcParam] -> RpcRequest
RpcRequest RpcProc
procSpExecuteSql Word16
0 [RpcParam
stmt], Maybe ([(Text, TypeInfo)], RpcParam)
prev)
    [(Text, EncodedParam)]
_ -> do
      let key :: [(Text, TypeInfo)]
key = [(Text
name, TypeInfo
ti) | (Text
name, (TypeInfo
ti, ParamValue
_)) <- [(Text, EncodedParam)]
named]
          !decl :: RpcParam
decl = case Maybe ([(Text, TypeInfo)], RpcParam)
prev of
            Just ([(Text, TypeInfo)]
key', RpcParam
d) | [(Text, TypeInfo)]
key' [(Text, TypeInfo)] -> [(Text, TypeInfo)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Text, TypeInfo)]
key -> RpcParam
d
            Maybe ([(Text, TypeInfo)], RpcParam)
_ -> [(Text, EncodedParam)] -> RpcParam
declarationParam [(Text, EncodedParam)]
named
      -- Force only the reusable shape. A lazy projection of named would
      -- otherwise keep every value alive while the following request sends.
      let forceKey :: ()
forceKey = ((Text, TypeInfo) -> () -> ()) -> () -> [(Text, TypeInfo)] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
name, TypeInfo
ti) ()
rest -> Text
name Text -> () -> ()
forall a b. a -> b -> b
`seq` TypeInfo
ti TypeInfo -> () -> ()
forall a b. a -> b -> b
`seq` ()
rest) () [(Text, TypeInfo)]
key
      ()
forceKey ()
-> Either
     String (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
-> Either
     String (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
forall a b. a -> b -> b
`seq` (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
-> Either
     String (Text, RpcRequest, Maybe ([(Text, TypeInfo)], RpcParam))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
sql, RpcProc -> Word16 -> [RpcParam] -> RpcRequest
RpcRequest RpcProc
procSpExecuteSql Word16
0 (RpcParam
stmt RpcParam -> [RpcParam] -> [RpcParam]
forall a. a -> [a] -> [a]
: RpcParam
decl RpcParam -> [RpcParam] -> [RpcParam]
forall a. a -> [a] -> [a]
: [(Text, EncodedParam)] -> [RpcParam]
valueParams [(Text, EncodedParam)]
named), ([(Text, TypeInfo)], RpcParam)
-> Maybe ([(Text, TypeInfo)], RpcParam)
forall a. a -> Maybe a
Just ([(Text, TypeInfo)]
key, RpcParam
decl))

-- | The statements, sent in messages of about 'statementMessageBytes'
-- each, one message's response read before the next is sent.  A message
-- whose response ended before all its statements ran is the last: the
-- rest haven't run.
runStatements :: StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements :: forall s a.
StatementEncoder s a -> s -> Connection -> [a] -> IO Statements
runStatements StatementEncoder s a
encode s
s0 Connection
conn [a]
items0 = Connection -> IO Statements -> IO Statements
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO Statements -> IO Statements) -> IO Statements -> IO Statements
forall a b. (a -> b) -> a -> b
$ Int
-> s
-> [a]
-> [[StatementOutcome]]
-> Maybe (Text, ServerMessage)
-> IO Statements
go Int
0 s
s0 [a]
items0 [] Maybe (Text, ServerMessage)
forall a. Maybe a
Nothing
  where
    go :: Int
-> s
-> [a]
-> [[StatementOutcome]]
-> Maybe (Text, ServerMessage)
-> IO Statements
go !Int
i s
s [a]
items [[StatementOutcome]]
acc Maybe (Text, ServerMessage)
failure = case [a]
items of
      [] -> Statements -> IO Statements
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StatementOutcome] -> Maybe (Text, ServerMessage) -> Statements
Statements ([[StatementOutcome]] -> [StatementOutcome]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[StatementOutcome]] -> [[StatementOutcome]]
forall a. [a] -> [a]
reverse [[StatementOutcome]]
acc)) Maybe (Text, ServerMessage)
failure)
      [a]
_ -> do
        ctx <- Connection -> IO TdsContext
connectionContext Connection
conn
        (stmts, n, rest, s') <- either (throwIO . EncodeError) pure (takeStatements encode ctx s i items)
        (outs, failure', complete) <- runMessage conn stmts n
        let failure'' = Maybe (Text, ServerMessage)
failure Maybe (Text, ServerMessage)
-> Maybe (Text, ServerMessage) -> Maybe (Text, ServerMessage)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Text, ServerMessage)
failure'
        if complete
          then go (i + n) s' rest (outs : acc) failure''
          else pure (Statements (concat (reverse (map (const StatementNotRun) rest : outs : acc))) failure'')

-- | The messages 'executeStatements' sends for these statements, for a
-- connection with this context (as 'queryRequestFor' for one query): each
-- statement an @sp_executesql@ RPC, in messages of about 1 MiB; or why a
-- statement can't be sent.
executeStatementsRequestsFor :: TdsContext -> [Query] -> IO [Request]
executeStatementsRequestsFor :: TdsContext -> [Query] -> IO [Request]
executeStatementsRequestsFor TdsContext
ctx = Int -> [Query] -> IO [Request]
go Int
0
  where
    go :: Int -> [Query] -> IO [Request]
go !Int
i = \case
      [] -> [Request] -> IO [Request]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      [Query]
qs -> do
        (stmts, n, rest, ()) <- (String -> IO ([(Text, RpcRequest)], Int, [Query], ()))
-> (([(Text, RpcRequest)], Int, [Query], ())
    -> IO ([(Text, RpcRequest)], Int, [Query], ()))
-> Either String ([(Text, RpcRequest)], Int, [Query], ())
-> IO ([(Text, RpcRequest)], Int, [Query], ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EncodeError -> IO ([(Text, RpcRequest)], Int, [Query], ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO ([(Text, RpcRequest)], Int, [Query], ()))
-> (String -> EncodeError)
-> String
-> IO ([(Text, RpcRequest)], Int, [Query], ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EncodeError
EncodeError) ([(Text, RpcRequest)], Int, [Query], ())
-> IO ([(Text, RpcRequest)], Int, [Query], ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StatementEncoder () Query
-> TdsContext
-> ()
-> Int
-> [Query]
-> Either String ([(Text, RpcRequest)], Int, [Query], ())
forall s a.
StatementEncoder s a
-> TdsContext
-> s
-> Int
-> [a]
-> Either String ([(Text, RpcRequest)], Int, [a], s)
takeStatements StatementEncoder () Query
queryStatement TdsContext
ctx () Int
i [Query]
qs)
        (:) <$> statementsRequest stmts <*> go (i + n) rest

-- | Send the statements (as many as the count) as one RPC message and read
-- the response: each statement's outcome, the first failure, and whether
-- every statement ran (the response didn't end early).
--
-- Each RPC's response ends with a DONEPROC (MS-TDS 2.2.4.3; a procedure a
-- statement calls reports DONEINPROC tokens, not a DONEPROC), so the
-- tokens up to the first DONEPROC are the first statement's, and so on;
-- a statement's count is the sum of the counts of its DONE tokens, as in
-- 'affectedRows'.  A response with fewer DONEPROCs than statements was
-- ended by an error that aborted the batch.  As in 'readStep', a DONE
-- flagged as failed in a response with no ERROR token is thrown as
-- 'SevereError', and a response cut off by the server closing the
-- connection after an error throws that error.
runMessage :: Connection -> [(Text, RpcRequest)] -> Int -> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
runMessage :: Connection
-> [(Text, RpcRequest)]
-> Int
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
runMessage Connection
conn [(Text, RpcRequest)]
stmts Int
n = do
  texts <- ((Text, RpcRequest) -> IO Text)
-> [(Text, RpcRequest)] -> IO [Text]
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 (Text -> IO Text
forall a. a -> IO a
evaluate (Text -> IO Text)
-> ((Text, RpcRequest) -> Text) -> (Text, RpcRequest) -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, RpcRequest) -> Text
forall a b. (a, b) -> a
fst) [(Text, RpcRequest)]
stmts
  Request{..} <- statementsRequest stmts
  mask $ \forall a. IO a -> IO a
restore -> do
    ar <- Connection
-> Maybe Text
-> PacketType
-> (TdsContext -> PacketWriter -> IO ())
-> IO ActiveResponse
startRequestFor Connection
conn Maybe Text
requestStatement PacketType
requestPacketType TdsContext -> PacketWriter -> IO ()
requestBody
    readingToEnd conn ar $ restore (runMessageResponse conn ar texts n)

-- | Read the response of a message of statements ('runMessage').
runMessageResponse :: Connection -> ActiveResponse -> [Text] -> Int -> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
runMessageResponse :: Connection
-> ActiveResponse
-> [Text]
-> Int
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
runMessageResponse Connection
conn ActiveResponse
ar [Text]
texts Int
n = do
  let go :: RunState
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
go RunState
st = do
        step <- Connection -> ActiveResponse -> RowRead () -> IO (ResponseStep ())
forall r.
Connection -> ActiveResponse -> RowRead r -> IO (ResponseStep r)
nextStep Connection
conn ActiveResponse
ar RowRead ()
ignoreRows IO (ResponseStep ())
-> (SomeException -> IO (ResponseStep ())) -> IO (ResponseStep ())
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> case SomeException -> Maybe SqlServerError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
          Just (SqlServerError
err :: SqlServerError) -> SqlServerError -> IO (ResponseStep ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SqlServerError
err { sqlErrorStatement = listToMaybe (runPending st) }
          Maybe SqlServerError
Nothing -> case (SomeException -> Maybe ConnectionClosed
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, RunState -> Maybe (Text, ServerMessage)
runFailure RunState
st Maybe (Text, ServerMessage)
-> Maybe (Text, ServerMessage) -> Maybe (Text, ServerMessage)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunState -> Maybe (Text, ServerMessage)
failedHere RunState
st) of
            (Just (ConnectionClosedBy CloseReason
reason), Just (Text
sql, ServerMessage
msg)) | Bool -> Bool
not (CloseReason -> Bool
byClient CloseReason
reason) -> SqlServerError -> IO (ResponseStep ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ServerMessage -> Maybe Text -> SqlServerError
SqlServerError ServerMessage
msg (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sql))
            (Maybe ConnectionClosed, Maybe (Text, ServerMessage))
_ -> SomeException -> IO (ResponseStep ())
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
        case step of
          StepRows RowBatch ()
_ -> RunState
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
go RunState
st
          StepToken Token
tok -> RunState
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
go (RunState -> Token -> RunState
onToken RunState
st Token
tok)
          ResponseStep ()
StepEnd -> do
            let RunState{Int
Int64
[Text]
[StatementOutcome]
Maybe (Text, ServerMessage)
Maybe (Done, Maybe Text)
Maybe ServerMessage
runPending :: RunState -> [Text]
runFailure :: RunState -> Maybe (Text, ServerMessage)
runEnded :: Int
runCount :: Int64
runErr :: Maybe ServerMessage
runFailure :: Maybe (Text, ServerMessage)
runFailedDone :: Maybe (Done, Maybe Text)
runOuts :: [StatementOutcome]
runPending :: [Text]
runEnded :: RunState -> Int
runCount :: RunState -> Int64
runErr :: RunState -> Maybe ServerMessage
runFailedDone :: RunState -> Maybe (Done, Maybe Text)
runOuts :: RunState -> [StatementOutcome]
..} = RunState
st
            -- An error with no DONEPROC after it belongs to the statement
            -- that was running.
                (Int
k', [StatementOutcome]
outs') = case Maybe ServerMessage
runErr of
                  Just ServerMessage
msg | Int
runEnded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n -> (Int
runEnded Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ServerMessage -> StatementOutcome
StatementFailed ServerMessage
msg StatementOutcome -> [StatementOutcome] -> [StatementOutcome]
forall a. a -> [a] -> [a]
: [StatementOutcome]
runOuts)
                  Maybe ServerMessage
_ -> (Int
runEnded, [StatementOutcome]
runOuts)
                failure' :: Maybe (Text, ServerMessage)
failure' = Maybe (Text, ServerMessage)
runFailure Maybe (Text, ServerMessage)
-> Maybe (Text, ServerMessage) -> Maybe (Text, ServerMessage)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunState -> Maybe (Text, ServerMessage)
failedHere RunState
st
            case (Maybe (Text, ServerMessage)
failure', Maybe (Done, Maybe Text)
runFailedDone) of
              (Maybe (Text, ServerMessage)
Nothing, Just (Done
d, Maybe Text
sql)) -> Connection
-> Done
-> Maybe Text
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
forall a. Connection -> Done -> Maybe Text -> IO a
throwSevere Connection
conn Done
d Maybe Text
sql
              (Maybe (Text, ServerMessage), Maybe (Done, Maybe Text))
_ -> ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StatementOutcome] -> [StatementOutcome]
forall a. [a] -> [a]
reverse [StatementOutcome]
outs' [StatementOutcome] -> [StatementOutcome] -> [StatementOutcome]
forall a. [a] -> [a] -> [a]
++ Int -> StatementOutcome -> [StatementOutcome]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k') StatementOutcome
StatementNotRun, Maybe (Text, ServerMessage)
failure', Int
runEnded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n)
  RunState
-> IO ([StatementOutcome], Maybe (Text, ServerMessage), Bool)
go (Int
-> Int64
-> Maybe ServerMessage
-> Maybe (Text, ServerMessage)
-> Maybe (Done, Maybe Text)
-> [StatementOutcome]
-> [Text]
-> RunState
RunState Int
0 Int64
0 Maybe ServerMessage
forall a. Maybe a
Nothing Maybe (Text, ServerMessage)
forall a. Maybe a
Nothing Maybe (Done, Maybe Text)
forall a. Maybe a
Nothing [] [Text]
texts)
  where
    byClient :: CloseReason -> Bool
byClient = \case
      CloseReason
ClosedByClient -> Bool
True
      CloseReason
_ -> Bool
False
    countOf :: Done -> b
countOf Done
d = if Done -> Bool
doneHasCount Done
d then Word64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Done -> Word64
doneRowCount Done
d) else b
0
    failedHere :: RunState -> Maybe (Text, ServerMessage)
failedHere RunState{Int
Int64
[Text]
[StatementOutcome]
Maybe (Text, ServerMessage)
Maybe (Done, Maybe Text)
Maybe ServerMessage
runPending :: RunState -> [Text]
runFailure :: RunState -> Maybe (Text, ServerMessage)
runEnded :: RunState -> Int
runCount :: RunState -> Int64
runErr :: RunState -> Maybe ServerMessage
runFailedDone :: RunState -> Maybe (Done, Maybe Text)
runOuts :: RunState -> [StatementOutcome]
runEnded :: Int
runCount :: Int64
runErr :: Maybe ServerMessage
runFailure :: Maybe (Text, ServerMessage)
runFailedDone :: Maybe (Done, Maybe Text)
runOuts :: [StatementOutcome]
runPending :: [Text]
..} = (,) (Text -> ServerMessage -> (Text, ServerMessage))
-> Maybe Text -> Maybe (ServerMessage -> (Text, ServerMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
runPending Maybe (ServerMessage -> (Text, ServerMessage))
-> Maybe ServerMessage -> Maybe (Text, ServerMessage)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ServerMessage
runErr
    onToken :: RunState -> Token -> RunState
onToken st :: RunState
st@RunState{Int
Int64
[Text]
[StatementOutcome]
Maybe (Text, ServerMessage)
Maybe (Done, Maybe Text)
Maybe ServerMessage
runPending :: RunState -> [Text]
runFailure :: RunState -> Maybe (Text, ServerMessage)
runEnded :: RunState -> Int
runCount :: RunState -> Int64
runErr :: RunState -> Maybe ServerMessage
runFailedDone :: RunState -> Maybe (Done, Maybe Text)
runOuts :: RunState -> [StatementOutcome]
runEnded :: Int
runCount :: Int64
runErr :: Maybe ServerMessage
runFailure :: Maybe (Text, ServerMessage)
runFailedDone :: Maybe (Done, Maybe Text)
runOuts :: [StatementOutcome]
runPending :: [Text]
..} = \case
      TError ServerMessage
msg -> RunState
st { runErr = runErr <|> Just msg }
      TDoneProc Done
d ->
        let !count' :: Int64
count' = Int64
runCount Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Done -> Int64
forall {b}. Num b => Done -> b
countOf Done
d
            out :: StatementOutcome
out = StatementOutcome
-> (ServerMessage -> StatementOutcome)
-> Maybe ServerMessage
-> StatementOutcome
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int64 -> StatementOutcome
StatementDone Int64
count') ServerMessage -> StatementOutcome
StatementFailed Maybe ServerMessage
runErr
         in RunState
              { runEnded :: Int
runEnded = Int
runEnded Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              , runCount :: Int64
runCount = Int64
0
              , runErr :: Maybe ServerMessage
runErr = Maybe ServerMessage
forall a. Maybe a
Nothing
              , runFailure :: Maybe (Text, ServerMessage)
runFailure = Maybe (Text, ServerMessage)
runFailure Maybe (Text, ServerMessage)
-> Maybe (Text, ServerMessage) -> Maybe (Text, ServerMessage)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunState -> Maybe (Text, ServerMessage)
failedHere RunState
st
              , runFailedDone :: Maybe (Done, Maybe Text)
runFailedDone = Done -> Maybe (Done, Maybe Text)
done Done
d
              , runOuts :: [StatementOutcome]
runOuts = StatementOutcome
out StatementOutcome -> [StatementOutcome] -> [StatementOutcome]
forall a. a -> [a] -> [a]
: [StatementOutcome]
runOuts
              , runPending :: [Text]
runPending = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
runPending
              }
      TDone Done
d -> RunState
st { runCount = runCount + countOf d, runFailedDone = done d }
      TDoneInProc Done
d -> RunState
st { runCount = runCount + countOf d, runFailedDone = done d }
      Token
_ -> RunState
st
      where
        done :: Done -> Maybe (Done, Maybe Text)
done Done
d = Maybe (Done, Maybe Text)
runFailedDone Maybe (Done, Maybe Text)
-> Maybe (Done, Maybe Text) -> Maybe (Done, Maybe Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (if Done -> Bool
doneError Done
d Bool -> Bool -> Bool
|| Done -> Bool
doneServerError Done
d then (Done, Maybe Text) -> Maybe (Done, Maybe Text)
forall a. a -> Maybe a
Just (Done
d, [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
runPending) else Maybe (Done, Maybe Text)
forall a. Maybe a
Nothing)

-- | Where 'runMessage' is in the response: how many statements have ended
-- (their DONEPROC has arrived), with these outcomes (newest first); the
-- texts of the rest, the running one first; the running one's count and
-- error so far; the first failure, and the first DONE flagged as failed.
data RunState = RunState
  { RunState -> Int
runEnded :: !Int
  , RunState -> Int64
runCount :: !Int64
  , RunState -> Maybe ServerMessage
runErr :: !(Maybe ServerMessage)
  , RunState -> Maybe (Text, ServerMessage)
runFailure :: !(Maybe (Text, ServerMessage))
  , RunState -> Maybe (Done, Maybe Text)
runFailedDone :: !(Maybe (Done, Maybe Text))
  , RunState -> [StatementOutcome]
runOuts :: [StatementOutcome]
  , RunState -> [Text]
runPending :: [Text]
  }

-- | 'queryS' with a 'RowDecoderMonadic' instead of a 'RowDecoder': the decoder
-- runs per row, so it can look at the columns ('remainingColumns') and
-- decode a shape only known at runtime.
querySMWith :: RowDecoderMonadic r -> Connection -> Query -> IO (Stream (Of r) IO ())
querySMWith :: forall r.
RowDecoderMonadic r
-> Connection -> Query -> IO (Stream (Of r) IO ())
querySMWith RowDecoderMonadic r
dec Connection
conn Query
q = Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request
-> (Request -> 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
>>= RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
forall r.
RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
firstResultSetS (RowDecoderMonadic r -> RowCompiler r
forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec) Connection
conn

-- | 'queryS' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance.
querySWith :: RowDecoder r -> Connection -> Query -> IO (Stream (Of r) IO ())
querySWith :: forall r.
RowDecoder r -> Connection -> Query -> IO (Stream (Of r) IO ())
querySWith RowDecoder r
dec Connection
conn Query
q = Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request
-> (Request -> 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
>>= RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
forall r.
RowCompiler r -> Connection -> Request -> IO (Stream (Of r) IO ())
firstResultSetS (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec) Connection
conn

-- | The rows of the first result set as a 'Stream', read from the socket
-- as they are consumed, so memory doesn't grow with the result.
-- "Hmssql.Query#g:streaming" shows how to consume one.
--
-- Read the stream to its end before making another request on the
-- connection.  The next request cancels the statement and discards what
-- was left, and the old stream then throws 'ResultAbandoned'.  So does a
-- stream whose read was interrupted, by 'System.Timeout.timeout' say,
-- which cancels the statement at once, and a stream run a second time
-- after it was drained.
--
-- A stream not read to its end leaves its statement running on the
-- server, holding its locks, until the next request,
-- 'Hmssql.Connection.cancelActiveStatement' or
-- 'Hmssql.Connection.release' cancels it.  On a MARS connection
-- ('Hmssql.Connection.connectMars') other requests leave the stream open
-- instead, so it stays open until it is read to its end, canceled with
-- 'Hmssql.Connection.cancelActiveStatement', or the connection is
-- released.  'withQueryS' is the form that can't leak a stream.
--
-- Canceling a statement that is still running inside a transaction under
-- @SET XACT_ABORT ON@ rolls the transaction back
-- ('Hmssql.Transaction.TransactionEndedEarly').  Where the transaction
-- must survive, read the stream to its end.
queryS :: FromSqlRow r => Connection -> Query -> IO (Stream (Of r) IO ())
queryS :: forall r.
FromSqlRow r =>
Connection -> Query -> IO (Stream (Of r) IO ())
queryS = RowDecoder r -> Connection -> Query -> IO (Stream (Of r) IO ())
forall r.
RowDecoder r -> Connection -> Query -> IO (Stream (Of r) IO ())
querySWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'queryS' in a scope.  The action gets the stream, and when the action
-- ends, a stream not read to its end is canceled ('cancelResponse').
-- When the action returns, or throws an exception of its own,
-- 'withQueryS' returns once the statement is over on the server and its
-- locks are released.  On a MARS connection
-- ('Hmssql.Connection.connectMars') this is the way to read a stream
-- beside other requests.  Without MARS it works too, under the rule of
-- 'queryS': a request the action makes abandons the stream.
--
-- > withQueryS conn "SELECT id FROM dbo.parent" $ \parents ->
-- >   S.mapM_ (\(Only pid) -> query conn ("SELECT ... WHERE parent_id = " <> param (pid :: Int))) parents
--
-- An interruption ('System.Timeout.timeout', 'Control.Concurrent.killThread')
-- doesn't wait.  The statement is canceled at once, and the connection's
-- next request reads the rest of the response first; a transaction
-- function, 'Hmssql.Connection.release' and
-- 'Hmssql.Connection.cancelActiveStatement' do the same.  Until then the
-- statement's locks may still be held, and
-- 'Hmssql.Connection.cancelActiveStatement' waits for them to go.  The
-- stream must not be used after the action.
withQueryS :: FromSqlRow r => Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQueryS :: forall r a.
FromSqlRow r =>
Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQueryS = RowDecoder r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
forall r a.
RowDecoder r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQuerySWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'withQueryS' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance.
withQuerySWith :: RowDecoder r -> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQuerySWith :: forall r a.
RowDecoder r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQuerySWith RowDecoder r
dec = RowCompiler r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
forall r a.
RowCompiler r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withFirstResultSetS (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec)

-- | 'withQueryS' with a 'RowDecoderMonadic' instead of a 'RowDecoder', as
-- 'querySMWith'.
withQuerySMWith :: RowDecoderMonadic r -> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQuerySMWith :: forall r a.
RowDecoderMonadic r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withQuerySMWith RowDecoderMonadic r
dec = RowCompiler r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
forall r a.
RowCompiler r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withFirstResultSetS (RowDecoderMonadic r -> RowCompiler r
forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec)

-- | As 'withResponse': the body runs under 'readingToEnd', so an
-- asynchronous exception out of it cancels the statement at once and
-- leaves the drain to the next operation, and a synchronous one cancels
-- and drains before it propagates.  A body that returns cancels and
-- drains too ('cancelResponse'), under the mask like the release of 'bracket':
-- interruptible only in the drain's reads, which then break the
-- connection.
withFirstResultSetS :: RowCompiler r -> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withFirstResultSetS :: forall r a.
RowCompiler r
-> Connection -> Query -> (Stream (Of r) IO () -> IO a) -> IO a
withFirstResultSetS RowCompiler r
compile Connection
conn Query
q Stream (Of r) IO () -> IO a
act = do
  req <- Connection -> Query -> IO Request
queryRequest Connection
conn Query
q
  mask $ \forall a. IO a -> IO a
restore -> do
    resp <- Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request
req
    r <- readingToEnd conn (respActive resp) (restore (act (streamFirstResultSet compile resp (drainResponse resp))))
    cancelResponse resp
    pure r

-- | One column's value in a row being read, followed by @r@, the rest of the
-- row.  'skipCell', 'cellText' and 'cellDecoded' are the usual ways to read one.
data Cell r = Cell
  { forall r. Cell r -> ColumnInfo
cellColumn :: !ColumnInfo
  , forall r. Cell r -> TdsContext
cellContext :: !TdsContext
    -- ^ The connection's context, as a field decoder takes it.
  , forall r. Cell r -> Int
cellAllocAhead :: !Int
    -- ^ The connection's 'Hmssql.Connection.connectValueAllocAhead'.
  , forall r. Cell r -> CellValue r
cellValue :: !(CellValue r)
  } deriving stock ((forall a b. (a -> b) -> Cell a -> Cell b)
-> (forall a b. a -> Cell b -> Cell a) -> Functor Cell
forall a b. a -> Cell b -> Cell a
forall a b. (a -> b) -> Cell a -> Cell b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Cell a -> Cell b
fmap :: forall a b. (a -> b) -> Cell a -> Cell b
$c<$ :: forall a b. a -> Cell b -> Cell a
<$ :: forall a b. a -> Cell b -> Cell a
Functor)

-- | A cell's value and what follows it.  A NULL gives the rest of the row at once.
-- A non-NULL value has its total length, if known, and its bytes, and gives the
-- rest of the row when they end, so a row's cells can only be read in order.
data CellValue r
  = CellNull r
  | CellBytes !(Maybe Int64) (Stream (Of B.ByteString) IO r)
  deriving stock ((forall a b. (a -> b) -> CellValue a -> CellValue b)
-> (forall a b. a -> CellValue b -> CellValue a)
-> Functor CellValue
forall a b. a -> CellValue b -> CellValue a
forall a b. (a -> b) -> CellValue a -> CellValue b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CellValue a -> CellValue b
fmap :: forall a b. (a -> b) -> CellValue a -> CellValue b
$c<$ :: forall a b. a -> CellValue b -> CellValue a
<$ :: forall a b. a -> CellValue b -> CellValue a
Functor)

-- | One row's cells, in column order.  Its result is the stream of the rows after it.
type RowCells = Stream Cell IO

-- | The columns of the first result set, and its rows as nested streams: rows of
-- cells, and cells of bytes.  A value is read as it arrives, so a large one
-- needn't be in memory.  For ordinary rows, 'queryS' is faster.
--
-- The rules of 'queryS' apply: a new request abandons the stream on a plain
-- connection, and on MARS it doesn't.  Reading any part of the stream a second
-- time, or using it after its scope ends, throws 'ResultAbandoned'.
queryCells :: Connection -> Query -> IO ([ColumnInfo], Stream RowCells IO ())
queryCells :: Connection -> Query -> IO ([ColumnInfo], Stream RowCells IO ())
queryCells Connection
conn Query
q = Connection
-> IO ([ColumnInfo], Stream RowCells IO ())
-> IO ([ColumnInfo], Stream RowCells IO ())
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO ([ColumnInfo], Stream RowCells IO ())
 -> IO ([ColumnInfo], Stream RowCells IO ()))
-> IO ([ColumnInfo], Stream RowCells IO ())
-> IO ([ColumnInfo], Stream RowCells IO ())
forall a b. (a -> b) -> a -> b
$ do
  req <- Connection -> Query -> IO Request
queryRequest Connection
conn Query
q
  resp <- startResponse conn req
  readingToEnd conn (respActive resp) (cellsOfResponse resp)

-- | 'queryCells' in a scope: when the action ends, a stream not read to its end is
-- canceled, with the same interruption rules as 'withQueryS'.
withQueryCells :: Connection -> Query -> ([ColumnInfo] -> Stream RowCells IO () -> IO a) -> IO a
withQueryCells :: forall a.
Connection
-> Query -> ([ColumnInfo] -> Stream RowCells IO () -> IO a) -> IO a
withQueryCells Connection
conn Query
q [ColumnInfo] -> Stream RowCells IO () -> IO a
use = do
  req <- Connection -> Query -> IO Request
queryRequest Connection
conn Query
q
  mask $ \forall a. IO a -> IO a
restore -> do
    resp <- Connection -> Request -> IO ResponseReader
startResponse Connection
conn Request
req
    r <- readingToEnd conn (respActive resp) $ restore $ do
      (cols, rows) <- cellsOfResponse resp
      use cols rows
    cancelResponse resp
    pure r

-- Build nested continuations over one response. The generation counter
-- rejects replayed pulls. Each pull's second argument describes how to drain
-- the remaining row if the caller abandons the continuation it receives.
--
-- Each pull takes the lock and catch frames, about 400 bytes, which is why this
-- costs several times a typed 'queryS' on small rows, and why it isn't the
-- interface for them.  It earns its place on large values, where a 256 MiB column
-- reads with nothing kept live.
cellsOfResponse :: ResponseReader -> IO ([ColumnInfo], Stream RowCells IO ())
cellsOfResponse :: ResponseReader -> IO ([ColumnInfo], Stream RowCells IO ())
cellsOfResponse ResponseReader
resp = do
  let findColumns :: IO (Maybe [ColumnInfo])
findColumns = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO (Maybe [ColumnInfo]))
-> IO (Maybe [ColumnInfo])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        StepToken (TColMetaData [ColumnInfo]
cols) -> Maybe [ColumnInfo] -> IO (Maybe [ColumnInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ColumnInfo] -> Maybe [ColumnInfo]
forall a. a -> Maybe a
Just [ColumnInfo]
cols)
        ResponseStep ()
StepEnd -> Maybe [ColumnInfo] -> IO (Maybe [ColumnInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [ColumnInfo]
forall a. Maybe a
Nothing
        ResponseStep ()
_ -> IO (Maybe [ColumnInfo])
findColumns
  found <- IO (Maybe [ColumnInfo])
findColumns
  case found of
    Maybe [ColumnInfo]
Nothing -> ([ColumnInfo], Stream RowCells IO ())
-> IO ([ColumnInfo], Stream RowCells IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], () -> Stream RowCells IO ()
forall a. a -> Stream RowCells IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    Just [ColumnInfo]
cols -> do
      context <- Connection -> IO TdsContext
connectionContext (ResponseReader -> Connection
respConn ResponseReader
resp)
      generation <- newIORef (0 :: Int)
      let conn = ResponseReader -> Connection
respConn ResponseReader
resp
          ar = ResponseReader -> ActiveResponse
respActive ResponseReader
resp
          claim Int
expected IO a
action = Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
            Connection -> ActiveResponse -> IO ()
checkCurrent Connection
conn ActiveResponse
ar
            current <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
generation
            when (current /= expected) (throwIO ResultAbandoned)
            writeIORef generation (current + 1)
            readingToEnd conn ar (restore action)
          pull Parser a
parser a -> Maybe (Parser ())
after = Connection
-> ActiveResponse -> Parser a -> (a -> Maybe (Parser ())) -> IO a
forall a.
Connection
-> ActiveResponse -> Parser a -> (a -> Maybe (Parser ())) -> IO a
readPiece Connection
conn ActiveResponse
ar Parser a
parser a -> Maybe (Parser ())
after
          info = [ColumnInfo] -> ResultSetInfo
compileResultSet [ColumnInfo]
cols
          skipColumns ByteString
bitmap = ByteString -> [(Int, ColumnShape)] -> Parser ()
V.skipCells ByteString
bitmap ([(Int, ColumnShape)] -> Parser ())
-> ([(a, (Int, ColumnShape))] -> [(Int, ColumnShape)])
-> [(a, (Int, ColumnShape))]
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, (Int, ColumnShape)) -> (Int, ColumnShape))
-> [(a, (Int, ColumnShape))] -> [(Int, ColumnShape)]
forall a b. (a -> b) -> [a] -> [b]
map (a, (Int, ColumnShape)) -> (Int, ColumnShape)
forall a b. (a, b) -> b
snd
          columns = [ColumnInfo]
-> [(Int, ColumnShape)] -> [(ColumnInfo, (Int, ColumnShape))]
forall a b. [a] -> [b] -> [(a, b)]
zip [ColumnInfo]
cols (ResultSetInfo -> [(Int, ColumnShape)]
rsCells ResultSetInfo
info)
          remaining ByteString
bitmap [(a, (Int, ColumnShape))]
rest = if [(a, (Int, ColumnShape))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, (Int, ColumnShape))]
rest then Maybe (Parser ())
forall a. Maybe a
Nothing else Parser () -> Maybe (Parser ())
forall a. a -> Maybe a
Just (ByteString -> [(a, (Int, ColumnShape))] -> Parser ()
forall {a}. ByteString -> [(a, (Int, ColumnShape))] -> Parser ()
skipColumns ByteString
bitmap [(a, (Int, ColumnShape))]
rest)
          rowStart = do
            token <- Parser (Maybe Precision)
P.peekToken
            case token of
              Just Precision
0xD1 -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> Recipe () ByteString -> Recipe () (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Recipe () ByteString
V.rowBitmap (ResultSetInfo -> Int
rsColumnCount ResultSetInfo
info)
              Just Precision
0xD2 -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> Recipe () ByteString -> Recipe () (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Recipe () ByteString
V.rowBitmap (ResultSetInfo -> Int
rsColumnCount ResultSetInfo
info)
              Maybe Precision
_ -> Maybe ByteString -> Recipe () (Maybe ByteString)
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
          rows Int
g = IO (Stream RowCells IO ()) -> Stream RowCells IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream RowCells IO ()) -> Stream RowCells IO ())
-> IO (Stream RowCells IO ()) -> Stream RowCells IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO (Stream RowCells IO ()) -> IO (Stream RowCells IO ())
forall {a}. Int -> IO a -> IO a
claim Int
g (IO (Stream RowCells IO ()) -> IO (Stream RowCells IO ()))
-> IO (Stream RowCells IO ()) -> IO (Stream RowCells IO ())
forall a b. (a -> b) -> a -> b
$ do
            bitmap <- Recipe () (Maybe ByteString)
-> (Maybe ByteString -> Maybe (Parser ())) -> IO (Maybe ByteString)
forall {a}. Parser a -> (a -> Maybe (Parser ())) -> IO a
pull Recipe () (Maybe ByteString)
rowStart (\Maybe ByteString
b -> Maybe ByteString
b Maybe ByteString
-> (ByteString -> Maybe (Parser ())) -> Maybe (Parser ())
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
bits -> ByteString
-> [(ColumnInfo, (Int, ColumnShape))] -> Maybe (Parser ())
forall {a}.
ByteString -> [(a, (Int, ColumnShape))] -> Maybe (Parser ())
remaining ByteString
bits [(ColumnInfo, (Int, ColumnShape))]
columns)
            case bitmap of
              Just ByteString
bits -> Stream RowCells IO () -> IO (Stream RowCells IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream Cell IO (Stream RowCells IO ()) -> Stream RowCells IO ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
Streaming.wrap (Int
-> ByteString
-> [(ColumnInfo, (Int, ColumnShape))]
-> Stream Cell IO (Stream RowCells IO ())
cells (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bits [(ColumnInfo, (Int, ColumnShape))]
columns))
              Maybe ByteString
Nothing -> ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO (Stream RowCells IO ()))
-> IO (Stream RowCells 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 -> Stream RowCells IO () -> IO (Stream RowCells IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream RowCells IO ()
forall a. a -> Stream RowCells IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                StepToken Token
tok | Token -> Bool
endsResultSet Token
tok -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO (Stream RowCells IO ()) -> IO (Stream RowCells IO ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Stream RowCells IO () -> IO (Stream RowCells IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream RowCells IO ()
forall a. a -> Stream RowCells IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                ResponseStep ()
_ -> Stream RowCells IO () -> IO (Stream RowCells IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Stream RowCells IO ()
rows (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          cells Int
g ByteString
_ [] = Stream RowCells IO () -> Stream Cell IO (Stream RowCells IO ())
forall a. a -> Stream Cell IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Stream RowCells IO ()
rows Int
g)
          cells Int
g ByteString
bitmap ((ColumnInfo
col, (Int
i, ColumnShape
shape)) : [(ColumnInfo, (Int, ColumnShape))]
later) = IO (Stream Cell IO (Stream RowCells IO ()))
-> Stream Cell IO (Stream RowCells IO ())
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream Cell IO (Stream RowCells IO ()))
 -> Stream Cell IO (Stream RowCells IO ()))
-> IO (Stream Cell IO (Stream RowCells IO ()))
-> Stream Cell IO (Stream RowCells IO ())
forall a b. (a -> b) -> a -> b
$ Int
-> IO (Stream Cell IO (Stream RowCells IO ()))
-> IO (Stream Cell IO (Stream RowCells IO ()))
forall {a}. Int -> IO a -> IO a
claim Int
g (IO (Stream Cell IO (Stream RowCells IO ()))
 -> IO (Stream Cell IO (Stream RowCells IO ())))
-> IO (Stream Cell IO (Stream RowCells IO ()))
-> IO (Stream Cell IO (Stream RowCells IO ()))
forall a b. (a -> b) -> a -> b
$ do
            cell <- Parser Cell -> (Cell -> Maybe (Parser ())) -> IO Cell
forall {a}. Parser a -> (a -> Maybe (Parser ())) -> IO a
pull (ByteString -> Int -> ColumnShape -> Parser Cell
V.cellAt ByteString
bitmap Int
i ColumnShape
shape) ((Cell -> Maybe (Parser ())) -> IO Cell)
-> (Cell -> Maybe (Parser ())) -> IO Cell
forall a b. (a -> b) -> a -> b
$ \Cell
value -> case Cell
value of
              Cell
V.NullCell -> ByteString
-> [(ColumnInfo, (Int, ColumnShape))] -> Maybe (Parser ())
forall {a}.
ByteString -> [(a, (Int, ColumnShape))] -> Maybe (Parser ())
remaining ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later
              Cell
_ -> Parser () -> Maybe (Parser ())
forall a. a -> Maybe a
Just (Cell -> Parser ()
V.skipValue Cell
value Parser () -> Parser () -> Parser ()
forall a b. Recipe () a -> Recipe () b -> Recipe () b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> [(ColumnInfo, (Int, ColumnShape))] -> Parser ()
forall {a}. ByteString -> [(a, (Int, ColumnShape))] -> Parser ()
skipColumns ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later)
            let value = case Cell
cell of
                  Cell
V.NullCell -> Stream Cell IO (Stream RowCells IO ())
-> CellValue (Stream Cell IO (Stream RowCells IO ()))
forall r. r -> CellValue r
CellNull (Int
-> ByteString
-> [(ColumnInfo, (Int, ColumnShape))]
-> Stream Cell IO (Stream RowCells IO ())
cells (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later)
                  Cell
_ -> Maybe Int64
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
-> CellValue (Stream Cell IO (Stream RowCells IO ()))
forall r. Maybe Int64 -> Stream (Of ByteString) IO r -> CellValue r
CellBytes (Cell -> Maybe Int64
V.cellLength Cell
cell) (Int
-> ByteString
-> [(ColumnInfo, (Int, ColumnShape))]
-> Stream (Of ByteString) (Recipe ()) ()
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
chunks (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later (Cell -> Stream (Of ByteString) (Recipe ()) ()
V.valueStream Cell
cell))
            pure (Streaming.wrap (Cell col context (connValueAllocAhead conn) value))
          chunks Int
g ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later Stream (Of ByteString) (Recipe ()) ()
source = IO
  (Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO
   (Stream
      (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
 -> Stream
      (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
-> IO
     (Stream
        (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
forall a b. (a -> b) -> a -> b
$ Int
-> IO
     (Stream
        (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
-> IO
     (Stream
        (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
forall {a}. Int -> IO a -> IO a
claim Int
g (IO
   (Stream
      (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
 -> IO
      (Stream
         (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))))
-> IO
     (Stream
        (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
-> IO
     (Stream
        (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ())))
forall a b. (a -> b) -> a -> b
$ do
            step <- Parser
  (Either () (Of ByteString (Stream (Of ByteString) (Recipe ()) ())))
-> (Either
      () (Of ByteString (Stream (Of ByteString) (Recipe ()) ()))
    -> Maybe (Parser ()))
-> IO
     (Either () (Of ByteString (Stream (Of ByteString) (Recipe ()) ())))
forall {a}. Parser a -> (a -> Maybe (Parser ())) -> IO a
pull (Stream (Of ByteString) (Recipe ()) ()
-> Parser
     (Either () (Of ByteString (Stream (Of ByteString) (Recipe ()) ())))
forall (m :: * -> *) (f :: * -> *) r.
Monad m =>
Stream f m r -> m (Either r (f (Stream f m r)))
Streaming.inspect Stream (Of ByteString) (Recipe ()) ()
source) ((Either () (Of ByteString (Stream (Of ByteString) (Recipe ()) ()))
  -> Maybe (Parser ()))
 -> IO
      (Either
         () (Of ByteString (Stream (Of ByteString) (Recipe ()) ()))))
-> (Either
      () (Of ByteString (Stream (Of ByteString) (Recipe ()) ()))
    -> Maybe (Parser ()))
-> IO
     (Either () (Of ByteString (Stream (Of ByteString) (Recipe ()) ())))
forall a b. (a -> b) -> a -> b
$ \case
              Left () -> ByteString
-> [(ColumnInfo, (Int, ColumnShape))] -> Maybe (Parser ())
forall {a}.
ByteString -> [(a, (Int, ColumnShape))] -> Maybe (Parser ())
remaining ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later
              Right (ByteString
_ :> Stream (Of ByteString) (Recipe ()) ()
next) -> Parser () -> Maybe (Parser ())
forall a. a -> Maybe a
Just (Stream (Of ByteString) (Recipe ()) () -> Parser ()
forall (m :: * -> *) a r. Monad m => Stream (Of a) m r -> m r
S.effects Stream (Of ByteString) (Recipe ()) ()
next Parser () -> Parser () -> Parser ()
forall a b. Recipe () a -> Recipe () b -> Recipe () b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> [(ColumnInfo, (Int, ColumnShape))] -> Parser ()
forall {a}. ByteString -> [(a, (Int, ColumnShape))] -> Parser ()
skipColumns ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later)
            pure $ case step of
              Left () -> Stream Cell IO (Stream RowCells IO ())
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
forall a. a -> Stream (Of ByteString) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
-> ByteString
-> [(ColumnInfo, (Int, ColumnShape))]
-> Stream Cell IO (Stream RowCells IO ())
cells (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later)
              Right (ByteString
bytes :> Stream (Of ByteString) (Recipe ()) ()
next) -> ByteString -> Stream (Of ByteString) IO ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield (ByteString -> ByteString
B.copy ByteString
bytes) Stream (Of ByteString) IO ()
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
forall a b.
Stream (Of ByteString) IO a
-> Stream (Of ByteString) IO b -> Stream (Of ByteString) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> ByteString
-> [(ColumnInfo, (Int, ColumnShape))]
-> Stream (Of ByteString) (Recipe ()) ()
-> Stream
     (Of ByteString) IO (Stream Cell IO (Stream RowCells IO ()))
chunks (Int
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bitmap [(ColumnInfo, (Int, ColumnShape))]
later Stream (Of ByteString) (Recipe ()) ()
next
      pure (cols, rows 0)

-- | Discard a cell's value and get the rest of the row.
skipCell :: Cell r -> IO r
skipCell :: forall r. Cell r -> IO r
skipCell Cell{CellValue r
cellValue :: forall r. Cell r -> CellValue r
cellValue :: CellValue r
cellValue} = case CellValue r
cellValue of
  CellNull r
rest -> r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
rest
  CellBytes Maybe Int64
_ Stream (Of ByteString) IO r
bytes -> Stream (Of ByteString) IO r -> IO r
forall (m :: * -> *) a r. Monad m => Stream (Of a) m r -> m r
S.effects Stream (Of ByteString) IO r
bytes

-- | A character or XML cell's value as 'Text' chunks, read as it arrives, returning
-- the rest of the row.  A NULL gives no chunks.  A column whose encoding can't be
-- decoded throws 'DecodeError'.
cellText :: Cell r -> Stream (Of Text) IO r
cellText :: forall r. Cell r -> Stream (Of Text) IO r
cellText Cell{cellColumn :: forall r. Cell r -> ColumnInfo
cellColumn = ColumnInfo
col, cellValue :: forall r. Cell r -> CellValue r
cellValue = CellValue r
value} = case CellValue r
value of
  CellNull r
rest -> r -> Stream (Of Text) IO r
forall a. a -> Stream (Of Text) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
rest
  CellBytes Maybe Int64
_ Stream (Of ByteString) IO r
bytes -> case TypeInfo
-> Either
     String (Stream (Of ByteString) IO r -> Stream (Of Text) IO r)
forall (m :: * -> *) r.
Monad m =>
TypeInfo
-> Either
     String (Stream (Of ByteString) m r -> Stream (Of Text) m r)
decodeColumnChunks (ColumnInfo -> TypeInfo
columnType ColumnInfo
col) of
    Left String
err -> IO (Stream (Of Text) IO r) -> Stream (Of Text) IO r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (DecodeError -> IO (Stream (Of Text) IO r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (Maybe Text -> String -> DecodeError
DecodeError (Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnInfo -> Text
columnName ColumnInfo
col)) String
err))
    Right Stream (Of ByteString) IO r -> Stream (Of Text) IO r
decode -> Stream (Of ByteString) IO r -> Stream (Of Text) IO r
decode Stream (Of ByteString) IO r
bytes

-- | Decode a cell with any field decoder, and get the rest of the row.  A failed
-- conversion is a 'Left' once the value has been read past, so the row can go on.
cellDecoded :: FieldDecoder a -> Cell r -> IO (Either DecodeError a, r)
cellDecoded :: forall a r.
FieldDecoder a -> Cell r -> IO (Either DecodeError a, r)
cellDecoded FieldDecoder a
decoder cell :: Cell r
cell@Cell{cellColumn :: forall r. Cell r -> ColumnInfo
cellColumn = ColumnInfo
col, TdsContext
cellContext :: forall r. Cell r -> TdsContext
cellContext :: TdsContext
cellContext, Int
cellAllocAhead :: forall r. Cell r -> Int
cellAllocAhead :: Int
cellAllocAhead, cellValue :: forall r. Cell r -> CellValue r
cellValue = CellValue r
value} = case FieldDecoder a
-> TdsContext -> ColumnInfo -> Either String (CellDecoder a)
forall a.
FieldDecoder a
-> TdsContext -> ColumnInfo -> Either String (CellDecoder a)
compileField FieldDecoder a
decoder TdsContext
cellContext ColumnInfo
col of
  Left String
err -> (DecodeError -> Either DecodeError a
forall a b. a -> Either a b
Left (Maybe Text -> String -> DecodeError
DecodeError (Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnInfo -> Text
columnName ColumnInfo
col)) String
err),) (r -> (Either DecodeError a, r))
-> IO r -> IO (Either DecodeError a, r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cell r -> IO r
forall r. Cell r -> IO r
skipCell Cell r
cell
  Right CellDecoder a
selected -> case CellDecoder a
selected of
    CellDecoder Either String a
onNull ValueReader a
_ ValueReader a
owned -> Either String a -> ValueReader a -> IO (Either DecodeError a, r)
forall {b}.
Either String b
-> (ByteString -> Either String b) -> IO (Either DecodeError b, r)
whole Either String a
onNull ValueReader a
owned
    -- A value past the limit, or of a total not sent, goes to the fold.
    FoldingCell Either String a
onNull ValueReader a
_ ValueReader a
owned Stream (Of ByteString) (Recipe ()) ()
-> Parser (Either ReadFailure a)
fold -> case CellValue r
value of
      CellBytes Maybe Int64
total Stream (Of ByteString) IO r
_ | Bool -> (Int64 -> Bool) -> Maybe Int64 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
streamWholeLimit) Maybe Int64
total -> (StreamedValue -> Parser (Either ReadFailure a))
-> IO (Either DecodeError a, r)
forall {b}.
(StreamedValue -> Parser (Either ReadFailure b))
-> IO (Either DecodeError b, r)
streamed ((StreamedValue -> Parser (Either ReadFailure a))
 -> IO (Either DecodeError a, r))
-> (StreamedValue -> Parser (Either ReadFailure a))
-> IO (Either DecodeError a, r)
forall a b. (a -> b) -> a -> b
$ \case
        StreamedBytes Maybe Int64
_ Stream (Of ByteString) (Recipe ()) ()
chunks -> Stream (Of ByteString) (Recipe ()) ()
-> Parser (Either ReadFailure a)
fold Stream (Of ByteString) (Recipe ()) ()
chunks
        StreamedWhole ValueBytes
bytes -> Either ReadFailure a -> Parser (Either ReadFailure a)
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> Either ReadFailure a
forall {b}. Either String b -> Either ReadFailure b
failed (ValueReader a
owned (ValueBytes -> ByteString
P.valueBytes ValueBytes
bytes)))
        StreamedValue
StreamedNull -> Either ReadFailure a -> Parser (Either ReadFailure a)
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> Either ReadFailure a
forall {b}. Either String b -> Either ReadFailure b
failed Either String a
onNull)
      CellValue r
_ -> Either String a -> ValueReader a -> IO (Either DecodeError a, r)
forall {b}.
Either String b
-> (ByteString -> Either String b) -> IO (Either DecodeError b, r)
whole Either String a
onNull ValueReader a
owned
    StreamingCell StreamedValue -> Parser (Either ReadFailure a)
read -> (StreamedValue -> Parser (Either ReadFailure a))
-> IO (Either DecodeError a, r)
forall {b}.
(StreamedValue -> Parser (Either ReadFailure b))
-> IO (Either DecodeError b, r)
streamed StreamedValue -> Parser (Either ReadFailure a)
read
  where
    named :: Either String b -> Either DecodeError b
named = (String -> Either DecodeError b)
-> (b -> Either DecodeError b)
-> Either String b
-> Either DecodeError b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodeError -> Either DecodeError b
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError b)
-> (String -> DecodeError) -> String -> Either DecodeError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> String -> DecodeError
DecodeError (Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnInfo -> Text
columnName ColumnInfo
col))) b -> Either DecodeError b
forall a b. b -> Either a b
Right
    failed :: Either String b -> Either ReadFailure b
failed = (String -> Either ReadFailure b)
-> (b -> Either ReadFailure b)
-> Either String b
-> Either ReadFailure b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ReadFailure -> Either ReadFailure b
forall a b. a -> Either a b
Left (ReadFailure -> Either ReadFailure b)
-> (String -> ReadFailure) -> String -> Either ReadFailure b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> ReadFailure
DecodeFailed (DecodeError -> ReadFailure)
-> (String -> DecodeError) -> String -> ReadFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> String -> DecodeError
DecodeError (Text -> Maybe Text
forall a. a -> Maybe a
Just (ColumnInfo -> Text
columnName ColumnInfo
col))) b -> Either ReadFailure b
forall a b. b -> Either a b
Right
    whole :: Either String b
-> (ByteString -> Either String b) -> IO (Either DecodeError b, r)
whole Either String b
onNull ByteString -> Either String b
owned = case CellValue r
value of
      CellNull r
rest -> do
        let !result :: Either DecodeError b
result = Either String b -> Either DecodeError b
forall {b}. Either String b -> Either DecodeError b
named Either String b
onNull
        (Either DecodeError b, r) -> IO (Either DecodeError b, r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError b
result, r
rest)
      CellBytes Maybe Int64
total Stream (Of ByteString) IO r
source -> do
        -- The chunks are already free of PLP framing, so no parser is involved.
        bytes :> rest <- (Accumulator -> ByteString -> IO Accumulator)
-> IO Accumulator
-> (Accumulator -> IO ByteString)
-> Stream (Of ByteString) IO r
-> IO (Of ByteString r)
forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> m x)
-> m x -> (x -> m b) -> Stream (Of a) m r -> m (Of b r)
S.foldM (Int -> Accumulator -> ByteString -> IO Accumulator
P.append Int
cellAllocAhead)
          (Accumulator -> IO Accumulator
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Word64 -> Accumulator
P.accumulator (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Maybe Int64 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int64
total))) Accumulator -> IO ByteString
P.finish Stream (Of ByteString) IO r
source
        let !result = Either String b -> Either DecodeError b
forall {b}. Either String b -> Either DecodeError b
named (ByteString -> Either String b
owned ByteString
bytes)
        pure (result, rest)
    streamed :: (StreamedValue -> Parser (Either ReadFailure b))
-> IO (Either DecodeError b, r)
streamed StreamedValue -> Parser (Either ReadFailure b)
read = case CellValue r
value of
      CellNull r
rest -> do
        (result, _) <- Parser (Either ReadFailure b)
-> [ByteString] -> IO (Either ReadFailure b, [ByteString])
forall a. Parser a -> [ByteString] -> IO (a, [ByteString])
P.parseChunks (StreamedValue -> Parser (Either ReadFailure b)
read StreamedValue
StreamedNull) []
        (, rest) <$> conversion result
      CellBytes Maybe Int64
total Stream (Of ByteString) IO r
source -> do
        -- A streaming decoder's stream returns (), so the rest of the row
        -- leaves through this reference.
        ending <- Maybe r -> IO (IORef (Maybe r))
forall a. a -> IO (IORef a)
newIORef Maybe r
forall a. Maybe a
Nothing
        let chunks = (forall a. IO a -> Recipe () a)
-> Stream (Of ByteString) IO r
-> Stream (Of ByteString) (Recipe ()) r
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> Stream (Of ByteString) m b -> Stream (Of ByteString) n b
Streaming.hoist IO a -> Parser a
forall a. IO a -> Recipe () a
P.effect Stream (Of ByteString) IO r
source Stream (Of ByteString) (Recipe ()) r
-> (r -> Stream (Of ByteString) (Recipe ()) ())
-> Stream (Of ByteString) (Recipe ()) ()
forall a b.
Stream (Of ByteString) (Recipe ()) a
-> (a -> Stream (Of ByteString) (Recipe ()) b)
-> Stream (Of ByteString) (Recipe ()) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r
rest -> Recipe () (Stream (Of ByteString) (Recipe ()) ())
-> Stream (Of ByteString) (Recipe ()) ()
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
Streaming.effect (Recipe () (Stream (Of ByteString) (Recipe ()) ())
 -> Stream (Of ByteString) (Recipe ()) ())
-> Recipe () (Stream (Of ByteString) (Recipe ()) ())
-> Stream (Of ByteString) (Recipe ()) ()
forall a b. (a -> b) -> a -> b
$ do
              IO () -> Parser ()
forall a. IO a -> Recipe () a
P.effect (IORef (Maybe r) -> Maybe r -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe r)
ending (r -> Maybe r
forall a. a -> Maybe a
Just r
rest))
              Stream (Of ByteString) (Recipe ()) ()
-> Recipe () (Stream (Of ByteString) (Recipe ()) ())
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Stream (Of ByteString) (Recipe ()) ()
forall a. a -> Stream (Of ByteString) (Recipe ()) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (result, _) <- P.parseChunks (read (StreamedBytes total chunks)) []
        decoded <- conversion result
        readIORef ending >>= \case
          Just r
rest -> (Either DecodeError b, r) -> IO (Either DecodeError b, r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecodeError b
decoded, r
rest)
          Maybe r
Nothing -> ProtocolError -> IO (Either DecodeError b, r)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> ProtocolError
ProtocolError String
"cell decoder did not finish its value")
    -- 'P.parseChunks' runs every consumer and discards nothing.
    conversion :: Either ReadFailure b -> IO (Either DecodeError b)
conversion = \case
      Left (DecodeFailed DecodeError
err) -> Either DecodeError b -> IO (Either DecodeError b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DecodeError -> Either DecodeError b
forall a b. a -> Either a b
Left DecodeError
err)
      Left ReadFailure
ReadDiscarded -> ProtocolError -> IO (Either DecodeError b)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> ProtocolError
ProtocolError String
"cell decoder discarded its value")
      Right b
a -> Either DecodeError b -> IO (Either DecodeError b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either DecodeError b
forall a b. b -> Either a b
Right b
a)

-- | 'query' with a 'RowDecoderMonadic' instead of a 'RowDecoder': the decoder
-- runs per row, so it can look at the columns ('remainingColumns') and
-- decode a shape only known at runtime.
queryMWith :: RowDecoderMonadic r -> Connection -> Query -> IO [r]
queryMWith :: forall r. RowDecoderMonadic r -> Connection -> Query -> IO [r]
queryMWith RowDecoderMonadic r
dec Connection
conn Query
q = RowCompiler r -> Connection -> Query -> IO [r]
forall r. RowCompiler r -> Connection -> Query -> IO [r]
collectFirstResultSet (RowDecoderMonadic r -> RowCompiler r
forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec) Connection
conn Query
q

-- | 'query' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance.
queryWith :: RowDecoder r -> Connection -> Query -> IO [r]
queryWith :: forall r. RowDecoder r -> Connection -> Query -> IO [r]
queryWith RowDecoder r
dec Connection
conn Query
q = RowCompiler r -> Connection -> Query -> IO [r]
forall r. RowCompiler r -> Connection -> Query -> IO [r]
collectFirstResultSet (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec) Connection
conn Query
q

-- | The rows of the first result set, decoded into the row type by its
-- 'FromSqlRow' instance, with the column types checked before the first
-- row.  A query with no result set, such as an @UPDATE@, gives @[]@.  The
-- rest of the response is read to its end, so a later result set is
-- discarded, and an error from a later statement is still thrown.
query :: FromSqlRow r => Connection -> Query -> IO [r]
query :: forall r. FromSqlRow r => Connection -> Query -> IO [r]
query = RowDecoder r -> Connection -> Query -> IO [r]
forall r. RowDecoder r -> Connection -> Query -> IO [r]
queryWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

collectFirstResultSet :: RowCompiler r -> Connection -> Query -> IO [r]
collectFirstResultSet :: forall r. RowCompiler r -> Connection -> Query -> IO [r]
collectFirstResultSet RowCompiler r
compile Connection
conn Query
q = Connection -> IO [r] -> IO [r]
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO [r] -> IO [r]) -> IO [r] -> IO [r]
forall a b. (a -> b) -> a -> b
$
  Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request -> (Request -> IO [r]) -> IO [r]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
req -> Connection -> Request -> (ResponseReader -> IO [r]) -> IO [r]
forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req (RowCompiler r -> ResponseReader -> IO [r]
forall r. RowCompiler r -> ResponseReader -> IO [r]
readFirstResultSet RowCompiler r
compile)

-- | Fold over the rows of the first result set as they arrive, without
-- building a list or a stream: the fastest way to count, sum or write
-- rows out.  The step runs with the connection lock held, in the middle
-- of reading the response, so it must not use the connection.  On a MARS
-- connection it may, because the request takes a session of its own.
-- An exception from the step cancels the response at once and
-- propagates.  If it is the step's own exception, the response is
-- drained before it propagates; if it is an interruption, the drain is
-- left to the next request.  After the fold, the rest of the response is
-- read to its end, as with 'query'.
queryFold :: FromSqlRow r => Connection -> Query -> a -> (a -> r -> IO a) -> IO a
queryFold :: forall r a.
FromSqlRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
queryFold = RowDecoder r
-> Connection -> Query -> a -> (a -> r -> IO a) -> IO a
forall r a.
RowDecoder r
-> Connection -> Query -> a -> (a -> r -> IO a) -> IO a
queryFoldWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'queryFold' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance.
queryFoldWith :: RowDecoder r -> Connection -> Query -> a -> (a -> r -> IO a) -> IO a
queryFoldWith :: forall r a.
RowDecoder r
-> Connection -> Query -> a -> (a -> r -> IO a) -> IO a
queryFoldWith RowDecoder r
dec Connection
conn Query
q a
z a -> r -> IO a
step = Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  req <- Connection -> Query -> IO Request
queryRequest Connection
conn Query
q
  withResponse conn req $ \ResponseReader
resp -> RowCompiler r -> ResponseReader -> a -> (a -> r -> IO a) -> IO a
forall r a.
RowCompiler r -> ResponseReader -> a -> (a -> r -> IO a) -> IO a
foldFirstResultSet (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec) ResponseReader
resp a
z a -> r -> IO a
step

-- | 'query' for exactly one row.  It throws 'UnexpectedResult' if the
-- first result set has no rows or several.
query1 :: FromSqlRow r => Connection -> Query -> IO r
query1 :: forall r. FromSqlRow r => Connection -> Query -> IO r
query1 = RowDecoder r -> Connection -> Query -> IO r
forall r. RowDecoder r -> Connection -> Query -> IO r
query1With RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'query1' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance. Throws 'UnexpectedResult' unless the first
-- result set has exactly one row.
query1With :: RowDecoder r -> Connection -> Query -> IO r
query1With :: forall r. RowDecoder r -> Connection -> Query -> IO r
query1With RowDecoder r
dec Connection
conn Query
q = RowDecoder r -> Connection -> Query -> IO [r]
forall r. RowDecoder r -> Connection -> Query -> IO [r]
queryWith RowDecoder r
dec Connection
conn Query
q IO [r] -> ([r] -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [r] -> IO r
forall r. [r] -> IO r
exactlyOne
{-# NOINLINE query1With #-}

-- | 'query' for at most one row.  It returns 'Nothing' if the first result
-- set has no rows, and throws 'UnexpectedResult' if it has several.
queryMay :: FromSqlRow r => Connection -> Query -> IO (Maybe r)
queryMay :: forall r. FromSqlRow r => Connection -> Query -> IO (Maybe r)
queryMay = RowDecoder r -> Connection -> Query -> IO (Maybe r)
forall r. RowDecoder r -> Connection -> Query -> IO (Maybe r)
queryMayWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'queryMay' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance. Throws 'UnexpectedResult' if the first result
-- set has more than one row.
queryMayWith :: RowDecoder r -> Connection -> Query -> IO (Maybe r)
queryMayWith :: forall r. RowDecoder r -> Connection -> Query -> IO (Maybe r)
queryMayWith RowDecoder r
dec Connection
conn Query
q = RowDecoder r -> Connection -> Query -> IO [r]
forall r. RowDecoder r -> Connection -> Query -> IO [r]
queryWith RowDecoder r
dec Connection
conn Query
q IO [r] -> ([r] -> IO (Maybe r)) -> IO (Maybe r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [r] -> IO (Maybe r)
forall r. [r] -> IO (Maybe r)
atMostOne
{-# NOINLINE queryMayWith #-}

------------------------------------------------------------------------------
-- Multiple result sets

-- | Every result set decoded with the given row decoder. Each set's
-- column count and types are checked before reading its rows, including
-- empty sets. Use 'queryResultSets' when the sets have different known shapes.
queryMultiWith :: RowDecoder r -> Connection -> Query -> IO [ResultSet r]
queryMultiWith :: forall r. RowDecoder r -> Connection -> Query -> IO [ResultSet r]
queryMultiWith RowDecoder r
dec Connection
conn Query
q = Connection -> IO [ResultSet r] -> IO [ResultSet r]
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO [ResultSet r] -> IO [ResultSet r])
-> IO [ResultSet r] -> IO [ResultSet r]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request -> (Request -> 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
>>= RowCompiler r -> Connection -> Request -> IO [ResultSet r]
forall r.
RowCompiler r -> Connection -> Request -> IO [ResultSet r]
collectResultSets (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec) Connection
conn

-- | 'queryMulti' with a 'RowDecoderMonadic' instead of 'SqlRow': every result
-- set in the response, each decoded with the same decoder, which runs per
-- row and can look at the columns ('remainingColumns') to adapt to each
-- set.
queryMultiMWith :: RowDecoderMonadic r -> Connection -> Query -> IO [ResultSet r]
queryMultiMWith :: forall r.
RowDecoderMonadic r -> Connection -> Query -> IO [ResultSet r]
queryMultiMWith RowDecoderMonadic r
dec Connection
conn Query
q = Connection -> IO [ResultSet r] -> IO [ResultSet r]
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO [ResultSet r] -> IO [ResultSet r])
-> IO [ResultSet r] -> IO [ResultSet r]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request -> (Request -> 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
>>= RowCompiler r -> Connection -> Request -> IO [ResultSet r]
forall r.
RowCompiler r -> Connection -> Request -> IO [ResultSet r]
collectResultSets (RowDecoderMonadic r -> RowCompiler r
forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec) Connection
conn

-- | Every result set in the response, in order, each row as a 'SqlRow'
-- ('sqlRowDecoderFor' the set's columns): for a batch or procedure whose
-- columns are only known at runtime.  For result sets of known types, use
-- 'queryResultSets'.
queryMulti :: Connection -> Query -> IO [ResultSet SqlRow]
queryMulti :: Connection -> Query -> IO [ResultSet SqlRow]
queryMulti Connection
conn Query
q = Connection -> IO [ResultSet SqlRow] -> IO [ResultSet SqlRow]
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO [ResultSet SqlRow] -> IO [ResultSet SqlRow])
-> IO [ResultSet SqlRow] -> IO [ResultSet SqlRow]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request
-> (Request -> IO [ResultSet SqlRow]) -> IO [ResultSet SqlRow]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RowCompiler SqlRow
-> Connection -> Request -> IO [ResultSet SqlRow]
forall r.
RowCompiler r -> Connection -> Request -> IO [ResultSet r]
collectResultSets RowCompiler SqlRow
sqlRowCompiler Connection
conn

collectResultSets :: RowCompiler r -> Connection -> Request -> IO [ResultSet r]
collectResultSets :: forall r.
RowCompiler r -> Connection -> Request -> IO [ResultSet r]
collectResultSets RowCompiler r
compile Connection
conn Request
req = Connection
-> Request
-> (ResponseReader -> IO [ResultSet r])
-> IO [ResultSet r]
forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req (RowCompiler r -> ResponseReader -> IO [ResultSet r]
forall r. RowCompiler r -> ResponseReader -> IO [ResultSet r]
readResultSets RowCompiler r
compile)

------------------------------------------------------------------------------
-- Typed multiple result sets

-- | 'resultSet' with the given row decoder instead of the row type's
-- 'FromSqlRow' instance.
resultSetWith :: RowDecoder r -> ResultSets [r]
resultSetWith :: forall r. RowDecoder r -> ResultSets [r]
resultSetWith RowDecoder r
dec = ([ColumnInfo], [r]) -> [r]
forall a b. (a, b) -> b
snd (([ColumnInfo], [r]) -> [r])
-> ResultSets ([ColumnInfo], [r]) -> ResultSets [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowCompiler r -> ResultSets ([ColumnInfo], [r])
forall r. RowCompiler r -> ResultSets ([ColumnInfo], [r])
nextResultSet (RowDecoder r -> RowCompiler r
forall r. RowDecoder r -> RowCompiler r
compilerFor RowDecoder r
dec)
{-# NOINLINE resultSetWith #-}

-- | The rows of the next result set, as 'query' would return them.  It
-- throws 'UnexpectedResult' if the response has no further result set.
resultSet :: FromSqlRow r => ResultSets [r]
resultSet :: forall r. FromSqlRow r => ResultSets [r]
resultSet = RowDecoder r -> ResultSets [r]
forall r. RowDecoder r -> ResultSets [r]
resultSetWith RowDecoder r
forall a. FromSqlRow a => RowDecoder a
rowDecoder

-- | 'resultSet' with a 'RowDecoderMonadic', which runs per row and can look at
-- the columns ('remainingColumns'), and the result set's columns returned
-- with its rows.
resultSetMWith :: RowDecoderMonadic r -> ResultSets (ResultSet r)
resultSetMWith :: forall r. RowDecoderMonadic r -> ResultSets (ResultSet r)
resultSetMWith RowDecoderMonadic r
dec = ([ColumnInfo] -> [r] -> ResultSet r)
-> ([ColumnInfo], [r]) -> ResultSet r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [ColumnInfo] -> [r] -> ResultSet r
forall r. [ColumnInfo] -> [r] -> ResultSet r
ResultSet (([ColumnInfo], [r]) -> ResultSet r)
-> ResultSets ([ColumnInfo], [r]) -> ResultSets (ResultSet r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowCompiler r -> ResultSets ([ColumnInfo], [r])
forall r. RowCompiler r -> ResultSets ([ColumnInfo], [r])
nextResultSet (RowDecoderMonadic r -> RowCompiler r
forall r. RowDecoderMonadic r -> RowCompiler r
compilerForM RowDecoderMonadic r
dec)
{-# NOINLINE resultSetMWith #-}

-- | Read the next result set and discard its rows.  It throws
-- 'UnexpectedResult' if the response has no further result set.
skipResultSet :: ResultSets ()
skipResultSet :: ResultSets ()
skipResultSet = ResultSets ([ColumnInfo], [()]) -> ResultSets ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RowCompiler () -> ResultSets ([ColumnInfo], [()])
forall r. RowCompiler r -> ResultSets ([ColumnInfo], [r])
nextResultSet (\TdsContext
_ [ColumnInfo]
cols -> CompiledRow () -> Either DecodeError (CompiledRow ())
forall a b. b -> Either a b
Right ([ColumnInfo] -> CompiledRow ()
skipRowDecoder [ColumnInfo]
cols)))

-- | Throws 'UnexpectedResult' if the response has no further result set.  On a
-- decode failure the rest of the response is drained before rethrowing.
nextResultSet :: RowCompiler r -> ResultSets ([ColumnInfo], [r])
nextResultSet :: forall r. RowCompiler r -> ResultSets ([ColumnInfo], [r])
nextResultSet RowCompiler r
compile = (TdsContext -> ResponseReader -> IO ([ColumnInfo], [r]))
-> ResultSets ([ColumnInfo], [r])
forall a. (TdsContext -> ResponseReader -> IO a) -> ResultSets a
ResultSets ((TdsContext -> ResponseReader -> IO ([ColumnInfo], [r]))
 -> ResultSets ([ColumnInfo], [r]))
-> (TdsContext -> ResponseReader -> IO ([ColumnInfo], [r]))
-> ResultSets ([ColumnInfo], [r])
forall a b. (a -> b) -> a -> b
$ \TdsContext
ctx ResponseReader
resp -> do
  let skip :: IO ([ColumnInfo], [r])
skip = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO ([ColumnInfo], [r]))
-> IO ([ColumnInfo], [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 -> UnexpectedResult -> IO ([ColumnInfo], [r])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (UnexpectedResult -> IO ([ColumnInfo], [r]))
-> UnexpectedResult -> IO ([ColumnInfo], [r])
forall a b. (a -> b) -> a -> b
$ String -> UnexpectedResult
UnexpectedResult String
"expected another result set"
        StepToken (TColMetaData [ColumnInfo]
cols) -> case RowCompiler r
compile TdsContext
ctx [ColumnInfo]
cols of
          Left DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO ([ColumnInfo], [r]) -> IO ([ColumnInfo], [r])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO ([ColumnInfo], [r])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
          Right CompiledRow r
compiled -> 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 IO (RowRead r)
-> (RowRead r -> IO ([ColumnInfo], [r])) -> IO ([ColumnInfo], [r])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RowRead r
decode -> [ColumnInfo] -> RowRead r -> [[r]] -> IO ([ColumnInfo], [r])
forall {t} {r}. t -> RowRead r -> [[r]] -> IO (t, [r])
collect [ColumnInfo]
cols RowRead r
decode []
        ResponseStep ()
_ -> IO ([ColumnInfo], [r])
skip
      collect :: t -> RowRead r -> [[r]] -> IO (t, [r])
collect t
cols RowRead r
decode [[r]]
acc = 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 (t, [r])) -> IO (t, [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 -> (t, [r]) -> IO (t, [r])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
cols, [[r]] -> [r]
forall r. [[r]] -> [r]
joinBatches [[r]]
acc)
        StepRows (RowBatch [r]
rows Maybe DecodeError
failed) -> case Maybe DecodeError
failed of
          Just DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO (t, [r]) -> IO (t, [r])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO (t, [r])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
          Maybe DecodeError
Nothing -> t -> RowRead r -> [[r]] -> IO (t, [r])
collect t
cols RowRead r
decode ([r]
rows [r] -> [[r]] -> [[r]]
forall a. a -> [a] -> [a]
: [[r]]
acc)
        -- A set followed directly by the next; leave its metadata for it.
        StepToken tok :: Token
tok@(TColMetaData [ColumnInfo]
_) -> do
          IORef (Maybe Token) -> Maybe Token -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ResponseReader -> IORef (Maybe Token)
respPushback ResponseReader
resp) (Token -> Maybe Token
forall a. a -> Maybe a
Just Token
tok)
          (t, [r]) -> IO (t, [r])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
cols, [[r]] -> [r]
forall r. [[r]] -> [r]
joinBatches [[r]]
acc)
        StepToken Token
tok
          | Token -> Bool
endsResultSet Token
tok -> (t, [r]) -> IO (t, [r])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
cols, [[r]] -> [r]
forall r. [[r]] -> [r]
joinBatches [[r]]
acc)
          | Bool
otherwise -> t -> RowRead r -> [[r]] -> IO (t, [r])
collect t
cols RowRead r
decode [[r]]
acc
  IO ([ColumnInfo], [r])
skip

-- | Run a batch that returns several result sets, and decode them one at
-- a time, each into its own row type.
--
-- > (parents, children) <- queryResultSets ((,) <$> resultSet <*> resultSet) conn
-- >   "SELECT id, name FROM dbo.parent; SELECT id, parent_id FROM dbo.child"
--
-- The whole response is read, so an error in a later statement still
-- throws 'SqlServerError', and result sets the 'ResultSets' didn't ask
-- for are discarded.
queryResultSets :: ResultSets a -> Connection -> Query -> IO a
queryResultSets :: forall a. ResultSets a -> Connection -> Query -> IO a
queryResultSets ResultSets a
sets Connection
conn Query
q = Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Request
queryRequest Connection
conn Query
q IO Request -> (Request -> 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
>>= ResultSets a -> Connection -> Request -> IO a
forall a. ResultSets a -> Connection -> Request -> IO a
runResultSetsOn ResultSets a
sets Connection
conn

runResultSetsOn :: ResultSets a -> Connection -> Request -> IO a
runResultSetsOn :: forall a. ResultSets a -> Connection -> Request -> IO a
runResultSetsOn ResultSets a
sets Connection
conn Request
req = Connection -> Request -> (ResponseReader -> IO a) -> IO a
forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req (ResultSets a -> ResponseReader -> IO a
forall a. ResultSets a -> ResponseReader -> IO a
readResultSetsWith ResultSets a
sets)

------------------------------------------------------------------------------
-- Stored procedures

-- | A parameter of a 'callProcedure' call.  'inParam' and 'outParam' build
-- one from a 'ToSqlField' value; 'rawInParam' and 'rawOutParam' declare an
-- exact wire type. Encoding runs in 'callProcedure', with the connection's
-- context.
data ProcParam = ProcParam
  { ProcParam -> Text
procParamName :: !Text
    -- ^ With the leading @\@@, or empty for positional.  Sent as given (not
    -- spliced into SQL, and not checked by 'paramNameProblem'): the server
    -- matches it against the procedure's parameters, ignoring trailing
    -- spaces, and reports a name it can't match as a 'SqlServerError'.
  , ProcParam -> TdsContext -> Either String EncodedParam
procParamEncode :: TdsContext -> Either String EncodedParam
    -- ^ Encode with the connection's context: the declared wire type and
    -- value's bytes ('Nothing' for NULL), or why it cannot be encoded.
    -- 'callProcedure' throws 'EncodeError' before sending on a 'Left'.
  , ProcParam -> Bool
procParamOutput :: !Bool
    -- ^ Whether the server returns the parameter's value after the call
    -- ('procOutputValues').
  }

-- | An input parameter, encoded with the connection's context when
-- 'callProcedure' runs. Encoding failures throw 'EncodeError' before
-- the procedure request is sent.
--
-- > inParam "@customer_id" (42 :: Int32)
inParam :: ToSqlField a => Text -> a -> ProcParam
inParam :: forall a. ToSqlField a => Text -> a -> ProcParam
inParam Text
name a
a = Text
-> (TdsContext -> Either String EncodedParam) -> Bool -> ProcParam
ProcParam Text
name (\TdsContext
ctx -> FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a) Bool
False
-- 'inParam' and 'outParam' are OPAQUE: inlined, or split into a worker whose result
-- the caller boxed again, a call of 'callProcedure' with one of each was 861 bytes of
-- object code; called, with 'maybeEncoder' out of line too, it is 613.
{-# OPAQUE inParam #-}

-- | An input/output parameter; the value is its initial value (a NULL of
-- the right type, @Nothing :: Maybe Int32@, when it has none).  Its value
-- after the call is in 'procOutputValues', decoded with
-- 'decodeReturnValue'.
--
-- The server returns an output value converted to the type declared for the
-- parameter, which is derived from the initial value, so that type is widened
-- so the output isn't truncated:
--
-- * strings and binary (@char@, @varchar@, @nchar@, @nvarchar@, @binary@,
--   @varbinary@) are declared as @(max)@;
-- * @decimal@ and @numeric@ are declared with precision 38 and scale 10, or
--   the initial value's scale if that is larger (but less than 10 if the
--   initial value's integer digits need it).  So @0 :: Decimal@ and
--   @Nothing :: Maybe Decimal@ both declare @decimal(38,10)@; to get more
--   decimal places give the initial value a larger scale (e.g.
--   @'Data.Decimal.roundTo' 20 0@).
--
-- Other types are declared as their 'ToSqlField' instance sends them.  An
-- @xml@ output parameter needs an @xml@ initial value such as
-- @'SqlXml' \"\"@ (the server won't convert xml to the @nvarchar@ a 'Text'
-- initial value declares).  For full control of the declared type, use
-- 'rawOutParam', which widens nothing.
-- Encoding and widening run in 'callProcedure', with the connection's
-- context; failures throw 'EncodeError' before the procedure request is sent.
outParam :: ToSqlField a => Text -> a -> ProcParam
outParam :: forall a. ToSqlField a => Text -> a -> ProcParam
outParam Text
name a
a = Text
-> (TdsContext -> Either String EncodedParam) -> Bool -> ProcParam
ProcParam Text
name TdsContext -> Either String EncodedParam
encode Bool
True
  where
    encode :: TdsContext -> Either String EncodedParam
encode TdsContext
ctx = FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
forall a.
FieldEncoder a -> TdsContext -> a -> Either String EncodedParam
encodeParam FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
fieldEncoder TdsContext
ctx a
a Either String EncodedParam
-> (EncodedParam -> Either String EncodedParam)
-> Either String EncodedParam
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EncodedParam -> Either String EncodedParam
widenOutputParam
{-# OPAQUE outParam #-}

-- | An input parameter with an exact wire type and encoded value, for a
-- type no 'ToSqlField' instance declares:
--
-- > rawInParam "@x" (TIDecimalN 20 4, decimalValue)
--
-- 'callProcedure' still validates the wire type and the value before
-- sending.
rawInParam :: Text -> (TypeInfo, RawBytes) -> ProcParam
rawInParam :: Text -> (TypeInfo, Maybe ByteString) -> ProcParam
rawInParam Text
name (TypeInfo
ti, Maybe ByteString
value) = Text
-> (TdsContext -> Either String EncodedParam) -> Bool -> ProcParam
ProcParam Text
name (Either String EncodedParam
-> TdsContext -> Either String EncodedParam
forall a b. a -> b -> a
const (EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, Maybe ByteString -> ParamValue
ParamBytes Maybe ByteString
value))) Bool
False

-- | 'rawInParam' as an input\/output parameter: the declared type is the
-- one given, with none of the widening of 'outParam', so the server converts
-- the output value to exactly it:
--
-- > rawOutParam "@x" (TIDecimalN 20 4, Nothing)   -- a NULL decimal(20,4)
rawOutParam :: Text -> (TypeInfo, RawBytes) -> ProcParam
rawOutParam :: Text -> (TypeInfo, Maybe ByteString) -> ProcParam
rawOutParam Text
name (TypeInfo
ti, Maybe ByteString
value) = Text
-> (TdsContext -> Either String EncodedParam) -> Bool -> ProcParam
ProcParam Text
name (Either String EncodedParam
-> TdsContext -> Either String EncodedParam
forall a b. a -> b -> a
const (EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, Maybe ByteString -> ParamValue
ParamBytes Maybe ByteString
value))) Bool
True

-- | Checks the type first ('typeInfoProblem'), so that an invalid one (a
-- hand-built @decimal(40,0)@) is refused rather than widened into a valid
-- one.
widenOutputParam :: EncodedParam -> Either String EncodedParam
widenOutputParam :: EncodedParam -> Either String EncodedParam
widenOutputParam (TypeInfo
_, ParamLazy ByteString
_) = String -> Either String EncodedParam
forall a b. a -> Either a b
Left String
"output parameters cannot stream"
widenOutputParam (TypeInfo
_, ParamStream Source ByteString
_) = String -> Either String EncodedParam
forall a b. a -> Either a b
Left String
"output parameters cannot stream"
widenOutputParam (TypeInfo
ti, ParamBytes Maybe ByteString
raw) = (String -> Either String (ZonkAny 0))
-> Maybe String -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Either String (ZonkAny 0)
forall a b. a -> Either a b
Left (TypeInfo -> Maybe String
typeInfoProblem TypeInfo
ti) Either String ()
-> Either String EncodedParam -> Either String EncodedParam
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> case TypeInfo
ti of
  TINVarChar Word16
_ Collation
c -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
c, ParamValue
v)
  TINChar Word16
_ Collation
c -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
c, ParamValue
v)
  TIBigVarChar Word16
_ Collation
c -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TIBigVarChar Word16
maxLength Collation
c, ParamValue
v)
  TIBigChar Word16
_ Collation
c -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> Collation -> TypeInfo
TIBigVarChar Word16
maxLength Collation
c, ParamValue
v)
  TIBigVarBinary Word16
_ -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength, ParamValue
v)
  TIBigBinary Word16
_ -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength, ParamValue
v)
  TIDecimalN Precision
p Precision
s -> (Precision -> Precision -> TypeInfo)
-> Precision -> Precision -> Either String EncodedParam
forall {t} {a}.
Num t =>
(t -> Precision -> a)
-> Precision -> Precision -> Either String (a, ParamValue)
decimal Precision -> Precision -> TypeInfo
TIDecimalN Precision
p Precision
s
  TINumericN Precision
p Precision
s -> (Precision -> Precision -> TypeInfo)
-> Precision -> Precision -> Either String EncodedParam
forall {t} {a}.
Num t =>
(t -> Precision -> a)
-> Precision -> Precision -> Either String (a, ParamValue)
decimal Precision -> Precision -> TypeInfo
TINumericN Precision
p Precision
s
  TypeInfo
_ -> EncodedParam -> Either String EncodedParam
forall a b. b -> Either a b
Right (TypeInfo
ti, ParamValue
v)
  where
    v :: ParamValue
v = Maybe ByteString -> ParamValue
ParamBytes Maybe ByteString
raw
    decimal :: (t -> Precision -> a)
-> Precision -> Precision -> Either String (a, ParamValue)
decimal t -> Precision -> a
mk Precision
p Precision
s = do
      let intDigits :: Int
intDigits = Precision -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Precision
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Precision -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Precision
s :: Int
          s' :: Precision
s' = Precision -> Precision -> Precision
forall a. Ord a => a -> a -> a
max Precision
s (Int -> Precision
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
10 (Int
38 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
intDigits))))
      v' <- case Maybe ByteString
raw of
        Maybe ByteString
Nothing -> Maybe ByteString -> Either String (Maybe ByteString)
forall a b. b -> Either a b
Right Maybe ByteString
forall a. Maybe a
Nothing
        Just ByteString
bs -> case Precision -> Precision -> ValueReader Decimal
readDecimal Precision
p Precision
s ByteString
bs of
          Left String
err -> String -> Either String (Maybe ByteString)
forall a b. a -> Either a b
Left (String
"invalid decimal parameter value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
          Right Decimal
d -> Maybe ByteString -> Either String (Maybe ByteString)
forall a b. b -> Either a b
Right (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Int -> Put -> ByteString
runPutSized Int
17 (Precision -> Precision -> Decimal -> Put
putDecimal Precision
38 Precision
s' Decimal
d)))
      Right (mk 38 s', ParamBytes v')

-- | What 'callProcedure' returns: the return status, the output
-- parameters' values and the result sets.
data ProcResult = ProcResult
  { ProcResult -> Maybe Int32
procReturnStatus :: !(Maybe Int32)
    -- ^ The procedure's @RETURN@ status, if the server sent one (it doesn't
    -- for a scalar function).
  , ProcResult -> [ReturnValue]
procOutputValues :: ![ReturnValue]
    -- ^ One value per output parameter ('outParam', or 'procParamOutput'
    -- set), in the order those parameters appear in the list passed to
    -- 'callProcedure' -- not the order the server sends them in, which
    -- differs (SQL Server sends @(max)@-typed values, which includes every
    -- string or binary 'outParam', after the others).  So
    -- @zip outputParams (procOutputValues res)@ pairs each parameter with
    -- its value, whether the parameters are passed by name or by position,
    -- interleaved with input parameters, or in a different order than the
    -- procedure declares them.
    --
    -- When the called object is a scalar user-defined function, its return
    -- value comes first ('rvStatus' has bit @0x02@ set); functions have no
    -- output parameters, so it is the only value.
  , ProcResult -> [ResultSet SqlRow]
procResultSets :: ![ResultSet SqlRow]
    -- ^ Every result set the procedure produced, as 'queryMulti' returns
    -- them.
  }

instance Show ProcResult where
  showsPrec :: Int -> ProcResult -> ShowS
showsPrec Int
p (ProcResult Maybe Int32
a [ReturnValue]
b [ResultSet SqlRow]
c) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"ProcResult"#
    [ Addr#
"procReturnStatus"# Addr# -> Maybe Int32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe Int32
a, Addr#
"procOutputValues"# Addr# -> [ReturnValue] -> Field
forall a. Show a => Addr# -> a -> Field
:= [ReturnValue]
b, Addr#
"procResultSets"# Addr# -> [ResultSet SqlRow] -> Field
forall a. Show a => Addr# -> a -> Field
:= [ResultSet SqlRow]
c ]
  {-# OPAQUE showsPrec #-}

-- | Call a stored procedure (or scalar function, or system procedure such as
-- @sp_executesql@) by RPC, with the parameters in the given order.  See
-- 'ProcResult' for how output values are ordered.  Like the other query
-- functions, it throws 'SqlServerError' if the server reports an error, even
-- one the procedure continues past; output values are then not available.
-- Parameters are encoded with the connection's context and validated
-- before sending; an encoding failure throws 'EncodeError'.
--
-- > res <- callProcedure conn "dbo.place_order"
-- >   [ inParam "@customer_id" (42 :: Int32)
-- >   , outParam "@order_id" (Nothing :: Maybe Int32)
-- >   ]
-- > let [orderId] = procOutputValues res
-- > print (decodeReturnValue orderId :: Either DecodeError (Maybe Int32), procReturnStatus res)
--
-- A procedure with typed result sets and no output parameters can also be
-- run as @EXEC dbo.report \@p1@ through 'queryResultSets'.
callProcedure :: Connection -> Text -> [ProcParam] -> IO ProcResult
callProcedure :: Connection -> Text -> [ProcParam] -> IO ProcResult
callProcedure Connection
conn Text
procName [ProcParam]
params = Connection -> IO ProcResult -> IO ProcResult
forall a. Connection -> IO a -> IO a
withConnectionLock Connection
conn (IO ProcResult -> IO ProcResult) -> IO ProcResult -> IO ProcResult
forall a b. (a -> b) -> a -> b
$ do
  ctx <- Connection -> IO TdsContext
connectionContext Connection
conn
  rpcParams <- either (throwIO . EncodeError) pure (traverse (toRpc ctx) params)
  rpcRequest procName rpcParams >>= \Request
req -> Connection
-> Request -> (ResponseReader -> IO ProcResult) -> IO ProcResult
forall a. Connection -> Request -> (ResponseReader -> IO a) -> IO a
withResponse Connection
conn Request
req (Connection -> ResponseReader -> IO ProcResult
readProcResult Connection
conn)
  where
    toRpc :: TdsContext -> ProcParam -> Either String RpcParam
toRpc TdsContext
ctx ProcParam{Bool
Text
TdsContext -> Either String EncodedParam
procParamName :: ProcParam -> Text
procParamEncode :: ProcParam -> TdsContext -> Either String EncodedParam
procParamOutput :: ProcParam -> Bool
procParamName :: Text
procParamEncode :: TdsContext -> Either String EncodedParam
procParamOutput :: Bool
..} = do
      (ti, v) <- TdsContext -> Either String EncodedParam
procParamEncode TdsContext
ctx
      pure (RpcParam procParamName (if procParamOutput then paramByRef else 0) ti v)

-- | Read a procedure call's response to its end ('callProcedure').
readProcResult :: Connection -> ResponseReader -> IO ProcResult
readProcResult :: Connection -> ResponseReader -> IO ProcResult
readProcResult Connection
conn ResponseReader
resp = do
  ctx <- Connection -> IO TdsContext
connectionContext Connection
conn
  -- Return tokens belong to the whole response; columns, the decoder and
  -- row batches belong only to the set being read. Completed sets, row batches
  -- and output tokens accumulate newest first.
  let beforeFirst !(Maybe Int32, [ReturnValue])
returns = ResponseReader -> RowRead () -> IO (ResponseStep ())
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead ()
ignoreRows IO (ResponseStep ())
-> (ResponseStep () -> IO ProcResult) -> IO ProcResult
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 Int32, [ReturnValue]) -> [ResultSet SqlRow] -> IO ProcResult
forall {f :: * -> *}.
Applicative f =>
(Maybe Int32, [ReturnValue]) -> [ResultSet SqlRow] -> f ProcResult
finish (Maybe Int32, [ReturnValue])
returns []
        StepToken (TColMetaData [ColumnInfo]
cols) -> (Maybe Int32, [ReturnValue])
-> [ResultSet SqlRow] -> [ColumnInfo] -> IO ProcResult
startSet (Maybe Int32, [ReturnValue])
returns [] [ColumnInfo]
cols
        StepToken Token
tok -> (Maybe Int32, [ReturnValue]) -> IO ProcResult
beforeFirst ((Maybe Int32, [ReturnValue])
-> Token -> (Maybe Int32, [ReturnValue])
onToken (Maybe Int32, [ReturnValue])
returns Token
tok)
        StepRows RowBatch ()
_ -> (Maybe Int32, [ReturnValue]) -> IO ProcResult
beforeFirst (Maybe Int32, [ReturnValue])
returns
      startSet (Maybe Int32, [ReturnValue])
returns [ResultSet SqlRow]
sets [ColumnInfo]
cols = do
        decode <- (DecodeError -> IO (RowRead SqlRow))
-> (CompiledRow SqlRow -> IO (RowRead SqlRow))
-> Either DecodeError (CompiledRow SqlRow)
-> IO (RowRead SqlRow)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\DecodeError
e -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO (RowRead SqlRow) -> IO (RowRead SqlRow)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO (RowRead SqlRow)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
e)
          (Int -> CompiledRow SqlRow -> IO (RowRead SqlRow)
forall a. Int -> CompiledRow a -> IO (RowRead a)
newRowRead (Connection -> Int
connValueAllocAhead (ResponseReader -> Connection
respConn ResponseReader
resp))) (RowCompiler SqlRow
sqlRowCompiler TdsContext
ctx [ColumnInfo]
cols)
        inSet returns sets cols decode []
      inSet !(Maybe Int32, [ReturnValue])
returns [ResultSet SqlRow]
sets [ColumnInfo]
cols RowRead SqlRow
decode [[SqlRow]]
batches = ResponseReader -> RowRead SqlRow -> IO (ResponseStep SqlRow)
forall r. ResponseReader -> RowRead r -> IO (ResponseStep r)
readStep ResponseReader
resp RowRead SqlRow
decode IO (ResponseStep SqlRow)
-> (ResponseStep SqlRow -> IO ProcResult) -> IO ProcResult
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 SqlRow
StepEnd -> (Maybe Int32, [ReturnValue]) -> [ResultSet SqlRow] -> IO ProcResult
forall {f :: * -> *}.
Applicative f =>
(Maybe Int32, [ReturnValue]) -> [ResultSet SqlRow] -> f ProcResult
finish (Maybe Int32, [ReturnValue])
returns ([ResultSet SqlRow]
-> [ColumnInfo] -> [[SqlRow]] -> [ResultSet SqlRow]
forall {r}. [ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
flush [ResultSet SqlRow]
sets [ColumnInfo]
cols [[SqlRow]]
batches)
        StepToken (TColMetaData [ColumnInfo]
next) -> (Maybe Int32, [ReturnValue])
-> [ResultSet SqlRow] -> [ColumnInfo] -> IO ProcResult
startSet (Maybe Int32, [ReturnValue])
returns ([ResultSet SqlRow]
-> [ColumnInfo] -> [[SqlRow]] -> [ResultSet SqlRow]
forall {r}. [ResultSet r] -> [ColumnInfo] -> [[r]] -> [ResultSet r]
flush [ResultSet SqlRow]
sets [ColumnInfo]
cols [[SqlRow]]
batches) [ColumnInfo]
next
        StepToken Token
tok -> (Maybe Int32, [ReturnValue])
-> [ResultSet SqlRow]
-> [ColumnInfo]
-> RowRead SqlRow
-> [[SqlRow]]
-> IO ProcResult
inSet ((Maybe Int32, [ReturnValue])
-> Token -> (Maybe Int32, [ReturnValue])
onToken (Maybe Int32, [ReturnValue])
returns Token
tok) [ResultSet SqlRow]
sets [ColumnInfo]
cols RowRead SqlRow
decode [[SqlRow]]
batches
        StepRows (RowBatch [SqlRow]
rows Maybe DecodeError
failed) -> case Maybe DecodeError
failed of
          Just DecodeError
err -> ResponseReader -> IO ()
drainResponse ResponseReader
resp IO () -> IO ProcResult -> IO ProcResult
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DecodeError -> IO ProcResult
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DecodeError
err
          Maybe DecodeError
Nothing -> (Maybe Int32, [ReturnValue])
-> [ResultSet SqlRow]
-> [ColumnInfo]
-> RowRead SqlRow
-> [[SqlRow]]
-> IO ProcResult
inSet (Maybe Int32, [ReturnValue])
returns [ResultSet SqlRow]
sets [ColumnInfo]
cols RowRead SqlRow
decode ([SqlRow]
rows [SqlRow] -> [[SqlRow]] -> [[SqlRow]]
forall a. a -> [a] -> [a]
: [[SqlRow]]
batches)
      onToken returns :: (Maybe Int32, [ReturnValue])
returns@(Maybe Int32
status, [ReturnValue]
outputs) = \case
        TReturnStatus Int32
value -> (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
value, [ReturnValue]
outputs)
        TReturnValue ReturnValue
value -> (Maybe Int32
status, ReturnValue
value ReturnValue -> [ReturnValue] -> [ReturnValue]
forall a. a -> [a] -> [a]
: [ReturnValue]
outputs)
        Token
_ -> (Maybe Int32, [ReturnValue])
returns
      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
      finish (Maybe Int32
status, [ReturnValue]
outputs) [ResultSet SqlRow]
sets = ProcResult -> f ProcResult
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int32 -> [ReturnValue] -> [ResultSet SqlRow] -> ProcResult
ProcResult Maybe Int32
status ([ReturnValue] -> [ReturnValue]
callerOrder [ReturnValue]
outputs) ([ResultSet SqlRow] -> [ResultSet SqlRow]
forall a. [a] -> [a]
reverse [ResultSet SqlRow]
sets))
  beforeFirst (Nothing, [])
  where
    -- RETURNVALUE tokens carry the parameter's 0-based position in the RPC
    -- parameter list (MS-TDS 2.2.7.18 ParamOrdinal), which is the position in
    -- @params@; a function's return value (status fUDF, 0x02) has ordinal 0
    -- as well, and goes first. The name isn't usable for matching: it is
    -- empty for positional parameters. sortOn is stable, so restore arrival
    -- order before sorting the accumulated outputs.
    callerOrder :: [ReturnValue] -> [ReturnValue]
callerOrder = (ReturnValue -> (Bool, Word16)) -> [ReturnValue] -> [ReturnValue]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\ReturnValue
rv -> (ReturnValue -> Precision
rvStatus ReturnValue
rv Precision -> Precision -> Precision
forall a. Bits a => a -> a -> a
.&. Precision
0x02 Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
0, ReturnValue -> Word16
rvOrdinal ReturnValue
rv)) ([ReturnValue] -> [ReturnValue])
-> ([ReturnValue] -> [ReturnValue])
-> [ReturnValue]
-> [ReturnValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ReturnValue] -> [ReturnValue]
forall a. [a] -> [a]
reverse

-- | Decode an output parameter's value ('procOutputValues') as a column
-- of its declared type would be decoded.
decodeReturnValue :: FromSqlField a => ReturnValue -> Either DecodeError a
decodeReturnValue :: forall a. FromSqlField a => ReturnValue -> Either DecodeError a
decodeReturnValue ReturnValue{Maybe ByteString
Precision
Word16
Word32
Text
TypeInfo
rvStatus :: ReturnValue -> Precision
rvOrdinal :: ReturnValue -> Word16
rvOrdinal :: Word16
rvName :: Text
rvStatus :: Precision
rvUserType :: Word32
rvFlags :: Word16
rvType :: TypeInfo
rvValue :: Maybe ByteString
rvFlags :: ReturnValue -> Word16
rvName :: ReturnValue -> Text
rvType :: ReturnValue -> TypeInfo
rvUserType :: ReturnValue -> Word32
rvValue :: ReturnValue -> Maybe ByteString
..} = do
  let col :: ColumnInfo
col = Text -> TypeInfo -> Word16 -> Word32 -> Maybe [Text] -> ColumnInfo
ColumnInfo Text
rvName TypeInfo
rvType Word16
rvFlags Word32
rvUserType Maybe [Text]
forall a. Maybe a
Nothing
  decode <- (String -> Either DecodeError (CellDecoder a))
-> (CellDecoder a -> Either DecodeError (CellDecoder a))
-> Either String (CellDecoder a)
-> Either DecodeError (CellDecoder a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodeError -> Either DecodeError (CellDecoder a)
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError (CellDecoder a))
-> (String -> DecodeError)
-> String
-> Either DecodeError (CellDecoder a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> String -> DecodeError
DecodeError (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rvName)) CellDecoder a -> Either DecodeError (CellDecoder a)
forall a b. b -> Either a b
Right (FieldDecoder a
-> TdsContext -> ColumnInfo -> Either String (CellDecoder a)
forall a.
FieldDecoder a
-> TdsContext -> ColumnInfo -> Either String (CellDecoder a)
compileField FieldDecoder a
forall a. FromSqlField a => FieldDecoder a
fieldDecoder TdsContext
defaultTdsContext ColumnInfo
col)
  either (Left . DecodeError (Just rvName)) Right (decodeCell decode rvValue)