{-# 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) -- | There several ways provided for specify stored procedures. -- See ProcID section of [\[MS-TDS\] 2.2.6.6 RPC Request](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/619c43b6-9495-4a58-9e49-a4950db245b3). 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 -- [MEMO] using Template Haskell forM [2..60] $ \n -> do dec <- rpcParamSetTupleQ n -- runIO $ putStrLn $ pprint dec return dec --instance (Data a1, Data a2) => RpcParamSet (RpcParam a1, RpcParam a2) where -- toRpcReqBatchParams (d1,d2) = [p1,bp] -- where -- !p1 = rpcReqBatchParam d1 -- !p2 = rpcReqBatchParam d2 -- 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 -- [MEMO] using Template Haskell forM [2..30] $ \n -> do dec <- rpcQuerySetTupleQ n -- runIO $ putStrLn $ pprint dec return dec --instance (RpcQueryId a1, RpcParamSet b1, RpcQueryId a2, RpcParamSet b2) => RpcQuerySet (RpcQuery a1 b1, RpcQuery a2 b2) where -- toRpcRequest (RpcQuery a1 b1,RpcQuery a2 b2) = RpcRequest [r1,r2] -- where -- !r1 = toRpcReqBatch a1 b1 -- !r2 = toRpcReqBatch a2 b2 -- 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