mssql-simple 0.4.0.2 → 0.5.0.0

raw patch · 9 files changed

+678/−173 lines, 9 filesdep +mtldep +uuid-typesdep ~ms-tdsPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, uuid-types

Dependency ranges changed: ms-tds

API changes (from Hackage documentation)

Files

• mssql-simple.cabal +8/−4
• src/Database/MSSQLServer/Connection.hs +5/−7
• src/Database/MSSQLServer/Query.hs +97/−38
• src/Database/MSSQLServer/Query/ResultSet.hs +101/−9
• src/Database/MSSQLServer/Query/Row.hs +6/−0
• src/Database/MSSQLServer/Query/RpcQuerySet.hs +341/−6
• src/Database/MSSQLServer/Query/RpcResponseSet.hs +70/−21
• src/Database/MSSQLServer/Query/Template.hs +2/−2
• src/Database/MSSQLServer/Query/TokenStreamParser.hs +48/−86

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3fdeca9ccee2c838ec977f3ba9cecc1833abeb358e2c85be382050d6cf7522ad+-- hash: f7f0ea35f8fb135356688fa555518383d0e49559703ffc5bf54c001806938f54  name:           mssql-simple-version:        0.4.0.2+version:        0.5.0.0 synopsis:       SQL Server client library implemented in Haskell description:    Please see the README on GitHub at <https://github.com/mitsuji/mssql-simple#readme> category:       Database@@ -47,12 +47,14 @@     , binary     , bytestring     , hostname-    , ms-tds >=0.3 && <0.4+    , ms-tds >=0.4 && <0.5+    , mtl     , network     , template-haskell     , text     , time     , tls+    , uuid-types   default-language: Haskell2010  test-suite tds-test@@ -68,11 +70,13 @@     , binary     , bytestring     , hostname-    , ms-tds >=0.3 && <0.4+    , ms-tds >=0.4 && <0.5     , mssql-simple+    , mtl     , network     , template-haskell     , text     , time     , tls+    , uuid-types   default-language: Haskell2010

@@ -19,13 +19,11 @@ import Data.Monoid ((<>),mempty)  import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB  import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T -import Data.Binary (Binary(..)) import qualified Data.Binary.Put as Put import qualified Data.Binary.Get as Get @@ -104,10 +102,10 @@      Prelogin plResOpts <- performPrelogin sock ps encrypt -  [PLOEncryption modeEnc]  <- case filter isPLOEncryption plResOpts of+  PLOEncryption modeEnc:_  <- case filter isPLOEncryption plResOpts of                                 [] -> throwIO $ ProtocolError "connect: PLOEncryption is necessary"                                 xs -> return xs-  [PLOMars modeMars] <- case filter isPLOMars plResOpts of+  PLOMars modeMars:_ <- case filter isPLOMars plResOpts of                           [] -> throwIO $ ProtocolError "connect: PLOMars is necessary"                           xs -> return xs   when (modeEnc/=encrypt)  $ throwIO $ ProtocolError "connect: Server reported unsupported encryption mode"@@ -207,15 +205,15 @@  validLoginAck :: Login7 -> TokenStreams -> IO () validLoginAck login7 (TokenStreams loginResTokenStreams) = do-  +   let loginAcks   = filter isTSLoginAck loginResTokenStreams   when (null loginAcks) $ do-    [TSError info] <- case filter isTSError loginResTokenStreams of+    TSError info:_ <- case filter isTSError loginResTokenStreams of                         [] -> throwIO $ ProtocolError "validLoginAck: TSError is necessary"                         xs -> return xs     throwIO $ AuthError info -  let [TSLoginAck _ tdsVersion' _ _] = loginAcks+  let (TSLoginAck _ tdsVersion' _ _):_ = loginAcks   when (tdsVersion /= tdsVersion') $ throwIO $ ProtocolError "validLoginAck: Server reported unsupported tds version"    return ()

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  module Database.MSSQLServer.Query ( -- * SQL Text Query                                     sql@@ -8,6 +9,8 @@                                   , Result (..)                                   , Row (..)                                   , Only (..)+                                  , RowCount (..)+                                  , ReturnStatus (..)                                                                      -- * RPC Query                                   , rpc@@ -29,38 +32,105 @@                                   , RpcParamSet (..)                                   , RpcParam (..)                                   , RpcParamName-                                  , nvarcharVal-                                  , ntextVal++                                  , 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                                   -- * Exceptions                                   , withTransaction                                   , QueryError (..)                                   ) where -import Control.Applicative((<$>))-import Data.Monoid ((<>)) import Data.Typeable(Typeable)  import Network.Socket (Socket) import Network.Socket.ByteString (recv) import Network.Socket.ByteString.Lazy (sendAll) -import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB- import qualified Data.Text as T  import qualified Data.Binary.Get as Get import qualified Data.Binary.Put as Put -import Control.Monad (when) import Control.Exception (Exception(..),throwIO,onException)  import Database.Tds.Message -import Database.MSSQLServer.Connection+import Database.MSSQLServer.Connection (Connection(..)) import Database.MSSQLServer.Query.Only import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.ResultSet@@ -68,6 +138,12 @@ 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 (Show,Typeable)@@ -80,38 +156,25 @@   sendAll sock $ Put.runPut $ putClientMessage ps $ CMSqlBatch $ SqlBatch query   TokenStreams tss <- readMessage sock $ Get.runGetIncremental getServerMessage -  case filter isTSError tss of-    [] -> case parse resultSetParser tss of-      [] -> error "sql: failed to parse token streams"-      (x,_):_ -> return x-    TSError info :_ -> throwIO $ QueryError info+  case parse responseParser tss of+    [] -> fail "sql: failed to parse token streams"+    (Left info,_):_ -> throwIO $ QueryError info+    (Right x,_):_ -> return x +  where+    responseParser :: (ResultSet a) => Parser (Either Info a)+    responseParser = runExceptT $ resultSetParser  + rpc :: (RpcQuerySet a, RpcResponseSet b) => Connection -> a -> IO b rpc (Connection sock ps) queries = do   sendAll sock $ Put.runPut $ putClientMessage ps $ CMRpcRequest $ toRpcRequest queries   TokenStreams tss <- readMessage sock $ Get.runGetIncremental getServerMessage -  case filter isTSError tss of-    [] -> case parse rpcResponseSetParser tss of-      [] -> error "rpc: failed to parse token streams"-      (x,_):_ -> return x-    TSError info :_ -> throwIO $ QueryError info----nvarcharVal :: RpcParamName -> T.Text -> RpcParam T.Text-nvarcharVal name ts = RpcParamVal name (TINVarChar (fromIntegral $ (T.length ts) * 2) (Collation 0x00000000 0x00)) ts--ntextVal :: RpcParamName -> T.Text -> RpcParam T.Text-ntextVal name ts = RpcParamVal name (TINText (fromIntegral $ (T.length ts) * 2) (Collation 0x00000000 0x00)) ts--varcharVal :: RpcParamName -> B.ByteString -> RpcParam B.ByteString-varcharVal name bs = RpcParamVal name (TIBigVarChar (fromIntegral $ B.length bs) (Collation 0x00000000 0x00)) bs--textVal :: RpcParamName -> B.ByteString -> RpcParam B.ByteString-textVal name bs = RpcParamVal name (TIText (fromIntegral $ B.length bs) (Collation 0x00000000 0x00)) bs+  case parse rpcResponseSetParser tss of+    [] -> fail "rpc: failed to parse token streams"+    (x,_):_ -> return x   @@ -127,10 +190,6 @@       rollback = sql conn $ T.pack "ROLLBACK TRANSACTION":: IO ()  --isTSError :: TokenStream -> Bool-isTSError (TSError{}) = True-isTSError _ = False  readMessage :: Socket -> Get.Decoder a -> IO a readMessage sock decoder = do

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}   module Database.MSSQLServer.Query.ResultSet ( ResultSet (..)@@ -8,6 +9,7 @@                                             ) where  +import Control.Applicative ((<$>)) import Database.Tds.Message import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.Only@@ -17,20 +19,106 @@ 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+#endif  ++noResult :: Parser' ()+noResult = do+  _ <- trySatisfyMany $ not . isTSDoneOrDoneProc+  _ <- trySatisfy isTSDoneOrDoneProc+  return ()+  where+    isTSDoneOrDoneProc :: TokenStream -> Bool+    isTSDoneOrDoneProc (TSDone{}) = True+    isTSDoneOrDoneProc (TSDoneProc{}) = True+    isTSDoneOrDoneProc _ = False+++returnStatus :: Parser' ReturnStatus+returnStatus = do+  _ <- trySatisfyMany $ not . isTSReturnStatus+  TSReturnStatus rets <- trySatisfy isTSReturnStatus+  _ <- trySatisfy isTSDoneProc+  return $ ReturnStatus $ fromIntegral rets+  where+    isTSReturnStatus :: TokenStream -> Bool+    isTSReturnStatus (TSReturnStatus{}) = True+    isTSReturnStatus _ = False++    isTSDoneProc :: TokenStream -> Bool+    isTSDoneProc (TSDoneProc{}) = True+    isTSDoneProc _ = False+++rowCount :: Parser' RowCount+rowCount = do+  _ <- trySatisfyMany $ not . isTSDone+  TSDone (Done _ _ rc) <- trySatisfy isTSDone+  return $ RowCount $ fromIntegral rc+++listOfRow :: Row a => Parser' ([a])+listOfRow = do+  tsCmd <- trySatisfy isTSColMetaData+  _ <- trySatisfyMany $ not . isTSRow+  tsRows <- trySatisfyMany isTSRow+  _ <- trySatisfyMany $ not . isTSDone -- necesarry ?+  _ <- trySatisfy $ isTSDone+  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++    getRawBytes :: RowColumnData -> RawBytes+    getRawBytes (RCDOrdinal dt) = dt+    getRawBytes (RCDLarge _ _ dt) = dt++++isTSDone :: TokenStream -> Bool+isTSDone (TSDone{}) = True+isTSDone _ = False+++++++ class ResultSet a where-  resultSetParser :: Parser a+  resultSetParser :: Parser' a   instance ResultSet () where   resultSetParser = noResult +instance ResultSet RowCount where+  resultSetParser = rowCount++instance ResultSet ReturnStatus where+  resultSetParser = returnStatus+ instance (Row a) => ResultSet [a] where   resultSetParser = listOfRow -instance ResultSet Int where-  resultSetParser = rowCount   -- [MEMO] using Template Haskell@@ -38,23 +126,27 @@   dec <- resultSetTupleQ n --  runIO $ putStrLn $ pprint dec   return dec---instance (Result a, Result b) => ResultSet (a, b) where+--instance (Result a1, Result a2) => ResultSet (a1, a2) where --  resultSetParser = do---    !r1 <- resultParser :: (Result a) => Parser a---    !r2 <- resultParser :: (Result b) => Parser b+--    !r1 <- resultParser :: (Result a1) => Parser' a1+--    !r2 <- resultParser :: (Result a2) => Parser' a2 --    return  (r1,r2) --   class Result a where-  resultParser :: Parser a+  resultParser :: Parser' a  instance Result () where   resultParser = noResult +instance Result RowCount where+  resultParser = rowCount++instance Result ReturnStatus where+  resultParser = returnStatus+ instance Row a => Result [a] where   resultParser = listOfRow -instance Result Int where-  resultParser = rowCount 

@@ -3,6 +3,8 @@ {-# LANGUAGE TemplateHaskell #-}  module Database.MSSQLServer.Query.Row ( Row (..)+                                      , RowCount (..)+                                      , ReturnStatus (..)                                       ) where  import Database.Tds.Message@@ -11,6 +13,10 @@  import Control.Monad(forM) import Language.Haskell.TH (runIO,pprint)+++newtype RowCount = RowCount Int+newtype ReturnStatus = ReturnStatus Int  mcdTypeInfo :: MetaColumnData -> TypeInfo mcdTypeInfo (MetaColumnData _ _ ti _ _) = ti

@@ -12,10 +12,89 @@                                               , 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@@ -25,8 +104,12 @@ 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++data RpcQuery a b = RpcQuery !a !b                   deriving (Show)  class RpcQueryId a where@@ -61,10 +144,10 @@  type RpcParamName  = T.Text -data RpcParam a = RpcParamVal RpcParamName TypeInfo a-                | RpcParamRef RpcParamName TypeInfo a-                | RpcParamDefVal RpcParamName TypeInfo a-                | RpcParamDefRef RpcParamName TypeInfo a+data RpcParam a = RpcParamVal !RpcParamName !TypeInfo !a+                | RpcParamRef !RpcParamName !TypeInfo !a+                | RpcParamDefVal !RpcParamName !TypeInfo !a+                | RpcParamDefRef !RpcParamName !TypeInfo !a                 deriving (Show)  @@ -91,7 +174,7 @@       !b1 = rpcReqBatchParam v1  -- [MEMO] using Template Haskell-forM [2..30] $ \n -> do+forM [2..60] $ \n -> do   dec <- rpcParamSetTupleQ n --  runIO $ putStrLn $ pprint dec   return dec@@ -124,3 +207,255 @@ --      !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++

@@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}  module Database.MSSQLServer.Query.RpcResponseSet ( RpcResponseSet (..)                                                  , RpcResponse (..)@@ -20,16 +21,60 @@ 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   +listOfRow :: Row a => Parser' ([a])+listOfRow = do+  _ <- trySatisfyMany $ not . isTSColMetaData+  tsCmd <- trySatisfy isTSColMetaData+  _ <- trySatisfyMany $ not . isTSRow+  tsRows <- trySatisfyMany isTSRow+  _ <- trySatisfyMany  $ not . isTSDoneInProc -- necesarry ?+  _ <- 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+  rpcResultSetParser :: Parser' a   instance RpcResultSet () where-  rpcResultSetParser = noResult+  rpcResultSetParser = return () + instance (Row a) => RpcResultSet [a] where   rpcResultSetParser = listOfRow @@ -41,17 +86,14 @@   return dec --instance (RpcResult a1, RpcResult a2) => RpcResultSet (a1, a2) where --  rpcResultSetParser = do---    !r1 <- rpcResultParser :: (RpcResult a1) => Parser a1---    !r2 <- rpcResultParser :: (RpcResult a2) => Parser a2+--    !r1 <- rpcResultParser :: (RpcResult a1) => Parser' a1+--    !r2 <- rpcResultParser :: (RpcResult a2) => Parser' a2 --    return  (r1,r2) --   class RpcResult a where-  rpcResultParser :: Parser a--instance RpcResult () where-  rpcResultParser = noResult+  rpcResultParser :: Parser' a  instance Row a => RpcResult [a] where   rpcResultParser = listOfRow@@ -96,25 +138,30 @@   -- (RpcOutputSet a, RpcResultSet b) => -data RpcResponse a b = RpcResponse Int a b+data RpcResponse a b = RpcResponse !Int !a !b+                     | RpcResponseError !Info                    deriving (Show)   rpcResponseParser :: (RpcOutputSet a, RpcResultSet b) => Parser (RpcResponse a b)-rpcResponseParser = p-  where-    p = do-      rss <- rpcResultSetParser-      _ <- many $ satisfy $ not . isTSReturnStatus-      TSReturnStatus ret <- satisfy isTSReturnStatus-      _ <- many $ satisfy $ not . isTSReturnValue-      rvs <- many $ satisfy isTSReturnValue-      _ <- many $ satisfy $ not . isTSDoneProc-      _ <- satisfy isTSDoneProc+rpcResponseParser = do+  let rrParser = runExceptT $ do+        rrs <- rpcResultSetParser+        _ <- trySatisfyMany $ not . isTSReturnStatus+        TSReturnStatus ret <- trySatisfy isTSReturnStatus+        _ <- trySatisfyMany $ not . isTSReturnValue+        rvs <- trySatisfyMany isTSReturnValue+        _ <- trySatisfyMany $ not . isTSDoneProc+        _ <- trySatisfy isTSDoneProc -      let rvs' = (\(TSReturnValue rv) -> rv) <$>  rvs-      return $ RpcResponse (fromIntegral ret) (fromReturnValues rvs') rss+        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@@ -126,6 +173,8 @@     isTSDoneProc :: TokenStream -> Bool     isTSDoneProc (TSDoneProc{}) = True     isTSDoneProc _ = False++   

@@ -92,7 +92,7 @@ #else                         [ClassP (mkName "Result") [VarT (mkName $ "a" <> show i)]] #endif-                        (AppT (ConT (mkName "Parser")) (VarT (mkName $ "a" <> show i)))+                        (AppT (ConT (mkName "Parser'")) (VarT (mkName $ "a" <> show i)))                       )                      )                  )@@ -212,7 +212,7 @@ #else                         [ClassP (mkName "RpcResult") [VarT (mkName $ "a" <> show i)]] #endif-                        (AppT (ConT (mkName "Parser")) (VarT (mkName $ "a" <> show i)))+                        (AppT (ConT (mkName "Parser'")) (VarT (mkName $ "a" <> show i)))                       )                      )                  )

@@ -4,28 +4,30 @@                                                     , parse                                                     , item                                                     , satisfy-                                                    , many-                                                    , many1-                                                    , oneOf-                                                    , noneOf-                                                    , noResult-                                                    , listOfRow-                                                    , rowCount+                                                    , satisfyNotError+                                                    , Parser'(..)+                                                    , trySatisfy+                                                    , trySatisfyMany                                                     ) where  -import Control.Applicative((<$>))-import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty))+import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty),many,(<$>)) import Control.Monad(Monad(..),MonadPlus(..),ap)+import Data.Monoid ((<>),mconcat) #if MIN_VERSION_base(4,9,0) import Control.Monad.Fail(MonadFail(..)) #endif-import Data.Monoid (mconcat,(<>),All(..),Any(..))  import Database.Tds.Message import Database.MSSQLServer.Query.Row  +#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except+#else+import Control.Monad.Error+import qualified Data.Text as T+#endif  data Parser a = Parser ([TokenStream] -> [(a,[TokenStream])]) @@ -69,90 +71,50 @@                  then return x                  else empty -many :: Parser a -> Parser [a]-many p = many1 p <|> return []+satisfyNotError :: (TokenStream -> Bool) -> Parser TokenStream+satisfyNotError f = satisfy (\x -> f x && (not . isTSError) x) -many1 :: Parser a -> Parser [a]-many1 p = do a <- p-             as <- many p-             return $ a:as -oneOf :: [TokenStream -> Bool] -> Parser TokenStream-oneOf xs = satisfy $ \x -> getAny $ mconcat $ (\f -> Any $ f x) <$> xs -noneOf :: [TokenStream -> Bool] -> Parser TokenStream-noneOf xs = satisfy $ \x -> getAll $ mconcat $ (\f -> All $ not $ f x) <$> xs+#if MIN_VERSION_mtl(2,2,1)+type Parser' = ExceptT Info Parser+#else+type Parser' = ErrorT Info Parser+instance Error Info where+  noMsg = Info 0 0 0 (T.pack "") (T.pack "") (T.pack "") 0+#endif  -noResult :: Parser ()-noResult = do-  _ <- many $ satisfy $ not . isTSDone-  _ <- satisfy isTSDone -- [MEMO] just parse here-  return ()-    where--      -- [TODO] check Status contains 0x10-      isTSDone :: TokenStream -> Bool-      isTSDone (TSDone{}) = True-      isTSDone (TSDoneInProc{}) = True-      isTSDone _ = False-  --listOfRow :: Row a => Parser ([a])-listOfRow = do-  _ <- many $ satisfy $ not . isTSColMetaData-  tsCmd <- satisfy isTSColMetaData-  _ <- many $ satisfy $ not . isTSRow-  tsRows <- many $ satisfy isTSRow-  _ <- many $ satisfy $ not . isTSDone-  _ <- satisfy isTSDone -- [MEMO] just parse here-  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--      -- [TODO] check Status contains 0x10-      isTSDone :: TokenStream -> Bool-      isTSDone (TSDone{}) = True-      isTSDone (TSDoneInProc{}) = True-      isTSDone _ = False+trySatisfy :: (TokenStream -> Bool) -> Parser' TokenStream+trySatisfy f = do+  ts <- lift $ (satisfyNotError f) <|> errorDone+  case ts of+    TSError ei -> throwError ei+    _ -> return ts -      getRawBytes :: RowColumnData -> RawBytes-      getRawBytes (RCDOrdinal dt) = dt-      getRawBytes (RCDLarge _ _ dt) = dt+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  -rowCount :: Parser Int-rowCount = do-  _ <- many $ satisfy $ not . isTSDone-  tsDone <- satisfy isTSDone-  return $-    let-      Done _ _ rc = getDone tsDone-    in fromIntegral rc-    where+errorDone :: Parser TokenStream+errorDone = do+  _  <- many $ satisfy $ not . isTSError+  ts <- satisfy isTSError+  _  <- many $ satisfy $ not . isTSDoneOrDoneProc+  _  <- satisfy isTSDoneOrDoneProc+  return ts+  where+    isTSDoneOrDoneProc :: TokenStream -> Bool+    isTSDoneOrDoneProc (TSDone{}) = True+    isTSDoneOrDoneProc (TSDoneProc{}) = True+    isTSDoneOrDoneProc _ = False -      -- [TODO] check Status contains 0x10-      isTSDone :: TokenStream -> Bool-      isTSDone (TSDone{}) = True-      isTSDone (TSDoneInProc{}) = True-      isTSDone _ = False+isTSError :: TokenStream -> Bool+isTSError (TSError{}) = True+isTSError _ = False -      getDone :: TokenStream -> Done-      getDone (TSDone x) = x-      getDone (TSDoneInProc x) = x-      getDone _ = error "rowCount: TSDone and TSDoneInProc are only possible here"