{-# LANGUAGE MagicHash #-}
-- | Messages sent from the client to the server.
--
-- [MS-TDS 2.2.6 Client Messages](https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/7ea9ee1a-b461-41f2-9004-141c0e712935)
module Hmssql.Tds.Client
  ( -- * PRELOGIN
    Prelogin (..)
  , PreloginOption (..)
  , Encryption (..)
  , encryptionWord
  , encryptionFromWord
  , putPrelogin
  , getPrelogin

    -- * LOGIN7
  , Login7 (..)
  , Feature (..)
  , featureUtf8Support
  , featureFedAuthToken
  , defaultLogin7
  , putLogin7
  , login7Problem
  , obfuscatePassword

    -- * SQLBatch and RPC
  , putAllHeaders
  , putSqlBatch
  , sqlBatchProblem, sqlBatchBuilder, rpcRequestBuilder, rpcParamBuilder, allHeadersBuilder
  , sqlBatchBody
  , RpcRequest (..)
  , RpcProc (..)
  , RpcParam (..)
  , paramByRef
  , paramDefault
  , procSpExecuteSql
  , putRpcRequest
  , rpcRequestBody
  , rpcRequestBodyUnchecked
  , newRpcWriter, writeRpcRequests
  , rpcRequestProblem
  , rpcParamProblem

    -- * Transaction Manager requests
  , tmBeginTransactionBuilder
  , tmBeginTransactionBody
  ) where

import Control.Exception (throwIO)
import Data.IORef
import Hmssql.Errors (EncodeError (..))
import Hmssql.Internal.Derived
import Hmssql.Tds.Parameter
import Hmssql.Tds.PacketWriter (PacketWriter, writeBuilder)
import Control.Monad (foldM, foldM_, forM_, when)
import Data.Binary.Get (Get)
import qualified Data.Binary.Get as Get
import Data.Binary.Put (Put, PutM)
import qualified Data.Binary.Put as Put
import Data.Bits (shiftL, shiftR, xor, (.|.), (.&.))
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Int (Int32)
import Data.List (intersperse, sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text.Internal as TI
import qualified Data.Text as T
import Data.Word (Word16, Word32, Word8)

import Hmssql.Tds.Packet (maxSqlBatchPackets, packetPayloadSize)
import Hmssql.Tds.Context
import Hmssql.Tds.Primitives (ucs2Length)
import Hmssql.Tds.TypeInfo
import qualified Hmssql.Tds.Utf16 as Utf16

------------------------------------------------------------------------------
-- PRELOGIN

-- | How much of the connection is encrypted ('Hmssql.Connection.connectEncryption').
-- The first four are the values of the ENCRYPTION option of PRELOGIN, where
-- the client and the server negotiate.  'EncryptStrict' is TDS 8.0, which
-- never negotiates.
data Encryption
  = EncryptOff
    -- ^ Encrypt the login packet only, or the whole session if the server
    -- requires it.  If the server doesn't support encryption at all,
    -- nothing is encrypted, not even the password.  (0x00)
  | EncryptOn
    -- ^ Encrypt the whole session, and fail if the server doesn't support
    -- encryption.  The default.  (0x01)
  | EncryptNotSup
    -- ^ Encrypt nothing, and fail if the server requires encryption.  (0x02)
  | EncryptReq
    -- ^ Encryption required.  It behaves as 'EncryptOn' does.  (0x03)
  | EncryptStrict
    -- ^ TDS 8.0: TLS from the first byte, before any PRELOGIN, and a
    -- failure against a server that doesn't support TDS 8.0.  (0x04, which
    -- is never sent, since there is no PRELOGIN to send it in)
  deriving stock (Encryption -> Encryption -> Bool
(Encryption -> Encryption -> Bool)
-> (Encryption -> Encryption -> Bool) -> Eq Encryption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Encryption -> Encryption -> Bool
== :: Encryption -> Encryption -> Bool
$c/= :: Encryption -> Encryption -> Bool
/= :: Encryption -> Encryption -> Bool
Eq, Int -> Encryption -> ShowS
[Encryption] -> ShowS
Encryption -> [Char]
(Int -> Encryption -> ShowS)
-> (Encryption -> [Char])
-> ([Encryption] -> ShowS)
-> Show Encryption
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Encryption -> ShowS
showsPrec :: Int -> Encryption -> ShowS
$cshow :: Encryption -> [Char]
show :: Encryption -> [Char]
$cshowList :: [Encryption] -> ShowS
showList :: [Encryption] -> ShowS
Show)

encryptionWord :: Encryption -> Word8
encryptionWord :: Encryption -> Word8
encryptionWord = \case
  Encryption
EncryptOff -> Word8
0x00
  Encryption
EncryptOn -> Word8
0x01
  Encryption
EncryptNotSup -> Word8
0x02
  Encryption
EncryptReq -> Word8
0x03
  Encryption
EncryptStrict -> Word8
0x04

encryptionFromWord :: Word8 -> Maybe Encryption
encryptionFromWord :: Word8 -> Maybe Encryption
encryptionFromWord = \case
  Word8
0x00 -> Encryption -> Maybe Encryption
forall a. a -> Maybe a
Just Encryption
EncryptOff
  Word8
0x01 -> Encryption -> Maybe Encryption
forall a. a -> Maybe a
Just Encryption
EncryptOn
  Word8
0x02 -> Encryption -> Maybe Encryption
forall a. a -> Maybe a
Just Encryption
EncryptNotSup
  Word8
0x03 -> Encryption -> Maybe Encryption
forall a. a -> Maybe a
Just Encryption
EncryptReq
  Word8
0x04 -> Encryption -> Maybe Encryption
forall a. a -> Maybe a
Just Encryption
EncryptStrict
  Word8
_ -> Maybe Encryption
forall a. Maybe a
Nothing

-- | One option of a PRELOGIN message.
data PreloginOption
  = PLVersion !Word8 !Word8 !Word16 !Word16   -- ^ major, minor, build, sub-build
  | PLEncryption !Word8
  | PLInstance !B.ByteString
  | PLThreadId !(Maybe Word32)
  | PLMars !Word8
  | PLTraceId !B.ByteString !B.ByteString !Word32
  | PLFedAuthRequired !Word8
  | PLNonce !B.ByteString
  | PLUnknown !Word8 !B.ByteString

instance Show PreloginOption where
  showsPrec :: Int -> PreloginOption -> ShowS
showsPrec Int
p = \case
    PLVersion Word8
a Word8
b Word16
c Word16
e -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"PLVersion"# [Word8 -> Arg
forall a. Show a => a -> Arg
Arg Word8
a, Word8 -> Arg
forall a. Show a => a -> Arg
Arg Word8
b, Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
c, Word16 -> Arg
forall a. Show a => a -> Arg
Arg Word16
e]
    PLEncryption Word8
a -> Int -> Addr# -> Word8 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLEncryption"# Word8
a
    PLInstance ByteString
a -> Int -> Addr# -> ByteString -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLInstance"# ByteString
a
    PLThreadId Maybe Word32
a -> Int -> Addr# -> Maybe Word32 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLThreadId"# Maybe Word32
a
    PLMars Word8
a -> Int -> Addr# -> Word8 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLMars"# Word8
a
    PLTraceId ByteString
a ByteString
b Word32
c -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"PLTraceId"# [ByteString -> Arg
forall a. Show a => a -> Arg
Arg ByteString
a, ByteString -> Arg
forall a. Show a => a -> Arg
Arg ByteString
b, Word32 -> Arg
forall a. Show a => a -> Arg
Arg Word32
c]
    PLFedAuthRequired Word8
a -> Int -> Addr# -> Word8 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLFedAuthRequired"# Word8
a
    PLNonce ByteString
a -> Int -> Addr# -> ByteString -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"PLNonce"# ByteString
a
    PLUnknown Word8
a ByteString
b -> Int -> Addr# -> [Arg] -> ShowS
showCon Int
p Addr#
"PLUnknown"# [Word8 -> Arg
forall a. Show a => a -> Arg
Arg Word8
a, ByteString -> Arg
forall a. Show a => a -> Arg
Arg ByteString
b]
  {-# OPAQUE showsPrec #-}

instance Eq PreloginOption where
  PreloginOption
x == :: PreloginOption -> PreloginOption -> Bool
== PreloginOption
y = case (PreloginOption
x, PreloginOption
y) of
    (PLVersion Word8
a Word8
b Word16
c Word16
e, PLVersion Word8
a' Word8
b' Word16
c' Word16
e') -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a' Bool -> Bool -> Bool
&& Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
b' Bool -> Bool -> Bool
&& Word16
c Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
c' Bool -> Bool -> Bool
&& Word16
e Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
e'
    (PLEncryption Word8
a, PLEncryption Word8
a') -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a'
    (PLInstance ByteString
a, PLInstance ByteString
a') -> ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
a ByteString
a'
    (PLThreadId Maybe Word32
a, PLThreadId Maybe Word32
a') -> Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
eq Maybe Word32
a Maybe Word32
a'
    (PLMars Word8
a, PLMars Word8
a') -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a'
    (PLTraceId ByteString
a ByteString
b Word32
c, PLTraceId ByteString
a' ByteString
b' Word32
c') -> ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
a ByteString
a' Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
b ByteString
b' Bool -> Bool -> Bool
&& Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
c'
    (PLFedAuthRequired Word8
a, PLFedAuthRequired Word8
a') -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a'
    (PLNonce ByteString
a, PLNonce ByteString
a') -> ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
a ByteString
a'
    (PLUnknown Word8
a ByteString
b, PLUnknown Word8
a' ByteString
b') -> Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a' Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
b ByteString
b'
    (PreloginOption, PreloginOption)
_ -> Bool
False
  {-# OPAQUE (==) #-}

-- | A PRELOGIN message: its options, in order.
newtype Prelogin = Prelogin [PreloginOption]
  deriving stock (Prelogin -> Prelogin -> Bool
(Prelogin -> Prelogin -> Bool)
-> (Prelogin -> Prelogin -> Bool) -> Eq Prelogin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Prelogin -> Prelogin -> Bool
== :: Prelogin -> Prelogin -> Bool
$c/= :: Prelogin -> Prelogin -> Bool
/= :: Prelogin -> Prelogin -> Bool
Eq)

instance Show Prelogin where
  showsPrec :: Int -> Prelogin -> ShowS
showsPrec Int
p (Prelogin [PreloginOption]
a) = Int -> Addr# -> [PreloginOption] -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"Prelogin"# [PreloginOption]
a
  {-# OPAQUE showsPrec #-}

optionToken :: PreloginOption -> Word8
optionToken :: PreloginOption -> Word8
optionToken = \case
  PLVersion{} -> Word8
0x00
  PLEncryption{} -> Word8
0x01
  PLInstance{} -> Word8
0x02
  PLThreadId{} -> Word8
0x03
  PLMars{} -> Word8
0x04
  PLTraceId{} -> Word8
0x05
  PLFedAuthRequired{} -> Word8
0x06
  PLNonce{} -> Word8
0x07
  PLUnknown Word8
t ByteString
_ -> Word8
t

optionPayload :: PreloginOption -> B.ByteString
optionPayload :: PreloginOption -> ByteString
optionPayload = LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString)
-> (PreloginOption -> LazyByteString)
-> PreloginOption
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> LazyByteString
Put.runPut (Put -> LazyByteString)
-> (PreloginOption -> Put) -> PreloginOption -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  PLVersion Word8
ma Word8
mi Word16
b Word16
sb -> Word8 -> Put
Put.putWord8 Word8
ma Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
Put.putWord8 Word8
mi Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
Put.putWord16be Word16
b Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
Put.putWord16be Word16
sb
  PLEncryption Word8
e -> Word8 -> Put
Put.putWord8 Word8
e
  PLInstance ByteString
name -> ByteString -> Put
Put.putByteString ByteString
name Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
Put.putWord8 Word8
0
  PLThreadId Maybe Word32
Nothing -> () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  PLThreadId (Just Word32
t) -> Word32 -> Put
Put.putWord32le Word32
t
  PLMars Word8
m -> Word8 -> Put
Put.putWord8 Word8
m
  PLTraceId ByteString
c ByteString
a Word32
s -> ByteString -> Put
Put.putByteString ByteString
c Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
Put.putByteString ByteString
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
Put.putWord32le Word32
s
  PLFedAuthRequired Word8
f -> Word8 -> Put
Put.putWord8 Word8
f
  PLNonce ByteString
n -> ByteString -> Put
Put.putByteString ByteString
n
  PLUnknown Word8
_ ByteString
bs -> ByteString -> Put
Put.putByteString ByteString
bs

putPrelogin :: Prelogin -> Put
putPrelogin :: Prelogin -> Put
putPrelogin (Prelogin [PreloginOption]
opts) = do
  let payloads :: [ByteString]
payloads = (PreloginOption -> ByteString) -> [PreloginOption] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map PreloginOption -> ByteString
optionPayload [PreloginOption]
opts
      tableLength :: Int
tableLength = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [PreloginOption] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PreloginOption]
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  (Int -> (PreloginOption, ByteString) -> PutM Int)
-> Int -> [(PreloginOption, ByteString)] -> Put
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Int -> (PreloginOption, ByteString) -> PutM Int
putIndex Int
tableLength ([PreloginOption] -> [ByteString] -> [(PreloginOption, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PreloginOption]
opts [ByteString]
payloads)
  Word8 -> Put
Put.putWord8 Word8
0xFF
  (ByteString -> Put) -> [ByteString] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> Put
Put.putByteString [ByteString]
payloads
  where
    putIndex :: Int -> (PreloginOption, B.ByteString) -> PutM Int
    putIndex :: Int -> (PreloginOption, ByteString) -> PutM Int
putIndex Int
offset (PreloginOption
opt, ByteString
payload) = do
      Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ PreloginOption -> Word8
optionToken PreloginOption
opt
      Word16 -> Put
Put.putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
      Word16 -> Put
Put.putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
payload
      Int -> PutM Int
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> PutM Int) -> Int -> PutM Int
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
payload

getPrelogin :: Get Prelogin
getPrelogin :: Get Prelogin
getPrelogin = do
  entries <- Get [(Word8, Int, Int)]
getEntries
  let tableLength = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [(Word8, Int, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Int, Int)]
entries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      end = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
tableLength Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l | (Word8
_, Int
o, Int
l) <- [(Word8, Int, Int)]
entries])
  -- Offsets count from the start of the message, so a non-empty option
  -- can't start inside the option table.
  forM_ entries $ \(Word8
t, Int
o, Int
l) ->
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tableLength) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> Get ()
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Get ()) -> [Char] -> Get ()
forall a b. (a -> b) -> a -> b
$ [Char]
"getPrelogin: option " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" at offset " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
o [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", inside the option table"
  payload <- Get.getByteString (end - tableLength)
  let slice Int
o Int
l = Int -> ByteString -> ByteString
B.take Int
l (Int -> ByteString -> ByteString
B.drop (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tableLength) ByteString
payload)
  Prelogin <$> mapM (\(Word8
t, Int
o, Int
l) -> Word8 -> ByteString -> Get PreloginOption
decodeOption Word8
t (Int -> Int -> ByteString
slice Int
o Int
l)) (sortOn (\(Word8
_, Int
o, Int
_) -> Int
o) entries)
  where
    getEntries :: Get [(Word8, Int, Int)]
getEntries = do
      t <- Get Word8
Get.getWord8
      if t == 0xFF
        then pure []
        else do
          o <- fromIntegral <$> Get.getWord16be
          l <- fromIntegral <$> Get.getWord16be
          ((t, o, l) :) <$> getEntries

    decodeOption :: Word8 -> B.ByteString -> Get PreloginOption
    decodeOption :: Word8 -> ByteString -> Get PreloginOption
decodeOption Word8
t ByteString
bs = case Word8
t of
      Word8
0x00 -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word16 -> Word16 -> PreloginOption
PLVersion (Word8 -> Word8 -> Word16 -> Word16 -> PreloginOption)
-> Get Word8 -> Get (Word8 -> Word16 -> Word16 -> PreloginOption)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8 Get (Word8 -> Word16 -> Word16 -> PreloginOption)
-> Get Word8 -> Get (Word16 -> Word16 -> PreloginOption)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
Get.getWord8 Get (Word16 -> Word16 -> PreloginOption)
-> Get Word16 -> Get (Word16 -> PreloginOption)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
Get.getWord16be Get (Word16 -> PreloginOption) -> Get Word16 -> Get PreloginOption
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
Get.getWord16be
      Word8
0x01 -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Word8 -> PreloginOption
PLEncryption (Word8 -> PreloginOption) -> Get Word8 -> Get PreloginOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8
      Word8
0x02 -> PreloginOption -> Get PreloginOption
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreloginOption -> Get PreloginOption)
-> PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ ByteString -> PreloginOption
PLInstance ((Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) ByteString
bs)
      Word8
0x03 | ByteString -> Bool
B.null ByteString
bs -> PreloginOption -> Get PreloginOption
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreloginOption -> Get PreloginOption)
-> PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> PreloginOption
PLThreadId Maybe Word32
forall a. Maybe a
Nothing
           | Bool
otherwise -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> PreloginOption
PLThreadId (Maybe Word32 -> PreloginOption)
-> (Word32 -> Maybe Word32) -> Word32 -> PreloginOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word32 -> PreloginOption) -> Get Word32 -> Get PreloginOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Get.getWord32le
      Word8
0x04 -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Word8 -> PreloginOption
PLMars (Word8 -> PreloginOption) -> Get Word8 -> Get PreloginOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8
      Word8
0x05 -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Word32 -> PreloginOption
PLTraceId (ByteString -> ByteString -> Word32 -> PreloginOption)
-> Get ByteString -> Get (ByteString -> Word32 -> PreloginOption)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
Get.getByteString Int
16 Get (ByteString -> Word32 -> PreloginOption)
-> Get ByteString -> Get (Word32 -> PreloginOption)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get ByteString
Get.getByteString Int
16 Get (Word32 -> PreloginOption) -> Get Word32 -> Get PreloginOption
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
Get.getWord32le
      Word8
0x06 -> Get PreloginOption -> Get PreloginOption
forall {f :: * -> *} {a}. MonadFail f => Get a -> f a
run (Get PreloginOption -> Get PreloginOption)
-> Get PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Word8 -> PreloginOption
PLFedAuthRequired (Word8 -> PreloginOption) -> Get Word8 -> Get PreloginOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8
      Word8
0x07 -> PreloginOption -> Get PreloginOption
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreloginOption -> Get PreloginOption)
-> PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ ByteString -> PreloginOption
PLNonce ByteString
bs
      Word8
_ -> PreloginOption -> Get PreloginOption
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreloginOption -> Get PreloginOption)
-> PreloginOption -> Get PreloginOption
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> PreloginOption
PLUnknown Word8
t ByteString
bs
      where
        run :: Get a -> f a
run Get a
g = case Get a
-> LazyByteString
-> Either
     (LazyByteString, ByteOffset, [Char])
     (LazyByteString, ByteOffset, a)
forall a.
Get a
-> LazyByteString
-> Either
     (LazyByteString, ByteOffset, [Char])
     (LazyByteString, ByteOffset, a)
Get.runGetOrFail Get a
g (ByteString -> LazyByteString
LB.fromStrict ByteString
bs) of
          Right (LazyByteString
_, ByteOffset
_, a
v) -> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
          Left (LazyByteString
_, ByteOffset
_, [Char]
err) -> [Char] -> f a
forall a. [Char] -> f a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> f a) -> [Char] -> f a
forall a b. (a -> b) -> a -> b
$ [Char]
"getPrelogin: option " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err

------------------------------------------------------------------------------
-- LOGIN7

-- | A LOGIN7 feature extension.
-- [MS-TDS 2.2.6.4 FeatureExt](https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/773a62b6-ee89-4c02-9e5e-344882630aac)
data Feature = Feature
  { Feature -> Word8
featureId :: !Word8
  , Feature -> ByteString
featureData :: !B.ByteString
  }

instance Eq Feature where
  Feature Word8
a ByteString
b == :: Feature -> Feature -> Bool
== Feature Word8
a' ByteString
b' = Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a' Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
b ByteString
b'
  {-# OPAQUE (==) #-}

-- | As derived, except that the data of a FEDAUTH feature (an access
-- token) is shown as @<redacted>@.
instance Show Feature where
  showsPrec :: Int -> Feature -> ShowS
showsPrec Int
p Feature{Word8
ByteString
featureId :: Feature -> Word8
featureData :: Feature -> ByteString
featureId :: Word8
featureData :: ByteString
..} = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"Feature"#
    [ Addr#
"featureId"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
featureId
    , if Word8
featureId Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
fedAuthFeatureId
        then Addr#
"featureData"# Addr# -> Verbatim -> Field
forall a. Show a => Addr# -> a -> Field
:= [Char] -> Verbatim
Verbatim [Char]
"<redacted>"
        else Addr#
"featureData"# Addr# -> ByteString -> Field
forall a. Show a => Addr# -> a -> Field
:= ByteString
featureData
    ]
  {-# OPAQUE showsPrec #-}

-- | Tell the server we can handle UTF-8 collations.
featureUtf8Support :: Feature
featureUtf8Support :: Feature
featureUtf8Support = Word8 -> ByteString -> Feature
Feature Word8
0x0A (Word8 -> ByteString
B.singleton Word8
0x01)

-- | The FEDAUTH feature extension.
fedAuthFeatureId :: Word8
fedAuthFeatureId :: Word8
fedAuthFeatureId = Word8
0x02

-- | Federated authentication with an access token the caller obtained
-- (MS-TDS calls the library "Security Token", 0x01): the token, UTF-16
-- encoded, goes in LOGIN7 and the server validates it; there is no further
-- exchange, unlike the MSAL library's, where the server first names the
-- token issuer (FEDAUTHINFO).
--
-- The first argument echoes the server's PRELOGIN answer to the
-- FEDAUTHREQUIRED option (the client must send that option to use this
-- feature), and the last is the nonce from that answer, if the server sent
-- one, which it only does when the client sent one.
featureFedAuthToken :: Bool -> Text -> Maybe B.ByteString -> Feature
featureFedAuthToken :: Bool -> Text -> Maybe ByteString -> Feature
featureFedAuthToken Bool
echo Text
token Maybe ByteString
nonce = Word8 -> ByteString -> Feature
Feature Word8
fedAuthFeatureId (ByteString -> Feature) -> ByteString -> Feature
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> LazyByteString
Put.runPut (Put -> LazyByteString) -> Put -> LazyByteString
forall a b. (a -> b) -> a -> b
$ do
  -- Options: bFedAuthLibrary in the upper 7 bits, fFedAuthEcho the lowest.
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Word8
0x01 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. (if Bool
echo then Word8
0x01 else Word8
0x00)
  let bytes :: ByteString
bytes = Text -> ByteString
Utf16.encodeUtf16LE Text
token
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bytes
  ByteString -> Put
Put.putByteString ByteString
bytes
  (ByteString -> Put) -> Maybe ByteString -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> Put
Put.putByteString Maybe ByteString
nonce

-- | A LOGIN7 message, which 'putLogin7' writes; start from 'defaultLogin7'.
data Login7 = Login7
  { Login7 -> TdsVersion
l7Version :: !TdsVersion
  , Login7 -> Word32
l7PacketSize :: !Word32
  , Login7 -> Word32
l7ClientProgVer :: !Word32
  , Login7 -> Word32
l7ClientPid :: !Word32
  , Login7 -> Word32
l7ConnectionId :: !Word32
  , Login7 -> Word8
l7OptionFlags1 :: !Word8
  , Login7 -> Word8
l7OptionFlags2 :: !Word8
  , Login7 -> Word8
l7TypeFlags :: !Word8
  , Login7 -> Word8
l7OptionFlags3 :: !Word8
  , Login7 -> Int32
l7TimeZone :: !Int32
  , Login7 -> Word32
l7Collation :: !Word32
  , Login7 -> Text
l7HostName :: !Text
  , Login7 -> Text
l7UserName :: !Text
  , Login7 -> Text
l7Password :: !Text
  , Login7 -> Text
l7AppName :: !Text
  , Login7 -> Text
l7ServerName :: !Text
  , Login7 -> Text
l7LibraryName :: !Text
  , Login7 -> Text
l7Language :: !Text
  , Login7 -> Text
l7Database :: !Text
  , Login7 -> ByteString
l7ClientId :: !B.ByteString
    -- ^ 6 bytes, nominally the MAC address.
  , Login7 -> [Feature]
l7Features :: ![Feature]
  }

instance Eq Login7 where
  Login7 TdsVersion
a Word32
b Word32
c Word32
e Word32
f Word8
g Word8
h Word8
i Word8
j Int32
k Word32
l Text
m Text
n Text
o Text
q Text
r Text
s Text
t Text
u ByteString
v [Feature]
w
      == :: Login7 -> Login7 -> Bool
== Login7 TdsVersion
a' Word32
b' Word32
c' Word32
e' Word32
f' Word8
g' Word8
h' Word8
i' Word8
j' Int32
k' Word32
l' Text
m' Text
n' Text
o' Text
q' Text
r' Text
s' Text
t' Text
u' ByteString
v' [Feature]
w' =
    TdsVersion -> TdsVersion -> Bool
forall a. Eq a => a -> a -> Bool
eq TdsVersion
a TdsVersion
a' Bool -> Bool -> Bool
&& Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
b' Bool -> Bool -> Bool
&& Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
c' Bool -> Bool -> Bool
&& Word32
e Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
e' Bool -> Bool -> Bool
&& Word32
f Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
f' Bool -> Bool -> Bool
&& Word8
g Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
g' Bool -> Bool -> Bool
&& Word8
h Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
h' Bool -> Bool -> Bool
&& Word8
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
i'
      Bool -> Bool -> Bool
&& Word8
j Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
j' Bool -> Bool -> Bool
&& Int32
k Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
k' Bool -> Bool -> Bool
&& Word32
l Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
l' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
m Text
m' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
n Text
n' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
o Text
o' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
q Text
q'
      Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
r Text
r' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
s Text
s' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
t Text
t' Bool -> Bool -> Bool
&& Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
u Text
u' Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq ByteString
v ByteString
v' Bool -> Bool -> Bool
&& [Feature] -> [Feature] -> Bool
forall a. Eq a => a -> a -> Bool
eq [Feature]
w [Feature]
w'
  {-# OPAQUE (==) #-}

-- | As derived, except that a non-empty password is shown as @<redacted>@.
instance Show Login7 where
  showsPrec :: Int -> Login7 -> ShowS
showsPrec Int
p Login7{Int32
[Feature]
Word8
Word32
ByteString
Text
TdsVersion
l7Version :: Login7 -> TdsVersion
l7PacketSize :: Login7 -> Word32
l7ClientProgVer :: Login7 -> Word32
l7ClientPid :: Login7 -> Word32
l7ConnectionId :: Login7 -> Word32
l7OptionFlags1 :: Login7 -> Word8
l7OptionFlags2 :: Login7 -> Word8
l7TypeFlags :: Login7 -> Word8
l7OptionFlags3 :: Login7 -> Word8
l7TimeZone :: Login7 -> Int32
l7Collation :: Login7 -> Word32
l7HostName :: Login7 -> Text
l7UserName :: Login7 -> Text
l7Password :: Login7 -> Text
l7AppName :: Login7 -> Text
l7ServerName :: Login7 -> Text
l7LibraryName :: Login7 -> Text
l7Language :: Login7 -> Text
l7Database :: Login7 -> Text
l7ClientId :: Login7 -> ByteString
l7Features :: Login7 -> [Feature]
l7Version :: TdsVersion
l7PacketSize :: Word32
l7ClientProgVer :: Word32
l7ClientPid :: Word32
l7ConnectionId :: Word32
l7OptionFlags1 :: Word8
l7OptionFlags2 :: Word8
l7TypeFlags :: Word8
l7OptionFlags3 :: Word8
l7TimeZone :: Int32
l7Collation :: Word32
l7HostName :: Text
l7UserName :: Text
l7Password :: Text
l7AppName :: Text
l7ServerName :: Text
l7LibraryName :: Text
l7Language :: Text
l7Database :: Text
l7ClientId :: ByteString
l7Features :: [Feature]
..} = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"Login7"#
    [ Addr#
"l7Version"# Addr# -> TdsVersion -> Field
forall a. Show a => Addr# -> a -> Field
:= TdsVersion
l7Version, Addr#
"l7PacketSize"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
l7PacketSize
    , Addr#
"l7ClientProgVer"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
l7ClientProgVer, Addr#
"l7ClientPid"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
l7ClientPid
    , Addr#
"l7ConnectionId"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
l7ConnectionId, Addr#
"l7OptionFlags1"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
l7OptionFlags1
    , Addr#
"l7OptionFlags2"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
l7OptionFlags2, Addr#
"l7TypeFlags"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
l7TypeFlags
    , Addr#
"l7OptionFlags3"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
l7OptionFlags3, Addr#
"l7TimeZone"# Addr# -> Int32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Int32
l7TimeZone
    , Addr#
"l7Collation"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
l7Collation, Addr#
"l7HostName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7HostName
    , Addr#
"l7UserName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7UserName
    , Addr#
"l7Password"# Addr# -> Verbatim -> Field
forall a. Show a => Addr# -> a -> Field
:= [Char] -> Verbatim
Verbatim (if Text -> Bool
T.null Text
l7Password then [Char]
"\"\"" else [Char]
"<redacted>")
    , Addr#
"l7AppName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7AppName, Addr#
"l7ServerName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7ServerName
    , Addr#
"l7LibraryName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7LibraryName, Addr#
"l7Language"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7Language
    , Addr#
"l7Database"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
l7Database, Addr#
"l7ClientId"# Addr# -> ByteString -> Field
forall a. Show a => Addr# -> a -> Field
:= ByteString
l7ClientId
    , Addr#
"l7Features"# Addr# -> [Feature] -> Field
forall a. Show a => Addr# -> a -> Field
:= [Feature]
l7Features
    ]
  {-# OPAQUE showsPrec #-}

-- | TDS 7.4, 4096-byte packets, empty names, and the UTF-8 feature.
defaultLogin7 :: Login7
defaultLogin7 :: Login7
defaultLogin7 = Login7
  { l7Version :: TdsVersion
l7Version = TdsVersion
Tds74
  , l7PacketSize :: Word32
l7PacketSize = Word32
4096
  , l7ClientProgVer :: Word32
l7ClientProgVer = Word32
0
  , l7ClientPid :: Word32
l7ClientPid = Word32
0
  , l7ConnectionId :: Word32
l7ConnectionId = Word32
0
  , l7OptionFlags1 :: Word8
l7OptionFlags1 = Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x40 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x20   -- fSetLang | fDatabase (fatal if missing) | fUseDB
  , l7OptionFlags2 :: Word8
l7OptionFlags2 = Word8
0x02 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x01            -- fODBC | fLanguage (fatal if missing)
  , l7TypeFlags :: Word8
l7TypeFlags = Word8
0
  , l7OptionFlags3 :: Word8
l7OptionFlags3 = Word8
0
  , l7TimeZone :: Int32
l7TimeZone = Int32
0
  , l7Collation :: Word32
l7Collation = Word32
0
  , l7HostName :: Text
l7HostName = Text
""
  , l7UserName :: Text
l7UserName = Text
""
  , l7Password :: Text
l7Password = Text
""
  , l7AppName :: Text
l7AppName = Text
""
  , l7ServerName :: Text
l7ServerName = Text
""
  , l7LibraryName :: Text
l7LibraryName = Text
"hmssql"
  , l7Language :: Text
l7Language = Text
""
  , l7Database :: Text
l7Database = Text
""
  , l7ClientId :: ByteString
l7ClientId = Int -> Word8 -> ByteString
B.replicate Int
6 Word8
0
  , l7Features :: [Feature]
l7Features = [Feature
featureUtf8Support]
  }

-- | Swap the nibbles of each byte, then XOR with 0xA5.
obfuscatePassword :: B.ByteString -> B.ByteString
obfuscatePassword :: ByteString -> ByteString
obfuscatePassword = (Word8 -> Word8) -> ByteString -> ByteString
B.map ((Word8 -> Word8) -> ByteString -> ByteString)
-> (Word8 -> Word8) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ \Word8
b -> ((Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4)) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
`xor` Word8
0xA5

login7FixedLength :: Int
login7FixedLength :: Int
login7FixedLength = Int
94

-- | Why 'putLogin7' can't encode this login, if it can't: its strings
-- (host, user, password, application, server, library, language and
-- database names) are located by 16-bit offsets from the start of the
-- message, so together they must end by byte 65535.  (Written modulo 65536
-- instead, a long application name would shift where the server reads the
-- following fields from.)  The server's own limit of 128 characters per
-- field is left to the server.  The message gives the length of each field
-- but the password's.
login7Problem :: Login7 -> Maybe String
login7Problem :: Login7 -> Maybe [Char]
login7Problem Login7
l
  | Int
end Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFFFF = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"the LOGIN7 strings are " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
login7FixedLength) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes long"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (host " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7HostName Login7
l)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", user " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7UserName Login7
l))
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", application " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7AppName Login7
l))
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", server " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7ServerName Login7
l)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", library " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7LibraryName Login7
l))
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", language " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7Language Login7
l)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", database " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length (Login7 -> Text
l7Database Login7
l))
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units, and the password); the wire format's 16-bit offsets allow at most "
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
0xFFFF Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
login7FixedLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" bytes"
  | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing
  where
    end :: Int
end = Int
login7FixedLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if [Feature] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Login7 -> [Feature]
l7Features Login7
l) then Int
0 else Int
4)
      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
ucs2Length [ Login7 -> Text
l7HostName Login7
l, Login7 -> Text
l7UserName Login7
l, Login7 -> Text
l7Password Login7
l, Login7 -> Text
l7AppName Login7
l
                                , Login7 -> Text
l7ServerName Login7
l, Login7 -> Text
l7LibraryName Login7
l, Login7 -> Text
l7Language Login7
l, Login7 -> Text
l7Database Login7
l ])

-- | Fails (with 'error') if there is a 'login7Problem'.
putLogin7 :: Login7 -> Put
putLogin7 :: Login7 -> Put
putLogin7 Login7
l = do
  ([Char] -> PutM (ZonkAny 0)) -> Maybe [Char] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
p -> [Char] -> PutM (ZonkAny 0)
forall a. HasCallStack => [Char] -> a
error ([Char]
"putLogin7: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
p)) (Login7 -> Maybe [Char]
login7Problem Login7
l)
  let ucs2 :: Text -> ByteString
ucs2 = Text -> ByteString
Utf16.encodeUtf16LE
      hasFeatures :: Bool
hasFeatures = Bool -> Bool
not ([Feature] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Login7 -> [Feature]
l7Features Login7
l))
      flags3 :: Word8
flags3 = Login7 -> Word8
l7OptionFlags3 Login7
l Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. (if Bool
hasFeatures then Word8
0x10 else Word8
0)
      -- FeatureExt: each feature's id, length and data, then a terminator.
      featureExtLength :: Int
featureExtLength
        | Bool
hasFeatures = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
featureData | Feature{Word8
ByteString
featureId :: Feature -> Word8
featureData :: Feature -> ByteString
featureData :: ByteString
featureId :: Word8
..} <- Login7 -> [Feature]
l7Features Login7
l] Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        | Bool
otherwise = Int
0
      -- Data section in wire order.  The extension slot holds a DWORD offset
      -- to FeatureExt, which is appended after everything else.
      hostName :: ByteString
hostName = Text -> ByteString
ucs2 (Login7 -> Text
l7HostName Login7
l)
      userName :: ByteString
userName = Text -> ByteString
ucs2 (Login7 -> Text
l7UserName Login7
l)
      password :: ByteString
password = ByteString -> ByteString
obfuscatePassword (Text -> ByteString
ucs2 (Login7 -> Text
l7Password Login7
l))
      appName :: ByteString
appName = Text -> ByteString
ucs2 (Login7 -> Text
l7AppName Login7
l)
      serverName :: ByteString
serverName = Text -> ByteString
ucs2 (Login7 -> Text
l7ServerName Login7
l)
      libraryName :: ByteString
libraryName = Text -> ByteString
ucs2 (Login7 -> Text
l7LibraryName Login7
l)
      language :: ByteString
language = Text -> ByteString
ucs2 (Login7 -> Text
l7Language Login7
l)
      database :: ByteString
database = Text -> ByteString
ucs2 (Login7 -> Text
l7Database Login7
l)
      extensionLen :: Int
extensionLen = if Bool
hasFeatures then Int
4 else Int
0
      firstHalf :: [ByteString]
firstHalf = [ByteString
hostName, ByteString
userName, ByteString
password, ByteString
appName, ByteString
serverName]
      secondHalf :: [ByteString]
secondHalf = [ByteString
libraryName, ByteString
language, ByteString
database]
      dataBeforeFeatures :: Int
dataBeforeFeatures = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Int
B.length [ByteString]
firstHalf) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
extensionLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Int
B.length [ByteString]
secondHalf)
      featureOffset :: Int
featureOffset = Int
login7FixedLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dataBeforeFeatures
      totalLength :: Int
totalLength = Int
featureOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
featureExtLength

  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalLength
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ TdsVersion -> Word32
tdsVersionWord (Login7 -> TdsVersion
l7Version Login7
l)
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word32
l7PacketSize Login7
l
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word32
l7ClientProgVer Login7
l
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word32
l7ClientPid Login7
l
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word32
l7ConnectionId Login7
l
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word8
l7OptionFlags1 Login7
l
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word8
l7OptionFlags2 Login7
l
  Word8 -> Put
Put.putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word8
l7TypeFlags Login7
l
  Word8 -> Put
Put.putWord8 Word8
flags3
  Int32 -> Put
Put.putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Int32
l7TimeZone Login7
l
  Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> Word32
l7Collation Login7
l

  off1 <- (Int -> ByteString -> PutM Int) -> Int -> [ByteString] -> PutM Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Int -> ByteString -> PutM Int
putOffsetLength Int
login7FixedLength [ByteString]
firstHalf
  off2 <- putOffsetLengthBytes off1 extensionLen
  off3 <- foldM putOffsetLength off2 secondHalf
  Put.putByteString $ B.take 6 (l7ClientId l <> B.replicate 6 0)
  _ <- putOffsetLengthBytes off3 0   -- SSPI
  _ <- putOffsetLengthBytes off3 0   -- AttachDBFile
  _ <- putOffsetLengthBytes off3 0   -- ChangePassword
  Put.putWord32le 0                  -- cbSSPILong

  mapM_ Put.putByteString firstHalf
  if hasFeatures then Put.putWord32le (fromIntegral featureOffset) else pure ()
  mapM_ Put.putByteString secondHalf
  when hasFeatures $ do
    forM_ (l7Features l) $ \Feature{Word8
ByteString
featureId :: Feature -> Word8
featureData :: Feature -> ByteString
featureId :: Word8
featureData :: ByteString
..} -> do
      Word8 -> Put
Put.putWord8 Word8
featureId
      Word32 -> Put
Put.putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
featureData
      ByteString -> Put
Put.putByteString ByteString
featureData
    Put.putWord8 0xFF
  where
    -- Lengths are in characters for strings; the extension slot is in bytes.
    putOffsetLength :: Int -> B.ByteString -> PutM Int
    putOffsetLength :: Int -> ByteString -> PutM Int
putOffsetLength Int
offset ByteString
bs = do
      Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
      Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
      Int -> PutM Int
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> PutM Int) -> Int -> PutM Int
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
bs

    putOffsetLengthBytes :: Int -> Int -> PutM Int
    putOffsetLengthBytes :: Int -> Int -> PutM Int
putOffsetLengthBytes Int
offset Int
len = do
      Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
      Word16 -> Put
Put.putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
      Int -> PutM Int
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> PutM Int) -> Int -> PutM Int
forall a b. (a -> b) -> a -> b
$ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len

------------------------------------------------------------------------------
-- SQLBatch and RPC

-- | ALL_HEADERS with a single Transaction Descriptor header.
-- MS-TDS 2.2.5.3 Packet Data Stream Headers
putAllHeaders :: TdsContext -> Put
putAllHeaders :: TdsContext -> Put
putAllHeaders = Builder -> Put
Put.putBuilder (Builder -> Put) -> (TdsContext -> Builder) -> TdsContext -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TdsContext -> Builder
allHeadersBuilder

allHeadersBuilder :: TdsContext -> BB.Builder
allHeadersBuilder :: TdsContext -> Builder
allHeadersBuilder TdsContext
ctx =
  Word32 -> Builder
BB.word32LE Word32
22 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
18 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
0x0002 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Word64 -> Builder
BB.word64LE Word64
descriptor Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BB.word32LE Word32
1
  where TransactionDescriptor Word64
descriptor = TransactionDescriptor
-> (TransactionDescriptor -> TransactionDescriptor)
-> Maybe TransactionDescriptor
-> TransactionDescriptor
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Word64 -> TransactionDescriptor
TransactionDescriptor Word64
0) TransactionDescriptor -> TransactionDescriptor
forall a. a -> a
id (TdsContext -> Maybe TransactionDescriptor
tdsTransaction TdsContext
ctx)

-- | The server's packet-count limit for a SQL batch. Most text fits using
-- its UTF-8 byte count as a bound, avoiding a separate whole-text scan.
sqlBatchProblem :: TdsContext -> Text -> Maybe String
sqlBatchProblem :: TdsContext -> Text -> Maybe [Char]
sqlBatchProblem TdsContext
ctx sql :: Text
sql@(TI.Text Array
_ Int
_ Int
utf8Length)
  | Int
utf8Length Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 = Maybe [Char]
forall a. Maybe a
Nothing
  | Int
actual Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit = Maybe [Char]
forall a. Maybe a
Nothing
  | Bool
otherwise = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"SQL batch too large: its " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
actual Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
22) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      [Char]
" bytes exceed the limit of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxSqlBatchPackets [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" packets")
  where
    limit :: Int
limit = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxSqlBatchPackets Int -> Int -> Int
forall a. Num a => a -> a -> a
* TdsContext -> Int
packetPayloadSize TdsContext
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
22
    actual :: Int
actual = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Text -> Int
Utf16.utf16Length Text
sql

putSqlBatch :: TdsContext -> Text -> Put
putSqlBatch :: TdsContext -> Text -> Put
putSqlBatch TdsContext
ctx = Builder -> Put
Put.putBuilder (Builder -> Put) -> (Text -> Builder) -> Text -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TdsContext -> Text -> Builder
sqlBatchBuilder TdsContext
ctx

sqlBatchBuilder :: TdsContext -> Text -> BB.Builder
sqlBatchBuilder :: TdsContext -> Text -> Builder
sqlBatchBuilder TdsContext
ctx Text
sql = TdsContext -> Builder
allHeadersBuilder TdsContext
ctx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Utf16.utf16LEBuilder Text
sql

sqlBatchBody :: TdsContext -> Text -> LB.ByteString
sqlBatchBody :: TdsContext -> Text -> LazyByteString
sqlBatchBody TdsContext
ctx = Builder -> LazyByteString
BB.toLazyByteString (Builder -> LazyByteString)
-> (Text -> Builder) -> Text -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TdsContext -> Text -> Builder
sqlBatchBuilder TdsContext
ctx

-- | The body of a Transaction Manager request that begins a transaction
-- (MS-TDS 2.2.6.9, TM_BEGIN_XACT): ALL_HEADERS, the request type (5), the
-- isolation level (0 keeps the session's; 1 READ UNCOMMITTED, 2 READ
-- COMMITTED, 3 REPEATABLE READ, 4 SERIALIZABLE, 5 SNAPSHOT, which the
-- session then keeps after the transaction), and an empty transaction
-- name.
tmBeginTransactionBuilder :: TdsContext -> Word8 -> BB.Builder
tmBeginTransactionBuilder :: TdsContext -> Word8 -> Builder
tmBeginTransactionBuilder TdsContext
ctx Word8
level = TdsContext -> Builder
allHeadersBuilder TdsContext
ctx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
5 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 Word8
level Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 Word8
0

tmBeginTransactionBody :: TdsContext -> Word8 -> LB.ByteString
tmBeginTransactionBody :: TdsContext -> Word8 -> LazyByteString
tmBeginTransactionBody TdsContext
ctx = Builder -> LazyByteString
BB.toLazyByteString (Builder -> LazyByteString)
-> (Word8 -> Builder) -> Word8 -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TdsContext -> Word8 -> Builder
tmBeginTransactionBuilder TdsContext
ctx

-- | The procedure an RPC calls: by its identifier ('procSpExecuteSql' is
-- @sp_executesql@) or by name.
data RpcProc
  = RpcProcId !Word16
  | RpcProcName !Text

instance Show RpcProc where
  showsPrec :: Int -> RpcProc -> ShowS
showsPrec Int
p = \case
    RpcProcId Word16
a -> Int -> Addr# -> Word16 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"RpcProcId"# Word16
a
    RpcProcName Text
a -> Int -> Addr# -> Text -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"RpcProcName"# Text
a
  {-# OPAQUE showsPrec #-}

instance Eq RpcProc where
  RpcProc
x == :: RpcProc -> RpcProc -> Bool
== RpcProc
y = case (RpcProc
x, RpcProc
y) of
    (RpcProcId Word16
a, RpcProcId Word16
a') -> Word16
a Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
a'
    (RpcProcName Text
a, RpcProcName Text
a') -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
eq Text
a Text
a'
    (RpcProc, RpcProc)
_ -> Bool
False
  {-# OPAQUE (==) #-}

procSpExecuteSql :: RpcProc
procSpExecuteSql :: RpcProc
procSpExecuteSql = Word16 -> RpcProc
RpcProcId Word16
10

-- | A parameter of an RPC.
data RpcParam = RpcParam
  { RpcParam -> Text
rpcParamName :: !Text
    -- ^ Including the leading @\@@; may be empty for positional parameters.
  , RpcParam -> Word8
rpcParamStatus :: !Word8
  , RpcParam -> TypeInfo
rpcParamType :: !TypeInfo
  , RpcParam -> ParamValue
rpcParamValue :: !ParamValue
  }

instance Show RpcParam where
  showsPrec :: Int -> RpcParam -> ShowS
showsPrec Int
p (RpcParam Text
a Word8
b TypeInfo
c ParamValue
e) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"RpcParam"#
    [ Addr#
"rpcParamName"# Addr# -> Text -> Field
forall a. Show a => Addr# -> a -> Field
:= Text
a, Addr#
"rpcParamStatus"# Addr# -> Word8 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word8
b, Addr#
"rpcParamType"# Addr# -> TypeInfo -> Field
forall a. Show a => Addr# -> a -> Field
:= TypeInfo
c
    , Addr#
"rpcParamValue"# Addr# -> ParamValue -> Field
forall a. Show a => Addr# -> a -> Field
:= ParamValue
e
    ]
  {-# OPAQUE showsPrec #-}

-- | Status flag: the parameter is an output parameter.
paramByRef :: Word8
paramByRef :: Word8
paramByRef = Word8
0x01

-- | Status flag: use the procedure's default value.
paramDefault :: Word8
paramDefault :: Word8
paramDefault = Word8
0x02

-- | One RPC: the procedure, the option flags and the parameters.
data RpcRequest = RpcRequest
  { RpcRequest -> RpcProc
rpcProc :: !RpcProc
  , RpcRequest -> Word16
rpcOptions :: !Word16
  , RpcRequest -> [RpcParam]
rpcParams :: ![RpcParam]
  }

instance Show RpcRequest where
  showsPrec :: Int -> RpcRequest -> ShowS
showsPrec Int
p (RpcRequest RpcProc
a Word16
b [RpcParam]
c) =
    Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"RpcRequest"# [Addr#
"rpcProc"# Addr# -> RpcProc -> Field
forall a. Show a => Addr# -> a -> Field
:= RpcProc
a, Addr#
"rpcOptions"# Addr# -> Word16 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word16
b, Addr#
"rpcParams"# Addr# -> [RpcParam] -> Field
forall a. Show a => Addr# -> a -> Field
:= [RpcParam]
c]
  {-# OPAQUE showsPrec #-}

-- | One or more RPCs in a single request, separated by the 0xFF batch flag.
--
-- Fails (with 'error') if 'rpcRequestProblem' finds a problem; callers
-- check first.  (Writing a name or value length modulo the size of its
-- length prefix would make the server read the rest as further fields: a
-- 300-character parameter name would go out as a 44-character name followed
-- by what the server takes for the parameter's type and value.)
putRpcRequest :: TdsContext -> [RpcRequest] -> Put
putRpcRequest :: TdsContext -> [RpcRequest] -> Put
putRpcRequest TdsContext
ctx [RpcRequest]
reqs = LazyByteString -> Put
Put.putLazyByteString (TdsContext -> [RpcRequest] -> LazyByteString
rpcRequestBody TdsContext
ctx [RpcRequest]
reqs)

-- | The bytes of 'putRpcRequest': fails (with 'error', when forced) if
-- 'rpcRequestProblem' finds a problem.
rpcRequestBody :: TdsContext -> [RpcRequest] -> LB.ByteString
rpcRequestBody :: TdsContext -> [RpcRequest] -> LazyByteString
rpcRequestBody TdsContext
ctx [RpcRequest]
reqs = case (RpcRequest -> Maybe [Char]) -> [RpcRequest] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RpcRequest -> Maybe [Char]
rpcRequestProblem [RpcRequest]
reqs of
  [Char]
p : [[Char]]
_ -> [Char] -> LazyByteString
forall a. HasCallStack => [Char] -> a
error ([Char]
"putRpcRequest: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
p)
  [] -> TdsContext -> [RpcRequest] -> LazyByteString
rpcRequestBodyUnchecked TdsContext
ctx [RpcRequest]
reqs

-- | Build a checked request's bytes with the same Builder used for sending.
rpcRequestBodyUnchecked :: TdsContext -> [RpcRequest] -> LB.ByteString
rpcRequestBodyUnchecked :: TdsContext -> [RpcRequest] -> LazyByteString
rpcRequestBodyUnchecked TdsContext
ctx = Builder -> LazyByteString
BB.toLazyByteString (Builder -> LazyByteString)
-> ([RpcRequest] -> Builder) -> [RpcRequest] -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TdsContext -> [RpcRequest] -> Builder
rpcRequestBuilder TdsContext
ctx

rpcRequestBuilder :: TdsContext -> [RpcRequest] -> BB.Builder
rpcRequestBuilder :: TdsContext -> [RpcRequest] -> Builder
rpcRequestBuilder TdsContext
ctx [RpcRequest]
requests = TdsContext -> Builder
allHeadersBuilder TdsContext
ctx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [RpcRequest] -> Builder
go [RpcRequest]
requests
  where
    go :: [RpcRequest] -> Builder
go [] = Builder
forall a. Monoid a => a
mempty
    go [RpcRequest
r] = RpcRequest -> Builder
request RpcRequest
r
    go (RpcRequest
r : [RpcRequest]
rs) = RpcRequest -> Builder
request RpcRequest
r Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 Word8
0xFF Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [RpcRequest] -> Builder
go [RpcRequest]
rs
    request :: RpcRequest -> Builder
request RpcRequest{[RpcParam]
Word16
RpcProc
rpcProc :: RpcRequest -> RpcProc
rpcOptions :: RpcRequest -> Word16
rpcParams :: RpcRequest -> [RpcParam]
rpcProc :: RpcProc
rpcOptions :: Word16
rpcParams :: [RpcParam]
..} = RpcProc -> Builder
proc RpcProc
rpcProc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
rpcOptions Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (RpcParam -> Builder) -> [RpcParam] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RpcParam -> Builder
rpcParamBuilder [RpcParam]
rpcParams
    proc :: RpcProc -> Builder
proc (RpcProcId Word16
pid) = Word16 -> Builder
BB.word16LE Word16
0xFFFF Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
pid
    proc (RpcProcName Text
name) = Word16 -> Builder
BB.word16LE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Utf16.utf16Length Text
name)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Utf16.utf16LEBuilder Text
name

rpcParamBuilder :: RpcParam -> BB.Builder
rpcParamBuilder :: RpcParam -> Builder
rpcParamBuilder param :: RpcParam
param@RpcParam{Word8
Text
TypeInfo
ParamValue
rpcParamName :: RpcParam -> Text
rpcParamStatus :: RpcParam -> Word8
rpcParamType :: RpcParam -> TypeInfo
rpcParamValue :: RpcParam -> ParamValue
rpcParamName :: Text
rpcParamStatus :: Word8
rpcParamType :: TypeInfo
rpcParamValue :: ParamValue
..} = RpcParam -> Builder
rpcParamHeader RpcParam
param Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case ParamValue
rpcParamValue of
  ParamBytes Maybe ByteString
bytes -> TypeInfo -> Maybe ByteString -> Builder
writeValue TypeInfo
rpcParamType Maybe ByteString
bytes
  ParamValue
_ -> [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error [Char]
"streamed RPC values require writeRpcRequests"

-- Shared by the sender and the in-memory serializer, so the two can't disagree.
-- Inlined so that its Builder composes with the value's at the call site.
rpcParamHeader :: RpcParam -> BB.Builder
rpcParamHeader :: RpcParam -> Builder
rpcParamHeader RpcParam{Word8
Text
TypeInfo
ParamValue
rpcParamName :: RpcParam -> Text
rpcParamStatus :: RpcParam -> Word8
rpcParamType :: RpcParam -> TypeInfo
rpcParamValue :: RpcParam -> ParamValue
rpcParamName :: Text
rpcParamStatus :: Word8
rpcParamType :: TypeInfo
rpcParamValue :: ParamValue
..} =
  Word8 -> Builder
BB.word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Utf16.utf16Length Text
rpcParamName)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Utf16.utf16LEBuilder Text
rpcParamName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Word8 -> Builder
BB.word8 Word8
rpcParamStatus Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TypeInfo -> Builder
writeTypeInfo TypeInfo
rpcParamType
{-# INLINE rpcParamHeader #-}

-- | Why 'putRpcRequest' can't encode this RPC, if it can't: a procedure name
-- of 65535 or more UTF-16 code units (NameLenProcID is a USHORT, and 0xFFFF
-- announces a procedure ID instead), or an 'rpcParamProblem'.
rpcRequestProblem :: RpcRequest -> Maybe String
rpcRequestProblem :: RpcRequest -> Maybe [Char]
rpcRequestProblem RpcRequest{[RpcParam]
Word16
RpcProc
rpcProc :: RpcRequest -> RpcProc
rpcOptions :: RpcRequest -> Word16
rpcParams :: RpcRequest -> [RpcParam]
rpcProc :: RpcProc
rpcOptions :: Word16
rpcParams :: [RpcParam]
..} = case RpcProc
rpcProc of
  RpcProcName Text
name
    | Text -> Int
ucs2Length Text
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xFFFF ->
        [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"the procedure name is " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length Text
name)
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units long; the wire format allows at most 65534"
  RpcProc
_ -> [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
listToMaybe ((RpcParam -> Maybe [Char]) -> [RpcParam] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RpcParam -> Maybe [Char]
rpcParamProblem [RpcParam]
rpcParams)

-- | Why a parameter can't be sent, if it can't: a name of more than 255
-- UTF-16 code units (a B_VARCHAR; SQL Server's own limit is 128 characters,
-- which it reports itself), a 'typeInfoProblem', or a 'valueProblem'.
rpcParamProblem :: RpcParam -> Maybe String
rpcParamProblem :: RpcParam -> Maybe [Char]
rpcParamProblem RpcParam{Word8
Text
TypeInfo
ParamValue
rpcParamName :: RpcParam -> Text
rpcParamStatus :: RpcParam -> Word8
rpcParamType :: RpcParam -> TypeInfo
rpcParamValue :: RpcParam -> ParamValue
rpcParamName :: Text
rpcParamStatus :: Word8
rpcParamType :: TypeInfo
rpcParamValue :: ParamValue
..}
  | Text -> Int
ucs2Length Text
rpcParamName Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0xFF = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
      [Char]
"parameter name " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Text -> Text
T.take Int
20 Text
rpcParamName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"...") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is "
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
ucs2Length Text
rpcParamName) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" UTF-16 code units long; the wire format allows at most 255"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (and SQL Server at most 128 characters)"
  | Bool
otherwise = (([Char]
"parameter " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
label [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": ") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Maybe [Char]
-> ([Char] -> Maybe [Char]) -> Maybe [Char] -> Maybe [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Word8
rpcParamStatus Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
paramByRef Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0 Bool -> Bool -> Bool
&& ParamValue -> Bool
streamed ParamValue
rpcParamValue then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"output parameters cannot stream" else TypeInfo -> ParamValue -> Maybe [Char]
paramValueProblem TypeInfo
rpcParamType ParamValue
rpcParamValue) [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (TypeInfo -> Maybe [Char]
typeInfoProblem TypeInfo
rpcParamType)
  where
    label :: [Char]
label = if Text -> Bool
T.null Text
rpcParamName then [Char]
"(positional)" else Text -> [Char]
T.unpack Text
rpcParamName

-- | The writer of these requests.  In-memory requests can be sent any number
-- of times.  Requests with lazy or effectful values can be sent once: the
-- writer takes them out of a reference as it starts, so the request no longer
-- keeps a lazy value's head alive while it is sent, and a value is read once
-- no matter how many threads try.  A query builds a new writer per send.
newRpcWriter :: [RpcRequest] -> IO (TdsContext -> PacketWriter -> IO ())
newRpcWriter :: [RpcRequest] -> IO (TdsContext -> PacketWriter -> IO ())
newRpcWriter [RpcRequest]
requests
  | Bool -> Bool
not ((RpcRequest -> Bool) -> [RpcRequest] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RpcParam -> Bool) -> [RpcParam] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ParamValue -> Bool
streamed (ParamValue -> Bool)
-> (RpcParam -> ParamValue) -> RpcParam -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcParam -> ParamValue
rpcParamValue) ([RpcParam] -> Bool)
-> (RpcRequest -> [RpcParam]) -> RpcRequest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcRequest -> [RpcParam]
rpcParams) [RpcRequest]
requests) = (TdsContext -> PacketWriter -> IO ())
-> IO (TdsContext -> PacketWriter -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\TdsContext
ctx PacketWriter
out -> TdsContext -> PacketWriter -> [RpcRequest] -> IO ()
writeRpcRequests TdsContext
ctx PacketWriter
out [RpcRequest]
requests)
  | Bool
otherwise = do
      remaining <- Maybe [RpcRequest] -> IO (IORef (Maybe [RpcRequest]))
forall a. a -> IO (IORef a)
newIORef ([RpcRequest] -> Maybe [RpcRequest]
forall a. a -> Maybe a
Just [RpcRequest]
requests)
      pure $ \TdsContext
ctx PacketWriter
out -> do
        pending <- IORef (Maybe [RpcRequest])
-> (Maybe [RpcRequest] -> (Maybe [RpcRequest], Maybe [RpcRequest]))
-> IO (Maybe [RpcRequest])
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe [RpcRequest])
remaining (\Maybe [RpcRequest]
r -> (Maybe [RpcRequest]
forall a. Maybe a
Nothing, Maybe [RpcRequest]
r))
        case pending of
          Maybe [RpcRequest]
Nothing -> EncodeError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> EncodeError
EncodeError [Char]
"a request containing lazy or streamed parameters can be sent only once")
          Just [RpcRequest]
rs -> TdsContext -> PacketWriter -> [RpcRequest] -> IO ()
writeRpcRequests TdsContext
ctx PacketWriter
out [RpcRequest]
rs

-- | Write requests whose types, names and values have been validated at
-- construction, in order, with one separator between requests.

-- Plain traversal of the lists is deliberate.  Once 'newRpcWriter' has taken the
-- requests, nothing refers to a parameter after its turn, and a private reference
-- per list would protect nothing more (Scale.ParameterResidency checks retention).
writeRpcRequests :: TdsContext -> PacketWriter -> [RpcRequest] -> IO ()
writeRpcRequests :: TdsContext -> PacketWriter -> [RpcRequest] -> IO ()
writeRpcRequests TdsContext
ctx PacketWriter
out [RpcRequest]
requests = do
  PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
out (TdsContext -> Builder
allHeadersBuilder TdsContext
ctx)
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
intersperse (PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
out (Word8 -> Builder
BB.word8 Word8
0xFF)) ((RpcRequest -> IO ()) -> [RpcRequest] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map RpcRequest -> IO ()
writeRequest [RpcRequest]
requests))
  where
    writeRequest :: RpcRequest -> IO ()
writeRequest RpcRequest{[RpcParam]
Word16
RpcProc
rpcProc :: RpcRequest -> RpcProc
rpcOptions :: RpcRequest -> Word16
rpcParams :: RpcRequest -> [RpcParam]
rpcProc :: RpcProc
rpcOptions :: Word16
rpcParams :: [RpcParam]
..} =
      let header :: Builder
header = (case RpcProc
rpcProc of
            RpcProcId Word16
pid -> Word16 -> Builder
BB.word16LE Word16
0xFFFF Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
pid
            RpcProcName Text
name -> Word16 -> Builder
BB.word16LE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Utf16.utf16Length Text
name)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Utf16.utf16LEBuilder Text
name) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
BB.word16LE Word16
rpcOptions
       -- The request's header goes in one Builder with its first parameter.
       -- Later parameters have only their own header, so a many-parameter
       -- request pays nothing for this (measured: 3.5% less allocation for a
       -- one-integer request, no change with many parameters).
       in case [RpcParam]
rpcParams of
            [] -> PacketWriter -> Builder -> IO ()
writeBuilder PacketWriter
out Builder
header
            RpcParam
first : [RpcParam]
rest -> do
              PacketWriter -> Builder -> TypeInfo -> ParamValue -> IO ()
writeParamValueWith PacketWriter
out (Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RpcParam -> Builder
rpcParamHeader RpcParam
first)
                (RpcParam -> TypeInfo
rpcParamType RpcParam
first) (RpcParam -> ParamValue
rpcParamValue RpcParam
first)
              [RpcParam] -> (RpcParam -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RpcParam]
rest ((RpcParam -> IO ()) -> IO ()) -> (RpcParam -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \param :: RpcParam
param@RpcParam{Word8
Text
TypeInfo
ParamValue
rpcParamName :: RpcParam -> Text
rpcParamStatus :: RpcParam -> Word8
rpcParamType :: RpcParam -> TypeInfo
rpcParamValue :: RpcParam -> ParamValue
rpcParamName :: Text
rpcParamStatus :: Word8
rpcParamType :: TypeInfo
rpcParamValue :: ParamValue
..} ->
                PacketWriter -> Builder -> TypeInfo -> ParamValue -> IO ()
writeParamValueWith PacketWriter
out (RpcParam -> Builder
rpcParamHeader RpcParam
param) TypeInfo
rpcParamType ParamValue
rpcParamValue