{-# LANGUAGE MagicHash #-}
-- | Bulk copy: many rows into one table in one request, by the protocol's
-- bulk load (what @bcp@ and .NET's @SqlBulkCopy@ use).  The rows go to the
-- server as a stream of binary values, each in its column's own wire type,
-- with no statement to compile and no parameters to bind, so it is the
-- fastest way to load a table.
--
-- > n <- bulkInsert conn "dbo.item" [(1 :: Int32, "one" :: Text, 9.99 :: Decimal), (2, "two", 0.5)]
--
-- 'bulkInsert' takes any 'ToSqlRow' value per row, asks the server for
-- the table's columns, converts each value to its column's type on the
-- client, and returns the number of rows the server inserted.
-- 'bulkInsertWith' adds the settings ('BulkCopy': which columns, the
-- server's options, batching); 'bulkInsertS' and 'bulkInsertSWith' take
-- the rows from a 'Stream', with defaults or explicit settings.  The rows of a list are streamed too, a packet at a time.
--
-- __Rows.__  A positional row supplies one value per selected column, in
-- the columns' order: under 'InsertableColumns' the table's insertable
-- columns in table order, so a derived 'ToSqlRow' record must follow the
-- table, where an @INSERT@ would name its columns; under 'NamedColumns' the
-- columns named, in that order.  A row with another number of values is an
-- 'EncodeError' naming the row.  A row of 'Hmssql.Encoding.NamedParams'
-- goes to the columns of its names instead, in any order, and must still
-- name every selected column: the one leading @\@@ a name may carry is
-- dropped, so @a@ and @\@a@ both name the column @a@, and @\@\@a@ names a
-- column called @\@a@.
--
-- > data NewItem = NewItem { itemId :: Int, itemName :: Text, itemPrice :: Decimal }
-- >   deriving stock (Generic)
-- >   deriving anyclass (ToSqlRow)
-- >
-- > n <- bulkInsertWith (bulkCopy "dbo.item") { bulkColumns = NamedColumns ["id", "name", "price"] } conn items
--
-- __What the server does with the rows.__  A bulk load skips the checks an
-- @INSERT@ makes unless asked for them: check constraints and foreign
-- keys are not checked ('bulkCheckConstraints'), insert triggers don't
-- fire ('bulkFireTriggers'), and a NULL for a column with a default gets
-- the default ('bulkKeepNulls').  Identity columns are generated by the
-- server unless explicitly selected (for example with 'bulkKeepIdentity').
-- Automatic discovery excludes computed, @rowversion@ and generated-always
-- columns. A failing batch may be rolled
-- back, while earlier batches remain committed; a trigger's @RAISERROR@
-- can report an error without rolling back its rows. Use
-- 'Hmssql.Transaction.withTransaction' for all-or-nothing loading.
--
-- __Types.__  Each value is converted to its column's type as its
-- 'Hmssql.Encoding.ToSqlField' instance sends it ('encodeBulkCell' has the rules).  A value
-- a column can't take (a 'Text' for an @int@ column, a string longer
-- than the column, a character its code page lacks) is an 'EncodeError'
-- naming the row and column, thrown before the row is sent, where a
-- plain @INSERT@ can truncate or transcode it silently.  A 'Double'
-- copied into a @decimal@ or @money@ column is rounded on the client
-- from its exact binary value, half away from zero, as the server rounds
-- it in a parameterized @INSERT@.
--
-- __Permissions.__  An @INSERT@ needs INSERT on the table.  A bulk load
-- also needs SELECT for the column discovery of 'InsertableColumns' and
-- 'NamedColumns' (a @SELECT TOP 0@; 'DescribedColumns' makes no such
-- request), ALTER TABLE when the table has a check constraint or a trigger
-- and 'bulkCheckConstraints' or 'bulkFireTriggers' is off (the server
-- refuses the load with error 5304; with both on, INSERT suffices), and
-- ALTER TABLE for 'bulkKeepIdentity'.  Measured on SQL Server 2025.
--
-- __When an @INSERT@ is the better tool.__  Bulk copy fills a table; for
-- an application's ordinary inserts, 'Hmssql.Query.execute' or
-- 'Hmssql.Query.executeMany' is usually right.  A bulk load has no
-- @OUTPUT@ clause, so generated keys must be queried back; it checks and
-- fires nothing unless asked, and then needs the permissions above; it is
-- one table and whole rows, with no @INSERT ... SELECT@, @MERGE@ or
-- expression; the server answers once per batch, so an error in the first
-- row surfaces after the whole batch is sent; it converts only within a
-- type family where an @INSERT@ converts a string to a number; and a load
-- holds its locks to the end of its transaction.  For a handful of rows,
-- 'Hmssql.Query.executeMany' is nearly as fast and is one round trip where
-- a load with column discovery is two.
--
-- __On a MARS connection__ ('Hmssql.Connection.connectMars') a load works
-- but is a poor neighbor: with a result set open on the connection it
-- fails with error 595 unless @SET XACT_ABORT ON@ is in effect, inside a
-- transaction any other request on the target table fails it with error
-- 3970, and beside busy streams it runs several times slower.  Large
-- loads belong on a connection of their own.
module Hmssql.BulkCopy
  ( -- * Inserting rows
    bulkInsert
  , bulkInsertWith
  , bulkInsertS
  , bulkInsertSWith

    -- * Settings
  , BulkCopy (..)
  , bulkCopy
  , BulkColumns (..)
  , BulkOrder (..)

    -- * The columns
  , BulkColumn (..)
  , describeBulkColumns

    -- * Low level
  , insertBulkStatement
  , bulkLoadPackets
  , encodeBulkCell
  , bulkWireType
  ) where

import Control.Exception (mask, throwIO)
import Control.Monad (forM, forM_, guard, unless, when)
import qualified Data.Binary.Put as Put
import Data.Bits ((.&.), (.|.), shiftR)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Internal as BI
import Data.Char (toLower)
import Data.Decimal (Decimal, DecimalRaw (..))
import Data.Fixed (Fixed (..))
import Data.Int (Int16, Int32, Int64)
import Data.IORef
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time
import Data.Word (Word16, Word64, Word8)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (plusPtr)
import Foreign.Storable (pokeByteOff)
import GHC.Float (double2Float, float2Double, castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble)
import Streaming (Of, Stream)
import qualified Streaming.Prelude as S
import System.IO.Unsafe (unsafePerformIO)

import Hmssql.Connection.Internal (Connection, sourceAction, connectionContext, readingToEnd, startStreamingRequest, withReservedSession)
import Hmssql.Internal.Derived
import Hmssql.SqlValue (SqlValue (..))
import Hmssql.Encoding (EncodedParam, ParamValue (..), Source (..), RowEncoder (..), ToSqlRow (..))
import Hmssql.Tds.Parameter (paramValueProblem, streamed, writeParamValueWith)
import Hmssql.Errors
import Hmssql.Query (ResultSet (..), affectedRows, execute, queryResultSets, rawSql, responseReader, resultSetMWith)
import Hmssql.Tds.Bytes
import Hmssql.Tds.CodePage (collationCodePage, collationTextDecoder, collationTextEncoder)
import Hmssql.Tds.Context
import Hmssql.Tds.Packet (PacketType (..))
import Hmssql.Tds.PacketWriter (PacketWriter, runPacketWriter, unsafeWriteSized, writeBuilder, writeBytes)
import Hmssql.Tds.Primitives
import Hmssql.Tds.Token (ColumnInfo (..))
import Hmssql.Tds.TypeInfo
import Hmssql.Tds.Utf16 (encodeUtf16LE)

------------------------------------------------------------------------------
-- Settings

-- | How a bulk copy is done: the table, which of its columns, the
-- server's bulk load options, and batching.  'bulkCopy' has the defaults
-- for a table.
data BulkCopy = BulkCopy
  { BulkCopy -> Text
bulkTable :: !Text
    -- ^ The table (or view) as SQL names it: @dbo.item@, @[my schema].[t]@,
    -- @#temp@, @db.dbo.t@.  Spliced into the statements as given, so
    -- quote it ('Hmssql.Query.escapeIdentifier' style) if it comes from data.
  , BulkCopy -> BulkColumns
bulkColumns :: !BulkColumns
    -- ^ Which columns the rows hold, and in what order.
  , BulkCopy -> Bool
bulkKeepIdentity :: !Bool
    -- ^ With 'InsertableColumns': send the identity column, with the rows'
    -- values, instead of letting the server generate it.  (A column named
    -- in 'NamedColumns' or given in 'DescribedColumns' is sent as it is.)
    -- The load then needs ALTER TABLE permission on the table.
  , BulkCopy -> Bool
bulkKeepNulls :: !Bool
    -- ^ @KEEP_NULLS@: insert a NULL as NULL where the column has a
    -- default; without it, the default is inserted instead.
  , BulkCopy -> Bool
bulkCheckConstraints :: !Bool
    -- ^ @CHECK_CONSTRAINTS@: check the table's check and foreign key
    -- constraints.  A bulk load skips them by default and leaves them
    -- marked as not trusted (@is_not_trusted@ in @sys.check_constraints@
    -- and @sys.foreign_keys@), which keeps the optimizer from relying on
    -- them until @ALTER TABLE ... WITH CHECK CHECK CONSTRAINT@ re-checks
    -- them; a load with this option keeps the trust.  Without this option
    -- and 'bulkFireTriggers' both, a table that has a check constraint or
    -- a trigger needs ALTER TABLE permission (error 5304).
  , BulkCopy -> Bool
bulkFireTriggers :: !Bool
    -- ^ @FIRE_TRIGGERS@: run the table's insert triggers.
  , BulkCopy -> Bool
bulkTableLock :: !Bool
    -- ^ @TABLOCK@: lock the whole table for the load, which allows
    -- minimal logging and is faster for a large load into a table nobody
    -- else is using.
  , BulkCopy -> [BulkOrder]
bulkOrder :: ![BulkOrder]
    -- ^ @ORDER(...)@: the rows are sorted by these columns, as the
    -- clustered index is; the server then needn't sort them.  Each batch
    -- must be in that order: a table with a clustered index refuses an
    -- out-of-order batch (error 4819, with or without 'bulkTableLock'),
    -- and a heap ignores the hint.
  , BulkCopy -> Maybe Int
bulkRowsPerBatch :: !(Maybe Int)
    -- ^ @ROWS_PER_BATCH@: about how many rows the load has, for the
    -- query optimizer.
  , BulkCopy -> Maybe Int
bulkKilobytesPerBatch :: !(Maybe Int)
    -- ^ @KILOBYTES_PER_BATCH@: about how much data, likewise.
  , BulkCopy -> Maybe Int
bulkBatchSize :: !(Maybe Int)
    -- ^ Send the rows in batches of this many, each a bulk load of its
    -- own (its own @INSERT BULK@ and round trip), committed on its own
    -- outside a transaction: a failure then loses only its batch's rows,
    -- and the server's memory for the load is bounded.  'Nothing' (the
    -- default): every row in one batch, as one request.
  }

instance Show BulkCopy where
  showsPrec :: Int -> BulkCopy -> ShowS
showsPrec Int
p (BulkCopy Text
a BulkColumns
b Bool
c Bool
e Bool
f Bool
g Bool
h [BulkOrder]
i Maybe Int
j Maybe Int
k Maybe Int
l) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"BulkCopy"#
    [ Addr#
"bulkTable"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
a, Addr#
"bulkColumns"# Addr# -> BulkColumns -> Field
forall a. Show a => Addr# -> a -> Field
:= BulkColumns
b, Addr#
"bulkKeepIdentity"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
c, Addr#
"bulkKeepNulls"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
e
    , Addr#
"bulkCheckConstraints"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
f, Addr#
"bulkFireTriggers"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
g, Addr#
"bulkTableLock"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
h
    , Addr#
"bulkOrder"# Addr# -> [BulkOrder] -> Field
forall a. Show a => Addr# -> a -> Field
:= [BulkOrder]
i, Addr#
"bulkRowsPerBatch"# Addr# -> Maybe Int -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe Int
j, Addr#
"bulkKilobytesPerBatch"# Addr# -> Maybe Int -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe Int
k
    , Addr#
"bulkBatchSize"# Addr# -> Maybe Int -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe Int
l
    ]
  {-# OPAQUE showsPrec #-}

-- | A column of the @ORDER@ hint.
data BulkOrder
  = Ascending !Text
  | Descending !Text

instance Show BulkOrder where
  showsPrec :: Int -> BulkOrder -> ShowS
showsPrec Int
p = \case
    Ascending Text
a -> Int -> Addr# -> Text -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"Ascending"# Text
a
    Descending Text
a -> Int -> Addr# -> Text -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"Descending"# Text
a
  {-# OPAQUE showsPrec #-}

instance Eq BulkOrder where
  BulkOrder
x == :: BulkOrder -> BulkOrder -> Bool
== BulkOrder
y = case (BulkOrder
x, BulkOrder
y) of
    (Ascending Text
a, Ascending Text
a') -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
a Text
a'
    (Descending Text
a, Descending Text
a') -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
a Text
a'
    (BulkOrder, BulkOrder)
_ -> Bool
False
  {-# OPAQUE (==) #-}

-- | The defaults for a table: every insertable column, no options, one
-- batch.
bulkCopy :: Text -> BulkCopy
bulkCopy :: Text -> BulkCopy
bulkCopy Text
table = BulkCopy
  { bulkTable :: Text
bulkTable = Text
table
  , bulkColumns :: BulkColumns
bulkColumns = BulkColumns
InsertableColumns
  , bulkKeepIdentity :: Bool
bulkKeepIdentity = Bool
False
  , bulkKeepNulls :: Bool
bulkKeepNulls = Bool
False
  , bulkCheckConstraints :: Bool
bulkCheckConstraints = Bool
False
  , bulkFireTriggers :: Bool
bulkFireTriggers = Bool
False
  , bulkTableLock :: Bool
bulkTableLock = Bool
False
  , bulkOrder :: [BulkOrder]
bulkOrder = []
  , bulkRowsPerBatch :: Maybe Int
bulkRowsPerBatch = Maybe Int
forall a. Maybe a
Nothing
  , bulkKilobytesPerBatch :: Maybe Int
bulkKilobytesPerBatch = Maybe Int
forall a. Maybe a
Nothing
  , bulkBatchSize :: Maybe Int
bulkBatchSize = Maybe Int
forall a. Maybe a
Nothing
  }

-- | Which columns the rows hold.
data BulkColumns
  = InsertableColumns
    -- ^ Every column of the table a plain @INSERT@ without a column list
    -- would take, in table order: all but the identity column (unless
    -- 'bulkKeepIdentity'), computed columns, @rowversion@ and the columns
    -- the server generates.  Asked of the server before the load, with a
    -- @SELECT TOP 0@ that needs SELECT permission on the table.
  | NamedColumns ![Text]
    -- ^ These columns, in this order; the rest get their defaults.  Asked
    -- of the server before the load (their types), so a name that isn't
    -- a column is a 'SqlServerError'.
  | DescribedColumns ![BulkColumn]
    -- ^ These columns, as described: no request to the server before the
    -- load.  For a table loaded many times ('describeBulkColumns' gives
    -- the description once), for a login without SELECT on the table, or
    -- to declare the types the rows are sent in yourself: the server
    -- converts what arrives to the column's type (as an @INSERT@ would,
    -- for a type it converts implicitly), so a @varchar@ column can be
    -- loaded as @nvarchar@, say.
    --
    -- > cols <- describeBulkColumns conn (bulkCopy "dbo.item")
    -- > let settings = (bulkCopy "dbo.item") { bulkColumns = DescribedColumns cols }
    -- > forM_ batches $ \rows -> bulkInsertWith settings conn rows

instance Show BulkColumns where
  showsPrec :: Int -> BulkColumns -> ShowS
showsPrec Int
p = \case
    BulkColumns
InsertableColumns -> String -> ShowS
showString String
"InsertableColumns"
    NamedColumns [Text]
a -> Int -> Addr# -> [Text] -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"NamedColumns"# [Text]
a
    DescribedColumns [BulkColumn]
a -> Int -> Addr# -> [BulkColumn] -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"DescribedColumns"# [BulkColumn]
a
  {-# OPAQUE showsPrec #-}

-- | A column as the bulk load declares it: its name, the wire type the
-- values are sent in (a length, precision and scale, or collation
-- included; 'Hmssql.SqlType.sqlTypeTypeInfo' gives the type of a
-- declaration such as @varchar(20)@), whether a NULL may be sent, and
-- whether it is the table's identity column.
data BulkColumn = BulkColumn
  { BulkColumn -> Text
bulkColumnName :: !Text
  , BulkColumn -> TypeInfo
bulkColumnType :: !TypeInfo
  , BulkColumn -> Bool
bulkColumnNullable :: !Bool
  , BulkColumn -> Bool
bulkColumnIdentity :: !Bool
  }

instance Show BulkColumn where
  showsPrec :: Int -> BulkColumn -> ShowS
showsPrec Int
p (BulkColumn Text
a TypeInfo
b Bool
c Bool
e) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"BulkColumn"#
    [ Addr#
"bulkColumnName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
a, Addr#
"bulkColumnType"# Addr# -> TypeInfo -> Field
forall a. Show a => Addr# -> a -> Field
:= TypeInfo
b, Addr#
"bulkColumnNullable"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
c
    , Addr#
"bulkColumnIdentity"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
e
    ]
  {-# OPAQUE showsPrec #-}

instance Eq BulkColumn where
  BulkColumn Text
a TypeInfo
b Bool
c Bool
e == :: BulkColumn -> BulkColumn -> Bool
== BulkColumn Text
a' TypeInfo
b' Bool
c' Bool
e' = Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
a Text
a' Bool -> Bool -> Bool
&& TypeInfo -> TypeInfo -> Bool
forall a. Eq a => a -> a -> Bool
eq TypeInfo
b TypeInfo
b' Bool -> Bool -> Bool
&& Bool
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
c' Bool -> Bool -> Bool
&& Bool
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
e'
  {-# OPAQUE (==) #-}

------------------------------------------------------------------------------
-- Inserting rows

-- | Insert the rows into the table, one value per insertable column
-- ('InsertableColumns'), and return how many rows the server inserted.
-- @'bulkInsertWith' ('bulkCopy' table)@.
--
-- > bulkInsert conn "dbo.item" [(1 :: Int32, "one" :: Text), (2, "two")]
bulkInsert :: ToSqlRow r => Connection -> Text -> [r] -> IO Int64
bulkInsert :: forall r. ToSqlRow r => Connection -> Text -> [r] -> IO Int64
bulkInsert Connection
conn Text
table = BulkCopy -> Connection -> [r] -> IO Int64
forall r. ToSqlRow r => BulkCopy -> Connection -> [r] -> IO Int64
bulkInsertWith (Text -> BulkCopy
bulkCopy Text
table) Connection
conn
-- Out of line: inlined, each use built its own 'BulkCopy' of the defaults, and a
-- function calling 'bulkInsert' was 527 bytes of object code instead of 327.
{-# NOINLINE bulkInsert #-}

-- | 'bulkInsert' with the settings.
--
-- > bulkInsertWith (bulkCopy "dbo.item") { bulkColumns = NamedColumns ["id", "name"], bulkTableLock = True } conn rows
bulkInsertWith :: ToSqlRow r => BulkCopy -> Connection -> [r] -> IO Int64
bulkInsertWith :: forall r. ToSqlRow r => BulkCopy -> Connection -> [r] -> IO Int64
bulkInsertWith BulkCopy
bc Connection
conn [r]
rows = BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
forall r.
ToSqlRow r =>
BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
bulkInsertSWith BulkCopy
bc Connection
conn ([r] -> Stream (Of r) IO ()
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f a -> Stream (Of a) m ()
S.each [r]
rows)
{-# NOINLINE bulkInsertWith #-}

-- | 'bulkInsert' with rows from a stream and the default settings.
-- Use 'bulkInsertSWith' to choose columns, batching or other options.
-- The streaming and interruption rules of 'bulkInsertSWith' apply.
--
-- > bulkInsertS conn "dbo.item" rows
bulkInsertS :: ToSqlRow r => Connection -> Text -> Stream (Of r) IO () -> IO Int64
bulkInsertS :: forall r.
ToSqlRow r =>
Connection -> Text -> Stream (Of r) IO () -> IO Int64
bulkInsertS Connection
conn Text
table = BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
forall r.
ToSqlRow r =>
BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
bulkInsertSWith (Text -> BulkCopy
bulkCopy Text
table) Connection
conn
{-# NOINLINE bulkInsertS #-}

-- | 'bulkInsertWith' with the rows from a stream, read as they are sent:
-- a packet's worth at a time, so a stream of any length needs no more
-- memory than that.
--
-- The stream runs while the request is being sent, with the connection
-- locked: it must not use this connection (stream the rows from another
-- one; on a MARS connection it may read a stream opened on this one
-- before the load began, but not start a request).  If it throws, the
-- load is canceled and the exception is rethrown. Earlier batches stay
-- committed. Cancellation normally leaves the connection usable, but the
-- server can close it for an incomplete large bulk message. A row whose
-- values can't be converted throws 'EncodeError' the same way, naming
-- the row (from 0) and the column.  An asynchronous exception (a
-- 'System.Timeout.timeout' expiring) while the rows are being sent
-- breaks the connection instead, as an interrupted send does for any
-- request.
--
-- With 'bulkBatchSize', each batch is sent and its response read before
-- the next batch's rows are pulled from the stream.  An empty stream
-- sends nothing and returns 0.
--
-- The usual source is a query on another connection, which copies a
-- table of any size a packet at a time:
--
-- > src <- queryS source "SELECT id, name, price FROM dbo.item WHERE price > 1"
-- > n <- bulkInsertS target "dbo.expensive_item" (src :: Stream (Of (Int, Text, Decimal)) IO ())
bulkInsertSWith :: forall r. ToSqlRow r => BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
bulkInsertSWith :: forall r.
ToSqlRow r =>
BulkCopy -> Connection -> Stream (Of r) IO () -> IO Int64
bulkInsertSWith BulkCopy
bc Connection
conn Stream (Of r) IO ()
rows0 = Connection -> IO Int64 -> IO Int64
forall a. Connection -> IO a -> IO a
withReservedSession Connection
conn (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ do
  batchSize <- case BulkCopy -> Maybe Int
bulkBatchSize BulkCopy
bc of
    Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 -> EncodeError -> IO (Maybe Int)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO (Maybe Int)) -> EncodeError -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ String -> EncodeError
EncodeError (String -> EncodeError) -> String -> EncodeError
forall a b. (a -> b) -> a -> b
$ String
"bulk copy: bulkBatchSize " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (at least 1, or Nothing)"
    Maybe Int
b -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
b
  cols <- describeBulkColumns conn bc
  when (null cols) $ throwIO $ EncodeError $ "bulk copy: " ++ T.unpack (bulkTable bc) ++ " has no column to insert"
  ctx <- connectionContext conn
  let convert = TdsContext -> [BulkColumn] -> r -> Either String [ParamValue]
forall r.
ToSqlRow r =>
TdsContext -> [BulkColumn] -> r -> Either String [ParamValue]
compileRow TdsContext
ctx [BulkColumn]
cols :: r -> Either String [ParamValue]
      -- Out of line, so that the message is built only when a row fails.
      -- Inlined at its two uses, GHC shared the @show i@ between them as a
      -- thunk allocated on every row's success path: 23,976 bytes per load of
      -- 1,000 rows (GHC 9.12.4, 2026-11-04).
      {-# NOINLINE rowProblem #-}
      rowProblem a
i String
msg = String -> EncodeError
EncodeError (String -> EncodeError) -> String -> EncodeError
forall a b. (a -> b) -> a -> b
$ String
"bulk copy: row " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (from 0), " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

      -- One batch: the first row (converted already), then the rest of
      -- the stream, or as many of it as the batch takes; the count, the
      -- index of the next row, and the stream after the batch.
      loadBatch :: Int -> [ParamValue] -> Stream (Of r) IO x -> IO (Int64, Int, x)
      loadBatch Int
i0 [ParamValue]
firstCells Stream (Of r) IO x
s0 = do
        -- The first row decides the layout.  @nchar@, @nvarchar@, @binary@ and
        -- @varbinary@ aren't PLP on the wire, so a stream in the first row makes
        -- its column @(max)@ for this batch; 'checkStreams' refuses a stream in a
        -- later row of a column that didn't.  A stream can't be measured ahead, so
        -- an over-long value is left to the server.  With ANSI_WARNINGS ON it
        -- refuses the load (error 2628); with it OFF it truncates, as an INSERT does.
        let layout :: [TypeInfo]
layout = (BulkColumn -> ParamValue -> TypeInfo)
-> [BulkColumn] -> [ParamValue] -> [TypeInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\BulkColumn
col ParamValue
value -> (if ParamValue -> Bool
streamed ParamValue
value then TypeInfo -> TypeInfo
promote else TypeInfo -> TypeInfo
forall a. a -> a
id) (TypeInfo -> TypeInfo
bulkWireType (BulkColumn -> TypeInfo
bulkColumnType BulkColumn
col))) [BulkColumn]
cols [ParamValue]
firstCells
            wireCols :: [BulkColumn]
wireCols = (BulkColumn -> TypeInfo -> BulkColumn)
-> [BulkColumn] -> [TypeInfo] -> [BulkColumn]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\BulkColumn
col TypeInfo
ti -> BulkColumn
col { bulkColumnType = ti }) [BulkColumn]
cols [TypeInfo]
layout
            stmt :: Text
stmt = BulkCopy -> [BulkColumn] -> Text
insertBulkStatement BulkCopy
bc [BulkColumn]
wireCols
            meta :: ByteString
meta = Text -> [BulkColumn] -> ByteString
colMetaData (BulkCopy -> Text
bulkTable BulkCopy
bc) [BulkColumn]
wireCols
            checkStreams :: a -> [ParamValue] -> IO ()
checkStreams a
i [ParamValue]
values = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((ParamValue -> Bool) -> [ParamValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ParamValue -> Bool
streamed [ParamValue]
values) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(BulkColumn, TypeInfo, ParamValue)]
-> ((BulkColumn, TypeInfo, ParamValue) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([BulkColumn]
-> [TypeInfo]
-> [ParamValue]
-> [(BulkColumn, TypeInfo, ParamValue)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [BulkColumn]
cols [TypeInfo]
layout [ParamValue]
values) (((BulkColumn, TypeInfo, ParamValue) -> IO ()) -> IO ())
-> ((BulkColumn, TypeInfo, ParamValue) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(BulkColumn
col, TypeInfo
ti, ParamValue
value) ->
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ParamValue -> Bool
streamed ParamValue
value Bool -> Bool -> Bool
&& Bool -> Bool
not (TypeInfo -> Bool
isPlp TypeInfo
ti)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncodeError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (a -> String -> EncodeError
forall {a}. Show a => a -> String -> EncodeError
rowProblem a
i (String
"column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (BulkColumn -> Text
bulkColumnName BulkColumn
col) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": the first row did not select a streaming wire type"))
        _ <- Connection -> Query -> IO Int64
execute Connection
conn (Text -> Query
rawSql Text
stmt)
        after <- newIORef Nothing
        -- Masked from the send to the guard on the response (the producer
        -- runs masked anyway, 'startStreamingRequest').
        n <- mask $ \forall a. IO a -> IO a
restore -> do
          ar <- Connection
-> Maybe Text
-> PacketType
-> (PacketWriter -> IO ())
-> IO ActiveResponse
startStreamingRequest Connection
conn (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stmt) PacketType
PTBulkLoad ((PacketWriter -> IO ()) -> IO ActiveResponse)
-> (PacketWriter -> IO ()) -> IO ActiveResponse
forall a b. (a -> b) -> a -> b
$ \PacketWriter
out -> do
            PacketWriter -> ByteString -> IO ()
writeBytes PacketWriter
out ByteString
meta
            PacketWriter -> [TypeInfo] -> [ParamValue] -> IO ()
writeRow PacketWriter
out [TypeInfo]
layout [ParamValue]
firstCells
            -- One guard around the whole batch: pulling a row may run the caller's
            -- stream, which must not start a request on this connection.  Taking
            -- it per row would cost a mask and a bracket per row, inside a send
            -- that is already masked.
            let loop :: Int -> Stream (Of r) IO x -> IO ()
loop !Int
i Stream (Of r) IO x
s = Stream (Of r) IO x -> IO (Either x (r, Stream (Of r) IO x))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Either r (a, Stream (Of a) m r))
S.next Stream (Of r) IO x
s IO (Either x (r, Stream (Of r) IO x))
-> (Either x (r, Stream (Of r) IO x) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left x
x -> IORef (Maybe (Int, x)) -> Maybe (Int, x) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, x))
after ((Int, x) -> Maybe (Int, x)
forall a. a -> Maybe a
Just (Int
i, x
x))
                  Right (r
row, Stream (Of r) IO x
s') -> do
                    cells <- (String -> IO [ParamValue])
-> ([ParamValue] -> IO [ParamValue])
-> Either String [ParamValue]
-> IO [ParamValue]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EncodeError -> IO [ParamValue]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO [ParamValue])
-> (String -> EncodeError) -> String -> IO [ParamValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> EncodeError
forall {a}. Show a => a -> String -> EncodeError
rowProblem Int
i) [ParamValue] -> IO [ParamValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> Either String [ParamValue]
convert r
row)
                    checkStreams i cells
                    writeRow out layout cells
                    loop (i + 1) s'
            Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
sourceAction Connection
conn (Int -> Stream (Of r) IO x -> IO ()
loop (Int
i0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Stream (Of r) IO x
s0)
            PacketWriter -> ByteString -> IO ()
writeBytes PacketWriter
out ByteString
doneToken
          readingToEnd conn ar (restore (responseReader conn ar (Just stmt) >>= affectedRows))
        readIORef after >>= \case
          Just (Int
i, x
x) -> (Int64, Int, x) -> IO (Int64, Int, x)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64
n, Int
i, x
x)
          Maybe (Int, x)
Nothing -> ProtocolError -> IO (Int64, Int, x)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ProtocolError -> IO (Int64, Int, x))
-> ProtocolError -> IO (Int64, Int, x)
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"bulk copy: the rows were not all sent"  -- can't happen: the producer completed

      go !Int64
total !Int
i Stream (Of r) IO ()
s = Connection
-> IO (Either () (r, Stream (Of r) IO ()))
-> IO (Either () (r, Stream (Of r) IO ()))
forall a. Connection -> IO a -> IO a
sourceAction Connection
conn (Stream (Of r) IO () -> IO (Either () (r, Stream (Of r) IO ()))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Either r (a, Stream (Of a) m r))
S.next Stream (Of r) IO ()
s) IO (Either () (r, Stream (Of r) IO ()))
-> (Either () (r, Stream (Of r) IO ()) -> 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
        Left () -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
total
        Right (r
first, Stream (Of r) IO ()
rest) -> do
          cells <- (String -> IO [ParamValue])
-> ([ParamValue] -> IO [ParamValue])
-> Either String [ParamValue]
-> IO [ParamValue]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EncodeError -> IO [ParamValue]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (EncodeError -> IO [ParamValue])
-> (String -> EncodeError) -> String -> IO [ParamValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> EncodeError
forall {a}. Show a => a -> String -> EncodeError
rowProblem Int
i) [ParamValue] -> IO [ParamValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> Either String [ParamValue]
convert r
first)
          case batchSize of
            Maybe Int
Nothing -> do
              (n, _, ()) <- Int -> [ParamValue] -> Stream (Of r) IO () -> IO (Int64, Int, ())
forall x.
Int -> [ParamValue] -> Stream (Of r) IO x -> IO (Int64, Int, x)
loadBatch Int
i [ParamValue]
cells Stream (Of r) IO ()
rest
              pure (total + n)
            Just Int
k -> do
              (n, i', rest') <- Int
-> [ParamValue]
-> Stream (Of r) IO (Stream (Of r) IO ())
-> IO (Int64, Int, Stream (Of r) IO ())
forall x.
Int -> [ParamValue] -> Stream (Of r) IO x -> IO (Int64, Int, x)
loadBatch Int
i [ParamValue]
cells (Int
-> Stream (Of r) IO () -> Stream (Of r) IO (Stream (Of r) IO ())
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
Int -> Stream f m r -> Stream f m (Stream f m r)
S.splitAt (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Stream (Of r) IO ()
rest)
              go (total + n) i' rest'
  go 0 (0 :: Int) rows0
  where
    promote :: TypeInfo -> TypeInfo
promote (TINChar Word16
_ Collation
c) = Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
c
    promote (TINVarChar Word16
_ Collation
c) = Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength Collation
c
    promote (TIBigBinary Word16
_) = Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength
    promote (TIBigVarBinary Word16
_) = Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength
    promote TypeInfo
ti = TypeInfo
ti
    isPlp :: TypeInfo -> Bool
isPlp TypeInfo
ti = case TypeInfo -> LengthKind
lengthKind TypeInfo
ti of LengthKind
Plp -> Bool
True; LengthKind
_ -> Bool
False

------------------------------------------------------------------------------
-- The columns

-- | The columns the rows of a bulk copy hold ('bulkColumns'): as given for
-- 'DescribedColumns'; for the others, asked of the server (@SELECT TOP 0
-- ... FROM@ the table, one round trip).  Each column keeps its real type
-- (a @varchar(50)@ column is a @'TIBigVarChar' 50@, with its collation),
-- which is what 'encodeBulkCell' validates a value against; the load sends
-- it in a wire type ('bulkWireType') the server transcodes from.  Throws
-- 'SqlServerError' for a table or column that doesn't exist.
describeBulkColumns :: Connection -> BulkCopy -> IO [BulkColumn]
describeBulkColumns :: Connection -> BulkCopy -> IO [BulkColumn]
describeBulkColumns Connection
conn BulkCopy
bc = case BulkCopy -> BulkColumns
bulkColumns BulkCopy
bc of
  DescribedColumns [BulkColumn]
cols -> [BulkColumn] -> IO [BulkColumn]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BulkColumn]
cols
  NamedColumns [Text]
names ->
    ((ColumnInfo, Word16) -> BulkColumn)
-> [(ColumnInfo, Word16)] -> [BulkColumn]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnInfo, Word16) -> BulkColumn
forall {a}. (Bits a, Num a) => (ColumnInfo, a) -> BulkColumn
fromColumnInfo ([(ColumnInfo, Word16)] -> [BulkColumn])
-> IO [(ColumnInfo, Word16)] -> IO [BulkColumn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO [(ColumnInfo, Word16)]
columnsOf (Text
"SELECT TOP 0 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteName [Text]
names) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BulkCopy -> Text
bulkTable BulkCopy
bc)
  BulkColumns
InsertableColumns ->
    ((ColumnInfo, Word16) -> BulkColumn)
-> [(ColumnInfo, Word16)] -> [BulkColumn]
forall a b. (a -> b) -> [a] -> [b]
map (ColumnInfo, Word16) -> BulkColumn
forall {a}. (Bits a, Num a) => (ColumnInfo, a) -> BulkColumn
fromColumnInfo ([(ColumnInfo, Word16)] -> [BulkColumn])
-> ([(ColumnInfo, Word16)] -> [(ColumnInfo, Word16)])
-> [(ColumnInfo, Word16)]
-> [BulkColumn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ColumnInfo, Word16) -> Bool)
-> [(ColumnInfo, Word16)] -> [(ColumnInfo, Word16)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ColumnInfo, Word16) -> Bool
forall {b} {a}. (Bits b, Num b) => (a, b) -> Bool
insertable ([(ColumnInfo, Word16)] -> [BulkColumn])
-> IO [(ColumnInfo, Word16)] -> IO [BulkColumn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO [(ColumnInfo, Word16)]
columnsOf (Text
"SELECT TOP 0 * FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BulkCopy -> Text
bulkTable BulkCopy
bc)
  where
    columnsOf :: Text -> IO [(ColumnInfo, Word16)]
columnsOf Text
sql = do
      cols <- ResultSet () -> [ColumnInfo]
forall r. ResultSet r -> [ColumnInfo]
resultColumns (ResultSet () -> [ColumnInfo])
-> IO (ResultSet ()) -> IO [ColumnInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResultSets (ResultSet ())
-> Connection -> Query -> IO (ResultSet ())
forall a. ResultSets a -> Connection -> Query -> IO a
queryResultSets (RowDecoderMonadic () -> ResultSets (ResultSet ())
forall r. RowDecoderMonadic r -> ResultSets (ResultSet r)
resultSetMWith (() -> RowDecoderMonadic ()
forall a. a -> RowDecoderMonadic a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) Connection
conn (Text -> Query
rawSql Text
sql)
      pure [(c, columnFlags c) | c <- cols]
    -- COLMETADATA flags (MS-TDS 2.2.7.4): fNullable 0x0001, usUpdateable
    -- 0x000C (0 read-only, 4 read/write, 8 unknown), fIdentity 0x0010,
    -- fComputed 0x0020.  A computed, @rowversion@ or generated column is
    -- read-only and never sent; the identity column is read-only too but
    -- is sent when 'bulkKeepIdentity'.
    insertable :: (a, b) -> Bool
insertable (a
_, b
flags) = Bool -> Bool
not Bool
computed Bool -> Bool -> Bool
&& (if Bool
identity then BulkCopy -> Bool
bulkKeepIdentity BulkCopy
bc else Bool -> Bool
not Bool
readonly)
      where
        computed :: Bool
computed = b
flags b -> b -> b
forall a. Bits a => a -> a -> a
.&. b
0x0020 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
0
        identity :: Bool
identity = b
flags b -> b -> b
forall a. Bits a => a -> a -> a
.&. b
0x0010 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
0
        readonly :: Bool
readonly = b
flags b -> b -> b
forall a. Bits a => a -> a -> a
.&. b
0x000C b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
0
    fromColumnInfo :: (ColumnInfo, a) -> BulkColumn
fromColumnInfo (ColumnInfo
c, a
flags) = BulkColumn
      { bulkColumnName :: Text
bulkColumnName = ColumnInfo -> Text
columnName ColumnInfo
c
      , bulkColumnType :: TypeInfo
bulkColumnType = ColumnInfo -> TypeInfo
columnType ColumnInfo
c
      , bulkColumnNullable :: Bool
bulkColumnNullable = a
flags a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0001 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
      , bulkColumnIdentity :: Bool
bulkColumnIdentity = a
flags a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0010 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
      }

-- | The wire type a column's values are sent as, which may differ from the
-- column's real type ('bulkColumnType').  Character (@char@, @varchar@,
-- @text@) and @ntext@ columns are sent as @nvarchar(max)@ (UTF-16)
-- and transcoded by the server to the column's own collation on insert (as
-- @bcp -w@ does): correct whatever the collation, where a single-byte value
-- would otherwise be read in the load's default collation, not the
-- column's. @image@ and @xml@ are sent as @varbinary(max)@; XML keeps
-- its byte encoding for the server's parser. Everything else is sent
-- as itself.  'encodeBulkCell' still validates a value against the real type,
-- so a character absent from the column's code page or a value too long is
-- refused on the client, not silently transcoded or truncated by the
-- server.
bulkWireType :: TypeInfo -> TypeInfo
bulkWireType :: TypeInfo -> TypeInfo
bulkWireType = \case
  TIBigChar Word16
_ Collation
_ -> Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)
  TIBigVarChar Word16
_ Collation
_ -> Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)
  TIText Word32
_ Collation
_ -> Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)
  TINText Word32
_ Collation
_ -> Word16 -> Collation -> TypeInfo
TINVarChar Word16
maxLength (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)
  TIImage Word32
_ -> Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength
  TIXml Maybe XmlSchema
_ -> Word16 -> TypeInfo
TIBigVarBinary Word16
maxLength
  TypeInfo
ti -> TypeInfo
ti

quoteName :: Text -> Text
quoteName :: Text -> Text
quoteName Text
n = 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
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- | The @INSERT BULK@ statement that announces the load: the table, each
-- column with the type it is sent as, and the options.
insertBulkStatement :: BulkCopy -> [BulkColumn] -> Text
insertBulkStatement :: BulkCopy -> [BulkColumn] -> Text
insertBulkStatement BulkCopy
bc [BulkColumn]
cols =
  Text
"INSERT BULK " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BulkCopy -> Text
bulkTable BulkCopy
bc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text -> Text
quoteName (BulkColumn -> Text
bulkColumnName BulkColumn
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeInfo -> Text
typeInfoSqlName (TypeInfo -> TypeInfo
bulkWireType (BulkColumn -> TypeInfo
bulkColumnType BulkColumn
c)) | BulkColumn
c <- [BulkColumn]
cols]
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
withClause
  where
    options :: [Text]
options = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"CHECK_CONSTRAINTS" | BulkCopy -> Bool
bulkCheckConstraints BulkCopy
bc]
      , [Text
"FIRE_TRIGGERS" | BulkCopy -> Bool
bulkFireTriggers BulkCopy
bc]
      , [Text
"KEEP_NULLS" | BulkCopy -> Bool
bulkKeepNulls BulkCopy
bc]
      , [Text
"TABLOCK" | BulkCopy -> Bool
bulkTableLock BulkCopy
bc]
      , [Text
"ROWS_PER_BATCH = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
tshow Int
n | Just Int
n <- [BulkCopy -> Maybe Int
bulkRowsPerBatch BulkCopy
bc]]
      , [Text
"KILOBYTES_PER_BATCH = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
tshow Int
n | Just Int
n <- [BulkCopy -> Maybe Int
bulkKilobytesPerBatch BulkCopy
bc]]
      , [Text
"ORDER(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((BulkOrder -> Text) -> [BulkOrder] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map BulkOrder -> Text
orderOf (BulkCopy -> [BulkOrder]
bulkOrder BulkCopy
bc)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" | Bool -> Bool
not ([BulkOrder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BulkCopy -> [BulkOrder]
bulkOrder BulkCopy
bc))]
      ]
    orderOf :: BulkOrder -> Text
orderOf = \case
      Ascending Text
c -> Text -> Text
quoteName Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ASC"
      Descending Text
c -> Text -> Text
quoteName Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" DESC"
    withClause :: Text
withClause
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
options = Text
""
      | Bool
otherwise = Text
" WITH (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
options Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    tshow :: Int -> Text
    tshow :: Int -> Text
tshow = String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

------------------------------------------------------------------------------
-- Rows

-- | The converter of a row: each value encoded by its 'Hmssql.Encoding.ToSqlField'
-- instance, then converted to its column ('encodeBulkCell').  Positional
-- values go to the columns in order; named ones ('Hmssql.Encoding.NamedParams') to the
-- columns of their names, with the one leading @\@@ 'Hmssql.Encoding.NamedParams' puts
-- before a name removed: an exact match first, else a case-insensitive
-- one when it matches one column and one value, since a catalog can be
-- case-sensitive (@a@ beside @A@).  A problem names the column.
compileRow :: forall r. ToSqlRow r => TdsContext -> [BulkColumn] -> r -> Either String [ParamValue]
compileRow :: forall r.
ToSqlRow r =>
TdsContext -> [BulkColumn] -> r -> Either String [ParamValue]
compileRow TdsContext
ctx [BulkColumn]
cols = \r
r -> [(Text, TdsContext -> Either String EncodedParam)]
-> Either String [ParamValue]
convertRow (RowEncoder r
-> r -> [(Text, TdsContext -> Either String EncodedParam)]
forall a.
RowEncoder a
-> a -> [(Text, TdsContext -> Either String EncodedParam)]
encodeParams RowEncoder r
enc r
r)
  where
    enc :: RowEncoder r
enc = RowEncoder r
forall a. ToSqlRow a => RowEncoder a
rowEncoder :: RowEncoder r
    n :: Int
n = [BulkColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BulkColumn]
cols
    converters :: [(BulkColumn, EncodedParam -> Either String ParamValue)]
converters = [(BulkColumn
c, TdsContext
-> BulkColumn -> EncodedParam -> Either String ParamValue
encodeBulkCell TdsContext
ctx BulkColumn
c) | BulkColumn
c <- [BulkColumn]
cols]
    foldedColumnNames :: [Text]
foldedColumnNames = (BulkColumn -> Text) -> [BulkColumn] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
T.toCaseFold (Text -> Text) -> (BulkColumn -> Text) -> BulkColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BulkColumn -> Text
bulkColumnName) [BulkColumn]
cols
    normalizeName :: Text -> Text
normalizeName Text
name = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name (Text -> Text -> Maybe Text
T.stripPrefix Text
"@" Text
name)
    convertRow :: [(Text, TdsContext -> Either String EncodedParam)]
-> Either String [ParamValue]
convertRow [(Text, TdsContext -> Either String EncodedParam)]
params
      | ((Text, TdsContext -> Either String EncodedParam) -> Bool)
-> [(Text, TdsContext -> Either String EncodedParam)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> ((Text, TdsContext -> Either String EncodedParam) -> Bool)
-> (Text, TdsContext -> Either String EncodedParam)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool)
-> ((Text, TdsContext -> Either String EncodedParam) -> Text)
-> (Text, TdsContext -> Either String EncodedParam)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, TdsContext -> Either String EncodedParam) -> Text
forall a b. (a, b) -> a
fst) [(Text, TdsContext -> Either String EncodedParam)]
params = [(Text, TdsContext -> Either String EncodedParam)]
-> Either String [ParamValue]
byName [(Text, TdsContext -> Either String EncodedParam)]
params
      | Bool
otherwise = [(BulkColumn, EncodedParam -> Either String ParamValue)]
-> [(Text, TdsContext -> Either String EncodedParam)]
-> Either String [ParamValue]
forall {a} {a} {a}.
[(BulkColumn, a -> Either String a)]
-> [(a, TdsContext -> Either String a)] -> Either String [a]
positional [(BulkColumn, EncodedParam -> Either String ParamValue)]
converters [(Text, TdsContext -> Either String EncodedParam)]
params
      where
        positional :: [(BulkColumn, a -> Either String a)]
-> [(a, TdsContext -> Either String a)] -> Either String [a]
positional [] [] = [a] -> Either String [a]
forall a b. b -> Either a b
Right []
        positional ((BulkColumn
c, a -> Either String a
conv) : [(BulkColumn, a -> Either String a)]
cs) ((a
_, TdsContext -> Either String a
e) : [(a, TdsContext -> Either String a)]
ps) = do
          v <- BulkColumn -> Either String a -> Either String a
forall {b}. BulkColumn -> Either String b -> Either String b
inColumn BulkColumn
c (TdsContext -> Either String a
e TdsContext
ctx Either String a -> (a -> Either String a) -> Either String a
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
>>= a -> Either String a
conv)
          (v :) <$> positional cs ps
        positional [(BulkColumn, a -> Either String a)]
_ [(a, TdsContext -> Either String a)]
_ = String -> Either String [a]
forall a b. a -> Either a b
Left (String -> Either String [a]) -> String -> Either String [a]
forall a b. (a -> b) -> a -> b
$ String
"the row has " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(Text, TdsContext -> Either String EncodedParam)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, TdsContext -> Either String EncodedParam)]
params) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" values for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" columns"
    byName :: [(Text, TdsContext -> Either String EncodedParam)]
-> Either String [ParamValue]
byName [(Text, TdsContext -> Either String EncodedParam)]
params = do
      given <- [(Text, TdsContext -> Either String EncodedParam)]
-> ((Text, TdsContext -> Either String EncodedParam)
    -> Either String (Text, TdsContext -> Either String EncodedParam))
-> Either String [(Text, TdsContext -> Either String EncodedParam)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, TdsContext -> Either String EncodedParam)]
params (((Text, TdsContext -> Either String EncodedParam)
  -> Either String (Text, TdsContext -> Either String EncodedParam))
 -> Either
      String [(Text, TdsContext -> Either String EncodedParam)])
-> ((Text, TdsContext -> Either String EncodedParam)
    -> Either String (Text, TdsContext -> Either String EncodedParam))
-> Either String [(Text, TdsContext -> Either String EncodedParam)]
forall a b. (a -> b) -> a -> b
$ \(Text
name, TdsContext -> Either String EncodedParam
e) ->
        if Text -> Bool
T.null Text
name
          then String
-> Either String (Text, TdsContext -> Either String EncodedParam)
forall a b. a -> Either a b
Left String
"the row mixes named and positional values"
          else (Text, TdsContext -> Either String EncodedParam)
-> Either String (Text, TdsContext -> Either String EncodedParam)
forall a b. b -> Either a b
Right (Text -> Text
normalizeName Text
name, TdsContext -> Either String EncodedParam
e)
      unless (length given == n) $
        Left $ "the row has " ++ show (length given) ++ " values for " ++ show n ++ " columns"
      forM converters $ \(BulkColumn
c, EncodedParam -> Either String ParamValue
conv) -> BulkColumn -> Either String ParamValue -> Either String ParamValue
forall {b}. BulkColumn -> Either String b -> Either String b
inColumn BulkColumn
c (Either String ParamValue -> Either String ParamValue)
-> Either String ParamValue -> Either String ParamValue
forall a b. (a -> b) -> a -> b
$ do
        e <- Text
-> [(Text, TdsContext -> Either String EncodedParam)]
-> Either String (TdsContext -> Either String EncodedParam)
forall {a}. Text -> [(Text, a)] -> Either String a
namedValue (BulkColumn -> Text
bulkColumnName BulkColumn
c) [(Text, TdsContext -> Either String EncodedParam)]
given
        e ctx >>= conv
    namedValue :: Text -> [(Text, a)] -> Either String a
namedValue Text
name [(Text, a)]
given = case [a
e | (Text
n, a
e) <- [(Text, a)]
given, Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name] of
      [a
e] -> a -> Either String a
forall a b. b -> Either a b
Right a
e
      [] ->
        let folded :: Text
folded = Text -> Text
T.toCaseFold Text
name
         in if [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
folded) [Text]
foldedColumnNames) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
              then String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"ambiguous column name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; use its exact spelling"
              else case [a
e | (Text
n, a
e) <- [(Text, a)]
given, Text -> Text
T.toCaseFold Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
folded] of
                [a
e] -> a -> Either String a
forall a b. b -> Either a b
Right a
e
                [] -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"no value named " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
name
                [a]
_ -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"more than one value matches column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
name
      [a]
_ -> String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"more than one value named " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
name
    inColumn :: BulkColumn -> Either String b -> Either String b
inColumn BulkColumn
c = (String -> Either String b)
-> (b -> Either String b) -> Either String b -> Either String b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
m -> String -> Either String b
forall a b. a -> Either a b
Left (String
"column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (BulkColumn -> Text
bulkColumnName BulkColumn
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m)) b -> Either String b
forall a b. b -> Either a b
Right

-- | Encode a value for a bulk load into this column: its bytes in the wire
-- type the column is sent as (@'bulkWireType' ('bulkColumnType' column)@), or
-- why the column can't take the value.  The column's own type supplies the
-- checks, and the wire type may differ: a @varchar@ column's value is checked
-- against the column's length and code page, then sent as UTF-16 in
-- @nvarchar(max)@ for the server to transcode.
--
-- A NULL is sent as NULL to a nullable column and refused for a NOT NULL one.
-- A value's framing is checked as an ordinary parameter's is
-- ('Hmssql.Tds.TypeInfo.valueProblem'), so an empty numeric or @sql_variant@
-- payload can't become a NULL by accident, and a value declared as a fixed
-- @char@, @nchar@ or @binary@ is padded to its length before conversion, as
-- an RPC parameter is.  Where the column's type and its wire type agree, a
-- value already in that type (an 'Int32' for an @int@ column, a 'Text' that
-- fits an @nvarchar@ column, or a matching 'Hmssql.Encoding.RawParam') is sent as it is.  A
-- value converted to @sql_variant@ keeps its declared base type, precision,
-- scale, length and collation, with its bytes as they are.  Other conversions
-- decode the value and encode it again:
--
-- * Integers, 'Bool', 'Decimal', 'Double', 'Float' and 'Money' to any of
--   @bit@ (nonzero is 1), the integer types (fractions truncate toward
--   zero, except 'Money', which rounds half away from zero), @decimal@ and @numeric@
--   (rounded to the column's scale, half away from zero, a floating-point
--   value from its exact binary value), @float@,
--   @real@, @money@ and @smallmoney@ (rounded to four places); a value
--   outside the column's range is refused. Nonfinite floating sources are
--   refused for @bit@ rather than converted to true.
-- * 'Text' (and 'String') to @nchar@, @nvarchar@, @ntext@
--   (as UTF-16), @char@, @varchar@, @text@ (validated against the column's
--   UTF-8 or single-byte code page, then sent as UTF-16; a character the
--   page lacks is refused), @xml@ and @sql_variant@ (as @nvarchar@, in the
--   session's collation). A string longer than the column is refused.
--   'SqlXml' goes to character and @xml@ columns too.  A character column
--   gets its text as it is, without the server's XML canonicalization, and
--   raw XML bytes in an encoding other than UTF-8 or a UTF-16 the client can
--   identify are refused there.
-- * 'Data.ByteString.ByteString' to @binary@, @varbinary@, @image@ and @sql_variant@;
--   longer than the column, refused.
-- * 'Day', 'TimeOfDay', 'LocalTime', 'UTCTime', 'DateTimeOffset' and
--   'ZonedTime' to @date@, @time@, @datetime2@, @datetimeoffset@ (at the
--   column's scale, rounded as the 'Hmssql.Encoding.ToSqlField' instances round),
--   @datetime@ and @smalldatetime@: a date at midnight, the date or time
--   part of a date-time, a @datetimeoffset@'s local time, a date-time
--   with offset zero.
-- * 'Data.UUID.Types.UUID' to @uniqueidentifier@ only; every value but 'SqlXml' to
--   @sql_variant@.
--
-- Anything else (a 'Text' for an @int@ column, a number for a string
-- column, a CLR type) is refused: convert it in Haskell, or declare the
-- column ('DescribedColumns') with the type the value is sent as and let
-- the server convert.
encodeBulkCell :: TdsContext -> BulkColumn -> EncodedParam -> Either String ParamValue
encodeBulkCell :: TdsContext
-> BulkColumn -> EncodedParam -> Either String ParamValue
encodeBulkCell TdsContext
ctx BulkColumn
col (TypeInfo
source, ParamBytes RawBytes
v) = RawBytes -> ParamValue
ParamBytes (RawBytes -> ParamValue)
-> Either String RawBytes -> Either String ParamValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TdsContext
-> BulkColumn -> (TypeInfo, RawBytes) -> Either String RawBytes
encodeBulkBytes TdsContext
ctx BulkColumn
col (TypeInfo
source, RawBytes
v)
-- A lazy or streamed value: its bytes can't be checked ahead, so only its
-- encoding is checked here.  The wire is UTF-16 for a character column, so a
-- @varchar(max)@ source is refused rather than transcoded.  A text source into
-- @xml@ gets a byte order mark, so that the server reads it as UTF-16.
encodeBulkCell TdsContext
_ BulkColumn
col (TypeInfo
source, ParamValue
value) = do
  (String -> Either String (ZonkAny 4))
-> Maybe String -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Either String (ZonkAny 4)
forall a b. a -> Either a b
Left (TypeInfo -> ParamValue -> Maybe String
paramValueProblem TypeInfo
source ParamValue
value)
  case TypeInfo -> TypeInfo
bulkWireType (BulkColumn -> TypeInfo
bulkColumnType BulkColumn
col) of
    TINChar{} | TypeInfo -> Bool
unicode TypeInfo
source -> ParamValue -> Either String ParamValue
forall a b. b -> Either a b
Right ParamValue
value
    TINVarChar{} | TypeInfo -> Bool
unicode TypeInfo
source -> ParamValue -> Either String ParamValue
forall a b. b -> Either a b
Right ParamValue
value
    TIBigBinary{} | TypeInfo -> Bool
binary TypeInfo
source -> ParamValue -> Either String ParamValue
forall a b. b -> Either a b
Right ParamValue
value
    TIBigVarBinary{} | TypeInfo -> Bool
binary TypeInfo
source Bool -> Bool -> Bool
|| TypeInfo -> Bool
xml TypeInfo
source -> ParamValue -> Either String ParamValue
forall a b. b -> Either a b
Right ParamValue
value
    TIBigVarBinary{} | Bool
isXmlTarget Bool -> Bool -> Bool
&& TypeInfo -> Bool
unicode TypeInfo
source -> ParamValue -> Either String ParamValue
forall a b. b -> Either a b
Right (ParamValue -> ParamValue
bom ParamValue
value)
    TypeInfo
_ -> String -> Either String ParamValue
forall a b. a -> Either a b
Left String
"stream type is incompatible with the bulk column's wire encoding"
  where
    unicode :: TypeInfo -> Bool
unicode TINVarChar{} = Bool
True
    unicode TypeInfo
_ = Bool
False
    binary :: TypeInfo -> Bool
binary TIBigVarBinary{} = Bool
True
    binary TypeInfo
_ = Bool
False
    xml :: TypeInfo -> Bool
xml TIXml{} = Bool
True
    xml TypeInfo
_ = Bool
False
    isXmlTarget :: Bool
isXmlTarget = case BulkColumn -> TypeInfo
bulkColumnType BulkColumn
col of TIXml{} -> Bool
True; TypeInfo
_ -> Bool
False
    bom :: ParamValue -> ParamValue
bom (ParamLazy ByteString
bs) = ByteString -> ParamValue
ParamLazy (ByteString -> ByteString
LB.fromStrict ByteString
"\xFF\xFE" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs)
    bom (ParamStream (Source forall r. (Stream (Of ByteString) IO () -> IO r) -> IO r
sourceOfBytes)) = Source ByteString -> ParamValue
ParamStream ((forall r. (Stream (Of ByteString) IO () -> IO r) -> IO r)
-> Source ByteString
forall a.
(forall r. (Stream (Of a) IO () -> IO r) -> IO r) -> Source a
Source (\Stream (Of ByteString) IO () -> IO r
use -> (Stream (Of ByteString) IO () -> IO r) -> IO r
forall r. (Stream (Of ByteString) IO () -> IO r) -> IO r
sourceOfBytes (\Stream (Of ByteString) IO ()
s -> Stream (Of ByteString) IO () -> IO r
use (ByteString -> Stream (Of ByteString) IO ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield ByteString
"\xFF\xFE" Stream (Of ByteString) IO ()
-> Stream (Of ByteString) IO () -> Stream (Of ByteString) 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
>> Stream (Of ByteString) IO ()
s))))
    bom ParamValue
bytes = ParamValue
bytes

-- | 'encodeBulkCell' for a value in memory, whose length and code page can be
-- checked before anything is sent.
encodeBulkBytes :: TdsContext -> BulkColumn -> (TypeInfo, RawBytes) -> Either String RawBytes
encodeBulkBytes :: TdsContext
-> BulkColumn -> (TypeInfo, RawBytes) -> Either String RawBytes
encodeBulkBytes TdsContext
ctx BulkColumn
col (TypeInfo
source, RawBytes
v) = case RawBytes
v of
  RawBytes
Nothing
    | BulkColumn -> Bool
bulkColumnNullable BulkColumn
col -> RawBytes -> Either String RawBytes
forall a b. b -> Either a b
Right RawBytes
forall a. Maybe a
Nothing
    | Bool
otherwise -> String -> Either String RawBytes
forall a b. a -> Either a b
Left String
"NULL, but the column is NOT NULL"
  Just ByteString
raw -> do
    (String -> Either String (ZonkAny 3))
-> Maybe String -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Either String (ZonkAny 3)
forall a b. a -> Either a b
Left (TypeInfo -> RawBytes -> Maybe String
valueProblem TypeInfo
source (ByteString -> RawBytes
forall a. a -> Maybe a
Just ByteString
raw))
    let bs :: ByteString
bs = TypeInfo -> ByteString -> ByteString
padFixedSource TypeInfo
source ByteString
raw
    ByteString -> RawBytes
forall a. a -> Maybe a
Just (ByteString -> RawBytes)
-> Either String ByteString -> Either String RawBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if TypeInfo
wire TypeInfo -> TypeInfo -> Bool
forall a. Eq a => a -> a -> Bool
== TypeInfo
real then ByteString -> Either String ByteString
asIs ByteString
bs else ByteString -> Either String ByteString
remapped ByteString
bs)
  where
    real :: TypeInfo
real = BulkColumn -> TypeInfo
bulkColumnType BulkColumn
col
    wire :: TypeInfo
wire = TypeInfo -> TypeInfo
bulkWireType TypeInfo
real
    -- The column's values are sent as themselves (the common case).
    asIs :: ByteString -> Either String ByteString
asIs ByteString
bs
      | TypeInfo -> TypeInfo -> ByteString -> Bool
sameStorage TypeInfo
real TypeInfo
source ByteString
bs = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
      | TISqlVariant Word32
_ <- TypeInfo
real = TdsContext -> TypeInfo -> ByteString -> Either String ByteString
variantFromSource TdsContext
ctx TypeInfo
source ByteString
bs
      | Bool
otherwise = TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
source ByteString
bs Either String SqlValue
-> (SqlValue -> Either String ByteString)
-> Either String ByteString
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
>>= TdsContext -> TypeInfo -> SqlValue -> Either String ByteString
encodeValueAs TdsContext
ctx TypeInfo
real
    -- A column sent in a different wire type ('bulkWireType'): a character
    -- column as UTF-16, or an image/XML column as varbinary. The value
    -- is validated against the /real/ type first (a character absent from
    -- the column's code page, or a value too long, is refused here, not
    -- silently transcoded or truncated by the server), then written in the
    -- wire type.
    remapped :: ByteString -> Either String ByteString
remapped ByteString
bs = case TypeInfo
real of
      -- XML's own parser interprets its declared byte encoding. Sending
      -- it through nvarchar makes unmarked UTF-8 look like UTF-16 text.
      TIXml Maybe XmlSchema
_ -> case TypeInfo
source of
        TIXml Maybe XmlSchema
_ -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
        TypeInfo
_ | TypeInfo -> Bool
isUnicode TypeInfo
source -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> ByteString
xmlUnicode ByteString
bs)
        TypeInfo
_ | Just Collation
coll <- TypeInfo -> Maybe Collation
ansiCollation TypeInfo
source
          , Collation -> Maybe Word16
collationCodePage Collation
coll Maybe Word16 -> Maybe Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
65001 Bool -> Bool -> Bool
|| ByteString -> Bool
hasXmlBom ByteString
bs Bool -> Bool -> Bool
|| RawBytes -> Bool
forall a. Maybe a -> Bool
isJust (ByteString -> RawBytes
xmlDeclaredEncoding ByteString
bs) -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
        TypeInfo
_ -> ByteString -> ByteString
xmlUnicode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf16LE (Text -> ByteString)
-> Either String Text -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String Text
charText ByteString
bs
      -- Both source and bulk wire are UTF-16. Passing the original code
      -- units also preserves SQL-accepted lone surrogates; a text decoder
      -- would replace them even though no character conversion is needed.
      TINText Word32
_ Collation
_ | TypeInfo -> Bool
isUnicode TypeInfo
source -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs
      TIImage Word32
_ -> case TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
source ByteString
bs of
        Right (SqlBinary ByteString
b) -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
b
        Right SqlValue
other -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String
"cannot copy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SqlValue -> String
describe SqlValue
other String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" into an image column")
        Left String
e -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
e
      TypeInfo
_ -> do
        t <- ByteString -> Either String Text
charText ByteString
bs
        validateChar real t
        Right (encodeUtf16LE t)
    -- Unicode-to-XML conversion assumes UTF-16 only when no byte order
    -- mark selects another encoding. Preserve that server decision.
    xmlUnicode :: ByteString -> ByteString
xmlUnicode ByteString
bs
      | ByteString -> Bool
hasXmlBom ByteString
bs = ByteString
bs
      | Bool
otherwise = ByteString
"\xFF\xFE" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs
    hasXmlBom :: ByteString -> Bool
hasXmlBom ByteString
bs = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
bs) [ByteString
"\xFF\xFE",ByteString
"\xFE\xFF",ByteString
"\xEF\xBB\xBF"]
    charText :: ByteString -> Either String Text
charText ByteString
bs = TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
source ByteString
bs Either String SqlValue
-> (SqlValue -> Either String Text) -> Either String Text
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
>>= \case
      SqlText Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
      SqlXml Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
      SqlValue
other -> String -> Either String Text
forall a b. a -> Either a b
Left (String
"cannot copy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SqlValue -> String
describe SqlValue
other String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" into a character column; convert it in Haskell first")

-- Fixed source declarations carry padding semantics before conversion to
-- another type, just as an RPC parameter does. Variable sources retain
-- their actual length. NULL is handled before this function is called.
padFixedSource :: TypeInfo -> B.ByteString -> B.ByteString
padFixedSource :: TypeInfo -> ByteString -> ByteString
padFixedSource TypeInfo
source ByteString
bs = case TypeInfo
source of
  TIBigChar Word16
n Collation
_ -> Int -> Word8 -> ByteString
padByte (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Word8
0x20
  TIBigBinary Word16
n -> Int -> Word8 -> ByteString
padByte (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Word8
0
  TINChar Word16
n Collation
_
    | Int
missing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int -> Bool
forall a. Integral a => a -> Bool
even Int
missing -> ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
B.concat (Int -> ByteString -> [ByteString]
forall a. Int -> a -> [a]
replicate (Int
missing Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) ([Word8] -> ByteString
B.pack [Word8
0x20,Word8
0]))
    where missing :: Int
missing = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
bs
  TypeInfo
_ -> ByteString
bs
  where
    padByte :: Int -> Word8 -> ByteString
padByte Int
width Word8
byte
      | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
B.length ByteString
bs = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
B.replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
bs) Word8
byte
      | Bool
otherwise = ByteString
bs

-- Only inspect the declaration's encoding attribute. XML syntax and charset
-- validation remain with SQL Server; this is not an XML document parser.
xmlDeclaredEncoding :: B.ByteString -> Maybe B.ByteString
xmlDeclaredEncoding :: ByteString -> RawBytes
xmlDeclaredEncoding ByteString
bs = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
"<?xml" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
bs)
  (next, _) <- ByteString -> Maybe (Word8, ByteString)
B.uncons (Int -> ByteString -> ByteString
B.drop Int
5 ByteString
bs)
  guard (xmlSpace next)
  let declaration = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
"?>" ByteString
bs)
      attribute = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
"encoding" ByteString
declaration)
  afterName <- B.stripPrefix "encoding" attribute
  afterEquals <- B.stripPrefix "=" (B.dropWhile xmlSpace afterName)
  (quote, value) <- B.uncons (B.dropWhile xmlSpace afterEquals)
  guard (quote == 34 || quote == 39)
  let (name, closing) = B.break (== quote) value
  guard (not (B.null closing))
  pure name
  where
    xmlSpace :: a -> Bool
xmlSpace a
byte = a
byte a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a
9,a
10,a
13,a
32]

-- | Check that a 'Text' fits a single-byte @char@\/@varchar@\/@text@
-- column: every character is representable in the column's code page (else
-- the server would store @\'?\'@, losing data) and, for a bounded column,
-- the encoded value is no longer than the column
-- (independent of @SET ANSI_WARNINGS@, which the server's own check
-- depends on).  A collation hmssql can't encode (a double-byte code page,
-- or an unknown one) is left to the server.  @nchar@\/@nvarchar@ (checked
-- by 'encodeValueAs') and @ntext@\/@xml@ (Unicode, no code page) don't
-- come here.
validateChar :: TypeInfo -> Text -> Either String ()
validateChar :: TypeInfo -> Text -> Either String ()
validateChar TypeInfo
ti Text
t = case TypeInfo
ti of
  TIBigChar Word16
n Collation
c -> Collation -> Maybe Int -> Either String ()
check Collation
c (Int -> Maybe Int
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n))
  TIBigVarChar Word16
n Collation
c
    | Word16
n Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength -> Collation -> Maybe Int -> Either String ()
check Collation
c Maybe Int
forall a. Maybe a
Nothing
    | Bool
otherwise -> Collation -> Maybe Int -> Either String ()
check Collation
c (Int -> Maybe Int
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n))
  TIText Word32
_ Collation
c -> Collation -> Maybe Int -> Either String ()
check Collation
c Maybe Int
forall a. Maybe a
Nothing
  TypeInfo
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()
  where
    check :: Collation -> Maybe Int -> Either String ()
check Collation
coll Maybe Int
mlimit = case Collation -> Either String (Text -> Either String ByteString)
collationTextEncoder Collation
coll of
      Left String
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()  -- a code page hmssql can't encode: the server enforces it
      Right Text -> Either String ByteString
enc -> case Text -> Either String ByteString
enc Text
t of
        Left String
err -> String -> Either String ()
forall a b. a -> Either a b
Left (String
"would lose data: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
        Right ByteString
bs -> case Maybe Int
mlimit of
          Just Int
n | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
            String
"the value encodes to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
B.length ByteString
bs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes; the column "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" holds " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
          Maybe Int
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()

-- | Whether the value's bytes, in the source type, are already what the
-- target type carries (and fit it).
sameStorage :: TypeInfo -> TypeInfo -> B.ByteString -> Bool
sameStorage :: TypeInfo -> TypeInfo -> ByteString -> Bool
sameStorage TypeInfo
target TypeInfo
source ByteString
bs = case (TypeInfo
target, TypeInfo
source) of
  (TypeInfo, TypeInfo)
_ | Just Int
m <- TypeInfo -> Maybe Int
intWidth TypeInfo
target, Just Int
n <- TypeInfo -> Maybe Int
intWidth TypeInfo
source -> Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    | TypeInfo -> Bool
isBit TypeInfo
target, TypeInfo -> Bool
isBit TypeInfo
source -> Bool
True
    | Just Int
m <- TypeInfo -> Maybe Int
floatWidth TypeInfo
target, Just Int
n <- TypeInfo -> Maybe Int
floatWidth TypeInfo
source -> Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    | Just Int
m <- TypeInfo -> Maybe Int
moneyWidth TypeInfo
target, Just Int
n <- TypeInfo -> Maybe Int
moneyWidth TypeInfo
source -> Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    | Just Int
m <- TypeInfo -> Maybe Int
dateTimeWidth TypeInfo
target, Just Int
n <- TypeInfo -> Maybe Int
dateTimeWidth TypeInfo
source -> Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    | Just (Word8
p, Word8
s) <- TypeInfo -> Maybe (Word8, Word8)
decimalOf TypeInfo
target, Just (Word8
p', Word8
s') <- TypeInfo -> Maybe (Word8, Word8)
decimalOf TypeInfo
source ->
        Word8
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
s' Bool -> Bool -> Bool
&& Word8
p' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
p Bool -> Bool -> Bool
&& Word8 -> Int
precisionToLength Word8
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Int
precisionToLength Word8
p'
    | Just Int
limit <- TypeInfo -> Maybe Int
unicodeLimit TypeInfo
target, TypeInfo -> Bool
isUnicode TypeInfo
source -> Int -> Bool
fits Int
limit
    | Just (Int
limit, Collation
c) <- TypeInfo -> Maybe (Int, Collation)
ansiLimit TypeInfo
target, Just Collation
c' <- TypeInfo -> Maybe Collation
ansiCollation TypeInfo
source ->
        Maybe Word16 -> Bool
forall a. Maybe a -> Bool
isJust (Collation -> Maybe Word16
collationCodePage Collation
c) Bool -> Bool -> Bool
&& Collation -> Maybe Word16
collationCodePage Collation
c Maybe Word16 -> Maybe Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Collation -> Maybe Word16
collationCodePage Collation
c' Bool -> Bool -> Bool
&& Int -> Bool
fits Int
limit
    | Just Int
limit <- TypeInfo -> Maybe Int
binaryLimit TypeInfo
target, TypeInfo -> Bool
isBinary TypeInfo
source -> Int -> Bool
fits Int
limit
  (TypeInfo
TIGuid, TypeInfo
TIGuid) -> Bool
True
  (TypeInfo
TIDateN, TypeInfo
TIDateN) -> Bool
True
  (TITimeN Word8
a, TITimeN Word8
b) -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
b
  (TIDateTime2N Word8
a, TIDateTime2N Word8
b) -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
b
  (TIDateTimeOffsetN Word8
a, TIDateTimeOffsetN Word8
b) -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
b
  (TIXml Maybe XmlSchema
_, TIXml Maybe XmlSchema
_) -> Bool
True
  (TISqlVariant Word32
_, TISqlVariant Word32
_) -> Bool
True
  (TIUdt UdtInfo
_, TIUdt UdtInfo
_) -> Bool
True
  (TypeInfo, TypeInfo)
_ -> Bool
False
  where
    fits :: Int -> Bool
fits Int
limit = Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit

-- Type families, by what the wire carries.

intWidth :: TypeInfo -> Maybe Int
intWidth :: TypeInfo -> Maybe Int
intWidth = \case
  TypeInfo
TIInt1 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  TypeInfo
TIInt2 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
  TypeInfo
TIInt4 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
  TypeInfo
TIInt8 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
  TIIntN Word8
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

isBit :: TypeInfo -> Bool
isBit :: TypeInfo -> Bool
isBit = \case
  TypeInfo
TIBit -> Bool
True
  TypeInfo
TIBitN -> Bool
True
  TypeInfo
_ -> Bool
False

floatWidth :: TypeInfo -> Maybe Int
floatWidth :: TypeInfo -> Maybe Int
floatWidth = \case
  TypeInfo
TIFlt4 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
  TypeInfo
TIFlt8 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
  TIFltN Word8
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

moneyWidth :: TypeInfo -> Maybe Int
moneyWidth :: TypeInfo -> Maybe Int
moneyWidth = \case
  TypeInfo
TIMoney4 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
  TypeInfo
TIMoney8 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
  TIMoneyN Word8
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

dateTimeWidth :: TypeInfo -> Maybe Int
dateTimeWidth :: TypeInfo -> Maybe Int
dateTimeWidth = \case
  TypeInfo
TIDateTime4 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
  TypeInfo
TIDateTime8 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
  TIDateTimeN Word8
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

decimalOf :: TypeInfo -> Maybe (Precision, Scale)
decimalOf :: TypeInfo -> Maybe (Word8, Word8)
decimalOf = \case
  TIDecimalN Word8
p Word8
s -> (Word8, Word8) -> Maybe (Word8, Word8)
forall a. a -> Maybe a
Just (Word8
p, Word8
s)
  TINumericN Word8
p Word8
s -> (Word8, Word8) -> Maybe (Word8, Word8)
forall a. a -> Maybe a
Just (Word8
p, Word8
s)
  TypeInfo
_ -> Maybe (Word8, Word8)
forall a. Maybe a
Nothing

-- | The most bytes a UTF-16 column takes (-1: no limit).
unicodeLimit :: TypeInfo -> Maybe Int
unicodeLimit :: TypeInfo -> Maybe Int
unicodeLimit = \case
  TINChar Word16
len Collation
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len)
  TINVarChar Word16
len Collation
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (if Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength then -Int
1 else Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len)
  TINText Word32
_ Collation
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
1)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

isUnicode :: TypeInfo -> Bool
isUnicode :: TypeInfo -> Bool
isUnicode = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> (TypeInfo -> Maybe Int) -> TypeInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> Maybe Int
unicodeLimit

-- | The most bytes a single-byte column takes, and its collation.
ansiLimit :: TypeInfo -> Maybe (Int, Collation)
ansiLimit :: TypeInfo -> Maybe (Int, Collation)
ansiLimit = \case
  TIBigChar Word16
len Collation
c -> (Int, Collation) -> Maybe (Int, Collation)
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len, Collation
c)
  TIBigVarChar Word16
len Collation
c -> (Int, Collation) -> Maybe (Int, Collation)
forall a. a -> Maybe a
Just (if Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength then -Int
1 else Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len, Collation
c)
  TIText Word32
_ Collation
c -> (Int, Collation) -> Maybe (Int, Collation)
forall a. a -> Maybe a
Just (-Int
1, Collation
c)
  TypeInfo
_ -> Maybe (Int, Collation)
forall a. Maybe a
Nothing

ansiCollation :: TypeInfo -> Maybe Collation
ansiCollation :: TypeInfo -> Maybe Collation
ansiCollation = ((Int, Collation) -> Collation)
-> Maybe (Int, Collation) -> Maybe Collation
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Collation) -> Collation
forall a b. (a, b) -> b
snd (Maybe (Int, Collation) -> Maybe Collation)
-> (TypeInfo -> Maybe (Int, Collation))
-> TypeInfo
-> Maybe Collation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> Maybe (Int, Collation)
ansiLimit

binaryLimit :: TypeInfo -> Maybe Int
binaryLimit :: TypeInfo -> Maybe Int
binaryLimit = \case
  TIBigBinary Word16
len -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len)
  TIBigVarBinary Word16
len -> Int -> Maybe Int
forall a. a -> Maybe a
Just (if Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength then -Int
1 else Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
len)
  TIImage Word32
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
1)
  TypeInfo
_ -> Maybe Int
forall a. Maybe a
Nothing

isBinary :: TypeInfo -> Bool
isBinary :: TypeInfo -> Bool
isBinary = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> (TypeInfo -> Maybe Int) -> TypeInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> Maybe Int
binaryLimit

-- | The value the bytes hold, in the source type.
sourceValue :: TypeInfo -> B.ByteString -> Either String SqlValue
sourceValue :: TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
ti ByteString
bs = case TypeInfo
ti of
  TypeInfo
_ | Just Int
n <- TypeInfo -> Maybe Int
intWidth TypeInfo
ti -> case Int
n of
        Int
1 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Word8 -> SqlValue
SqlWord8 (ByteString -> Int -> Word8
word8At ByteString
bs Int
0))
        Int
2 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Int16 -> SqlValue
SqlInt16 (ByteString -> Int -> Int16
int16LeAt ByteString
bs Int
0))
        Int
4 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Int32 -> SqlValue
SqlInt32 (ByteString -> Int -> Int32
int32LeAt ByteString
bs Int
0))
        Int
8 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Int64 -> SqlValue
SqlInt64 (ByteString -> Int -> Int64
int64LeAt ByteString
bs Int
0))
        Int
_ -> Either String SqlValue
forall {b}. Either String b
badLength
    | TypeInfo -> Bool
isBit TypeInfo
ti -> if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Bool -> SqlValue
SqlBool (ByteString -> Int -> Word8
word8At ByteString
bs Int
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)) else Either String SqlValue
forall {b}. Either String b
badLength
    | Just Int
n <- TypeInfo -> Maybe Int
floatWidth TypeInfo
ti -> case Int
n of
        Int
4 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Float -> SqlValue
SqlFloat (Word32 -> Float
castWord32ToFloat (ByteString -> Int -> Word32
word32LeAt ByteString
bs Int
0)))
        Int
8 | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Double -> SqlValue
SqlDouble (Word64 -> Double
castWord64ToDouble (ByteString -> Int -> Word64
word64LeAt ByteString
bs Int
0)))
        Int
_ -> Either String SqlValue
forall {b}. Either String b
badLength
    | Just Int
_ <- TypeInfo -> Maybe Int
moneyWidth TypeInfo
ti -> Money -> SqlValue
SqlMoney (Money -> SqlValue)
-> Either String Money -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueReader Money
readMoney ByteString
bs
    | Just Int
n <- TypeInfo -> Maybe Int
dateTimeWidth TypeInfo
ti ->
        LocalTime -> SqlValue
SqlDateTime (LocalTime -> SqlValue)
-> Either String LocalTime -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 then (Day -> Int64 -> LocalTime) -> ValueReader LocalTime
forall a. (Day -> Int64 -> a) -> ValueReader a
readDateTime4With Day -> Int64 -> LocalTime
localTimeOf else (Day -> Int64 -> LocalTime) -> ValueReader LocalTime
forall a. (Day -> Int64 -> a) -> ValueReader a
readDateTime8With Day -> Int64 -> LocalTime
localTimeOf) ByteString
bs
    | Just (Word8
p, Word8
s) <- TypeInfo -> Maybe (Word8, Word8)
decimalOf TypeInfo
ti -> Decimal -> SqlValue
SqlDecimal (Decimal -> SqlValue)
-> Either String Decimal -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> ValueReader Decimal
readDecimal Word8
p Word8
s ByteString
bs
    | TypeInfo -> Bool
isUnicode TypeInfo
ti -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (Text -> SqlValue
SqlText (ByteString -> Text
decodeUtf16LE ByteString
bs))
    | Just Collation
c <- TypeInfo -> Maybe Collation
ansiCollation TypeInfo
ti -> Text -> SqlValue
SqlText (Text -> SqlValue) -> Either String Text -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Collation -> Either String (ByteString -> Either String Text)
collationTextDecoder Collation
c Either String (ByteString -> Either String Text)
-> ((ByteString -> Either String Text) -> Either String Text)
-> Either String Text
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
>>= ((ByteString -> Either String Text)
-> ByteString -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString
bs))
    | TypeInfo -> Bool
isBinary TypeInfo
ti -> SqlValue -> Either String SqlValue
forall a b. b -> Either a b
Right (ByteString -> SqlValue
SqlBinary ByteString
bs)
  TypeInfo
TIGuid -> UUID -> SqlValue
SqlGuid (UUID -> SqlValue) -> Either String UUID -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueReader UUID
readGuid ByteString
bs
  TypeInfo
TIDateN -> Day -> SqlValue
SqlDate (Day -> SqlValue) -> Either String Day -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueReader Day
readDate ByteString
bs
  TITimeN Word8
s -> TimeOfDay -> SqlValue
SqlTime (TimeOfDay -> SqlValue)
-> Either String TimeOfDay -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> ValueReader TimeOfDay
readTime Word8
s ByteString
bs
  TIDateTime2N Word8
s -> LocalTime -> SqlValue
SqlDateTime (LocalTime -> SqlValue)
-> Either String LocalTime -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> ValueReader LocalTime
readDateTime2 Word8
s ByteString
bs
  TIDateTimeOffsetN Word8
s -> DateTimeOffset -> SqlValue
SqlDateTimeOffset (DateTimeOffset -> SqlValue)
-> Either String DateTimeOffset -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> ValueReader DateTimeOffset
readDateTimeOffset Word8
s ByteString
bs
  TIXml Maybe XmlSchema
_ -> Text -> SqlValue
SqlXml (Text -> SqlValue) -> Either String Text -> Either String SqlValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String Text
forall {a}. IsString a => ByteString -> Either a Text
xmlText ByteString
bs
  TISqlVariant Word32
_ -> String -> Either String SqlValue
forall a b. a -> Either a b
Left String
"a sql_variant value can be copied only into a sql_variant column"
  TIUdt UdtInfo
_ -> String -> Either String SqlValue
forall a b. a -> Either a b
Left String
"a CLR user-defined type value can be copied only into a column of its type"
  TypeInfo
TINull -> String -> Either String SqlValue
forall a b. a -> Either a b
Left String
"a value of no type"
  TypeInfo
_ -> String -> Either String SqlValue
forall a b. a -> Either a b
Left (String
"a value of type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" can't be converted")
  where
    len :: Int
len = ByteString -> Int
B.length ByteString
bs
    badLength :: Either String b
badLength = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" value of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes"
    -- SqlXml's normal representation is BOM-marked UTF-16. Raw XML may
    -- instead use UTF-8 or identifiable UTF-16BE. Character destinations retain
    -- lexical text; XML destinations bypass this conversion entirely.
    xmlText :: ByteString -> Either a Text
xmlText ByteString
b
      | (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b) [ByteString
"\xFF\xFE\0\0",ByteString
"\0\0\xFE\xFF"] =
          a -> Either a Text
forall a b. a -> Either a b
Left a
"XML byte encoding cannot be converted to characters on the client; use Text or an explicit server CONVERT"
      | ByteString
"\xFF\xFE" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b = Text -> Either a Text
forall a b. b -> Either a b
Right (ByteString -> Text
decodeUtf16LE (Int -> ByteString -> ByteString
B.drop Int
2 ByteString
b))
      | ByteString
"\xFE\xFF" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b = Text -> Either a Text
forall a b. b -> Either a b
Right (OnDecodeError -> ByteString -> Text
TE.decodeUtf16BEWith OnDecodeError
lenientDecode (Int -> ByteString -> ByteString
B.drop Int
2 ByteString
b))
      | ByteString
"\xEF\xBB\xBF" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b = ByteString -> Either a Text
forall {a}. IsString a => ByteString -> Either a Text
utf8 (Int -> ByteString -> ByteString
B.drop Int
3 ByteString
b)
      | ByteString
"<\0" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b = Text -> Either a Text
forall a b. b -> Either a b
Right (ByteString -> Text
decodeUtf16LE ByteString
b)
      | ByteString
"\0<" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
b = Text -> Either a Text
forall a b. b -> Either a b
Right (OnDecodeError -> ByteString -> Text
TE.decodeUtf16BEWith OnDecodeError
lenientDecode ByteString
b)
      | Just ByteString
encoding <- ByteString -> RawBytes
xmlDeclaredEncoding ByteString
b
      , (Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower ByteString
encoding ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString
"utf-8",ByteString
"utf8",ByteString
"us-ascii"] =
          a -> Either a Text
forall a b. a -> Either a b
Left a
"XML byte encoding cannot be converted to characters on the client; use Text or an explicit server CONVERT"
      | Bool
otherwise = ByteString -> Either a Text
forall {a}. IsString a => ByteString -> Either a Text
utf8 ByteString
b
      where
        utf8 :: ByteString -> Either a Text
utf8 ByteString
bytes = case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bytes of
          Left UnicodeException
_ -> a -> Either a Text
forall a b. a -> Either a b
Left a
"XML bytes are not UTF-8; copy into xml or convert to Text explicitly"
          Right Text
text -> Text -> Either a Text
forall a b. b -> Either a b
Right Text
text

-- | The value encoded for the target type.
{-# NOINLINE encodeValueAs #-}
encodeValueAs :: TdsContext -> TypeInfo -> SqlValue -> Either String B.ByteString
encodeValueAs :: TdsContext -> TypeInfo -> SqlValue -> Either String ByteString
encodeValueAs TdsContext
ctx TypeInfo
ti SqlValue
v = case TypeInfo
ti of
  TypeInfo
_ | Just Int
n <- TypeInfo -> Maybe Int
intWidth TypeInfo
ti -> SqlValue -> Either String Int64
toInt64 SqlValue
v Either String Int64
-> (Int64 -> Either String ByteString) -> Either String ByteString
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
>>= Int -> Int64 -> Either String ByteString
intBytes Int
n
    | TypeInfo -> Bool
isBit TypeInfo
ti -> (\Bool
b -> Word8 -> ByteString
B.singleton (if Bool
b then Word8
1 else Word8
0)) (Bool -> ByteString)
-> Either String Bool -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlValue -> Either String Bool
toBool SqlValue
v
    | Just Int
n <- TypeInfo -> Maybe Int
floatWidth TypeInfo
ti -> do
        d <- SqlValue -> Either String Double
toDouble SqlValue
v
        when (isNaN d || isInfinite d) $
          Left (describe v ++ " (not a finite number) can't be stored in " ++ T.unpack (typeInfoSqlName ti))
        if n == 4
          then do
            f <- toFloat v
            if isInfinite f
              then Left (describe v ++ " is out of the range of real")
              else Right (littleEndian 4 (fromIntegral (castFloatToWord32 f)))
          else Right (littleEndian 8 (castDoubleToWord64 d))
    | Just Int
n <- TypeInfo -> Maybe Int
moneyWidth TypeInfo
ti -> do
        m <- SqlValue -> Either String Money
toMoney SqlValue
v
        if n == 4
          then mapM_ Left (money4Problem m) >> put 4 (putMoney4 m)
          else mapM_ Left (money8Problem m) >> put 8 (putMoney8 m)
    | Just Int
n <- TypeInfo -> Maybe Int
dateTimeWidth TypeInfo
ti -> do
        lt <- SqlValue -> Either String LocalTime
toLocalTime SqlValue
v
        if n == 4 then putDateTime4 lt >>= put 4 else putDateTime8 lt >>= put 8
    | Just (Word8
p, Word8
s) <- TypeInfo -> Maybe (Word8, Word8)
decimalOf TypeInfo
ti -> do
        d <- Word8 -> SqlValue -> Either String Decimal
toDecimal Word8
s SqlValue
v Either String Decimal
-> (Decimal -> Either String Decimal) -> Either String Decimal
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
>>= Word8 -> Word8 -> Decimal -> Either String Decimal
rescale Word8
p Word8
s
        put 17 (putDecimal p s d)
    | Just Int
limit <- TypeInfo -> Maybe Int
unicodeLimit TypeInfo
ti -> do
        t <- SqlValue -> Either String Text
toText SqlValue
v
        let bs = Text -> ByteString
encodeUtf16LE Text
t
        checkLength limit bs "characters" (`div` 2)
    | Just (Int
limit, Collation
c) <- TypeInfo -> Maybe (Int, Collation)
ansiLimit TypeInfo
ti -> do
        t <- SqlValue -> Either String Text
toText SqlValue
v
        encoder <- collationTextEncoder c
        bs <- encoder t
        checkLength limit bs "bytes" id
    | Just Int
limit <- TypeInfo -> Maybe Int
binaryLimit TypeInfo
ti -> do
        bs <- SqlValue -> Either String ByteString
toBinary SqlValue
v
        checkLength limit bs "bytes" id
  TypeInfo
TIGuid -> case SqlValue
v of
    SqlGuid UUID
g -> Int -> Put -> Either String ByteString
put Int
16 (UUID -> Put
putGuid UUID
g)
    SqlValue
_ -> Either String ByteString
forall {b}. Either String b
mismatch
  TypeInfo
TIDateN -> SqlValue -> Either String Day
toDay SqlValue
v Either String Day
-> (Day -> Either String Put) -> Either String Put
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
>>= Day -> Either String Put
putDate Either String Put
-> (Put -> Either String ByteString) -> Either String ByteString
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
>>= Int -> Put -> Either String ByteString
put Int
3
  TITimeN Word8
s -> SqlValue -> Either String TimeOfDay
toTimeOfDay SqlValue
v Either String TimeOfDay
-> (TimeOfDay -> Either String Put) -> Either String Put
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
>>= Word8 -> TimeOfDay -> Either String Put
putTime Word8
s Either String Put
-> (Put -> Either String ByteString) -> Either String ByteString
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
>>= Int -> Put -> Either String ByteString
put Int
5
  TIDateTime2N Word8
s -> SqlValue -> Either String LocalTime
toLocalTime SqlValue
v Either String LocalTime
-> (LocalTime -> Either String Put) -> Either String Put
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
>>= Word8 -> LocalTime -> Either String Put
putDateTime2 Word8
s Either String Put
-> (Put -> Either String ByteString) -> Either String ByteString
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
>>= Int -> Put -> Either String ByteString
put Int
8
  TIDateTimeOffsetN Word8
s -> SqlValue -> Either String DateTimeOffset
toDateTimeOffset SqlValue
v Either String DateTimeOffset
-> (DateTimeOffset -> Either String Put) -> Either String Put
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
>>= Word8 -> DateTimeOffset -> Either String Put
putDateTimeOffset Word8
s Either String Put
-> (Put -> Either String ByteString) -> Either String ByteString
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
>>= Int -> Put -> Either String ByteString
put Int
10
  TIXml Maybe XmlSchema
_ -> (\Text
t -> ByteString
"\xFF\xFE" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf16LE Text
t) (Text -> ByteString)
-> Either String Text -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlValue -> Either String Text
toText SqlValue
v
  TISqlVariant Word32
_ -> TdsContext -> SqlValue -> Either String ByteString
variantOf TdsContext
ctx SqlValue
v
  TIUdt UdtInfo
_ -> Either String ByteString
forall {b}. Either String b
mismatch
  TypeInfo
TINull -> Either String ByteString
forall {b}. Either String b
mismatch
  TypeInfo
_ -> Either String ByteString
forall {b}. Either String b
mismatch
  where
    put :: Int -> Put.Put -> Either String B.ByteString
    put :: Int -> Put -> Either String ByteString
put Int
n Put
p = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Int -> Put -> ByteString
runPutSized Int
n Put
p)
    mismatch :: Either String b
mismatch = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"cannot copy " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SqlValue -> String
describe SqlValue
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" into a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti)
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" column; convert it in Haskell first"
    checkLength :: Int
-> ByteString -> String -> (Int -> a) -> Either String ByteString
checkLength Int
limit ByteString
bs String
what Int -> a
units
      | Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit = String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$
          String
"the value is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show (Int -> a
units (ByteString -> Int
B.length ByteString
bs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" long; the column "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" holds " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show (Int -> a
units Int
limit)
      | Bool
otherwise = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
bs

    toInt64 :: SqlValue -> Either String Int64
    toInt64 :: SqlValue -> Either String Int64
toInt64 = \case
      SqlBool Bool
b -> Int64 -> Either String Int64
forall a b. b -> Either a b
Right (if Bool
b then Int64
1 else Int64
0)
      SqlWord8 Word8
i -> Int64 -> Either String Int64
forall a b. b -> Either a b
Right (Word8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      SqlInt16 Int16
i -> Int64 -> Either String Int64
forall a b. b -> Either a b
Right (Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
      SqlInt32 Int32
i -> Int64 -> Either String Int64
forall a b. b -> Either a b
Right (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
      SqlInt64 Int64
i -> Int64 -> Either String Int64
forall a b. b -> Either a b
Right Int64
i
      SqlDecimal Decimal
d -> Integer -> Either String Int64
forall {b}. Num b => Integer -> Either String b
integral (Decimal -> Integer
forall b. Integral b => Decimal -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Decimal
d :: Integer)
      SqlMoney (Money (MkFixed Integer
m)) -> Integer -> Either String Int64
forall {b}. Num b => Integer -> Either String b
integral (Integer -> Integer
forall a. Num a => a -> a
signum Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* ((Integer -> Integer
forall a. Num a => a -> a
abs Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
5000) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10000))
      SqlFloat Float
f -> Double -> Either String Int64
real (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
f)
      SqlDouble Double
d -> Double -> Either String Int64
real Double
d
      SqlValue
_ -> Either String Int64
forall {b}. Either String b
mismatch
      where
        integral :: Integer -> Either String b
integral Integer
i
          | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
minBound :: Int64) Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64) = Either String b
forall {b}. Either String b
outOfRange
          | Bool
otherwise = b -> Either String b
forall a b. b -> Either a b
Right (Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
i)
        real :: Double -> Either String Int64
        real :: Double -> Either String Int64
real Double
d
          | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
|| Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< -Double
9223372036854775808 Bool -> Bool -> Bool
|| Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
9223372036854775808 = Either String Int64
forall {b}. Either String b
outOfRange
          | Bool
otherwise = Int64 -> Either String Int64
forall a b. b -> Either a b
Right (Double -> Int64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
d)
    intBytes :: Int -> Int64 -> Either String B.ByteString
    intBytes :: Int -> Int64 -> Either String ByteString
intBytes Int
n Int64
i
      | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
lo Bool -> Bool -> Bool
|| Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
hi = Either String ByteString
forall {b}. Either String b
outOfRange
      | Bool
otherwise = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Int -> Word64 -> ByteString
littleEndian Int
n (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i))
      where
        (Int64
lo, Int64
hi) = case Int
n of
          Int
1 -> (Int64
0, Int64
255)
          Int
2 -> (Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16
forall a. Bounded a => a
minBound :: Int16), Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16
forall a. Bounded a => a
maxBound :: Int16))
          Int
4 -> (Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: Int32), Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32))
          Int
_ -> (Int64
forall a. Bounded a => a
minBound, Int64
forall a. Bounded a => a
maxBound)
    outOfRange :: Either String b
outOfRange = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ SqlValue -> String
describe SqlValue
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is out of the range of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti)

    toBool :: SqlValue -> Either String Bool
toBool = \case
      SqlBool Bool
b -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
b
      SqlWord8 Word8
i -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Word8
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)
      SqlInt16 Int16
i -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Int16
i Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int16
0)
      SqlInt32 Int32
i -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Int32
i Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
0)
      SqlInt64 Int64
i -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0)
      SqlDecimal Decimal
d -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Decimal
d Decimal -> Decimal -> Bool
forall a. Eq a => a -> a -> Bool
/= Decimal
0)
      SqlMoney Money
m -> Bool -> Either String Bool
forall a b. b -> Either a b
Right (Money
m Money -> Money -> Bool
forall a. Eq a => a -> a -> Bool
/= Money
0)
      SqlFloat Float
f -> Float -> Either String Bool
forall a. RealFloat a => a -> Either String Bool
finiteBit Float
f
      SqlDouble Double
d -> Double -> Either String Bool
forall a. RealFloat a => a -> Either String Bool
finiteBit Double
d
      SqlValue
_ -> Either String Bool
forall {b}. Either String b
mismatch
      where
        finiteBit :: RealFloat a => a -> Either String Bool
        finiteBit :: forall a. RealFloat a => a -> Either String Bool
finiteBit a
n
          | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
n Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
n = Either String Bool
forall {b}. Either String b
outOfRange
          | Bool
otherwise = Bool -> Either String Bool
forall a b. b -> Either a b
Right (a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0)

    toDouble :: SqlValue -> Either String Double
    toDouble :: SqlValue -> Either String Double
toDouble = \case
      SqlBool Bool
b -> Double -> Either String Double
forall a b. b -> Either a b
Right (if Bool
b then Double
1 else Double
0)
      SqlWord8 Word8
i -> Double -> Either String Double
forall a b. b -> Either a b
Right (Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      SqlInt16 Int16
i -> Double -> Either String Double
forall a b. b -> Either a b
Right (Int16 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
      SqlInt32 Int32
i -> Double -> Either String Double
forall a b. b -> Either a b
Right (Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
      SqlInt64 Int64
i -> Double -> Either String Double
forall a b. b -> Either a b
Right (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      SqlDecimal Decimal
d -> Double -> Either String Double
forall a b. b -> Either a b
Right (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Decimal -> Rational
forall a. Real a => a -> Rational
toRational Decimal
d))
      SqlMoney Money
m -> Double -> Either String Double
forall a b. b -> Either a b
Right (Money -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Money
m)
      SqlFloat Float
f -> Double -> Either String Double
forall a b. b -> Either a b
Right (Float -> Double
float2Double Float
f)
      SqlDouble Double
d -> Double -> Either String Double
forall a b. b -> Either a b
Right Double
d
      SqlValue
_ -> Either String Double
forall {b}. Either String b
mismatch

    -- Exact sources must round directly to real's 24-bit precision. An
    -- intermediate Double can erase which side of a Float midpoint they
    -- lie on, so a second rounding chooses the wrong neighbor.
    toFloat :: SqlValue -> Either String Float
    toFloat :: SqlValue -> Either String Float
toFloat = \case
      SqlBool Bool
b -> Float -> Either String Float
forall a b. b -> Either a b
Right (if Bool
b then Float
1 else Float
0)
      SqlWord8 Word8
i -> Float -> Either String Float
forall a b. b -> Either a b
Right (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      SqlInt16 Int16
i -> Float -> Either String Float
forall a b. b -> Either a b
Right (Int16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
      SqlInt32 Int32
i -> Float -> Either String Float
forall a b. b -> Either a b
Right (Int32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
      SqlInt64 Int64
i -> Float -> Either String Float
forall a b. b -> Either a b
Right (Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      SqlDecimal Decimal
d -> Float -> Either String Float
forall a b. b -> Either a b
Right (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Decimal -> Rational
forall a. Real a => a -> Rational
toRational Decimal
d))
      SqlMoney Money
m -> Float -> Either String Float
forall a b. b -> Either a b
Right (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational (Money -> Rational
forall a. Real a => a -> Rational
toRational Money
m))
      SqlFloat Float
f -> Float -> Either String Float
forall a b. b -> Either a b
Right Float
f
      SqlDouble Double
d -> Float -> Either String Float
forall a b. b -> Either a b
Right (Double -> Float
double2Float Double
d)
      SqlValue
_ -> Either String Float
forall {b}. Either String b
mismatch

    toMoney :: SqlValue -> Either String Money
    toMoney :: SqlValue -> Either String Money
toMoney = \case
      SqlMoney Money
m -> Money -> Either String Money
forall a b. b -> Either a b
Right Money
m
      SqlBool Bool
b -> Money -> Either String Money
forall a b. b -> Either a b
Right (if Bool
b then Money
1 else Money
0)
      SqlWord8 Word8
i -> Money -> Either String Money
forall a b. b -> Either a b
Right (Word8 -> Money
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      SqlInt16 Int16
i -> Money -> Either String Money
forall a b. b -> Either a b
Right (Int16 -> Money
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
      SqlInt32 Int32
i -> Money -> Either String Money
forall a b. b -> Either a b
Right (Int32 -> Money
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
      SqlInt64 Int64
i -> Money -> Either String Money
forall a b. b -> Either a b
Right (Int64 -> Money
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      SqlDecimal Decimal
d -> Decimal -> Money
money (Decimal -> Money) -> Either String Decimal -> Either String Money
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> Decimal -> Either String Decimal
rescale Word8
38 Word8
4 Decimal
d
      SqlFloat Float
f -> Decimal -> Money
money (Decimal -> Money) -> Either String Decimal -> Either String Money
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Float -> Either String Decimal
forall a. RealFloat a => Word8 -> a -> Either String Decimal
roundedFloating Word8
4 Float
f
      SqlDouble Double
d -> Decimal -> Money
money (Decimal -> Money) -> Either String Decimal -> Either String Money
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Double -> Either String Decimal
forall a. RealFloat a => Word8 -> a -> Either String Decimal
roundedFloating Word8
4 Double
d
      SqlValue
_ -> Either String Money
forall {b}. Either String b
mismatch
      where
        money :: Decimal -> Money
money (Decimal Word8
_ Integer
m) = Fixed E4 -> Money
Money (Integer -> Fixed E4
forall k (a :: k). Integer -> Fixed a
MkFixed Integer
m)

    toDecimal :: Scale -> SqlValue -> Either String Decimal
    toDecimal :: Word8 -> SqlValue -> Either String Decimal
toDecimal Word8
s = \case
      SqlDecimal Decimal
d -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right Decimal
d
      SqlBool Bool
b -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (if Bool
b then Decimal
1 else Decimal
0)
      SqlWord8 Word8
i -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Word8 -> Decimal
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      SqlInt16 Int16
i -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Int16 -> Decimal
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)
      SqlInt32 Int32
i -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Int32 -> Decimal
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
      SqlInt64 Int64
i -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Int64 -> Decimal
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      SqlMoney (Money (MkFixed Integer
m)) -> Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
4 Integer
m)
      SqlFloat Float
f -> Word8 -> Float -> Either String Decimal
forall a. RealFloat a => Word8 -> a -> Either String Decimal
roundedFloating Word8
s Float
f
      SqlDouble Double
d -> Word8 -> Double -> Either String Decimal
forall a. RealFloat a => Word8 -> a -> Either String Decimal
roundedFloating Word8
s Double
d
      SqlValue
_ -> Either String Decimal
forall {b}. Either String b
mismatch

    -- Scale the exact binary rational, not the floating value: multiplying
    -- in Float or Double first discards low bits, or adds a fractional
    -- tail, even when the value fits the target exactly.  Then round half
    -- away from zero, as the server rounds a float into a decimal (0.125
    -- is 0.13), and as 'rescale' rounds a 'Decimal'.
    roundedFloating :: RealFloat a => Scale -> a -> Either String Decimal
    roundedFloating :: forall a. RealFloat a => Word8 -> a -> Either String Decimal
roundedFloating Word8
s a
n
      | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
n Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
n = Either String Decimal
forall {b}. Either String b
outOfRange
      | Bool
otherwise = Decimal -> Either String Decimal
forall a b. b -> Either a b
Right (Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
s (Rational -> Integer
halfAwayFromZero (a -> Rational
forall a. Real a => a -> Rational
toRational a
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
10 Rational -> Word8 -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
s)))
    halfAwayFromZero :: Rational -> Integer
    halfAwayFromZero :: Rational -> Integer
halfAwayFromZero Rational
r = (if Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 then Integer -> Integer
forall a. Num a => a -> a
negate else Integer -> Integer
forall a. a -> a
id) (if Rational
f Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2 then Integer
q Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 else Integer
q)
      where
        (Integer
q, Rational
f) = Rational -> (Integer, Rational)
forall b. Integral b => Rational -> (b, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Rational -> Rational
forall a. Num a => a -> a
abs Rational
r)

    -- To the scale, half away from zero (as SQL Server rounds), then
    -- within the precision.
    rescale :: Precision -> Scale -> Decimal -> Either String Decimal
    rescale :: Word8 -> Word8 -> Decimal -> Either String Decimal
rescale Word8
p Word8
s d :: Decimal
d@(Decimal Word8
sc Integer
m)
      | Int
digits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p = String -> Either String Decimal
forall a b. a -> Either a b
Left (String -> Either String Decimal)
-> String -> Either String Decimal
forall a b. (a -> b) -> a -> b
$ SqlValue -> String
describe SqlValue
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not fit " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti)
      | Bool
otherwise = Decimal -> Either String Decimal
forall a b. b -> Either a b
Right Decimal
d'
      where
        d' :: Decimal
d'@(Decimal Word8
_ Integer
m') = if
          | Word8
sc Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
s -> Decimal
d
          | Word8
sc Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
s -> Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
s (Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Word8 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Word8
s Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
sc))
          | Bool
otherwise ->
              let k :: Integer
k = Integer
10 Integer -> Word8 -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Word8
sc Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
s)
                  (Integer
q, Integer
r) = Integer -> Integer
forall a. Num a => a -> a
abs Integer
m Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
k
                  q' :: Integer
q' = if Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
k then Integer
q Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 else Integer
q
               in Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
s (Integer -> Integer
forall a. Num a => a -> a
signum Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
q')
        digits :: Int
digits = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Integer -> String
forall a. Show a => a -> String
show (Integer -> Integer
forall a. Num a => a -> a
abs Integer
m'))

    toText :: SqlValue -> Either String Text
toText = \case
      SqlText Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
      SqlXml Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
      SqlValue
_ -> Either String Text
forall {b}. Either String b
mismatch
    toBinary :: SqlValue -> Either String ByteString
toBinary = \case
      SqlBinary ByteString
b -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
b
      SqlValue
_ -> Either String ByteString
forall {b}. Either String b
mismatch
    toDay :: SqlValue -> Either String Day
toDay = \case
      SqlDate Day
d -> Day -> Either String Day
forall a b. b -> Either a b
Right Day
d
      SqlDateTime LocalTime
lt -> Day -> Either String Day
forall a b. b -> Either a b
Right (LocalTime -> Day
localDay LocalTime
lt)
      SqlDateTimeOffset DateTimeOffset
dto -> Day -> Either String Day
forall a b. b -> Either a b
Right (LocalTime -> Day
localDay (DateTimeOffset -> LocalTime
dtoLocalTime DateTimeOffset
dto))
      SqlValue
_ -> Either String Day
forall {b}. Either String b
mismatch
    toTimeOfDay :: SqlValue -> Either String TimeOfDay
toTimeOfDay = \case
      SqlTime TimeOfDay
t -> TimeOfDay -> Either String TimeOfDay
forall a b. b -> Either a b
Right TimeOfDay
t
      SqlDateTime LocalTime
lt -> TimeOfDay -> Either String TimeOfDay
forall a b. b -> Either a b
Right (LocalTime -> TimeOfDay
localTimeOfDay LocalTime
lt)
      SqlDateTimeOffset DateTimeOffset
dto -> TimeOfDay -> Either String TimeOfDay
forall a b. b -> Either a b
Right (LocalTime -> TimeOfDay
localTimeOfDay (DateTimeOffset -> LocalTime
dtoLocalTime DateTimeOffset
dto))
      SqlValue
_ -> Either String TimeOfDay
forall {b}. Either String b
mismatch
    toLocalTime :: SqlValue -> Either String LocalTime
toLocalTime = \case
      SqlDateTime LocalTime
lt -> LocalTime -> Either String LocalTime
forall a b. b -> Either a b
Right LocalTime
lt
      SqlDate Day
d -> LocalTime -> Either String LocalTime
forall a b. b -> Either a b
Right (Day -> TimeOfDay -> LocalTime
LocalTime Day
d TimeOfDay
midnight)
      SqlDateTimeOffset DateTimeOffset
dto -> LocalTime -> Either String LocalTime
forall a b. b -> Either a b
Right (DateTimeOffset -> LocalTime
dtoLocalTime DateTimeOffset
dto)
      SqlValue
_ -> Either String LocalTime
forall {b}. Either String b
mismatch
    toDateTimeOffset :: SqlValue -> Either String DateTimeOffset
toDateTimeOffset = \case
      SqlDateTimeOffset DateTimeOffset
dto -> DateTimeOffset -> Either String DateTimeOffset
forall a b. b -> Either a b
Right DateTimeOffset
dto
      SqlDateTime LocalTime
lt -> DateTimeOffset -> Either String DateTimeOffset
forall a b. b -> Either a b
Right (UTCTime -> Int16 -> DateTimeOffset
DateTimeOffset (TimeZone -> LocalTime -> UTCTime
localTimeToUTC TimeZone
utc LocalTime
lt) Int16
0)
      SqlDate Day
d -> DateTimeOffset -> Either String DateTimeOffset
forall a b. b -> Either a b
Right (UTCTime -> Int16 -> DateTimeOffset
DateTimeOffset (TimeZone -> LocalTime -> UTCTime
localTimeToUTC TimeZone
utc (Day -> TimeOfDay -> LocalTime
LocalTime Day
d TimeOfDay
midnight)) Int16
0)
      SqlValue
_ -> Either String DateTimeOffset
forall {b}. Either String b
mismatch
    dtoLocalTime :: DateTimeOffset -> LocalTime
dtoLocalTime (DateTimeOffset UTCTime
u Int16
mins) = TimeZone -> UTCTime -> LocalTime
utcToLocalTime (Int -> TimeZone
minutesToTimeZone (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
mins)) UTCTime
u

-- | The value, named for a message.
describe :: SqlValue -> String
describe :: SqlValue -> String
describe = \case
  SqlValue
SqlNull -> String
"NULL"
  SqlBool Bool
b -> String
"the bit " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
b)
  SqlWord8 Word8
i -> String
"the integer " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
i
  SqlInt16 Int16
i -> String
"the integer " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int16 -> String
forall a. Show a => a -> String
show Int16
i
  SqlInt32 Int32
i -> String
"the integer " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
i
  SqlInt64 Int64
i -> String
"the integer " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
i
  SqlFloat Float
f -> String
"the real " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
f
  SqlDouble Double
d -> String
"the float " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
d
  SqlDecimal Decimal
d -> String
"the decimal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Decimal -> String
forall a. Show a => a -> String
show Decimal
d
  SqlMoney Money
m -> String
"the money value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Money -> String
forall a. Show a => a -> String
show Money
m
  SqlGuid UUID
g -> String
"the uniqueidentifier " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UUID -> String
forall a. Show a => a -> String
show UUID
g
  SqlDateTime LocalTime
lt -> String
"the date-time " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LocalTime -> String
forall a. Show a => a -> String
show LocalTime
lt
  SqlDate Day
d -> String
"the date " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Day -> String
forall a. Show a => a -> String
show Day
d
  SqlTime TimeOfDay
t -> String
"the time " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TimeOfDay -> String
forall a. Show a => a -> String
show TimeOfDay
t
  SqlDateTimeOffset DateTimeOffset
dto -> String
"the datetimeoffset " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ZonedTime -> String
forall a. Show a => a -> String
show (DateTimeOffset -> ZonedTime
dateTimeOffsetToZonedTime DateTimeOffset
dto)
  SqlText Text
t -> String
"the string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (Int -> Text -> Text
T.take Int
40 Text
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
40 then String
"..." else String
"")
  SqlBinary ByteString
b -> String
"a binary value of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
B.length ByteString
b) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes"
  SqlXml Text
_ -> String
"an xml value"

-- | A @sql_variant@ value carrying the source's own declaration: its base
-- type, precision and scale, length, fixedness and collation, with the
-- bytes as they are.  Going through 'SqlValue' first would widen each to
-- its constructor's canonical type (@smallmoney@ to @money@, @datetime@
-- to @datetime2(7)@, @decimal(38,2)@ to a smaller precision) and replace
-- a lone surrogate.  A source outside the variant's base types (a LOB, a
-- type with no variant form) is decoded and sent as 'variantOf' sends a
-- 'SqlValue'; a UTF-16 LOB that fits goes as a bounded @nvarchar@.
variantFromSource :: TdsContext -> TypeInfo -> B.ByteString -> Either String B.ByteString
variantFromSource :: TdsContext -> TypeInfo -> ByteString -> Either String ByteString
variantFromSource TdsContext
ctx TypeInfo
source ByteString
bs = case TypeInfo
source of
  TypeInfo
_ | Just Int
4 <- TypeInfo -> Maybe Int
moneyWidth TypeInfo
source, ByteString -> Int
B.length ByteString
bsInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
4 -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x7A ByteString
B.empty
    | Just Int
n <- TypeInfo -> Maybe Int
dateTimeWidth TypeInfo
source, Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
4,Int
8] -> Word8 -> ByteString -> Either String ByteString
wrap (if Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
4 then Word8
0x3A else Word8
0x3D) ByteString
B.empty
  TIDecimalN Word8
p Word8
s | Word8
pWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>=Word8
1 Bool -> Bool -> Bool
&& Word8
pWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word8
38 Bool -> Bool -> Bool
&& Word8
sWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word8
p -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x6A ([Word8] -> ByteString
B.pack [Word8
p,Word8
s])
  TINumericN Word8
p Word8
s | Word8
pWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>=Word8
1 Bool -> Bool -> Bool
&& Word8
pWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word8
38 Bool -> Bool -> Bool
&& Word8
sWord8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word8
p -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x6C ([Word8] -> ByteString
B.pack [Word8
p,Word8
s])
  TITimeN Word8
s -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x29 (Word8 -> ByteString
B.singleton Word8
s)
  TIDateTime2N Word8
s -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x2A (Word8 -> ByteString
B.singleton Word8
s)
  TIDateTimeOffsetN Word8
s -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0x2B (Word8 -> ByteString
B.singleton Word8
s)
  TIBigChar Word16
n Collation
c | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n -> Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
0xAF Word16
n Collation
c
  TIBigVarChar Word16
n Collation
c | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n -> Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
0xA7 Word16
n Collation
c
  TINChar Word16
n Collation
c | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n Bool -> Bool -> Bool
&& Word16 -> Bool
forall a. Integral a => a -> Bool
even Word16
n Bool -> Bool -> Bool
&& Int -> Bool
forall a. Integral a => a -> Bool
even (ByteString -> Int
B.length ByteString
bs) -> Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
0xEF Word16
n Collation
c
  TINVarChar Word16
n Collation
c | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n Bool -> Bool -> Bool
&& Word16 -> Bool
forall a. Integral a => a -> Bool
even Word16
n Bool -> Bool -> Bool
&& Int -> Bool
forall a. Integral a => a -> Bool
even (ByteString -> Int
B.length ByteString
bs) -> Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
0xE7 Word16
n Collation
c
  TIBigBinary Word16
n | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0xAD (Int -> Word64 -> ByteString
littleEndian Int
2 (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n))
  TIBigVarBinary Word16
n | Word16 -> Bool
forall a. Integral a => a -> Bool
bounded Word16
n -> Word8 -> ByteString -> Either String ByteString
wrap Word8
0xA5 (Int -> Word64 -> ByteString
littleEndian Int
2 (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n))
  -- A UTF-16 LOB that fits goes as a bounded nvarchar, its code units
  -- kept rather than decoded and re-encoded.
  TypeInfo
_ | TypeInfo -> Bool
isUnicode TypeInfo
source, Int -> Bool
forall a. Integral a => a -> Bool
even (ByteString -> Int
B.length ByteString
bs), ByteString -> Int
B.length ByteString
bsInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
8000 ->
        Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
0xE7 Word16
8000 (Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0)
  TypeInfo
_ -> TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
source ByteString
bs Either String SqlValue
-> (SqlValue -> Either String ByteString)
-> Either String ByteString
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
>>= TdsContext -> SqlValue -> Either String ByteString
variantOf TdsContext
ctx
  where
    bounded :: a -> Bool
bounded a
n = a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
0 Bool -> Bool -> Bool
&& a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
8000 Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
bsInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
    wrap :: Word8 -> ByteString -> Either String ByteString
wrap Word8
base ByteString
props = do
      -- The bytes are checked as a value of the source type first.
      _ <- TypeInfo -> ByteString -> Either String SqlValue
sourceValue TypeInfo
source ByteString
bs
      Right (variantBytes base props bs)
    character :: Word8 -> Word16 -> Collation -> Either String B.ByteString
    character :: Word8 -> Word16 -> Collation -> Either String ByteString
character Word8
base Word16
n Collation
coll = do
      bytes <- if Collation
collCollation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
==Word32 -> Word8 -> Collation
Collation Word32
0 Word8
0
        then Either String ByteString
-> (ByteString -> Either String ByteString)
-> RawBytes
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"the session's collation isn't known, so a string can't be sent as sql_variant") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (TdsContext -> RawBytes
tdsCollation TdsContext
ctx)
        else ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Int -> Put -> ByteString
runPutSized Int
5 (Collation -> Put
putCollation Collation
coll))
      wrap base (bytes <> littleEndian 2 (fromIntegral n))
{-# NOINLINE variantFromSource #-}

-- A sql_variant envelope carries its base type and property bytes before
-- the payload (MS-TDS 2.2.5.5.4). A broad SqlValue uses its canonical type;
-- strings use nvarchar in the session collation, with at most 8000 bytes.
--
-- Out of line, as 'variantFromSource' is: a sql_variant column is rare, and
-- inlined at its two call sites in 'encodeBulkCell' its 18 cases were
-- about 10 KB of code each.
variantOf :: TdsContext -> SqlValue -> Either String B.ByteString
variantOf :: TdsContext -> SqlValue -> Either String ByteString
variantOf TdsContext
ctx = \case
  SqlBool Bool
b -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x32 ByteString
B.empty (Word8 -> ByteString
B.singleton (if Bool
b then Word8
1 else Word8
0)))
  SqlWord8 Word8
i -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x30 ByteString
B.empty (Word8 -> ByteString
B.singleton Word8
i))
  SqlInt16 Int16
i -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x34 ByteString
B.empty (Int -> Word64 -> ByteString
littleEndian Int
2 (Int16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i)))
  SqlInt32 Int32
i -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x38 ByteString
B.empty (Int -> Word64 -> ByteString
littleEndian Int
4 (Int32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)))
  SqlInt64 Int64
i -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x7F ByteString
B.empty (Int -> Word64 -> ByteString
littleEndian Int
8 (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)))
  SqlFloat Float
f -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x3B ByteString
B.empty (Int -> Word64 -> ByteString
littleEndian Int
4 (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Word32
castFloatToWord32 Float
f))))
  SqlDouble Double
d -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x3E ByteString
B.empty (Int -> Word64 -> ByteString
littleEndian Int
8 (Double -> Word64
castDoubleToWord64 Double
d)))
  SqlDecimal d :: Decimal
d@(Decimal Word8
s Integer
m) -> do
    let p :: Word8
p = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Integer -> String
forall a. Show a => a -> String
show (Integer -> Integer
forall a. Num a => a -> a
abs Integer
m))) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s))
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
p Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
38 Bool -> Bool -> Bool
|| Word8
s Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
38) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String
"the decimal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Decimal -> String
forall a. Show a => a -> String
show Decimal
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has more than 38 digits")
    ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x6A ([Word8] -> ByteString
B.pack [Word8
p, Word8
s]) (Int -> Put -> ByteString
runPutSized Int
17 (Word8 -> Word8 -> Decimal -> Put
putDecimal Word8
p Word8
s Decimal
d)))
  SqlMoney Money
m -> do
    (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 (Money -> Maybe String
money8Problem Money
m)
    ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x3C ByteString
B.empty (Int -> Put -> ByteString
runPutSized Int
8 (Money -> Put
putMoney8 Money
m)))
  SqlGuid UUID
g -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x24 ByteString
B.empty (Int -> Put -> ByteString
runPutSized Int
16 (UUID -> Put
putGuid UUID
g)))
  SqlDateTime LocalTime
lt -> Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x2A (Word8 -> ByteString
B.singleton Word8
7) (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Put -> ByteString
runPutSized Int
8 (Put -> ByteString)
-> Either String Put -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> LocalTime -> Either String Put
putDateTime2 Word8
7 LocalTime
lt
  SqlDate Day
d -> Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x28 ByteString
B.empty (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Put -> ByteString
runPutSized Int
3 (Put -> ByteString)
-> Either String Put -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> Either String Put
putDate Day
d
  SqlTime TimeOfDay
t -> Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x29 (Word8 -> ByteString
B.singleton Word8
7) (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Put -> ByteString
runPutSized Int
5 (Put -> ByteString)
-> Either String Put -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> TimeOfDay -> Either String Put
putTime Word8
7 TimeOfDay
t
  SqlDateTimeOffset DateTimeOffset
dto -> Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0x2B (Word8 -> ByteString
B.singleton Word8
7) (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Put -> ByteString
runPutSized Int
10 (Put -> ByteString)
-> Either String Put -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> DateTimeOffset -> Either String Put
putDateTimeOffset Word8
7 DateTimeOffset
dto
  SqlText Text
t -> do
    collation <- Either String ByteString
-> (ByteString -> Either String ByteString)
-> RawBytes
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"the session's collation isn't known, so a string can't be sent as sql_variant") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (TdsContext -> RawBytes
tdsCollation TdsContext
ctx)
    let bs = Text -> ByteString
encodeUtf16LE Text
t
    when (B.length bs > 8000) $ Left "a sql_variant string holds at most 4000 characters"
    Right (variant 0xE7 (collation <> littleEndian 2 8000) bs)
  SqlBinary ByteString
bs -> do
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8000) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"a sql_variant binary value holds at most 8000 bytes"
    ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Word8 -> ByteString -> ByteString -> ByteString
variant Word8
0xA5 (Int -> Word64 -> ByteString
littleEndian Int
2 Word64
8000) ByteString
bs)
  SqlXml Text
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"an xml value can't be sql_variant"
  SqlValue
SqlNull -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"NULL"
  where
    variant :: Word8 -> ByteString -> ByteString -> ByteString
variant = Word8 -> ByteString -> ByteString -> ByteString
variantBytes
{-# NOINLINE variantOf #-}

variantBytes :: Word8 -> B.ByteString -> B.ByteString -> B.ByteString
variantBytes :: Word8 -> ByteString -> ByteString -> ByteString
variantBytes Word8
base ByteString
props ByteString
value = [ByteString] -> ByteString
B.concat [[Word8] -> ByteString
B.pack [Word8
base, Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
props)], ByteString
props, ByteString
value]

-- | The low @n@ bytes of the word, little-endian.
littleEndian :: Int -> Word64 -> B.ByteString
littleEndian :: Int -> Word64 -> ByteString
littleEndian Int
n Word64
w = [Word8] -> ByteString
B.pack [Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` (Word64
256 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
i)) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

------------------------------------------------------------------------------
-- The message

-- | The COLMETADATA token the load starts with (the same layout the
-- server sends, MS-TDS 2.2.7.4): one token per message, written as a
-- 'Data.Binary.Put.Put'.
colMetaData :: Text -> [BulkColumn] -> B.ByteString
colMetaData :: Text -> [BulkColumn] -> ByteString
colMetaData Text
table [BulkColumn]
cols = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  Word8 -> Put
Put.putWord8 Word8
0x81
  Word16 -> Put
Put.putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([BulkColumn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BulkColumn]
cols))
  [BulkColumn] -> (BulkColumn -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BulkColumn]
cols ((BulkColumn -> Put) -> Put) -> (BulkColumn -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \BulkColumn
c -> do
    Word32 -> Put
Put.putWord32le Word32
0  -- UserType
    Word16 -> Put
Put.putWord16le (BulkColumn -> Word16
flagsOf BulkColumn
c)
    let wt :: TypeInfo
wt = TypeInfo -> TypeInfo
bulkWireType (BulkColumn -> TypeInfo
bulkColumnType BulkColumn
c)
    TdsContext -> TypeInfo -> Put
putTypeInfo TdsContext
defaultTdsContext TypeInfo
wt
    case TypeInfo
wt of
      TIText{} -> Put
tableName
      TINText{} -> Put
tableName
      TIImage{} -> Put
tableName
      TypeInfo
_ -> () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Text -> Put
putBVarChar (BulkColumn -> Text
bulkColumnName BulkColumn
c)
  where
    -- Nullable, updatable (read/write), identity.
    flagsOf :: BulkColumn -> Word16
flagsOf BulkColumn
c = (if BulkColumn -> Bool
bulkColumnNullable BulkColumn
c then Word16
0x0001 else Word16
0) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
0x0004 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (if BulkColumn -> Bool
bulkColumnIdentity BulkColumn
c then Word16
0x0010 else Word16
0) :: Word16
    tableName :: Put
tableName = Word8 -> Put
Put.putWord8 Word8
1 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Put
putUsVarChar Text
table

-- | The DONE that ends the load: DONE_FINAL, no count.
doneToken :: B.ByteString
doneToken :: ByteString
doneToken = [Word8] -> ByteString
B.pack (Word8
0xFD Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
12 Word8
0)

-- | A value in a bulk load ROW.  A PLP type is written with the
-- unknown-length total and 8000-byte chunks ('bulkPlp'); every other
-- type as 'writeValue' writes it.
bulkValue :: TypeInfo -> RawBytes -> BB.Builder
bulkValue :: TypeInfo -> RawBytes -> Builder
bulkValue TypeInfo
ti RawBytes
v = case TypeInfo -> LengthKind
lengthKind TypeInfo
ti of
  LengthKind
Plp -> RawBytes -> Builder
bulkPlp RawBytes
v
  LengthKind
_ -> TypeInfo -> RawBytes -> Builder
writeValue TypeInfo
ti RawBytes
v
{-# INLINE bulkValue #-}

-- | A PLP value for a bulk load: NULL as all-ones; otherwise the
-- unknown-length total (@0xFFFFFFFFFFFFFFFE@), the bytes in chunks of at
-- most 'bulkChunk' bytes (each a 4-byte length and its bytes), and a
-- zero-length terminator.  (SQL Server's bulk row parser refuses the
-- known-length total an RPC parameter uses, and refuses chunks longer
-- than 8000 bytes.)
bulkPlp :: RawBytes -> BB.Builder
bulkPlp :: RawBytes -> Builder
bulkPlp = \case
  RawBytes
Nothing -> Word64 -> Builder
BB.word64LE Word64
0xFFFFFFFFFFFFFFFF
  Just ByteString
bs -> Word64 -> Builder
BB.word64LE Word64
0xFFFFFFFFFFFFFFFE Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
chunks ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
0
  where
    chunks :: ByteString -> Builder
chunks ByteString
b
      | ByteString -> Bool
B.null ByteString
b = Builder
forall a. Monoid a => a
mempty
      | Bool
otherwise = let (ByteString
c, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
bulkChunk ByteString
b in Word32 -> Builder
BB.word32LE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
c)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.byteString ByteString
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
chunks ByteString
rest
{-# INLINE bulkPlp #-}

-- | The largest PLP chunk a bulk load sends (SQL Server's limit).
bulkChunk :: Int
bulkChunk :: Int
bulkChunk = Int
8000

-- | Write one ROW token.  Consecutive in-memory cells share one Builder, and so
-- one run into the packet buffer, rather than one each.  A lazy or streamed cell
-- flushes what came before it as its prefix before its source runs, so nothing
-- keeps an earlier cell's bytes alive while a source is being read.
writeRow :: PacketWriter -> [TypeInfo] -> [ParamValue] -> IO ()
-- A row whose cells are all in memory and none PLP, the usual kind, is poked into
-- the packet, with its size and its pokes both from 'cellFrame'.  Through a Builder
-- per row it cost about 1,300 bytes and 250 ns per row of an int, an nvarchar(50)
-- and a decimal, in the Builder's closures for each cell, by ticky; the original
-- row walk poked, at 179 bytes and 66 ns.  Strict prefixes for the lengths
-- ('BB.word8' of a computed length, as a 'BP.FixedPrim') saved nothing, and a
-- cheaper 'writeBuilder' could reach only its own 129 bytes per row.  Choosing each
-- column's encoder once per batch, rather than dispatching on its length kind per
-- cell, was measured and rejected: the bulk framing benchmarks allocated 3% more,
-- and their time stayed within the noise.
writeRow :: PacketWriter -> [TypeInfo] -> [ParamValue] -> IO ()
writeRow PacketWriter
out [TypeInfo]
tis [ParamValue]
values
  | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = PacketWriter -> Int -> (Ptr Word8 -> IO ()) -> IO ()
unsafeWriteSized PacketWriter
out Int
size ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
p Int
0 (Word8
0xD1 :: Word8) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Word8 -> Int -> [TypeInfo] -> [ParamValue] -> IO ()
forall {a}. Ptr a -> Int -> [TypeInfo] -> [ParamValue] -> IO ()
pokeCells Ptr Word8
p Int
1 [TypeInfo]
tis [ParamValue]
values
  | Bool
otherwise = Builder -> [TypeInfo] -> [ParamValue] -> IO ()
go (Word8 -> Builder
BB.word8 Word8
0xD1) [TypeInfo]
tis [ParamValue]
values
  where
    size :: Int
size = Int -> [TypeInfo] -> [ParamValue] -> Int
sized Int
1 [TypeInfo]
tis [ParamValue]
values
    -- The row's size if it can be poked, and otherwise 0.
    sized :: Int -> [TypeInfo] -> [ParamValue] -> Int
sized !Int
n (TypeInfo
ti : [TypeInfo]
tis') (ParamBytes RawBytes
bytes : [ParamValue]
values')
      | LengthKind
Plp <- TypeInfo -> LengthKind
lengthKind TypeInfo
ti = Int
0
      | (Int
width, Word64
_, ByteString
payload) <- TypeInfo -> RawBytes -> (Int, Word64, ByteString)
cellFrame TypeInfo
ti RawBytes
bytes = Int -> [TypeInfo] -> [ParamValue] -> Int
sized (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
payload) [TypeInfo]
tis' [ParamValue]
values'
    sized Int
n [] [] = Int
n
    sized Int
_ [TypeInfo]
_ [ParamValue]
_ = Int
0
    pokeCells :: Ptr a -> Int -> [TypeInfo] -> [ParamValue] -> IO ()
pokeCells Ptr a
p !Int
at (TypeInfo
ti : [TypeInfo]
tis') (ParamBytes RawBytes
bytes : [ParamValue]
values')
      | (Int
width, Word64
prefix, ByteString
payload) <- TypeInfo -> RawBytes -> (Int, Word64, ByteString)
cellFrame TypeInfo
ti RawBytes
bytes = do
          Ptr a -> Int -> Int -> Word64 -> IO ()
forall {t} {t} {b}.
(Integral t, Bits t, Num t, Ord t) =>
Ptr b -> Int -> t -> t -> IO ()
pokePrefix Ptr a
p Int
at Int
width Word64
prefix
          -- unsafeWithForeignPtr, as PacketWriter's own copy does: the copy can't
          -- diverge, and unsafeUseAsCString built a closure for keepAlive# per cell.
          case ByteString
payload of
            BI.BS ForeignPtr Word8
src Int
n -> ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
BI.unsafeWithForeignPtr ForeignPtr Word8
src ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
from -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes (Ptr a
p Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width)) Ptr Word8
from Int
n
          Ptr a -> Int -> [TypeInfo] -> [ParamValue] -> IO ()
pokeCells Ptr a
p (Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
payload) [TypeInfo]
tis' [ParamValue]
values'
    pokeCells Ptr a
_ Int
_ [TypeInfo]
_ [ParamValue]
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    pokePrefix :: Ptr b -> Int -> t -> t -> IO ()
pokePrefix Ptr b
p !Int
at !t
width !t
prefix
      | t
width t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          Ptr b -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
p Int
at (t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
prefix :: Word8)
          Ptr b -> Int -> t -> t -> IO ()
pokePrefix Ptr b
p (Int
at Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
width t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (t
prefix t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
    go :: Builder -> [TypeInfo] -> [ParamValue] -> IO ()
go Builder
prefix (TypeInfo
ti : [TypeInfo]
tis') (ParamValue
value : [ParamValue]
values') = case ParamValue
value of
      ParamBytes RawBytes
bytes -> Builder -> [TypeInfo] -> [ParamValue] -> IO ()
go (Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TypeInfo -> RawBytes -> Builder
bulkValue TypeInfo
ti RawBytes
bytes) [TypeInfo]
tis' [ParamValue]
values'
      ParamValue
_ -> PacketWriter -> Builder -> TypeInfo -> ParamValue -> IO ()
writeParamValueWith PacketWriter
out Builder
prefix TypeInfo
ti ParamValue
value IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> [TypeInfo] -> [ParamValue] -> IO ()
go Builder
forall a. Monoid a => a
mempty [TypeInfo]
tis' [ParamValue]
values'
    go Builder
prefix [TypeInfo]
_ [ParamValue]
_ = PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
out Builder
prefix

-- | A non-PLP cell held in memory as 'writeValue' writes it: the width in bytes of
-- its length prefix, the prefix's value, little-endian, and the bytes after it.  This
-- is the poked row's one description of a cell, and it must agree with 'writeValue',
-- which "Wire.BulkPacketsSpec" checks.
cellFrame :: TypeInfo -> RawBytes -> (Int, Word64, B.ByteString)
cellFrame :: TypeInfo -> RawBytes -> (Int, Word64, ByteString)
cellFrame TypeInfo
ti RawBytes
value = case (TypeInfo -> LengthKind
lengthKind TypeInfo
ti, RawBytes
value) of
  (LengthKind
ByteLen, RawBytes
Nothing) -> (Int
1, Word64
0, ByteString
B.empty)
  (LengthKind
ByteLen, Just ByteString
bs) -> (Int
1, ByteString -> Word64
len ByteString
bs, ByteString
bs)
  (LengthKind
UShortCharBin, RawBytes
Nothing) -> (Int
2, Word64
0xFFFF, ByteString
B.empty)
  (LengthKind
UShortCharBin, Just ByteString
bs) -> (Int
2, ByteString -> Word64
len ByteString
bs, ByteString
bs)
  (LengthKind
LongLen, RawBytes
Nothing) -> (Int
4, Word64
0xFFFFFFFF, ByteString
B.empty)
  (LengthKind
LongLen, Just ByteString
bs) -> (Int
4, ByteString -> Word64
len ByteString
bs, ByteString
bs)
  (LengthKind
VariantLen, RawBytes
Nothing) -> (Int
4, Word64
0, ByteString
B.empty)
  (LengthKind
VariantLen, Just ByteString
bs) -> (Int
4, ByteString -> Word64
len ByteString
bs, ByteString
bs)
  (Fixed Int
_, Just ByteString
bs) -> (Int
0, Word64
0, ByteString
bs)
  -- 'NoValue', a NULL of a fixed type (ruled out by 'lengthProblem'), and PLP, which
  -- the caller never pokes, write nothing here.
  (LengthKind, RawBytes)
_ -> (Int
0, Word64
0, ByteString
B.empty)
  where len :: ByteString -> Word64
len = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (ByteString -> Int) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length
{-# INLINE cellFrame #-}

-- | The packets of a bulk load message for these columns and rows (each
-- row's values converted already, as 'encodeBulkCell' gives them), as
-- 'bulkInsertS' sends them: COLMETADATA, a ROW per row, and the DONE,
-- framed into packets of the context's size.  For tests and benchmarks.
bulkLoadPackets :: TdsContext -> Text -> [BulkColumn] -> [[RawBytes]] -> [B.ByteString]
bulkLoadPackets :: TdsContext -> Text -> [BulkColumn] -> [[RawBytes]] -> [ByteString]
bulkLoadPackets TdsContext
ctx Text
table [BulkColumn]
cols [[RawBytes]]
rows = IO [ByteString] -> [ByteString]
forall a. IO a -> a
unsafePerformIO (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ do
  acc <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []
  let tis = (BulkColumn -> TypeInfo) -> [BulkColumn] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInfo -> TypeInfo
bulkWireType (TypeInfo -> TypeInfo)
-> (BulkColumn -> TypeInfo) -> BulkColumn -> TypeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BulkColumn -> TypeInfo
bulkColumnType) [BulkColumn]
cols
  runPacketWriter ctx PTBulkLoad (\ByteString
p -> IORef [ByteString] -> ([ByteString] -> [ByteString]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [ByteString]
acc (ByteString
p ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)) $ \PacketWriter
out -> do
    PacketWriter -> ByteString -> IO ()
writeBytes PacketWriter
out (Text -> [BulkColumn] -> ByteString
colMetaData Text
table [BulkColumn]
cols)
    ([RawBytes] -> IO ()) -> [[RawBytes]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PacketWriter -> [TypeInfo] -> [ParamValue] -> IO ()
writeRow PacketWriter
out [TypeInfo]
tis ([ParamValue] -> IO ())
-> ([RawBytes] -> [ParamValue]) -> [RawBytes] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawBytes -> ParamValue) -> [RawBytes] -> [ParamValue]
forall a b. (a -> b) -> [a] -> [b]
map RawBytes -> ParamValue
ParamBytes) [[RawBytes]]
rows
    PacketWriter -> ByteString -> IO ()
writeBytes PacketWriter
out ByteString
doneToken
  reverse <$> readIORef acc