{-# LANGUAGE MagicHash #-}
{-# LANGUAGE QualifiedDo #-}
-- | Column/parameter type descriptors and the length-prefixed value encodings
-- that go with them.
--
-- [MS-TDS 2.2.5.4 Data Type Definitions](https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/ffb02215-af07-4b50-8545-1fd522106c68)
module Hmssql.Tds.TypeInfo
  ( TypeInfo (..)
  , XmlSchema (..)
  , UdtInfo (..)
  , maxLength
  , RawBytes
  , readDecimalInfo
  , readTypeInfo
  , putTypeInfo
  , putValue
  , putValueUnchecked
  , LengthKind (..)
  , lengthKind
  , valueProblem
  , typeInfoProblem
  , typeInfoSqlName
  , isNullableType
    -- * The wire layouts, written to any sink
  , writeTypeInfo
  , writeValue
  ) where

import Control.Monad (when)
import Data.Binary.Put (Put)
import qualified Data.Binary.Put as Put
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Internal as BBI
import qualified Data.ByteString as B
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word16, Word32, Word8)
import Text.Printf (printf)

import Hmssql.Internal.Derived
import qualified Hmssql.Tds.Parser as P
import qualified Hmssql.Tds.Parser.OutOfLine as O
import Hmssql.Tds.Context
import Hmssql.Tds.Primitives
import qualified Hmssql.Tds.Utf16 as Utf16

-- | Sentinel length for @varchar(max)@, @nvarchar(max)@, @varbinary(max)@.
maxLength :: Word16
maxLength :: Word16
maxLength = Word16
0xFFFF

-- | The schema collection of a typed @xml@ column or parameter.
data XmlSchema = XmlSchema
  { XmlSchema -> Text
xmlDbName :: !Text
  , XmlSchema -> Text
xmlOwningSchema :: !Text
  , XmlSchema -> Text
xmlSchemaCollection :: !Text
  }

instance Show XmlSchema where
  showsPrec :: Int -> XmlSchema -> ShowS
showsPrec Int
p (XmlSchema Text
a Text
b Text
c) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"XmlSchema"#
    [ Addr#
"xmlDbName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
a, Addr#
"xmlOwningSchema"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
b, Addr#
"xmlSchemaCollection"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
c ]
  {-# OPAQUE showsPrec #-}

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

-- | MS-TDS 2.2.5.5.2 UDT_INFO, as the server sends it in COLMETADATA
-- and RETURNVALUE.
data UdtInfo = UdtInfo
  { UdtInfo -> Word16
udtMaxLength :: !Word16
    -- ^ The largest serialized value in bytes, 0xFFFF if unlimited.  The
    -- values themselves are always PLP.
  , UdtInfo -> Text
udtDbName :: !Text
  , UdtInfo -> Text
udtSchemaName :: !Text
  , UdtInfo -> Text
udtTypeName :: !Text
  , UdtInfo -> Text
udtAssemblyQualifiedName :: !Text
  }

instance Show UdtInfo where
  showsPrec :: Int -> UdtInfo -> ShowS
showsPrec Int
p (UdtInfo Word16
a Text
b Text
c Text
e Text
f) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"UdtInfo"#
    [ Addr#
"udtMaxLength"# Addr# -> Word16 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word16
a, Addr#
"udtDbName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
b, Addr#
"udtSchemaName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
c, Addr#
"udtTypeName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
e
    , Addr#
"udtAssemblyQualifiedName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
f
    ]
  {-# OPAQUE showsPrec #-}

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

-- | A type as the wire describes it (MS-TDS 2.2.5.4 TYPE_INFO): the
-- token's type byte with its length, precision and scale, or collation,
-- as the server sends it in COLMETADATA and a client sends it for a
-- parameter.  The wire has fewer types than T-SQL (@int@ arrives as
-- @TIIntN 4@ or @TIInt4@; @json@ and @vector@ as character types):
-- "Hmssql.SqlType" names the declared type.  'Hmssql.Encoding.RawParam' takes one to send
-- a value with a wire type of your choosing.
data TypeInfo
  = TINull                              -- ^ 0x1F
  | TIBit                               -- ^ 0x32
  | TIInt1                              -- ^ 0x30
  | TIInt2                              -- ^ 0x34
  | TIInt4                              -- ^ 0x38
  | TIInt8                              -- ^ 0x7F
  | TIMoney4                            -- ^ 0x7A
  | TIMoney8                            -- ^ 0x3C
  | TIDateTime4                         -- ^ 0x3A
  | TIDateTime8                         -- ^ 0x3D
  | TIFlt4                              -- ^ 0x3B
  | TIFlt8                              -- ^ 0x3E

  | TIBitN                              -- ^ 0x68
  | TIIntN !Word8                       -- ^ 0x26, length 1/2/4/8
  | TIMoneyN !Word8                     -- ^ 0x6E, length 4/8
  | TIDateTimeN !Word8                  -- ^ 0x6F, length 4/8
  | TIFltN !Word8                       -- ^ 0x6D, length 4/8

  | TIGuid                              -- ^ 0x24
  | TIDecimalN !Precision !Scale        -- ^ 0x6A
  | TINumericN !Precision !Scale        -- ^ 0x6C

  | TIDateN                             -- ^ 0x28
  | TITimeN !Scale                      -- ^ 0x29
  | TIDateTime2N !Scale                 -- ^ 0x2A
  | TIDateTimeOffsetN !Scale            -- ^ 0x2B

  | TIBigChar !Word16 !Collation        -- ^ 0xAF
  | TIBigVarChar !Word16 !Collation     -- ^ 0xA7, 0xFFFF = max
  | TIText !Word32 !Collation           -- ^ 0x23
  | TINChar !Word16 !Collation          -- ^ 0xEF
  | TINVarChar !Word16 !Collation       -- ^ 0xE7, 0xFFFF = max
  | TINText !Word32 !Collation          -- ^ 0x63

  | TIBigBinary !Word16                 -- ^ 0xAD
  | TIBigVarBinary !Word16              -- ^ 0xA5, 0xFFFF = max
  | TIImage !Word32                     -- ^ 0x22

  | TIXml !(Maybe XmlSchema)            -- ^ 0xF1
  | TISqlVariant !Word32                -- ^ 0x62
  | TIUdt !UdtInfo
    -- ^ 0xF0, a CLR user-defined type (@hierarchyid@, @geometry@,
    -- @geography@, ...).  Parsed so a result containing one can be read
    -- past, but not decoded ("Hmssql.Decoding" rejects it except as raw
    -- bytes) nor sent ('typeInfoProblem').

instance Show TypeInfo where
  showsPrec :: Int -> TypeInfo -> ShowS
showsPrec Int
p = \case
    TypeInfo
TINull -> [Char] -> ShowS
showString [Char]
"TINull"
    TypeInfo
TIBit -> [Char] -> ShowS
showString [Char]
"TIBit"
    TypeInfo
TIInt1 -> [Char] -> ShowS
showString [Char]
"TIInt1"
    TypeInfo
TIInt2 -> [Char] -> ShowS
showString [Char]
"TIInt2"
    TypeInfo
TIInt4 -> [Char] -> ShowS
showString [Char]
"TIInt4"
    TypeInfo
TIInt8 -> [Char] -> ShowS
showString [Char]
"TIInt8"
    TypeInfo
TIMoney4 -> [Char] -> ShowS
showString [Char]
"TIMoney4"
    TypeInfo
TIMoney8 -> [Char] -> ShowS
showString [Char]
"TIMoney8"
    TypeInfo
TIDateTime4 -> [Char] -> ShowS
showString [Char]
"TIDateTime4"
    TypeInfo
TIDateTime8 -> [Char] -> ShowS
showString [Char]
"TIDateTime8"
    TypeInfo
TIFlt4 -> [Char] -> ShowS
showString [Char]
"TIFlt4"
    TypeInfo
TIFlt8 -> [Char] -> ShowS
showString [Char]
"TIFlt8"
    TypeInfo
TIBitN -> [Char] -> ShowS
showString [Char]
"TIBitN"
    TIIntN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIIntN"# Precision
a
    TIMoneyN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIMoneyN"# Precision
a
    TIDateTimeN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIDateTimeN"# Precision
a
    TIFltN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIFltN"# Precision
a
    TypeInfo
TIGuid -> [Char] -> ShowS
showString [Char]
"TIGuid"
    TIDecimalN Precision
a Precision
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TIDecimalN"# [Precision -> Arg
forall a. Show a => a -> Arg
Arg Precision
a, Precision -> Arg
forall a. Show a => a -> Arg
Arg Precision
b]
    TINumericN Precision
a Precision
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TINumericN"# [Precision -> Arg
forall a. Show a => a -> Arg
Arg Precision
a, Precision -> Arg
forall a. Show a => a -> Arg
Arg Precision
b]
    TypeInfo
TIDateN -> [Char] -> ShowS
showString [Char]
"TIDateN"
    TITimeN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TITimeN"# Precision
a
    TIDateTime2N Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIDateTime2N"# Precision
a
    TIDateTimeOffsetN Precision
a -> Int -> Addr# -> Precision -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIDateTimeOffsetN"# Precision
a
    TIBigChar Word16
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TIBigChar"# [Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TIBigVarChar Word16
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TIBigVarChar"# [Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TIText Word32
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TIText"# [Word32 -> Arg
forall a. Show a => a -> Arg
Arg Word32
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TINChar Word16
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TINChar"# [Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TINVarChar Word16
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TINVarChar"# [Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TINText Word32
a Collation
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"TINText"# [Word32 -> Arg
forall a. Show a => a -> Arg
Arg Word32
a, Collation -> Arg
forall a. Show a => a -> Arg
Arg Collation
b]
    TIBigBinary Word16
a -> Int -> Addr# -> Word16 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIBigBinary"# Word16
a
    TIBigVarBinary Word16
a -> Int -> Addr# -> Word16 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIBigVarBinary"# Word16
a
    TIImage Word32
a -> Int -> Addr# -> Word32 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIImage"# Word32
a
    TIXml Maybe XmlSchema
a -> Int -> Addr# -> Maybe XmlSchema -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIXml"# Maybe XmlSchema
a
    TISqlVariant Word32
a -> Int -> Addr# -> Word32 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TISqlVariant"# Word32
a
    TIUdt UdtInfo
a -> Int -> Addr# -> UdtInfo -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TIUdt"# UdtInfo
a
  {-# OPAQUE showsPrec #-}

instance Eq TypeInfo where
  TypeInfo
x == :: TypeInfo -> TypeInfo -> Bool
== TypeInfo
y = case (TypeInfo
x, TypeInfo
y) of
    (TypeInfo
TINull, TypeInfo
TINull) -> Bool
True
    (TypeInfo
TIBit, TypeInfo
TIBit) -> Bool
True
    (TypeInfo
TIInt1, TypeInfo
TIInt1) -> Bool
True
    (TypeInfo
TIInt2, TypeInfo
TIInt2) -> Bool
True
    (TypeInfo
TIInt4, TypeInfo
TIInt4) -> Bool
True
    (TypeInfo
TIInt8, TypeInfo
TIInt8) -> Bool
True
    (TypeInfo
TIMoney4, TypeInfo
TIMoney4) -> Bool
True
    (TypeInfo
TIMoney8, TypeInfo
TIMoney8) -> Bool
True
    (TypeInfo
TIDateTime4, TypeInfo
TIDateTime4) -> Bool
True
    (TypeInfo
TIDateTime8, TypeInfo
TIDateTime8) -> Bool
True
    (TypeInfo
TIFlt4, TypeInfo
TIFlt4) -> Bool
True
    (TypeInfo
TIFlt8, TypeInfo
TIFlt8) -> Bool
True
    (TypeInfo
TIBitN, TypeInfo
TIBitN) -> Bool
True
    (TIIntN Precision
a, TIIntN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIMoneyN Precision
a, TIMoneyN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIDateTimeN Precision
a, TIDateTimeN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIFltN Precision
a, TIFltN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TypeInfo
TIGuid, TypeInfo
TIGuid) -> Bool
True
    (TIDecimalN Precision
a Precision
b, TIDecimalN Precision
a' Precision
b') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a' Bool -> Bool -> Bool
&& Precision
b Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
b'
    (TINumericN Precision
a Precision
b, TINumericN Precision
a' Precision
b') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a' Bool -> Bool -> Bool
&& Precision
b Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
b'
    (TypeInfo
TIDateN, TypeInfo
TIDateN) -> Bool
True
    (TITimeN Precision
a, TITimeN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIDateTime2N Precision
a, TIDateTime2N Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIDateTimeOffsetN Precision
a, TIDateTimeOffsetN Precision
a') -> Precision
a Precision -> Precision -> Bool
forall a. Eq a => a -> a -> Bool
== Precision
a'
    (TIBigChar Word16
a Collation
b, TIBigChar Word16
a' Collation
b') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TIBigVarChar Word16
a Collation
b, TIBigVarChar Word16
a' Collation
b') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TIText Word32
a Collation
b, TIText Word32
a' Collation
b') -> Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TINChar Word16
a Collation
b, TINChar Word16
a' Collation
b') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TINVarChar Word16
a Collation
b, TINVarChar Word16
a' Collation
b') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TINText Word32
a Collation
b, TINText Word32
a' Collation
b') -> Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
a' Bool -> Bool -> Bool
&& Collation -> Collation -> Bool
forall a. Eq a => a -> a -> Bool
eq Collation
b Collation
b'
    (TIBigBinary Word16
a, TIBigBinary Word16
a') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a'
    (TIBigVarBinary Word16
a, TIBigVarBinary Word16
a') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a'
    (TIImage Word32
a, TIImage Word32
a') -> Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
a'
    (TIXml Maybe XmlSchema
a, TIXml Maybe XmlSchema
a') -> Maybe XmlSchema -> Maybe XmlSchema -> Bool
forall a. Eq a => a -> a -> Bool
eq Maybe XmlSchema
a Maybe XmlSchema
a'
    (TISqlVariant Word32
a, TISqlVariant Word32
a') -> Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
a'
    (TIUdt UdtInfo
a, TIUdt UdtInfo
a') -> UdtInfo -> UdtInfo -> Bool
forall a. Eq a => a -> a -> Bool
eq UdtInfo
a UdtInfo
a'
    (TypeInfo, TypeInfo)
_ -> Bool
False
  {-# OPAQUE (==) #-}

-- | Whether the wire encoding of this type can carry NULL.
isNullableType :: TypeInfo -> Bool
isNullableType :: TypeInfo -> Bool
isNullableType = \case
  TypeInfo
TIBit -> Bool
False
  TypeInfo
TIInt1 -> Bool
False
  TypeInfo
TIInt2 -> Bool
False
  TypeInfo
TIInt4 -> Bool
False
  TypeInfo
TIInt8 -> Bool
False
  TypeInfo
TIMoney4 -> Bool
False
  TypeInfo
TIMoney8 -> Bool
False
  TypeInfo
TIDateTime4 -> Bool
False
  TypeInfo
TIDateTime8 -> Bool
False
  TypeInfo
TIFlt4 -> Bool
False
  TypeInfo
TIFlt8 -> Bool
False
  TypeInfo
_ -> Bool
True

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

-- | A column's or parameter's TYPE_INFO, as COLMETADATA and RETURNVALUE carry it.
readTypeInfo :: P.Parser TypeInfo
readTypeInfo :: Parser TypeInfo
readTypeInfo = Parser Precision
O.word8 Parser Precision
-> (Precision -> Parser TypeInfo) -> Parser TypeInfo
forall env a b. Recipe env a -> (a -> Recipe env b) -> Recipe env b
O.>>= \case
  Precision
0x1F -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TINull
  Precision
0x32 -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIBit
  Precision
0x30 -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIInt1
  Precision
0x34 -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIInt2
  Precision
0x38 -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIInt4
  Precision
0x7F -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIInt8
  Precision
0x7A -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIMoney4
  Precision
0x3C -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIMoney8
  Precision
0x3A -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIDateTime4
  Precision
0x3D -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIDateTime8
  Precision
0x3B -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIFlt4
  Precision
0x3E -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIFlt8

  Precision
0x68 -> TypeInfo
TIBitN TypeInfo -> Parser Precision -> Parser TypeInfo
forall a env b. a -> Recipe env b -> Recipe env a
O.<$ Parser Precision
O.word8
  Precision
0x26 -> Precision -> TypeInfo
TIIntN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> [Precision] -> Parser Precision
forall {t :: * -> *}. Foldable t => t Precision -> Parser Precision
lengthIn [Precision
1, Precision
2, Precision
4, Precision
8]
  Precision
0x6E -> Precision -> TypeInfo
TIMoneyN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> [Precision] -> Parser Precision
forall {t :: * -> *}. Foldable t => t Precision -> Parser Precision
lengthIn [Precision
4, Precision
8]
  Precision
0x6F -> Precision -> TypeInfo
TIDateTimeN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> [Precision] -> Parser Precision
forall {t :: * -> *}. Foldable t => t Precision -> Parser Precision
lengthIn [Precision
4, Precision
8]
  Precision
0x6D -> Precision -> TypeInfo
TIFltN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> [Precision] -> Parser Precision
forall {t :: * -> *}. Foldable t => t Precision -> Parser Precision
lengthIn [Precision
4, Precision
8]

  Precision
0x24 -> TypeInfo
TIGuid TypeInfo -> Parser Precision -> Parser TypeInfo
forall a env b. a -> Recipe env b -> Recipe env a
O.<$ [Precision] -> Parser Precision
forall {t :: * -> *}. Foldable t => t Precision -> Parser Precision
lengthIn [Precision
16]
  Precision
0x6A -> Parser Precision
O.word8 Parser Precision -> Parser TypeInfo -> Parser TypeInfo
forall env a b. Recipe env a -> Recipe env b -> Recipe env b
O.*> (Precision -> Precision -> TypeInfo) -> Parser TypeInfo
forall a. (Precision -> Precision -> a) -> Parser a
readDecimalInfo Precision -> Precision -> TypeInfo
TIDecimalN
  Precision
0x6C -> Parser Precision
O.word8 Parser Precision -> Parser TypeInfo -> Parser TypeInfo
forall env a b. Recipe env a -> Recipe env b -> Recipe env b
O.*> (Precision -> Precision -> TypeInfo) -> Parser TypeInfo
forall a. (Precision -> Precision -> a) -> Parser a
readDecimalInfo Precision -> Precision -> TypeInfo
TINumericN

  Precision
0x28 -> TypeInfo -> Parser TypeInfo
forall a. a -> Recipe () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo
TIDateN
  Precision
0x29 -> Precision -> TypeInfo
TITimeN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Parser Precision
getScale
  Precision
0x2A -> Precision -> TypeInfo
TIDateTime2N (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Parser Precision
getScale
  Precision
0x2B -> Precision -> TypeInfo
TIDateTimeOffsetN (Precision -> TypeInfo) -> Parser Precision -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Parser Precision
getScale

  Precision
0xAF -> Word16 -> Collation -> TypeInfo
TIBigChar (Word16 -> Collation -> TypeInfo)
-> Recipe () Word16 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)
  Precision
0xA7 -> Word16 -> Collation -> TypeInfo
TIBigVarChar (Word16 -> Collation -> TypeInfo)
-> Recipe () Word16 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)
  Precision
0x23 -> Word32 -> Collation -> TypeInfo
TIText (Word32 -> Collation -> TypeInfo)
-> Recipe () Word32 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)
  Precision
0xEF -> Word16 -> Collation -> TypeInfo
TINChar (Word16 -> Collation -> TypeInfo)
-> Recipe () Word16 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)
  Precision
0xE7 -> Word16 -> Collation -> TypeInfo
TINVarChar (Word16 -> Collation -> TypeInfo)
-> Recipe () Word16 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)
  Precision
0x63 -> Word32 -> Collation -> TypeInfo
TINText (Word32 -> Collation -> TypeInfo)
-> Recipe () Word32 -> Recipe () (Collation -> TypeInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Collation -> TypeInfo)
-> Recipe () Collation -> Parser TypeInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> (Word32 -> Precision -> Collation
Collation (Word32 -> Precision -> Collation)
-> Recipe () Word32 -> Recipe () (Precision -> Collation)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le Recipe () (Precision -> Collation)
-> Parser Precision -> Recipe () Collation
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Parser Precision
O.word8)

  Precision
0xAD -> Word16 -> TypeInfo
TIBigBinary (Word16 -> TypeInfo) -> Recipe () Word16 -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le
  Precision
0xA5 -> Word16 -> TypeInfo
TIBigVarBinary (Word16 -> TypeInfo) -> Recipe () Word16 -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le
  Precision
0x22 -> Word32 -> TypeInfo
TIImage (Word32 -> TypeInfo) -> Recipe () Word32 -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le

  Precision
0xF1 -> O.do
    present <- Parser Precision
O.word8
    if present == 0
      then pure $ TIXml Nothing
      else TIXml . Just O.<$> (XmlSchema O.<$> P.bVarChar O.<*> P.bVarChar O.<*> P.usVarChar)
  Precision
0x62 -> Word32 -> TypeInfo
TISqlVariant (Word32 -> TypeInfo) -> Recipe () Word32 -> Parser TypeInfo
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word32
O.word32le

  Precision
0xF0 -> (UdtInfo -> TypeInfo) -> Recipe () UdtInfo -> Parser TypeInfo
forall a b. (a -> b) -> Recipe () a -> Recipe () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UdtInfo -> TypeInfo
TIUdt (Recipe () UdtInfo -> Parser TypeInfo)
-> Recipe () UdtInfo -> Parser TypeInfo
forall a b. (a -> b) -> a -> b
$
    Word16 -> Text -> Text -> Text -> Text -> UdtInfo
UdtInfo (Word16 -> Text -> Text -> Text -> Text -> UdtInfo)
-> Recipe () Word16
-> Recipe () (Text -> Text -> Text -> Text -> UdtInfo)
forall a b env. (a -> b) -> Recipe env a -> Recipe env b
O.<$> Recipe () Word16
O.word16le Recipe () (Text -> Text -> Text -> Text -> UdtInfo)
-> Recipe () Text -> Recipe () (Text -> Text -> Text -> UdtInfo)
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Recipe () Text
P.bVarChar Recipe () (Text -> Text -> Text -> UdtInfo)
-> Recipe () Text -> Recipe () (Text -> Text -> UdtInfo)
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Recipe () Text
P.bVarChar Recipe () (Text -> Text -> UdtInfo)
-> Recipe () Text -> Recipe () (Text -> UdtInfo)
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Recipe () Text
P.bVarChar Recipe () (Text -> UdtInfo) -> Recipe () Text -> Recipe () UdtInfo
forall env a b. Recipe env (a -> b) -> Recipe env a -> Recipe env b
O.<*> Recipe () Text
P.usVarChar
  Precision
0xF3 -> [Char] -> Parser TypeInfo
forall a. [Char] -> Recipe () a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"readTypeInfo: table-valued parameters are not supported"
  Precision
code -> [Char] -> Parser TypeInfo
forall a. [Char] -> Recipe () a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser TypeInfo) -> [Char] -> Parser TypeInfo
forall a b. (a -> b) -> a -> b
$ [Char]
"readTypeInfo: unknown data type 0x" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> Precision -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%02x" Precision
code
  where
    lengthIn :: t Precision -> Parser Precision
lengthIn t Precision
allowed = O.do
      len <- Parser Precision
O.word8
      when (len `notElem` allowed) $
        fail $ "readTypeInfo: invalid length " ++ show len
      pure len
    getScale :: Parser Precision
getScale = O.do
      s <- Parser Precision
O.word8
      when (s > 7) $ fail $ "readTypeInfo: invalid scale " ++ show s
      pure s

-- | Precision and scale of @decimal@ / @numeric@, which must satisfy
-- 1 <= precision <= 38 and scale <= precision (MS-TDS 2.2.5.5.1.3).
readDecimalInfo :: (Precision -> Scale -> a) -> P.Parser a
readDecimalInfo :: forall a. (Precision -> Precision -> a) -> Parser a
readDecimalInfo Precision -> Precision -> a
mk = O.do
  p <- Parser Precision
O.word8
  s <- O.word8
  when (p < 1 || p > 38) $ fail $ "invalid decimal precision " ++ show p
  when (s > p) $ fail $ "invalid decimal scale " ++ show s ++ " for precision " ++ show p
  pure (mk p s)

-- | TYPE_INFO as a 'Put': 'writeTypeInfo'.
putTypeInfo :: TdsContext -> TypeInfo -> Put
putTypeInfo :: TdsContext -> TypeInfo -> Put
putTypeInfo TdsContext
_ctx = Builder -> Put
Put.putBuilder (Builder -> Put) -> (TypeInfo -> Builder) -> TypeInfo -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> Builder
writeTypeInfo

------------------------------------------------------------------------------
-- The wire layouts, written

-- | A B_VARCHAR: a one-byte count of UTF-16 code units, then the text.
-- Fails (with 'error') for more than 255 units, which the count can't
-- hold; 'typeInfoProblem' refuses such names first.
bVarChar :: Text -> BB.Builder
bVarChar :: Text -> Builder
bVarChar Text
t
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFF = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ [Char]
"bVarChar: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units do not fit in a B_VARCHAR (at most 255)"
  | Bool
otherwise = Precision -> Builder
BB.word8 (Int -> Precision
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  where
    bs :: StrictByteString
bs = Text -> StrictByteString
Utf16.encodeUtf16LE Text
t
    n :: Int
n = StrictByteString -> Int
B.length StrictByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
{-# NOINLINE bVarChar #-}

-- | A US_VARCHAR: a two-byte count, then the text; fails past 65535 units.
usVarChar :: Text -> BB.Builder
usVarChar :: Text -> Builder
usVarChar Text
t
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFFFF = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ [Char]
"usVarChar: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units do not fit in a US_VARCHAR (at most 65535)"
  | Bool
otherwise = Word16 -> Builder
BB.word16LE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  where
    bs :: StrictByteString
bs = Text -> StrictByteString
Utf16.encodeUtf16LE Text
t
    n :: Int
n = StrictByteString -> Int
B.length StrictByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
{-# NOINLINE usVarChar #-}
-- Both out of line: only an XML schema or a UDT has these names, and inlined, each
-- of the seven was a copy of the UTF-16 encoder in 'writeTypeInfo', 6.8 KB in all.
-- (Sharing the other layouts of 'writeTypeInfo' the same way saved 7 KB more, but
-- each parameter then allocated 16 to 64 bytes more, the boxed fields and the joined
-- Builders' continuations.)

-- | TYPE_INFO (MS-TDS 2.2.5.6): the type byte, then what the type
-- carries (a length, a precision and scale, a collation, names).
writeTypeInfo :: TypeInfo -> BB.Builder
writeTypeInfo :: TypeInfo -> Builder
writeTypeInfo = \case
  TypeInfo
TINull -> Precision -> Builder
BB.word8 Precision
0x1F
  TypeInfo
TIBit -> Precision -> Builder
BB.word8 Precision
0x32
  TypeInfo
TIInt1 -> Precision -> Builder
BB.word8 Precision
0x30
  TypeInfo
TIInt2 -> Precision -> Builder
BB.word8 Precision
0x34
  TypeInfo
TIInt4 -> Precision -> Builder
BB.word8 Precision
0x38
  TypeInfo
TIInt8 -> Precision -> Builder
BB.word8 Precision
0x7F
  TypeInfo
TIMoney4 -> Precision -> Builder
BB.word8 Precision
0x7A
  TypeInfo
TIMoney8 -> Precision -> Builder
BB.word8 Precision
0x3C
  TypeInfo
TIDateTime4 -> Precision -> Builder
BB.word8 Precision
0x3A
  TypeInfo
TIDateTime8 -> Precision -> Builder
BB.word8 Precision
0x3D
  TypeInfo
TIFlt4 -> Precision -> Builder
BB.word8 Precision
0x3B
  TypeInfo
TIFlt8 -> Precision -> Builder
BB.word8 Precision
0x3E

  TypeInfo
TIBitN -> Precision -> Builder
BB.word8 Precision
0x68 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
1
  TIIntN Precision
n -> Precision -> Builder
BB.word8 Precision
0x26 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
n
  TIMoneyN Precision
n -> Precision -> Builder
BB.word8 Precision
0x6E Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
n
  TIDateTimeN Precision
n -> Precision -> Builder
BB.word8 Precision
0x6F Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
n
  TIFltN Precision
n -> Precision -> Builder
BB.word8 Precision
0x6D Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
n

  TypeInfo
TIGuid -> Precision -> Builder
BB.word8 Precision
0x24 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
16
  TIDecimalN Precision
p Precision
sc -> Precision -> Builder
BB.word8 Precision
0x6A Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Precision -> Builder
decimalInfo Precision
p Precision
sc
  TINumericN Precision
p Precision
sc -> Precision -> Builder
BB.word8 Precision
0x6C Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Precision -> Builder
decimalInfo Precision
p Precision
sc

  TypeInfo
TIDateN -> Precision -> Builder
BB.word8 Precision
0x28
  TITimeN Precision
sc -> Precision -> Builder
BB.word8 Precision
0x29 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
sc
  TIDateTime2N Precision
sc -> Precision -> Builder
BB.word8 Precision
0x2A Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
sc
  TIDateTimeOffsetN Precision
sc -> Precision -> Builder
BB.word8 Precision
0x2B Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
sc

  TIBigChar Word16
len Collation
col -> Precision -> Builder
BB.word8 Precision
0xAF Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col
  TIBigVarChar Word16
len Collation
col -> Precision -> Builder
BB.word8 Precision
0xA7 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col
  TIText Word32
len Collation
col -> Precision -> Builder
BB.word8 Precision
0x23 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col
  TINChar Word16
len Collation
col -> Precision -> Builder
BB.word8 Precision
0xEF Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col
  TINVarChar Word16
len Collation
col -> Precision -> Builder
BB.word8 Precision
0xE7 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col
  TINText Word32
len Collation
col -> Precision -> Builder
BB.word8 Precision
0x63 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
len Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Collation -> Builder
collation Collation
col

  TIBigBinary Word16
len -> Precision -> Builder
BB.word8 Precision
0xAD Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len
  TIBigVarBinary Word16
len -> Precision -> Builder
BB.word8 Precision
0xA5 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
len
  TIImage Word32
len -> Precision -> Builder
BB.word8 Precision
0x22 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
len

  TIXml Maybe XmlSchema
Nothing -> Precision -> Builder
BB.word8 Precision
0xF1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
0
  TIXml (Just XmlSchema{Text
xmlDbName :: XmlSchema -> Text
xmlOwningSchema :: XmlSchema -> Text
xmlSchemaCollection :: XmlSchema -> Text
xmlDbName :: Text
xmlOwningSchema :: Text
xmlSchemaCollection :: Text
..}) ->
    Precision -> Builder
BB.word8 Precision
0xF1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
bVarChar Text
xmlDbName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
bVarChar Text
xmlOwningSchema Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
usVarChar Text
xmlSchemaCollection
  TISqlVariant Word32
len -> Precision -> Builder
BB.word8 Precision
0x62 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
len
  -- The COLMETADATA form, which 'readTypeInfo' reads.  (An RPC parameter
  -- would have the shorter UDT_INFO_IN_RPC; 'typeInfoProblem' refuses UDT
  -- parameters.)
  TIUdt UdtInfo{Word16
Text
udtMaxLength :: UdtInfo -> Word16
udtDbName :: UdtInfo -> Text
udtSchemaName :: UdtInfo -> Text
udtTypeName :: UdtInfo -> Text
udtAssemblyQualifiedName :: UdtInfo -> Text
udtMaxLength :: Word16
udtDbName :: Text
udtSchemaName :: Text
udtTypeName :: Text
udtAssemblyQualifiedName :: Text
..} ->
    Precision -> Builder
BB.word8 Precision
0xF0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
udtMaxLength Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
bVarChar Text
udtDbName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
bVarChar Text
udtSchemaName
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
bVarChar Text
udtTypeName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
usVarChar Text
udtAssemblyQualifiedName
  where
    decimalInfo :: Precision -> Precision -> Builder
decimalInfo Precision
p Precision
sc = Precision -> Builder
BB.word8 (Int -> Precision
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Precision -> Int
precisionToLength Precision
p) Precision -> Precision -> Precision
forall a. Num a => a -> a -> a
+ Precision
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
p Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
sc
    collation :: Collation -> Builder
collation (Collation Word32
info Precision
sortId) = Word32 -> Builder
BB.word32LE Word32
info Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Precision -> Builder
BB.word8 Precision
sortId
-- Out of line.  INLINE, it was 25 KB of object code at each of its five copies (three
-- in Tds.Client's RPC writers, two here), 119 KB of the library in all; out of line
-- it is one call per parameter, and the RPC encoding benchmarks allocate the same.

-- | A value as RPC parameters carry it, after its TYPE_INFO: nothing for
-- a type with no value, the bytes of a fixed-length type, else a length
-- prefix (whose NULL spelling depends on the kind, 'LengthKind') and the
-- bytes, or PLP chunks.  Nothing is checked here: a value too long for its
-- length prefix wraps, and an empty BYTE-length or @sql_variant@ payload is
-- written as NULL.  'putValue' checks with 'valueProblem' first; this is for
-- values checked already.
writeValue :: TypeInfo -> RawBytes -> BB.Builder
writeValue :: TypeInfo -> RawBytes -> Builder
writeValue TypeInfo
ti RawBytes
rb = (forall r. BuildStep r -> BuildStep r) -> Builder
BBI.builder (TypeInfo -> RawBytes -> BuildStep r -> BuildStep r
forall a. TypeInfo -> RawBytes -> BuildStep a -> BuildStep a
writeValueStep TypeInfo
ti RawBytes
rb)
{-# INLINE writeValue #-}

-- The framing is compiled once, as a function of the Builder's continuation and
-- buffer together rather than one returning a Builder, so a caller composes it
-- without allocating a Builder closure first.  Out of line as a Builder-returning
-- function, 'writeValue' cost the sender 32 bytes of allocation per parameter;
-- as this step it costs nothing over the inlined copy, and the copies the sender,
-- the in-memory serializer and the tests had are one (19,752 bytes less of
-- library code, GHC 9.12.4, 2026-11-04).  This touches no buffer itself.
writeValueStep :: TypeInfo -> RawBytes -> BBI.BuildStep a -> BBI.BuildStep a
writeValueStep :: forall a. TypeInfo -> RawBytes -> BuildStep a -> BuildStep a
writeValueStep TypeInfo
ti RawBytes
rb BuildStep a
next BufferRange
range = Builder -> BuildStep a -> BuildStep a
forall a. Builder -> BuildStep a -> BuildStep a
BBI.runBuilderWith (TypeInfo -> RawBytes -> Builder
valueBuilder TypeInfo
ti RawBytes
rb) BuildStep a
next BufferRange
range
{-# NOINLINE writeValueStep #-}

valueBuilder :: TypeInfo -> RawBytes -> BB.Builder
valueBuilder :: TypeInfo -> RawBytes -> Builder
valueBuilder TypeInfo
ti RawBytes
rb = case (TypeInfo -> LengthKind
lengthKind TypeInfo
ti, RawBytes
rb) of
  (LengthKind
NoValue, RawBytes
_) -> Builder
forall a. Monoid a => a
mempty
  (Fixed Int
_, Just StrictByteString
bs) -> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  (Fixed Int
_, RawBytes
Nothing) -> Builder
forall a. Monoid a => a
mempty  -- ruled out by 'lengthProblem'
  (LengthKind
ByteLen, RawBytes
Nothing) -> Precision -> Builder
BB.word8 Precision
0
  (LengthKind
ByteLen, Just StrictByteString
bs) -> Precision -> Builder
BB.word8 (Int -> Precision
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  (LengthKind
UShortCharBin, RawBytes
Nothing) -> Word16 -> Builder
BB.word16LE Word16
0xFFFF
  (LengthKind
UShortCharBin, Just StrictByteString
bs) -> Word16 -> Builder
BB.word16LE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  (LengthKind
LongLen, RawBytes
Nothing) -> Word32 -> Builder
BB.word32LE Word32
0xFFFFFFFF
  (LengthKind
LongLen, Just StrictByteString
bs) -> Word32 -> Builder
BB.word32LE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  (LengthKind
VariantLen, RawBytes
Nothing) -> Word32 -> Builder
BB.word32LE Word32
0
  (LengthKind
VariantLen, Just StrictByteString
bs) -> Word32 -> Builder
BB.word32LE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
bs
  (LengthKind
Plp, RawBytes
Nothing) -> Word64 -> Builder
BB.word64LE Word64
0xFFFFFFFFFFFFFFFF
  (LengthKind
Plp, Just StrictByteString
bs) -> Word64 -> Builder
BB.word64LE (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
chunks StrictByteString
bs
  where
    -- One chunk (up to 1 GiB), as SqlClient sends a value it holds: a
    -- value of 8 KiB or more is then referred to by the message body, not
    -- copied into it (binary copies anything shorter, which 8000-byte
    -- chunks would all be), and is copied once, when it is framed.
    chunks :: StrictByteString -> Builder
chunks StrictByteString
b
      | StrictByteString -> Bool
B.null StrictByteString
b = Word32 -> Builder
BB.word32LE Word32
0
      | Bool
otherwise =
          let (StrictByteString
chunk, StrictByteString
rest) = Int -> StrictByteString -> (StrictByteString, StrictByteString)
B.splitAt Int
plpChunk StrictByteString
b
           in Word32 -> Builder
BB.word32LE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StrictByteString -> Int
B.length StrictByteString
chunk)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
BB.byteString StrictByteString
chunk Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> StrictByteString -> Builder
chunks StrictByteString
rest
{-# INLINE valueBuilder #-}

-- | The largest PLP chunk sent.
plpChunk :: Int
plpChunk :: Int
plpChunk = Int
0x40000000

------------------------------------------------------------------------------
-- Values

-- | An undecoded column or parameter value; 'Nothing' is SQL NULL.
type RawBytes = Maybe B.ByteString

-- | How a type's values are delimited on the wire ('lengthKind').
data LengthKind
  = Fixed !Int
  | ByteLen         -- ^ 1-byte length, 0 = NULL
  | UShortCharBin   -- ^ 2-byte length, 0xFFFF = NULL
  | LongLen         -- ^ 4-byte length, 0xFFFFFFFF = NULL
  | VariantLen      -- ^ 4-byte length, 0 = NULL (@sql_variant@)
  | Plp             -- ^ partially length-prefixed
  | NoValue

-- | How values of the type are delimited.
lengthKind :: TypeInfo -> LengthKind
lengthKind :: TypeInfo -> LengthKind
lengthKind = \case
  TypeInfo
TINull -> LengthKind
NoValue
  TypeInfo
TIBit -> Int -> LengthKind
Fixed Int
1
  TypeInfo
TIInt1 -> Int -> LengthKind
Fixed Int
1
  TypeInfo
TIInt2 -> Int -> LengthKind
Fixed Int
2
  TypeInfo
TIInt4 -> Int -> LengthKind
Fixed Int
4
  TypeInfo
TIInt8 -> Int -> LengthKind
Fixed Int
8
  TypeInfo
TIMoney4 -> Int -> LengthKind
Fixed Int
4
  TypeInfo
TIMoney8 -> Int -> LengthKind
Fixed Int
8
  TypeInfo
TIDateTime4 -> Int -> LengthKind
Fixed Int
4
  TypeInfo
TIDateTime8 -> Int -> LengthKind
Fixed Int
8
  TypeInfo
TIFlt4 -> Int -> LengthKind
Fixed Int
4
  TypeInfo
TIFlt8 -> Int -> LengthKind
Fixed Int
8

  TypeInfo
TIBitN -> LengthKind
ByteLen
  TIIntN Precision
_ -> LengthKind
ByteLen
  TIMoneyN Precision
_ -> LengthKind
ByteLen
  TIDateTimeN Precision
_ -> LengthKind
ByteLen
  TIFltN Precision
_ -> LengthKind
ByteLen
  TypeInfo
TIGuid -> LengthKind
ByteLen
  TIDecimalN Precision
_ Precision
_ -> LengthKind
ByteLen
  TINumericN Precision
_ Precision
_ -> LengthKind
ByteLen
  TypeInfo
TIDateN -> LengthKind
ByteLen
  TITimeN Precision
_ -> LengthKind
ByteLen
  TIDateTime2N Precision
_ -> LengthKind
ByteLen
  TIDateTimeOffsetN Precision
_ -> LengthKind
ByteLen

  TIBigChar Word16
_ Collation
_ -> LengthKind
UShortCharBin
  TIBigVarChar Word16
len Collation
_ | Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength -> LengthKind
Plp
                     | Bool
otherwise -> LengthKind
UShortCharBin
  TIText Word32
_ Collation
_ -> LengthKind
LongLen
  TINChar Word16
_ Collation
_ -> LengthKind
UShortCharBin
  TINVarChar Word16
len Collation
_ | Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength -> LengthKind
Plp
                   | Bool
otherwise -> LengthKind
UShortCharBin
  TINText Word32
_ Collation
_ -> LengthKind
LongLen

  TIBigBinary Word16
_ -> LengthKind
UShortCharBin
  TIBigVarBinary Word16
len | Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength -> LengthKind
Plp
                     | Bool
otherwise -> LengthKind
UShortCharBin
  TIImage Word32
_ -> LengthKind
LongLen

  TIXml Maybe XmlSchema
_ -> LengthKind
Plp
  TISqlVariant Word32
_ -> LengthKind
VariantLen
  TIUdt UdtInfo
_ -> LengthKind
Plp

-- | Why 'putValue' can't write this value for this type, if it can't: a
-- fixed-length type given the wrong number of bytes or NULL, or a value too
-- long for its length prefix, which would otherwise be written modulo 256
-- (or 65536, ...).  A USHORT length of 0xFFFF would even read as NULL.
lengthProblem :: TypeInfo -> RawBytes -> Maybe String
lengthProblem :: TypeInfo -> RawBytes -> Maybe [Char]
lengthProblem TypeInfo
ti RawBytes
rb = case (TypeInfo -> LengthKind
lengthKind TypeInfo
ti, RawBytes
rb) of
  (Fixed Int
n, Just StrictByteString
bs)
    | StrictByteString -> Int
B.length StrictByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" requires exactly " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes, not " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StrictByteString -> Int
B.length StrictByteString
bs)
  (Fixed Int
_, RawBytes
Nothing) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be NULL"
  (LengthKind
ByteLen, Just StrictByteString
bs) -> Integer -> StrictByteString -> Maybe [Char]
atMost Integer
0xFF StrictByteString
bs
  (LengthKind
UShortCharBin, Just StrictByteString
bs) -> Integer -> StrictByteString -> Maybe [Char]
atMost Integer
0xFFFE StrictByteString
bs
  (LengthKind
LongLen, Just StrictByteString
bs) -> Integer -> StrictByteString -> Maybe [Char]
atMost Integer
0x7FFFFFFF StrictByteString
bs
  (LengthKind
VariantLen, Just StrictByteString
bs) -> Integer -> StrictByteString -> Maybe [Char]
atMost Integer
0xFFFFFFFE StrictByteString
bs
  (LengthKind, RawBytes)
_ -> Maybe [Char]
forall a. Maybe a
Nothing
  where
    name :: [Char]
name = Text -> [Char]
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti)
    atMost :: Integer -> B.ByteString -> Maybe String
    atMost :: Integer -> StrictByteString -> Maybe [Char]
atMost Integer
limit StrictByteString
bs
      | Int -> Integer
forall a. Integral a => a -> Integer
toInteger (StrictByteString -> Int
B.length StrictByteString
bs) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
limit = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
          [Char]
"a " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (StrictByteString -> Int
B.length StrictByteString
bs) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-byte " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" value is too long for its length prefix (at most "
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
limit [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes)"
      | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

-- | Why a value can't be sent as a parameter of this type, if it can't:
-- a 'lengthProblem', or an empty value of a type whose length prefix uses 0
-- for NULL (every BYTE-length type, and @sql_variant@), which the server
-- would read as NULL.
valueProblem :: TypeInfo -> RawBytes -> Maybe String
valueProblem :: TypeInfo -> RawBytes -> Maybe [Char]
valueProblem TypeInfo
ti RawBytes
rb = case TypeInfo -> RawBytes -> Maybe [Char]
lengthProblem TypeInfo
ti RawBytes
rb of
  Just [Char]
p -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
p
  Maybe [Char]
Nothing -> case (TypeInfo -> LengthKind
lengthKind TypeInfo
ti, RawBytes
rb) of
    (LengthKind
ByteLen, Just StrictByteString
bs) | StrictByteString -> Bool
B.null StrictByteString
bs -> Maybe [Char]
emptyIsNull
    (LengthKind
VariantLen, Just StrictByteString
bs) | StrictByteString -> Bool
B.null StrictByteString
bs -> Maybe [Char]
emptyIsNull
    (LengthKind, RawBytes)
_ -> Maybe [Char]
forall a. Maybe a
Nothing
  where
    emptyIsNull :: Maybe [Char]
emptyIsNull = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"an empty " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (TypeInfo -> Text
typeInfoSqlName TypeInfo
ti) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" value would be read as NULL (use Nothing for NULL)"

-- | Why a parameter can't have this type, if it can't: a precision or
-- scale SQL Server doesn't have (a @decimal@ or @numeric@ precision outside
-- 1 through 38 or a scale above the precision, MS-TDS 2.2.5.5.1.3; a
-- @time@, @datetime2@ or @datetimeoffset@ scale above 7, 2.2.5.4.2), XML
-- schema names too long for their length prefixes, or a CLR user-defined
-- type, which hmssql doesn't send.
typeInfoProblem :: TypeInfo -> Maybe String
typeInfoProblem :: TypeInfo -> Maybe [Char]
typeInfoProblem = \case
  TIDecimalN Precision
p Precision
s -> [Char] -> Precision -> Precision -> Maybe [Char]
decimalProblem [Char]
"decimal" Precision
p Precision
s
  TINumericN Precision
p Precision
s -> [Char] -> Precision -> Precision -> Maybe [Char]
decimalProblem [Char]
"numeric" Precision
p Precision
s
  TITimeN Precision
s -> [Char] -> Precision -> Maybe [Char]
scaleProblem [Char]
"time" Precision
s
  TIDateTime2N Precision
s -> [Char] -> Precision -> Maybe [Char]
scaleProblem [Char]
"datetime2" Precision
s
  TIDateTimeOffsetN Precision
s -> [Char] -> Precision -> Maybe [Char]
scaleProblem [Char]
"datetimeoffset" Precision
s
  TIUdt UdtInfo
u -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
    [Char]
"CLR user-defined type (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (TypeInfo -> Text
typeInfoSqlName (UdtInfo -> TypeInfo
TIUdt UdtInfo
u)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
") parameters are not supported;"
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" send the value as varbinary(max) (its serialized form) or nvarchar and convert it in the query"
  TIXml (Just XmlSchema{Text
xmlDbName :: XmlSchema -> Text
xmlOwningSchema :: XmlSchema -> Text
xmlSchemaCollection :: XmlSchema -> Text
xmlDbName :: Text
xmlOwningSchema :: Text
xmlSchemaCollection :: Text
..})
    | Text -> Int
ucs2Length Text
xmlDbName Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFF Bool -> Bool -> Bool
|| Text -> Int
ucs2Length Text
xmlOwningSchema Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFF Bool -> Bool -> Bool
|| Text -> Int
ucs2Length Text
xmlSchemaCollection Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFFFF ->
        [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"an XML schema collection name is too long"
  TypeInfo
_ -> Maybe [Char]
forall a. Maybe a
Nothing

decimalProblem :: String -> Precision -> Scale -> Maybe String
decimalProblem :: [Char] -> Precision -> Precision -> Maybe [Char]
decimalProblem [Char]
name Precision
p Precision
s
  | Precision
p Precision -> Precision -> Bool
forall a. Ord a => a -> a -> Bool
< Precision
1 Bool -> Bool -> Bool
|| Precision
p Precision -> Precision -> Bool
forall a. Ord a => a -> a -> Bool
> Precision
38 = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" precision " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Precision -> [Char]
forall a. Show a => a -> [Char]
show Precision
p [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (1 through 38)"
  | Precision
s Precision -> Precision -> Bool
forall a. Ord a => a -> a -> Bool
> Precision
p = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" scale " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Precision -> [Char]
forall a. Show a => a -> [Char]
show Precision
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" for precision " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Precision -> [Char]
forall a. Show a => a -> [Char]
show Precision
p [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (at most the precision)"
  | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

-- | Write a value as it appears in RPC parameters. Fails (with 'error')
-- if 'valueProblem' finds invalid framing, including a non-NULL empty
-- payload whose length would encode NULL. This does not validate the
-- type declaration or the payload's semantic value.
putValue :: TdsContext -> TypeInfo -> RawBytes -> Put
putValue :: TdsContext -> TypeInfo -> RawBytes -> Put
putValue TdsContext
_ctx TypeInfo
ti RawBytes
rb = case TypeInfo -> RawBytes -> Maybe [Char]
valueProblem TypeInfo
ti RawBytes
rb of
  Just [Char]
p -> [Char] -> Put
forall a. HasCallStack => [Char] -> a
error ([Char]
"putValue: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
p)
  Maybe [Char]
Nothing -> TypeInfo -> RawBytes -> Put
putValueUnchecked TypeInfo
ti RawBytes
rb

-- | 'putValue' __without the check__, for a value checked with
-- 'valueProblem'. Invalid lengths can wrap or encode NULL ('writeValue').
putValueUnchecked :: TypeInfo -> RawBytes -> Put
putValueUnchecked :: TypeInfo -> RawBytes -> Put
putValueUnchecked TypeInfo
ti = Builder -> Put
Put.putBuilder (Builder -> Put) -> (RawBytes -> Builder) -> RawBytes -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInfo -> RawBytes -> Builder
writeValue TypeInfo
ti

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

-- | The T-SQL type declaration for a parameter of this type, as used in the
-- @\@params@ argument of @sp_executesql@.
typeInfoSqlName :: TypeInfo -> Text
typeInfoSqlName :: TypeInfo -> Text
typeInfoSqlName = \case
  TypeInfo
TINull -> Text
"sql_variant"
  TypeInfo
TIBit -> Text
"bit"
  TypeInfo
TIInt1 -> Text
"tinyint"
  TypeInfo
TIInt2 -> Text
"smallint"
  TypeInfo
TIInt4 -> Text
"int"
  TypeInfo
TIInt8 -> Text
"bigint"
  TypeInfo
TIMoney4 -> Text
"smallmoney"
  TypeInfo
TIMoney8 -> Text
"money"
  TypeInfo
TIDateTime4 -> Text
"smalldatetime"
  TypeInfo
TIDateTime8 -> Text
"datetime"
  TypeInfo
TIFlt4 -> Text
"real"
  TypeInfo
TIFlt8 -> Text
"float"
  TypeInfo
TIBitN -> Text
"bit"
  TIIntN Precision
1 -> Text
"tinyint"
  TIIntN Precision
2 -> Text
"smallint"
  TIIntN Precision
4 -> Text
"int"
  TIIntN Precision
_ -> Text
"bigint"
  TIMoneyN Precision
4 -> Text
"smallmoney"
  TIMoneyN Precision
_ -> Text
"money"
  TIDateTimeN Precision
4 -> Text
"smalldatetime"
  TIDateTimeN Precision
_ -> Text
"datetime"
  TIFltN Precision
4 -> Text
"real"
  TIFltN Precision
_ -> Text
"float"
  TypeInfo
TIGuid -> Text
"uniqueidentifier"
  TIDecimalN Precision
p Precision
s -> Text
"decimal(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TINumericN Precision
p Precision
s -> Text
"numeric(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TypeInfo
TIDateN -> Text
"date"
  TITimeN Precision
s -> Text
"time(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  -- The declarations of the common parameters, without building them
  -- (@sp_executesql@'s @\@params@ names every parameter's type).
  TIDateTime2N Precision
7 -> Text
"datetime2(7)"
  TIDateTimeOffsetN Precision
7 -> Text
"datetimeoffset(7)"
  TINVarChar Word16
8000 Collation
_ -> Text
"nvarchar(4000)"
  TINVarChar Word16
0xFFFF Collation
_ -> Text
"nvarchar(max)"
  TIBigVarBinary Word16
8000 -> Text
"varbinary(8000)"
  TIBigVarBinary Word16
0xFFFF -> Text
"varbinary(max)"
  TIDateTime2N Precision
s -> Text
"datetime2(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIDateTimeOffsetN Precision
s -> Text
"datetimeoffset(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Precision -> Text
forall a. Show a => a -> Text
tshow Precision
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIBigChar Word16
len Collation
_ -> Text
"char(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
tshow Word16
len Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIBigVarChar Word16
len Collation
_ -> Text
"varchar(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
sizeOrMax Word16
len Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIText Word32
_ Collation
_ -> Text
"text"
  TINChar Word16
len Collation
_ -> Text
"nchar(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
tshow (Word16
len Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`div` Word16
2) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TINVarChar Word16
len Collation
_ -> Text
"nvarchar(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength then Text
"max" else Word16 -> Text
forall a. Show a => a -> Text
tshow (Word16
len Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`div` Word16
2)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TINText Word32
_ Collation
_ -> Text
"ntext"
  TIBigBinary Word16
len -> Text
"binary(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
tshow Word16
len Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIBigVarBinary Word16
len -> Text
"varbinary(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
sizeOrMax Word16
len Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TIImage Word32
_ -> Text
"image"
  TIXml Maybe XmlSchema
_ -> Text
"xml"
  TISqlVariant Word32
_ -> Text
"sql_variant"
  -- System CLR types are declared by name; others need their schema.
  TIUdt UdtInfo{Word16
Text
udtMaxLength :: UdtInfo -> Word16
udtDbName :: UdtInfo -> Text
udtSchemaName :: UdtInfo -> Text
udtTypeName :: UdtInfo -> Text
udtAssemblyQualifiedName :: UdtInfo -> Text
udtMaxLength :: Word16
udtDbName :: Text
udtSchemaName :: Text
udtTypeName :: Text
udtAssemblyQualifiedName :: Text
..}
    | Text
udtSchemaName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"sys" -> Text
udtTypeName
    | Bool
otherwise -> Text -> Text
quote Text
udtSchemaName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
quote Text
udtTypeName
  where
    quote :: Text -> Text
quote 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
"]"
    tshow :: Show a => a -> Text
    tshow :: forall a. Show a => a -> Text
tshow = [Char] -> Text
T.pack ([Char] -> Text) -> (a -> [Char]) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show
    sizeOrMax :: Word16 -> Text
sizeOrMax Word16
len = if Word16
len Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
maxLength then Text
"max" else Word16 -> Text
forall a. Show a => a -> Text
tshow Word16
len