{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
module Database.MSSQLServer.Query (
sql
, ResultSet (..)
, Result (..)
, Row (..)
, Only (..)
, RowCount (..)
, ReturnStatus (..)
, rpc
, RpcResponseSet (..)
, RpcResponse (..)
, RpcOutputSet (..)
, RpcResultSet (..)
, RpcResult (..)
, RpcQuerySet (..)
, RpcQuery (..)
, RpcQueryId (..)
, StoredProcedure (..)
, RpcParamSet (..)
, RpcParam (..)
, RpcParamName
, 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
, withTransaction
, QueryError (..)
) where
import Data.Typeable(Typeable)
import Network.Socket (Socket)
import Network.Socket.ByteString (recv)
import Network.Socket.ByteString.Lazy (sendAll)
import qualified Data.Text as T
import qualified Data.Binary.Get as Get
import qualified Data.Binary.Put as Put
import Control.Exception (Exception(..),throwIO,onException)
import Database.Tds.Message
import Database.MSSQLServer.Connection (Connection(..))
import Database.MSSQLServer.Query.Only
import Database.MSSQLServer.Query.Row
import Database.MSSQLServer.Query.ResultSet
import Database.MSSQLServer.Query.RpcResponseSet
import Database.MSSQLServer.Query.RpcQuerySet
import Database.MSSQLServer.Query.TokenStreamParser
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#else
import Control.Monad.Error
runExceptT = runErrorT
#endif
data QueryError = QueryError !Info
deriving (Int -> QueryError -> ShowS
[QueryError] -> ShowS
QueryError -> String
(Int -> QueryError -> ShowS)
-> (QueryError -> String)
-> ([QueryError] -> ShowS)
-> Show QueryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryError] -> ShowS
$cshowList :: [QueryError] -> ShowS
show :: QueryError -> String
$cshow :: QueryError -> String
showsPrec :: Int -> QueryError -> ShowS
$cshowsPrec :: Int -> QueryError -> ShowS
Show,Typeable)
instance Exception QueryError
sql :: ResultSet a => Connection -> T.Text -> IO a
sql :: Connection -> Text -> IO a
sql (Connection Socket
sock Word32
ps) Text
query = do
Socket -> ByteString -> IO ()
sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps (ClientMessage -> Put) -> ClientMessage -> Put
forall a b. (a -> b) -> a -> b
$ SqlBatch -> ClientMessage
CMSqlBatch (SqlBatch -> ClientMessage) -> SqlBatch -> ClientMessage
forall a b. (a -> b) -> a -> b
$ Text -> SqlBatch
SqlBatch Text
query
TokenStreams [TokenStream]
tss <- Socket -> Decoder TokenStreams -> IO TokenStreams
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock (Decoder TokenStreams -> IO TokenStreams)
-> Decoder TokenStreams -> IO TokenStreams
forall a b. (a -> b) -> a -> b
$ Get TokenStreams -> Decoder TokenStreams
forall a. Get a -> Decoder a
Get.runGetIncremental Get TokenStreams
forall a. ServerMessage a => Get a
getServerMessage
case Parser (Either Info a)
-> [TokenStream] -> [(Either Info a, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser (Either Info a)
forall a. ResultSet a => Parser (Either Info a)
responseParser [TokenStream]
tss of
[] -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sql: failed to parse token streams"
(Left Info
info,[TokenStream]
_):[(Either Info a, [TokenStream])]
_ -> QueryError -> IO a
forall e a. Exception e => e -> IO a
throwIO (QueryError -> IO a) -> QueryError -> IO a
forall a b. (a -> b) -> a -> b
$ Info -> QueryError
QueryError Info
info
(Right a
x,[TokenStream]
_):[(Either Info a, [TokenStream])]
_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
where
responseParser :: (ResultSet a) => Parser (Either Info a)
responseParser :: Parser (Either Info a)
responseParser = ExceptT Info Parser a -> Parser (Either Info a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Info Parser a -> Parser (Either Info a))
-> ExceptT Info Parser a -> Parser (Either Info a)
forall a b. (a -> b) -> a -> b
$ ExceptT Info Parser a
forall a. ResultSet a => Parser' a
resultSetParser
rpc :: (RpcQuerySet a, RpcResponseSet b) => Connection -> a -> IO b
rpc :: Connection -> a -> IO b
rpc (Connection Socket
sock Word32
ps) a
queries = do
Socket -> ByteString -> IO ()
sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps (ClientMessage -> Put) -> ClientMessage -> Put
forall a b. (a -> b) -> a -> b
$ RpcRequest -> ClientMessage
CMRpcRequest (RpcRequest -> ClientMessage) -> RpcRequest -> ClientMessage
forall a b. (a -> b) -> a -> b
$ a -> RpcRequest
forall a. RpcQuerySet a => a -> RpcRequest
toRpcRequest a
queries
TokenStreams [TokenStream]
tss <- Socket -> Decoder TokenStreams -> IO TokenStreams
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock (Decoder TokenStreams -> IO TokenStreams)
-> Decoder TokenStreams -> IO TokenStreams
forall a b. (a -> b) -> a -> b
$ Get TokenStreams -> Decoder TokenStreams
forall a. Get a -> Decoder a
Get.runGetIncremental Get TokenStreams
forall a. ServerMessage a => Get a
getServerMessage
case Parser b -> [TokenStream] -> [(b, [TokenStream])]
forall a. Parser a -> [TokenStream] -> [(a, [TokenStream])]
parse Parser b
forall a. RpcResponseSet a => Parser a
rpcResponseSetParser [TokenStream]
tss of
[] -> String -> IO b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"rpc: failed to parse token streams"
(b
x,[TokenStream]
_):[(b, [TokenStream])]
_ -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
withTransaction :: Connection -> IO a -> IO a
withTransaction :: Connection -> IO a -> IO a
withTransaction Connection
conn IO a
act = do
IO ()
begin
a
r <- IO a
act IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` IO ()
rollback
IO ()
commit
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
where
begin :: IO ()
begin = Connection -> Text -> IO ()
forall a. ResultSet a => Connection -> Text -> IO a
sql Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"BEGIN TRANSACTION" :: IO ()
commit :: IO ()
commit = Connection -> Text -> IO ()
forall a. ResultSet a => Connection -> Text -> IO a
sql Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"COMMIT TRANSACTION" :: IO ()
rollback :: IO ()
rollback = Connection -> Text -> IO ()
forall a. ResultSet a => Connection -> Text -> IO a
sql Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"ROLLBACK TRANSACTION":: IO ()
readMessage :: Socket -> Get.Decoder a -> IO a
readMessage :: Socket -> Decoder a -> IO a
readMessage Socket
sock Decoder a
decoder = do
ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
512
case Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
Get.pushChunk Decoder a
decoder ByteString
bs of
Get.Done ByteString
_ ByteOffset
_ a
msg -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
msg
Decoder a
decoder' -> Socket -> Decoder a -> IO a
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock Decoder a
decoder'