{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Database.MSSQLServer.Query.RpcResponseSet ( RpcResponseSet (..)
, RpcResponse (..)
, RpcResultSet (..)
, RpcResult (..)
, RpcOutputSet (..)
) where
import Control.Applicative(Alternative((<|>)),many,(<$>))
import Database.Tds.Message
import Database.MSSQLServer.Query.Row
import Database.MSSQLServer.Query.Only
import Database.MSSQLServer.Query.TokenStreamParser
import Database.MSSQLServer.Query.Template
import Control.Monad(forM)
import Language.Haskell.TH (runIO,pprint)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#else
import Control.Monad.Error
runExceptT = runErrorT
#endif
errorDone :: Parser TokenStream
errorDone = do
_ <- many $ satisfy $ not . isTSError
ts <- satisfy isTSError
_ <- many $ satisfy $ not . isFinalTSDoneProc
_ <- satisfy isFinalTSDoneProc
return ts
trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream
trySatisfy f = do
ts <- lift $ (satisfyNotError f) <|> errorDone
case ts of
TSError ei -> throwError ei
_ -> return ts
trySatisfyMany :: (TokenStream -> Bool) -> Parser' [TokenStream]
trySatisfyMany f = do
tss <- lift $ (many $ satisfyNotError f) <|> ((\x->[x]) <$> errorDone)
case tss of
(TSError ei):_ -> throwError ei
_ -> return tss
listOfRow :: Row a => Parser' ([a])
listOfRow = do
_ <- trySatisfyMany $ not . isTSColMetaData
tsCmd <- trySatisfy isTSColMetaData
_ <- trySatisfyMany $ not . isTSRow
tsRows <- trySatisfyMany isTSRow
_ <- trySatisfyMany $ not . isTSDoneInProc
_ <- trySatisfy isTSDoneInProc
return $
let
(TSColMetaData (maybeCmd)) = tsCmd
mcds = case (\(ColMetaData x) -> x) <$> maybeCmd of
Nothing -> error "listOfRow: ColMetaData is necessary"
Just mcds' -> mcds'
rows = (\(TSRow row) -> getRawBytes <$> row) <$> tsRows
in fromListOfRawBytes mcds <$> rows
where
isTSColMetaData :: TokenStream -> Bool
isTSColMetaData (TSColMetaData{}) = True
isTSColMetaData _ = False
isTSRow :: TokenStream -> Bool
isTSRow (TSRow{}) = True
isTSRow _ = False
isTSDoneInProc :: TokenStream -> Bool
isTSDoneInProc (TSDoneInProc{}) = True
isTSDoneInProc _ = False
getRawBytes :: RowColumnData -> RawBytes
getRawBytes (RCDOrdinal dt) = dt
getRawBytes (RCDLarge _ _ dt) = dt
class RpcResultSet a where
rpcResultSetParser :: Parser' a
instance RpcResultSet () where
rpcResultSetParser = return ()
instance (Row a) => RpcResultSet [a] where
rpcResultSetParser = listOfRow
forM [2..30] $ \n -> do
dec <- rpcResultSetTupleQ n
return dec
class RpcResult a where
rpcResultParser :: Parser' a
instance Row a => RpcResult [a] where
rpcResultParser = listOfRow
rvTypeInfo :: ReturnValue -> TypeInfo
rvTypeInfo (ReturnValue _ _ _ _ _ ti _) = ti
rvRawBytes :: ReturnValue -> RawBytes
rvRawBytes (ReturnValue _ _ _ _ _ _ rb) = rb
class RpcOutputSet a where
fromReturnValues :: [ReturnValue] -> a
instance RpcOutputSet () where
fromReturnValues [] = ()
fromReturnValues _ = error "fromReturnValues: List length must be 0"
instance (Data a) => RpcOutputSet (Only a) where
fromReturnValues [r1] = Only d1
where
!d1 = fromRawBytes (rvTypeInfo r1) (rvRawBytes r1)
fromReturnValues _ = error "fromReturnValues: List length must be 1"
forM [2..30] $ \n -> do
dec <- rpcOutputSetTupleQ n
return dec
data RpcResponse a b = RpcResponse !Int !a !b
| RpcResponseError !Info
deriving (Show)
rpcResponseParser :: (RpcOutputSet a, RpcResultSet b) => Bool -> Parser (RpcResponse a b)
rpcResponseParser final = do
let rrParser = runExceptT $ do
rrs <- rpcResultSetParser
_ <- trySatisfyMany $ not . isTSReturnStatus
TSReturnStatus ret <- trySatisfy isTSReturnStatus
_ <- trySatisfyMany $ not . isTSReturnValue
rvs <- trySatisfyMany isTSReturnValue
_ <- trySatisfyMany $ not . isTSDoneProc
_ <- if final
then trySatisfy isFinalTSDoneProc
else trySatisfy isTSDoneProc
let rvs' = (\(TSReturnValue rv) -> rv) <$> rvs
return $ RpcResponse (fromIntegral ret) (fromReturnValues rvs') rrs
err <- rrParser
case err of
Left ei -> return $ RpcResponseError ei
Right rr -> return rr
where
isTSReturnStatus :: TokenStream -> Bool
isTSReturnStatus (TSReturnStatus{}) = True
isTSReturnStatus _ = False
isTSReturnValue :: TokenStream -> Bool
isTSReturnValue (TSReturnValue{}) = True
isTSReturnValue _ = False
class RpcResponseSet a where
rpcResponseSetParser :: Parser a
instance (RpcOutputSet a1, RpcResultSet b1) => RpcResponseSet (RpcResponse a1 b1) where
rpcResponseSetParser = rpcResponseParser True
forM [2..30] $ \n -> do
dec <- rpcResponseSetTupleQ n
return dec