{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.MSSQLServer.Query.RpcQuerySet ( RpcQuerySet (..)
, RpcQuery (..)
, RpcQueryId (..)
, StoredProcedure (..)
, RpcParamSet (..)
, RpcParam (..)
, RpcParamName
, rpcReqBatchParam
, bitVal
, tinyintVal
, smallintVal
, intVal
, bigintVal
, smallmoneyVal
, moneyVal
, smalldatetimeVal
, datetimeVal
, float24Val
, realVal
, float53Val
, doubleVal
, uniqueidentifierVal
, decimalVal
, numericVal
, charVal
, varcharVal
, textVal
, ncharVal
, nvarcharVal
, ntextVal
, binaryVal
, varbinaryVal
, imageVal
, bitRef
, tinyintRef
, smallintRef
, intRef
, bigintRef
, smallmoneyRef
, moneyRef
, smalldatetimeRef
, datetimeRef
, float24Ref
, realRef
, float53Ref
, doubleRef
, uniqueidentifierRef
, decimalRef
, numericRef
, charRef
, varcharRef
, textRef
, ncharRef
, nvarcharRef
, ntextRef
, binaryRef
, varbinaryRef
, imageRef
, bitDefRef
, tinyintDefRef
, smallintDefRef
, intDefRef
, bigintDefRef
, smallmoneyDefRef
, moneyDefRef
, smalldatetimeDefRef
, datetimeDefRef
, float24DefRef
, realDefRef
, float53DefRef
, doubleDefRef
, uniqueidentifierDefRef
, decimalDefRef
, numericDefRef
, charDefRef
, varcharDefRef
, textDefRef
, ncharDefRef
, nvarcharDefRef
, ntextDefRef
, binaryDefRef
, varbinaryDefRef
, imageDefRef
) where
import qualified Data.Text as T
import qualified Data.ByteString as B
import Data.Word (Word16(..))
import Database.Tds.Message
import Database.MSSQLServer.Query.Only
import Database.MSSQLServer.Query.Template
import Control.Monad(forM)
import Language.Haskell.TH (runIO,pprint)
import Data.Time (UTCTime(..))
import Data.UUID.Types (UUID)
import Data.Fixed (Fixed(..),HasResolution(..))
data RpcQuery a b = RpcQuery !a !b
deriving (Show)
class RpcQueryId a where
toRpcReqBatch :: (RpcParamSet b) => a -> b -> RpcReqBatch
instance RpcQueryId Word16 where
toRpcReqBatch id ps = RpcReqBatchProcId id 0x0000 $ toRpcReqBatchParams ps
instance RpcQueryId T.Text where
toRpcReqBatch name ps = RpcReqBatchProcName name 0x0000 $ toRpcReqBatchParams ps
data StoredProcedure = SP_Cursor
| SP_CursorOpen
| SP_CursorPrepare
| SP_CursorExecute
| SP_CursorPrepExec
| SP_CursorUnprepare
| SP_CursorFetch
| SP_CursorOption
| SP_CursorClose
| SP_ExecuteSql
| SP_Prepare
| SP_Execute
| SP_PrepExec
| SP_PrepExecRpc
| SP_Unprepare
deriving (Show,Enum,Bounded)
instance RpcQueryId StoredProcedure where
toRpcReqBatch sp ps = RpcReqBatchProcId (fromIntegral $ (fromEnum sp) +1) 0x0000 $ toRpcReqBatchParams ps
type RpcParamName = T.Text
data RpcParam a = RpcParamVal !RpcParamName !TypeInfo !a
| RpcParamRef !RpcParamName !TypeInfo !a
| RpcParamDefVal !RpcParamName !TypeInfo !a
| RpcParamDefRef !RpcParamName !TypeInfo !a
deriving (Show)
rpcReqBatchParam :: (Data a) => RpcParam a -> RpcReqBatchParam
rpcReqBatchParam = f
where
f (RpcParamVal name ti dt) = RpcReqBatchParam name 0 ti (toRawBytes ti dt)
f (RpcParamRef name ti dt) = RpcReqBatchParam name 1 ti (toRawBytes ti dt)
f (RpcParamDefVal name ti dt) = RpcReqBatchParam name 2 ti (toRawBytes ti dt)
f (RpcParamDefRef name ti dt) = RpcReqBatchParam name 3 ti (toRawBytes ti dt)
class RpcParamSet a where
toRpcReqBatchParams :: a -> [RpcReqBatchParam]
instance RpcParamSet () where
toRpcReqBatchParams _ = []
instance (Data a) => RpcParamSet (RpcParam a) where
toRpcReqBatchParams v1 = [b1]
where
!b1 = rpcReqBatchParam v1
forM [2..60] $ \n -> do
dec <- rpcParamSetTupleQ n
return dec
class RpcQuerySet a where
toRpcRequest :: a -> RpcRequest
instance (RpcQueryId a1, RpcParamSet b1) => RpcQuerySet (RpcQuery a1 b1) where
toRpcRequest (RpcQuery a1 b1) = RpcRequest [r1]
where
!r1 = toRpcReqBatch a1 b1
forM [2..30] $ \n -> do
dec <- rpcQuerySetTupleQ n
return dec
decimalScale :: (HasResolution a) => Fixed a -> Scale
decimalScale = digits . resolution
where
digits :: Integer -> Scale
digits = truncate . (logBase 10.0) . fromInteger
bitVal :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
bitVal name n = RpcParamVal name TIBitN n
tinyintVal :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
tinyintVal name n = RpcParamVal name TIIntN1 n
smallintVal :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
smallintVal name n = RpcParamVal name TIIntN2 n
intVal :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
intVal name n = RpcParamVal name TIIntN4 n
bigintVal :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
bigintVal name n = RpcParamVal name TIIntN8 n
smallmoneyVal :: RpcParamName -> (Maybe Money) -> RpcParam (Maybe Money)
smallmoneyVal name m = RpcParamVal name TIMoneyN4 m
moneyVal :: RpcParamName -> (Maybe Money) -> RpcParam (Maybe Money)
moneyVal name m = RpcParamVal name TIMoneyN8 m
smalldatetimeVal :: RpcParamName -> (Maybe UTCTime) -> RpcParam (Maybe UTCTime)
smalldatetimeVal name dt = RpcParamVal name TIDateTimeN4 dt
datetimeVal :: RpcParamName -> (Maybe UTCTime) -> RpcParam (Maybe UTCTime)
datetimeVal name dt = RpcParamVal name TIDateTimeN8 dt
float24Val :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
float24Val name n = RpcParamVal name TIFltN4 n
realVal :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
realVal = float24Val
float53Val :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
float53Val name n = RpcParamVal name TIFltN8 n
doubleVal :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
doubleVal = float53Val
uniqueidentifierVal :: RpcParamName -> (Maybe UUID) -> RpcParam (Maybe UUID)
uniqueidentifierVal name uuid = RpcParamVal name TIGUID uuid
decimalVal :: (HasResolution a) => RpcParamName -> Precision -> (Either Scale (Fixed a)) -> RpcParam (Maybe (Fixed a))
decimalVal name p (Left s) = RpcParamVal name (TIDecimalN p s) Nothing
decimalVal name p (Right f) = RpcParamVal name (TIDecimalN p (decimalScale f)) (Just f)
numericVal :: (HasResolution a) => RpcParamName -> Precision -> (Either Scale (Fixed a)) -> RpcParam (Maybe (Fixed a))
numericVal name p (Left s) = RpcParamVal name (TINumericN p s) Nothing
numericVal name p (Right f) = RpcParamVal name (TINumericN p (decimalScale f)) (Just f)
charVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
charVal name Nothing = RpcParamVal name (TIBigChar 0xffff (Collation 0x00000000 0x00)) Nothing
charVal name (Just bs) = RpcParamVal name (TIBigChar (fromIntegral $ B.length bs) (Collation 0x00000000 0x00)) (Just bs)
varcharVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
varcharVal name Nothing = RpcParamVal name (TIBigVarChar 0xffff (Collation 0x00000000 0x00)) Nothing
varcharVal name (Just bs) = RpcParamVal name (TIBigVarChar (fromIntegral $ B.length bs) (Collation 0x00000000 0x00)) (Just bs)
textVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
textVal name Nothing = RpcParamVal name (TIText 0xffffffff (Collation 0x00000000 0x00)) Nothing
textVal name (Just bs) = RpcParamVal name (TIText (fromIntegral $ B.length bs) (Collation 0x00000000 0x00)) (Just bs)
ncharVal :: RpcParamName -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
ncharVal name Nothing = RpcParamVal name (TINChar 0xffff (Collation 0x00000000 0x00)) Nothing
ncharVal name (Just ts) = RpcParamVal name (TINChar (fromIntegral $ (T.length ts) * 2) (Collation 0x00000000 0x00)) (Just ts)
nvarcharVal :: RpcParamName -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
nvarcharVal name Nothing = RpcParamVal name (TINVarChar 0xffff (Collation 0x00000000 0x00)) Nothing
nvarcharVal name (Just ts) = RpcParamVal name (TINVarChar (fromIntegral $ (T.length ts) * 2) (Collation 0x00000000 0x00)) (Just ts)
ntextVal :: RpcParamName -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
ntextVal name Nothing = RpcParamVal name (TINText 0xffffffff (Collation 0x00000000 0x00)) Nothing
ntextVal name (Just ts) = RpcParamVal name (TINText (fromIntegral $ (T.length ts) * 2) (Collation 0x00000000 0x00)) (Just ts)
binaryVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
binaryVal name Nothing = RpcParamVal name (TIBigBinary 0xffff) Nothing
binaryVal name (Just bs) = RpcParamVal name (TIBigBinary (fromIntegral $ B.length bs)) (Just bs)
varbinaryVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
varbinaryVal name Nothing = RpcParamVal name (TIBigVarBinary 0xffff) Nothing
varbinaryVal name (Just bs) = RpcParamVal name (TIBigVarBinary (fromIntegral $ B.length bs)) (Just bs)
imageVal :: RpcParamName -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
imageVal name Nothing = RpcParamVal name (TIImage 0xffffffff) Nothing
imageVal name (Just bs) = RpcParamVal name (TIImage (fromIntegral $ B.length bs)) (Just bs)
bitRef :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
bitRef name n = RpcParamRef name TIBitN n
tinyintRef :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
tinyintRef name n = RpcParamRef name TIIntN1 n
smallintRef :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
smallintRef name n = RpcParamRef name TIIntN2 n
intRef :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
intRef name n = RpcParamRef name TIIntN4 n
bigintRef :: (Integral a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
bigintRef name n = RpcParamRef name TIIntN8 n
smallmoneyRef :: RpcParamName -> (Maybe Money) -> RpcParam (Maybe Money)
smallmoneyRef name m = RpcParamRef name TIMoneyN4 m
moneyRef :: RpcParamName -> (Maybe Money) -> RpcParam (Maybe Money)
moneyRef name m = RpcParamRef name TIMoneyN8 m
smalldatetimeRef :: RpcParamName -> (Maybe UTCTime) -> RpcParam (Maybe UTCTime)
smalldatetimeRef name dt = RpcParamRef name TIDateTimeN4 dt
datetimeRef :: RpcParamName -> (Maybe UTCTime) -> RpcParam (Maybe UTCTime)
datetimeRef name dt = RpcParamRef name TIDateTimeN8 dt
float24Ref :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
float24Ref name n = RpcParamRef name TIFltN4 n
realRef :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
realRef = float24Ref
float53Ref :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
float53Ref name n = RpcParamRef name TIFltN8 n
doubleRef :: (Fractional a) => RpcParamName -> (Maybe a) -> RpcParam (Maybe a)
doubleRef = float53Ref
uniqueidentifierRef :: RpcParamName -> (Maybe UUID) -> RpcParam (Maybe UUID)
uniqueidentifierRef name uuid = RpcParamRef name TIGUID uuid
decimalRef :: (HasResolution a) => RpcParamName -> Precision -> (Either Scale (Fixed a)) -> RpcParam (Maybe (Fixed a))
decimalRef name p (Left s) = RpcParamRef name (TIDecimalN p s) Nothing
decimalRef name p (Right f) = RpcParamRef name (TIDecimalN p (decimalScale f)) (Just f)
numericRef :: (HasResolution a) => RpcParamName -> Precision -> (Either Scale (Fixed a)) -> RpcParam (Maybe (Fixed a))
numericRef name p (Left s) = RpcParamRef name (TINumericN p s) Nothing
numericRef name p (Right f) = RpcParamRef name (TINumericN p (decimalScale f)) (Just f)
charRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
charRef name len bs = RpcParamRef name (TIBigChar (fromIntegral len) (Collation 0x00000000 0x00)) bs
varcharRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
varcharRef name len bs = RpcParamRef name (TIBigVarChar (fromIntegral len) (Collation 0x00000000 0x00)) bs
textRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
textRef name len bs = RpcParamRef name (TIText (fromIntegral len) (Collation 0x00000000 0x00)) bs
ncharRef :: RpcParamName -> Int -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
ncharRef name len ts = RpcParamRef name (TINChar (fromIntegral $ len *2) (Collation 0x00000000 0x00)) ts
nvarcharRef :: RpcParamName -> Int -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
nvarcharRef name len ts = RpcParamRef name (TINVarChar (fromIntegral $ len *2) (Collation 0x00000000 0x00)) ts
ntextRef :: RpcParamName -> Int -> (Maybe T.Text) -> RpcParam (Maybe T.Text)
ntextRef name len ts = RpcParamRef name (TINText (fromIntegral $ len *2) (Collation 0x00000000 0x00)) ts
binaryRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
binaryRef name len bs = RpcParamRef name (TIBigBinary (fromIntegral len)) bs
varbinaryRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
varbinaryRef name len bs = RpcParamRef name (TIBigVarBinary (fromIntegral len)) bs
imageRef :: RpcParamName -> Int -> (Maybe B.ByteString) -> RpcParam (Maybe B.ByteString)
imageRef name len bs = RpcParamRef name (TIImage (fromIntegral len)) bs
bitDefRef :: (Integral a) => RpcParamName -> RpcParam (Maybe a)
bitDefRef name = RpcParamDefRef name TIBitN Nothing
tinyintDefRef :: (Integral a) => RpcParamName -> RpcParam (Maybe a)
tinyintDefRef name = RpcParamDefRef name TIIntN1 Nothing
smallintDefRef :: (Integral a) => RpcParamName -> RpcParam (Maybe a)
smallintDefRef name = RpcParamDefRef name TIIntN2 Nothing
intDefRef :: (Integral a) => RpcParamName -> RpcParam (Maybe a)
intDefRef name = RpcParamDefRef name TIIntN4 Nothing
bigintDefRef :: (Integral a) => RpcParamName -> RpcParam (Maybe a)
bigintDefRef name = RpcParamDefRef name TIIntN8 Nothing
smallmoneyDefRef :: RpcParamName -> RpcParam (Maybe Money)
smallmoneyDefRef name = RpcParamDefRef name TIMoneyN4 Nothing
moneyDefRef :: RpcParamName -> RpcParam (Maybe Money)
moneyDefRef name = RpcParamDefRef name TIMoneyN8 Nothing
smalldatetimeDefRef :: RpcParamName -> RpcParam (Maybe UTCTime)
smalldatetimeDefRef name = RpcParamDefRef name TIDateTimeN4 Nothing
datetimeDefRef :: RpcParamName -> RpcParam (Maybe UTCTime)
datetimeDefRef name = RpcParamDefRef name TIDateTimeN8 Nothing
float24DefRef :: (Fractional a) => RpcParamName -> RpcParam (Maybe a)
float24DefRef name = RpcParamDefRef name TIFltN4 Nothing
realDefRef :: (Fractional a) => RpcParamName -> RpcParam (Maybe a)
realDefRef = float24DefRef
float53DefRef :: (Fractional a) => RpcParamName -> RpcParam (Maybe a)
float53DefRef name = RpcParamDefRef name TIFltN8 Nothing
doubleDefRef :: (Fractional a) => RpcParamName -> RpcParam (Maybe a)
doubleDefRef = float53DefRef
uniqueidentifierDefRef :: RpcParamName -> RpcParam (Maybe UUID)
uniqueidentifierDefRef name = RpcParamDefRef name TIGUID Nothing
decimalDefRef :: (HasResolution a) => RpcParamName -> Precision -> Scale -> RpcParam (Maybe (Fixed a))
decimalDefRef name p s = RpcParamDefRef name (TIDecimalN p s) Nothing
numericDefRef :: (HasResolution a) => RpcParamName -> Precision -> Scale -> RpcParam (Maybe (Fixed a))
numericDefRef name p s = RpcParamDefRef name (TINumericN p s) Nothing
charDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
charDefRef name len = RpcParamDefRef name (TIBigChar (fromIntegral len) (Collation 0x00000000 0x00)) Nothing
varcharDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
varcharDefRef name len = RpcParamDefRef name (TIBigVarChar (fromIntegral len) (Collation 0x00000000 0x00)) Nothing
textDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
textDefRef name len = RpcParamDefRef name (TIText (fromIntegral len) (Collation 0x00000000 0x00)) Nothing
ncharDefRef :: RpcParamName -> Int -> RpcParam (Maybe T.Text)
ncharDefRef name len = RpcParamDefRef name (TINChar (fromIntegral $ len *2) (Collation 0x00000000 0x00)) Nothing
nvarcharDefRef :: RpcParamName -> Int -> RpcParam (Maybe T.Text)
nvarcharDefRef name len = RpcParamDefRef name (TINVarChar (fromIntegral $ len *2) (Collation 0x00000000 0x00)) Nothing
ntextDefRef :: RpcParamName -> Int -> RpcParam (Maybe T.Text)
ntextDefRef name len = RpcParamDefRef name (TINText (fromIntegral $ len *2) (Collation 0x00000000 0x00)) Nothing
binaryDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
binaryDefRef name len = RpcParamDefRef name (TIBigBinary (fromIntegral len)) Nothing
varbinaryDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
varbinaryDefRef name len = RpcParamDefRef name (TIBigVarBinary (fromIntegral len)) Nothing
imageDefRef :: RpcParamName -> Int -> RpcParam (Maybe B.ByteString)
imageDefRef name len = RpcParamDefRef name (TIImage (fromIntegral len)) Nothing