{-# LANGUAGE MagicHash #-}
-- | Runtime state that affects how TDS messages are serialized and parsed.
--
-- Every @get@/@put@ function in "Hmssql.Tds.*" takes a 'TdsContext' so that
-- protocol-version-dependent encodings are decided in one place.
module Hmssql.Tds.Context
  ( TdsVersion (..)
  , tdsVersionWord
  , tdsVersionFromWord
  , TransactionDescriptor (..)
  , TdsContext (..)
  , defaultTdsContext
  , minPacketSize
  , maxPacketSize
  , clampPacketSize
  ) where

import qualified Data.ByteString as B
import Data.Word (Word32, Word64)
import Hmssql.Internal.Derived

-- | Protocol versions this library can negotiate.
--
-- TDS 7.4 is the baseline (SQL Server 2017 and later, Azure SQL).  TDS 8.0 is the
-- same token stream over TLS from byte zero ("strict" encryption).
data TdsVersion
  = Tds74
  | Tds80
  deriving stock (TdsVersion -> TdsVersion -> Bool
(TdsVersion -> TdsVersion -> Bool)
-> (TdsVersion -> TdsVersion -> Bool) -> Eq TdsVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TdsVersion -> TdsVersion -> Bool
== :: TdsVersion -> TdsVersion -> Bool
$c/= :: TdsVersion -> TdsVersion -> Bool
/= :: TdsVersion -> TdsVersion -> Bool
Eq, Eq TdsVersion
Eq TdsVersion =>
(TdsVersion -> TdsVersion -> Ordering)
-> (TdsVersion -> TdsVersion -> Bool)
-> (TdsVersion -> TdsVersion -> Bool)
-> (TdsVersion -> TdsVersion -> Bool)
-> (TdsVersion -> TdsVersion -> Bool)
-> (TdsVersion -> TdsVersion -> TdsVersion)
-> (TdsVersion -> TdsVersion -> TdsVersion)
-> Ord TdsVersion
TdsVersion -> TdsVersion -> Bool
TdsVersion -> TdsVersion -> Ordering
TdsVersion -> TdsVersion -> TdsVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TdsVersion -> TdsVersion -> Ordering
compare :: TdsVersion -> TdsVersion -> Ordering
$c< :: TdsVersion -> TdsVersion -> Bool
< :: TdsVersion -> TdsVersion -> Bool
$c<= :: TdsVersion -> TdsVersion -> Bool
<= :: TdsVersion -> TdsVersion -> Bool
$c> :: TdsVersion -> TdsVersion -> Bool
> :: TdsVersion -> TdsVersion -> Bool
$c>= :: TdsVersion -> TdsVersion -> Bool
>= :: TdsVersion -> TdsVersion -> Bool
$cmax :: TdsVersion -> TdsVersion -> TdsVersion
max :: TdsVersion -> TdsVersion -> TdsVersion
$cmin :: TdsVersion -> TdsVersion -> TdsVersion
min :: TdsVersion -> TdsVersion -> TdsVersion
Ord, Int -> TdsVersion -> ShowS
[TdsVersion] -> ShowS
TdsVersion -> String
(Int -> TdsVersion -> ShowS)
-> (TdsVersion -> String)
-> ([TdsVersion] -> ShowS)
-> Show TdsVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TdsVersion -> ShowS
showsPrec :: Int -> TdsVersion -> ShowS
$cshow :: TdsVersion -> String
show :: TdsVersion -> String
$cshowList :: [TdsVersion] -> ShowS
showList :: [TdsVersion] -> ShowS
Show, Int -> TdsVersion
TdsVersion -> Int
TdsVersion -> [TdsVersion]
TdsVersion -> TdsVersion
TdsVersion -> TdsVersion -> [TdsVersion]
TdsVersion -> TdsVersion -> TdsVersion -> [TdsVersion]
(TdsVersion -> TdsVersion)
-> (TdsVersion -> TdsVersion)
-> (Int -> TdsVersion)
-> (TdsVersion -> Int)
-> (TdsVersion -> [TdsVersion])
-> (TdsVersion -> TdsVersion -> [TdsVersion])
-> (TdsVersion -> TdsVersion -> [TdsVersion])
-> (TdsVersion -> TdsVersion -> TdsVersion -> [TdsVersion])
-> Enum TdsVersion
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: TdsVersion -> TdsVersion
succ :: TdsVersion -> TdsVersion
$cpred :: TdsVersion -> TdsVersion
pred :: TdsVersion -> TdsVersion
$ctoEnum :: Int -> TdsVersion
toEnum :: Int -> TdsVersion
$cfromEnum :: TdsVersion -> Int
fromEnum :: TdsVersion -> Int
$cenumFrom :: TdsVersion -> [TdsVersion]
enumFrom :: TdsVersion -> [TdsVersion]
$cenumFromThen :: TdsVersion -> TdsVersion -> [TdsVersion]
enumFromThen :: TdsVersion -> TdsVersion -> [TdsVersion]
$cenumFromTo :: TdsVersion -> TdsVersion -> [TdsVersion]
enumFromTo :: TdsVersion -> TdsVersion -> [TdsVersion]
$cenumFromThenTo :: TdsVersion -> TdsVersion -> TdsVersion -> [TdsVersion]
enumFromThenTo :: TdsVersion -> TdsVersion -> TdsVersion -> [TdsVersion]
Enum, TdsVersion
TdsVersion -> TdsVersion -> Bounded TdsVersion
forall a. a -> a -> Bounded a
$cminBound :: TdsVersion
minBound :: TdsVersion
$cmaxBound :: TdsVersion
maxBound :: TdsVersion
Bounded)

-- | The version DWORD sent in LOGIN7 (little-endian on the wire).
tdsVersionWord :: TdsVersion -> Word32
tdsVersionWord :: TdsVersion -> Word32
tdsVersionWord = \case
  TdsVersion
Tds74 -> Word32
0x74000004
  TdsVersion
Tds80 -> Word32
0x08000000

-- | Interpret the version DWORD from LOGINACK (big-endian on the wire).
tdsVersionFromWord :: Word32 -> Maybe TdsVersion
tdsVersionFromWord :: Word32 -> Maybe TdsVersion
tdsVersionFromWord = \case
  Word32
0x74000004 -> TdsVersion -> Maybe TdsVersion
forall a. a -> Maybe a
Just TdsVersion
Tds74
  Word32
0x08000000 -> TdsVersion -> Maybe TdsVersion
forall a. a -> Maybe a
Just TdsVersion
Tds80
  Word32
_ -> Maybe TdsVersion
forall a. Maybe a
Nothing

-- | The server's identifier for the session's transaction, from a transaction
-- ENVCHANGE, which every request sends back in its ALL_HEADERS.
newtype TransactionDescriptor = TransactionDescriptor Word64
  deriving newtype (TransactionDescriptor -> TransactionDescriptor -> Bool
(TransactionDescriptor -> TransactionDescriptor -> Bool)
-> (TransactionDescriptor -> TransactionDescriptor -> Bool)
-> Eq TransactionDescriptor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransactionDescriptor -> TransactionDescriptor -> Bool
== :: TransactionDescriptor -> TransactionDescriptor -> Bool
$c/= :: TransactionDescriptor -> TransactionDescriptor -> Bool
/= :: TransactionDescriptor -> TransactionDescriptor -> Bool
Eq, Eq TransactionDescriptor
Eq TransactionDescriptor =>
(TransactionDescriptor -> TransactionDescriptor -> Ordering)
-> (TransactionDescriptor -> TransactionDescriptor -> Bool)
-> (TransactionDescriptor -> TransactionDescriptor -> Bool)
-> (TransactionDescriptor -> TransactionDescriptor -> Bool)
-> (TransactionDescriptor -> TransactionDescriptor -> Bool)
-> (TransactionDescriptor
    -> TransactionDescriptor -> TransactionDescriptor)
-> (TransactionDescriptor
    -> TransactionDescriptor -> TransactionDescriptor)
-> Ord TransactionDescriptor
TransactionDescriptor -> TransactionDescriptor -> Bool
TransactionDescriptor -> TransactionDescriptor -> Ordering
TransactionDescriptor
-> TransactionDescriptor -> TransactionDescriptor
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TransactionDescriptor -> TransactionDescriptor -> Ordering
compare :: TransactionDescriptor -> TransactionDescriptor -> Ordering
$c< :: TransactionDescriptor -> TransactionDescriptor -> Bool
< :: TransactionDescriptor -> TransactionDescriptor -> Bool
$c<= :: TransactionDescriptor -> TransactionDescriptor -> Bool
<= :: TransactionDescriptor -> TransactionDescriptor -> Bool
$c> :: TransactionDescriptor -> TransactionDescriptor -> Bool
> :: TransactionDescriptor -> TransactionDescriptor -> Bool
$c>= :: TransactionDescriptor -> TransactionDescriptor -> Bool
>= :: TransactionDescriptor -> TransactionDescriptor -> Bool
$cmax :: TransactionDescriptor
-> TransactionDescriptor -> TransactionDescriptor
max :: TransactionDescriptor
-> TransactionDescriptor -> TransactionDescriptor
$cmin :: TransactionDescriptor
-> TransactionDescriptor -> TransactionDescriptor
min :: TransactionDescriptor
-> TransactionDescriptor -> TransactionDescriptor
Ord)

instance Show TransactionDescriptor where
  showsPrec :: Int -> TransactionDescriptor -> ShowS
showsPrec Int
p (TransactionDescriptor Word64
a) = Int -> Addr# -> Word64 -> ShowS
forall a. Show a => Int -> Addr# -> a -> ShowS
showCon1 Int
p Addr#
"TransactionDescriptor"# Word64
a
  {-# OPAQUE showsPrec #-}

-- | The protocol state a connection has negotiated, which the encoders
-- and parsers take as an argument; 'Hmssql.Connection.connectionContext'
-- reads a connection's.
data TdsContext = TdsContext
  { TdsContext -> TdsVersion
tdsVersion :: !TdsVersion
    -- ^ The version the server agreed to in LOGINACK.
  , TdsContext -> Word32
tdsPacketSize :: !Word32
    -- ^ Negotiated packet size, including the 8-byte header.
  , TdsContext -> Maybe TransactionDescriptor
tdsTransaction :: !(Maybe TransactionDescriptor)
    -- ^ Current transaction, sent in the ALL_HEADERS of every request.
  , TdsContext -> Bool
tdsUtf8Support :: !Bool
    -- ^ Server acknowledged the UTF8_SUPPORT feature extension.
  , TdsContext -> Maybe ByteString
tdsCollation :: !(Maybe B.ByteString)
    -- ^ The session's default collation, the five bytes of the last SQL
    -- collation ENVCHANGE (at login, and after a @USE@), if any: what a
    -- string is sent with where a collation is needed and none is known
    -- (a @sql_variant@ value in "Hmssql.BulkCopy").
  }

instance Show TdsContext where
  showsPrec :: Int -> TdsContext -> ShowS
showsPrec Int
p (TdsContext TdsVersion
a Word32
b Maybe TransactionDescriptor
c Bool
e Maybe ByteString
f) = Int -> Addr# -> [Field] -> ShowS
showRecord Int
p Addr#
"TdsContext"#
    [ Addr#
"tdsVersion"# Addr# -> TdsVersion -> Field
forall a. Show a => Addr# -> a -> Field
:= TdsVersion
a, Addr#
"tdsPacketSize"# Addr# -> Word32 -> Field
forall a. Show a => Addr# -> a -> Field
:= Word32
b, Addr#
"tdsTransaction"# Addr# -> Maybe TransactionDescriptor -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe TransactionDescriptor
c
    , Addr#
"tdsUtf8Support"# Addr# -> Bool -> Field
forall a. Show a => Addr# -> a -> Field
:= Bool
e, Addr#
"tdsCollation"# Addr# -> Maybe ByteString -> Field
forall a. Show a => Addr# -> a -> Field
:= Maybe ByteString
f
    ]
  {-# OPAQUE showsPrec #-}

instance Eq TdsContext where
  TdsContext TdsVersion
a Word32
b Maybe TransactionDescriptor
c Bool
e Maybe ByteString
f == :: TdsContext -> TdsContext -> Bool
== TdsContext TdsVersion
a' Word32
b' Maybe TransactionDescriptor
c' Bool
e' Maybe ByteString
f' =
    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
&& Maybe TransactionDescriptor -> Maybe TransactionDescriptor -> Bool
forall a. Eq a => a -> a -> Bool
eq Maybe TransactionDescriptor
c Maybe TransactionDescriptor
c' Bool -> Bool -> Bool
&& Bool
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
e' Bool -> Bool -> Bool
&& Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
eq Maybe ByteString
f Maybe ByteString
f'
  {-# OPAQUE (==) #-}

-- | The range of packet sizes, header included, that SQL Server negotiates
-- (its @network packet size@ option; MS-TDS 2.2.6.4 LOGIN7
-- PacketSize).
minPacketSize, maxPacketSize :: Word32
minPacketSize :: Word32
minPacketSize = Word32
512
maxPacketSize :: Word32
maxPacketSize = Word32
32767

-- | The nearest packet size in 'minPacketSize' .. 'maxPacketSize'.
clampPacketSize :: Word32 -> Word32
clampPacketSize :: Word32 -> Word32
clampPacketSize = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
minPacketSize (Word32 -> Word32) -> (Word32 -> Word32) -> Word32 -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
maxPacketSize

-- | TDS 7.4, 4096-byte packets, no transaction: what a connection starts
-- from, and what the pure encoders are tested with.
defaultTdsContext :: TdsContext
defaultTdsContext :: TdsContext
defaultTdsContext = TdsContext
  { tdsVersion :: TdsVersion
tdsVersion = TdsVersion
Tds74
  , tdsPacketSize :: Word32
tdsPacketSize = Word32
4096
  , tdsTransaction :: Maybe TransactionDescriptor
tdsTransaction = Maybe TransactionDescriptor
forall a. Maybe a
Nothing
  , tdsUtf8Support :: Bool
tdsUtf8Support = Bool
False
  , tdsCollation :: Maybe ByteString
tdsCollation = Maybe ByteString
forall a. Maybe a
Nothing
  }