mssql-simple 0.3.0.0 → 0.4.0.0

raw patch · 7 files changed

+112/−150 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• mssql-simple.cabal +2/−2
• src/Database/MSSQLServer/Query.hs +11/−26
• src/Database/MSSQLServer/Query/ResultSet.hs +9/−24
• src/Database/MSSQLServer/Query/Row.hs +0/−4
• src/Database/MSSQLServer/Query/RpcQuerySet.hs +0/−1
• src/Database/MSSQLServer/Query/RpcResponseSet.hs +71/−86
• src/Database/MSSQLServer/Query/TokenStreamParser.hs +19/−7

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 746ba7c124efc008044c4c42749d9ba2caf522a663254b0269a7e1ea92ed1423+-- hash: 7e21b82d01e699c1397575c7711a08b3f1da63a9bb3de6aa289435456f38bd0f  name:           mssql-simple-version:        0.3.0.0+version:        0.4.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

@@ -51,7 +51,6 @@  import qualified Data.Text as T -import Data.Binary (Binary(..),encode) import qualified Data.Binary.Get as Get import qualified Data.Binary.Put as Put @@ -66,6 +65,7 @@ import Database.MSSQLServer.Query.ResultSet import Database.MSSQLServer.Query.RpcResponseSet import Database.MSSQLServer.Query.RpcQuerySet+import Database.MSSQLServer.Query.TokenStreamParser   data QueryError = QueryError !Info@@ -79,10 +79,11 @@   sendAll sock $ Put.runPut $ putClientMessage ps $ CMSqlBatch $ SqlBatch query   TokenStreams tss <- readMessage sock $ Get.runGetIncremental getServerMessage -  case filter isTSError tss of-    [] -> return $ fromTokenStreams tss-    TSError info :_ -> throwIO $ QueryError info-+  case parse resultSetParser tss of+    [] -> case filter isTSError tss of+      [] -> error "sql: failed to parse token streams"+      TSError info :_ -> throwIO $ QueryError info+    (x,_):_ -> return x   rpc :: (RpcQuerySet a, RpcResponseSet b) => Connection -> a -> IO b@@ -90,27 +91,11 @@   sendAll sock $ Put.runPut $ putClientMessage ps $ CMRpcRequest $ toRpcRequest queries   TokenStreams tss <- readMessage sock $ Get.runGetIncremental getServerMessage -  case filter isTSError tss of-    [] -> return $ fromListOfTokenStreams $ splitBy isTSDoneProc tss-    TSError info :_ -> throwIO $ QueryError info-  -  where-    isTSDoneProc :: TokenStream -> Bool-    isTSDoneProc (TSDoneProc{}) = True-    isTSDoneProc _ = False---    spanBy :: (a -> Bool) -> [a] -> ([a],[a])-    spanBy q xs = case span (not . q) xs of-      t@(ys,z:zs) | (q z) -> (ys <> [z], zs)-                  | otherwise -> t-      t -> t--    splitBy :: (a -> Bool) -> [a] ->[[a]]-    splitBy q xs = case spanBy q xs of-      (ys,[]) -> [ys]-      (ys,zs) -> ys:splitBy q zs-+  case parse rpcResponseSetParser tss of+    [] -> case filter isTSError tss of+      [] -> error "rpc: failed to parse token streams"+      TSError info :_ -> throwIO $ QueryError info+    (x,_):_ -> return x   nvarcharVal :: RpcParamName -> T.Text -> RpcParam T.Text

@@ -2,11 +2,10 @@ {-# LANGUAGE BangPatterns #-}  module Database.MSSQLServer.Query.ResultSet ( ResultSet (..)-                                            , Result+                                            , Result (..)                                             ) where  -import Control.Applicative((<$>),Applicative((<*>)),Alternative(empty)) import Database.Tds.Message import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.Only@@ -15,30 +14,22 @@   class ResultSet a where-  fromTokenStreams :: [TokenStream] -> a+  resultSetParser :: Parser a   instance ResultSet () where-  fromTokenStreams xs = case parse noResult xs of-                          [] -> error "fromTokenStreams(ResultSet ()): failed to parse"-                          (x,_):_ -> x+  resultSetParser = noResult  instance (Row a) => ResultSet [a] where-  fromTokenStreams xs = case parse listOfRow xs of-                          [] -> error "fromTokenStreams(ResultSet [Row a]): failed to parse"-                          (x,_):_ -> x+  resultSetParser = listOfRow  instance ResultSet Int where-  fromTokenStreams xs = case parse rowCount xs of-                          [] -> error "fromTokenStreams(ResultSet Int): failed to parse"-                          (x,_):_ -> x+  resultSetParser = rowCount   -- [TODO] use Template Haskell instance (Result a, Result b) => ResultSet (a, b) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(ResultSet (Result a, Result b)): failed to parse"-                          (x,_):_ -> x+  resultSetParser = p     where       p :: (Result a, Result b) => Parser (a, b)       p = do@@ -47,9 +38,7 @@         return  (r1,r2)  instance (Result a, Result b, Result c) => ResultSet (a, b, c) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(ResultSet (Result a, Result b, Result c)): failed to parse"-                          (x,_):_ -> x+  resultSetParser = p     where       p :: (Result a, Result b, Result c) => Parser (a, b, c)       p = do@@ -59,9 +48,7 @@         return  (r1,r2,r3)  instance (Result a, Result b, Result c, Result d) => ResultSet (a, b, c, d) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(ResultSet (Result a, Result b, Result c, Result d)): failed to parse"-                          (x,_):_ -> x+  resultSetParser = p     where       p :: (Result a, Result b, Result c, Result d) => Parser (a, b, c, d)       p = do@@ -72,9 +59,7 @@         return  (r1,r2,r3,r4)  instance (Result a, Result b, Result c, Result d, Result e) => ResultSet (a, b, c, d, e) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(ResultSet (Result a, Result b, Result c, Result d, Result e)): failed to parse"-                          (x,_):_ -> x+  resultSetParser = p     where       p :: (Result a, Result b, Result c, Result d, Result e) => Parser (a, b, c, d, e)       p = do

@@ -16,10 +16,6 @@   fromListOfRawBytes :: [MetaColumnData] -> [RawBytes] -> a  -- [TODO] use Template Haskell-instance Row () where-  fromListOfRawBytes [] [] = ()-  fromListOfRawBytes _ _ = error "fromListOfRawBytes: List length must be 0"- instance (Data a) => Row (Only a) where   fromListOfRawBytes [m1] [b1] = Only d1     where

@@ -14,7 +14,6 @@                                               ) where  -import Control.Applicative((<$>),(<*>)) import qualified Data.Text as T import Data.Word (Word16(..)) 

@@ -4,170 +4,155 @@  module Database.MSSQLServer.Query.RpcResponseSet ( RpcResponseSet (..)                                                  , RpcResponse (..)-                                                 , RpcResultSet-                                                 , RpcResult+                                                 , RpcResultSet (..)+                                                 , RpcResult (..)                                                  , RpcOutputSet (..)                                                  ) where -import Control.Applicative((<$>),(<*>))+import Control.Applicative((<$>)) import Database.Tds.Message import Database.MSSQLServer.Query.Row import Database.MSSQLServer.Query.Only- import Database.MSSQLServer.Query.TokenStreamParser     class RpcResponseSet a where-  fromListOfTokenStreams :: [[TokenStream]] -> a+  rpcResponseSetParser :: Parser a  -- [TODO] use Template Haskell instance (RpcOutputSet a1, RpcResultSet b1) => RpcResponseSet (RpcResponse a1 b1) where-  fromListOfTokenStreams [v1] = b1-    where-      !b1 = rpcResponse v1-  fromListOfTokenStreams _ = error "fromListOfTokenStreams: List length must be 1"-  +  rpcResponseSetParser = rpcResponseParser+ instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2) where-  fromListOfTokenStreams [v1,v2] =  (b1, b2)-    where-      !b1 = rpcResponse v1-      !b2 = rpcResponse v2-  fromListOfTokenStreams _ = error "fromListOfTokenStreams: List length must be 2"+  rpcResponseSetParser = do+    !b1 <- rpcResponseParser+    !b2 <- rpcResponseParser+    return (b1,b2)  instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2, RpcOutputSet a3, RpcResultSet b3) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2, RpcResponse a3 b3) where-  fromListOfTokenStreams [v1,v2,v3] =  (b1, b2, b3)-    where-      !b1 = rpcResponse v1-      !b2 = rpcResponse v2-      !b3 = rpcResponse v3-  fromListOfTokenStreams _ = error "fromListOfTokenStreams: List length must be 3"+  rpcResponseSetParser = do+    !b1 <- rpcResponseParser+    !b2 <- rpcResponseParser+    !b3 <- rpcResponseParser+    return (b1,b2,b3)  instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2, RpcOutputSet a3, RpcResultSet b3, RpcOutputSet a4, RpcResultSet b4) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2, RpcResponse a3 b3, RpcResponse a4 b4) where-  fromListOfTokenStreams [v1,v2,v3,v4] =  (b1, b2, b3, b4)-    where-      !b1 = rpcResponse v1-      !b2 = rpcResponse v2-      !b3 = rpcResponse v3-      !b4 = rpcResponse v4-  fromListOfTokenStreams _ = error "fromListOfTokenStreams: List length must be 4"+  rpcResponseSetParser = do+    !b1 <- rpcResponseParser+    !b2 <- rpcResponseParser+    !b3 <- rpcResponseParser+    !b4 <- rpcResponseParser+    return (b1,b2,b3,b4)  instance (RpcOutputSet a1, RpcResultSet b1, RpcOutputSet a2, RpcResultSet b2, RpcOutputSet a3, RpcResultSet b3, RpcOutputSet a4, RpcResultSet b4, RpcOutputSet a5, RpcResultSet b5) => RpcResponseSet (RpcResponse a1 b1, RpcResponse a2 b2, RpcResponse a3 b3, RpcResponse a4 b4, RpcResponse a5 b5) where-  fromListOfTokenStreams [v1,v2,v3,v4,v5] =  (b1, b2, b3, b4, b5)-    where-      !b1 = rpcResponse v1-      !b2 = rpcResponse v2-      !b3 = rpcResponse v3-      !b4 = rpcResponse v4-      !b5 = rpcResponse v5-  fromListOfTokenStreams _ = error "fromListOfTokenStreams: List length must be 5"---+  rpcResponseSetParser = do+    !b1 <- rpcResponseParser+    !b2 <- rpcResponseParser+    !b3 <- rpcResponseParser+    !b4 <- rpcResponseParser+    !b5 <- rpcResponseParser+    return (b1,b2,b3,b4,b5)  -- (RpcOutputSet a, RpcResultSet b) =>  data RpcResponse a b = RpcResponse Int a b                    deriving (Show) -rpcResponse :: (RpcOutputSet a, RpcResultSet b) => [TokenStream] -> RpcResponse a b-rpcResponse tss =-  -- [TODO] performance tuning (avoid filter all)-  let [TSReturnStatus ret] = case filter isTSReturnStatus tss of-                               [] -> error "rpcResponse: TSReturnStatus is necessary"-                               xs -> xs-      rvs = (\(TSReturnValue rv) -> rv) <$> filter isTSReturnValue tss-      rss = fromTokenStreams tss -  in RpcResponse (fromIntegral ret) (fromReturnValues rvs) rss-+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++      let rvs' = (\(TSReturnValue rv) -> rv) <$>  rvs+      return $ RpcResponse (fromIntegral ret) (fromReturnValues rvs') rss+     isTSReturnStatus :: TokenStream -> Bool     isTSReturnStatus (TSReturnStatus{}) = True     isTSReturnStatus _ = False-    +     isTSReturnValue :: TokenStream -> Bool     isTSReturnValue (TSReturnValue{}) = True     isTSReturnValue _ = False +    isTSDoneProc :: TokenStream -> Bool+    isTSDoneProc (TSDoneProc{}) = True+    isTSDoneProc _ = False  + class RpcResultSet a where-  fromTokenStreams :: [TokenStream] -> a+  rpcResultSetParser :: Parser a   instance RpcResultSet () where-  fromTokenStreams xs = case parse noResult xs of-                          [] -> error "fromTokenStreams(RpcResultSet ()): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = noResult  instance (Row a) => RpcResultSet [a] where-  fromTokenStreams xs = case parse listOfRow xs of-                          [] -> error "fromTokenStreams(RpcResultSet [Row a]): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = listOfRow   -- [TODO] use Template Haskell instance (RpcResult a, RpcResult b) => RpcResultSet (a, b) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(RpcResultSet (RpcResult a, RpcResult b)): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = p     where       p :: (RpcResult a, RpcResult b) => Parser (a, b)       p = do-        !r1 <- resultParser :: (RpcResult a) => Parser a-        !r2 <- resultParser :: (RpcResult b) => Parser b+        !r1 <- rpcResultParser :: (RpcResult a) => Parser a+        !r2 <- rpcResultParser :: (RpcResult b) => Parser b         return  (r1,r2)  instance (RpcResult a, RpcResult b, RpcResult c) => RpcResultSet (a, b, c) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(RpcResultSet (RpcResult a, RpcResult b, RpcResult c)): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = p     where       p :: (RpcResult a, RpcResult b, RpcResult c) => Parser (a, b, c)       p = do-        !r1 <- resultParser :: (RpcResult a) => Parser a-        !r2 <- resultParser :: (RpcResult b) => Parser b-        !r3 <- resultParser :: (RpcResult c) => Parser c+        !r1 <- rpcResultParser :: (RpcResult a) => Parser a+        !r2 <- rpcResultParser :: (RpcResult b) => Parser b+        !r3 <- rpcResultParser :: (RpcResult c) => Parser c         return  (r1,r2,r3)  instance (RpcResult a, RpcResult b, RpcResult c, RpcResult d) => RpcResultSet (a, b, c, d) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(RpcResultSet (RpcResult a, RpcResult b, RpcResult c, RpcResult d)): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = p     where       p :: (RpcResult a, RpcResult b, RpcResult c, RpcResult d) => Parser (a, b, c, d)       p = do-        !r1 <- resultParser :: (RpcResult a) => Parser a-        !r2 <- resultParser :: (RpcResult b) => Parser b-        !r3 <- resultParser :: (RpcResult c) => Parser c-        !r4 <- resultParser :: (RpcResult d) => Parser d+        !r1 <- rpcResultParser :: (RpcResult a) => Parser a+        !r2 <- rpcResultParser :: (RpcResult b) => Parser b+        !r3 <- rpcResultParser :: (RpcResult c) => Parser c+        !r4 <- rpcResultParser :: (RpcResult d) => Parser d         return  (r1,r2,r3,r4)  instance (RpcResult a, RpcResult b, RpcResult c, RpcResult d, RpcResult e) => RpcResultSet (a, b, c, d, e) where-  fromTokenStreams xs = case parse p xs of-                          [] -> error "fromTokenStreams(RpcResultSet (RpcResult a, RpcResult b, RpcResult c, RpcResult d, RpcResult e)): failed to parse"-                          (x,_):_ -> x+  rpcResultSetParser = p     where       p :: (RpcResult a, RpcResult b, RpcResult c, RpcResult d, RpcResult e) => Parser (a, b, c, d, e)       p = do-        !r1 <- resultParser :: (RpcResult a) => Parser a-        !r2 <- resultParser :: (RpcResult b) => Parser b-        !r3 <- resultParser :: (RpcResult c) => Parser c-        !r4 <- resultParser :: (RpcResult d) => Parser d-        !r5 <- resultParser :: (RpcResult e) => Parser e+        !r1 <- rpcResultParser :: (RpcResult a) => Parser a+        !r2 <- rpcResultParser :: (RpcResult b) => Parser b+        !r3 <- rpcResultParser :: (RpcResult c) => Parser c+        !r4 <- rpcResultParser :: (RpcResult d) => Parser d+        !r5 <- rpcResultParser :: (RpcResult e) => Parser e         return  (r1,r2,r3,r4,r5)    class RpcResult a where-  resultParser :: Parser a+  rpcResultParser :: Parser a  instance RpcResult () where-  resultParser = noResult+  rpcResultParser = noResult  instance Row a => RpcResult [a] where-  resultParser = listOfRow+  rpcResultParser = listOfRow     

@@ -1,4 +1,4 @@-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}  module Database.MSSQLServer.Query.TokenStreamParser ( Parser(..)                                                     , parse@@ -16,7 +16,10 @@  import Control.Applicative((<$>)) import Control.Applicative(Applicative((<*>),pure),Alternative((<|>),empty))-import Control.Monad(Monad(..))+import Control.Monad(Monad(..),MonadPlus(..),ap)+#if MIN_VERSION_base(4,9,0)+import Control.Monad.Fail(MonadFail(..))+#endif import Data.Monoid (mconcat,(<>),All(..),Any(..))  import Database.Tds.Message@@ -34,16 +37,25 @@   fmap f p = Parser $ \xs -> [(f x,xs') | (x,xs') <- parse p xs]  instance Applicative Parser where-  pure x = Parser $ \xs -> [(x,xs)]-  (<*>) f p = Parser $ \xs -> [(f' x,xs'') | (x,xs') <- parse p xs, (f',xs'') <- parse f xs']+  pure = return+  (<*>) = ap  instance Alternative Parser where-  empty = Parser $ \_ -> []-  (<|>) p q = Parser $ \xs -> parse p xs <> parse q xs+  empty = mzero+  (<|>) = mplus  instance Monad Parser where-  return = pure+  return x = Parser $ \xs -> [(x,xs)]   p >>= f  = Parser $ \ts -> mconcat [parse (f t) ts' | (t,ts') <- parse p ts]++instance MonadPlus Parser where+  mzero = Parser $ \_ -> []+  mplus p q = Parser $ \xs -> parse p xs <> parse q xs++#if MIN_VERSION_base(4,9,0)+instance MonadFail Parser where+  fail _ = mzero+#endif   item :: Parser TokenStream