ms-tds 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+106/−121 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +1/−7
• ms-tds.cabal +2/−2
• src/Database/Tds/Message.hs +60/−25
• src/Database/Tds/Message/Client.hs +18/−6
• src/Database/Tds/Message/DataStream.hs +23/−19
• src/Database/Tds/Message/Header.hs +2/−62

@@ -42,9 +42,6 @@   * Test legacy data types  -* Transaction support-- * Implement data types   * AltMetaData   * AltRow@@ -71,8 +68,6 @@   * Login7: client program version   * Login7: timezone   * Login7: language-  * Login7: collation-  * RpcReqBatchProcId: ProcID   * TSEnvChange: Type   * TSLoginAck: Interface   * TSReturnValue: Status@@ -80,7 +75,7 @@  * Implement Flag interfaces   * Header status-  * PLOEncription+  * PLOEncryption   * PLOMars   * Login7 flag1   * Login7 flag2@@ -102,7 +97,6 @@   * Mars support   * SSPI support   * FedAuth support-  * Variable PacketSize support   * TDS protocol versions other than 7.1    * Attention  

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 49394a8278191a141ae8a27d9e19f2c2d1bbab3d689aa2454d6b9b44ae2312e9+-- hash: efad0660f5cf0042c8ade6a168534cd8a14bd8d00708563ceeb560d6e059d864  name:           ms-tds-version:        0.2.0.0+version:        0.3.0.0 synopsis:       TDS Protocol implemented in Haskell description:    Please see the README on GitHub at <https://github.com/mitsuji/ms-tds#readme> category:       Database

@@ -1,9 +1,14 @@ module Database.Tds.Message ( -- * Client Message                               ClientMessage (..)+                            , getClientMessage+                            , putClientMessage                                                            -- ** Login                             , Login7+                            , tdsVersion                             , defaultLogin7+                            , l7PacketSize+                            , l7ClientProgVer                             , l7ConnectionID                             , l7OptionFlags1                             , l7OptionFlags2@@ -11,6 +16,7 @@                             , l7TypeFlags                             , l7TimeZone                             , l7Collation+                            , l7CltIntName                             , l7Language                             , l7ClientPID                             , l7ClientMacAddr@@ -20,7 +26,6 @@                             , l7UserName                             , l7Password                             , l7Database-                            , tdsVersion                                                          -- ** SQL Batch                             , SqlBatch (..)@@ -39,7 +44,8 @@                                                          -- * Server Message                             , ServerMessage (..)-                            , ServerMessageInstance (..)+                            , getServerMessage+                            , putServerMessage                                                          , TokenStreams (..)                             , TokenStream (..)@@ -152,6 +158,9 @@  import Control.Applicative((<$>)) +import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Builder as BB+ import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..)) import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..)) @@ -159,6 +168,9 @@ import qualified Data.Binary.Put as Put import qualified Data.Binary.Get as Get +import Control.Monad.Writer (WriterT(..),runWriterT,tell)+import Control.Monad.Trans (lift)+ import Database.Tds.Primitives.Null import Database.Tds.Primitives.Decimal import Database.Tds.Primitives.Money@@ -174,7 +186,41 @@   +putMessage :: Word32 -> Word8 -> LB.ByteString -> Put+putMessage ps pt bs = mapM_ f $ split (ps -headerLength) bs+  where+    f :: (Bool,LB.ByteString) -> Put+    f (isLast,bs) = do+      let+        len = (fromIntegral $ LB.length bs) + headerLength+        flg = if isLast then 0x01 else 0x00 -- last flag+      put $ Header pt flg len 0 0 0+      Put.putLazyByteString bs +  +    split :: Word32 -> LB.ByteString -> [(Bool,LB.ByteString)]+    split len lbs =+      let+        (lbs',rem) = LB.splitAt (fromIntegral len) lbs+      in if LB.null rem+         then [(True,lbs')]+         else (False,lbs'): split len rem+++getMessage :: Get (Word8,LB.ByteString)+getMessage = (\(pt,bs) -> (pt,BB.toLazyByteString bs)) <$> runWriterT f+  where+    f :: WriterT BB.Builder Get Word8+    f = do+      (Header pt flg len _ _ _) <- lift get+      tell =<< BB.byteString <$> (lift $ Get.getByteString (fromIntegral $ len -8))+      if flg == 0x01+        then return pt+        else f++++ -- | [\[MS-TDS\] 2.2.1 Client Messages](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/7ea9ee1a-b461-41f2-9004-141c0e712935) data ClientMessage = CMPrelogin !Prelogin                    | CMLogin7 !Login7@@ -182,14 +228,14 @@                    | CMRpcRequest !RpcRequest                    deriving (Show) -putClientMessage :: ClientMessage -> Put-putClientMessage x =+putClientMessage :: Word32 -> ClientMessage -> Put+putClientMessage ps x =   let (pt,bs) = case x of         CMPrelogin   pr -> (0x12,encode pr)         CMLogin7     l7 -> (0x10,encode l7)         CMSqlBatch   b  -> (0x01,encode b)         CMRpcRequest r  -> (0x03,encode r)-  in putMessage pt bs+  in putMessage ps pt bs  getClientMessage :: Get ClientMessage getClientMessage = do@@ -201,34 +247,23 @@     0x03 -> return $ CMRpcRequest $ decode bs     _ -> fail "getClientMessage: invalid packet type" -instance Binary ClientMessage where-  put = putClientMessage-  get = getClientMessage   -class Binary a => ServerMessageInstance a-instance ServerMessageInstance Prelogin-instance ServerMessageInstance TokenStreams+-- | [\[MS-TDS\] 2.2.2 Server Messages](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/342f4cbb-2b4b-489c-8b63-f99b12021a94)+class Binary a => ServerMessage a+instance ServerMessage Prelogin+instance ServerMessage TokenStreams -putServerMessageInstance :: ServerMessageInstance a => a -> Put-putServerMessageInstance x =-  putMessage 0x04 $ encode x+putServerMessage :: ServerMessage a => Word32 -> a -> Put+putServerMessage ps x =+  putMessage ps 0x04 $ encode x -getServerMessageInstance :: ServerMessageInstance a => Get a-getServerMessageInstance = do+getServerMessage :: ServerMessage a => Get a+getServerMessage = do   (pt,bs) <- getMessage   case pt of     0x04 -> return $ decode bs     _ -> fail "getServerMessageInstance: invalid packet type"----- | [\[MS-TDS\] 2.2.2 Server Messages](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/342f4cbb-2b4b-489c-8b63-f99b12021a94)-newtype ServerMessage a = ServerMessage a-                        deriving (Show)--instance (ServerMessageInstance a) => Binary (ServerMessage a) where-  put (ServerMessage x) = putServerMessageInstance x-  get = ServerMessage <$> getServerMessageInstance  

@@ -6,7 +6,10 @@   module Database.Tds.Message.Client ( Login7+                                   , tdsVersion                                    , defaultLogin7+                                   , l7PacketSize+                                   , l7ClientProgVer                                    , l7ConnectionID                                    , l7OptionFlags1                                    , l7OptionFlags2@@ -14,6 +17,7 @@                                    , l7TypeFlags                                    , l7TimeZone                                    , l7Collation+                                   , l7CltIntName                                    , l7Language                                    , l7ClientPID                                    , l7ClientMacAddr@@ -58,7 +62,6 @@  import Control.Monad (foldM,foldM_) -import Database.Tds.Message.Header import Database.Tds.Message.Prelogin import Database.Tds.Message.DataStream import Database.Tds.Primitives.Collation@@ -90,20 +93,29 @@                      }             deriving (Show) ++tdsVersion :: Word32+tdsVersion = 0x71000001+-- [MEMO]+-- tds70Version = 0x70000000+-- tds71Version = 0x71000001+-- tds72Version = 0x72090002+-- tds73Version = 0x730B0003+-- tds74Version = 0x74000004++ defaultLogin7 :: Login7 defaultLogin7 = Login7 { l7TdsVersion = tdsVersion-                         , l7PacketSize = packetSize-                         , l7ClientProgVer = 0x0683f2f8  -- [MEMO] 0x00000007+                         , l7PacketSize = 4096+                         , l7ClientProgVer = 0 -- [MEMO] 0x0683f2f8, 0x00000007                          , l7ConnectionID = 0                          , l7OptionFlags1 = 0x80 + 0x40 + 0x20                          , l7OptionFlags2 = 0  -- [MEMO] 0x02 + 0x01--                          , l7OptionFlags3 = 0                          , l7TypeFlags = 0                          , l7TimeZone = 0  -- [MEMO] -120                          , l7Collation = 0x00000000  -- [MEMO] 0x36040000, 0x1104d000, 0x09040000-                         , l7CltIntName = T.pack "DB-Library" -- [MDMO] "OLEDB", "ODBC"+                         , l7CltIntName = mempty -- [MDMO] "DB-Library", "OLEDB", "ODBC"                          , l7Language = mempty -- [MEMO] "us_english"                          , l7ClientPID = 0                          , l7ClientMacAddr = mempty

@@ -499,7 +499,7 @@   withValidIntegral :: String -> TypeInfo -> (TypeInfo -> a) -> a-withValidIntegral ht = f+withValidIntegral tn = f   where     f :: TypeInfo -> (TypeInfo -> a) -> a     f ti@TIBit g = g ti@@ -512,7 +512,7 @@     f ti@TIIntN2 g = g ti      f ti@TIIntN4 g = g ti     f ti@TIIntN8 g = g ti-    f ti _ = error $ "withValidIntegral: " <> (show ti) <> " is not convertible from/to " <> ht+    f ti _ = error $ "withValidIntegral: " <> (show ti) <> " is not convertible from/to " <> tn  withValidBool = withValidIntegral "Bool" withValidInt = withValidIntegral "Int"@@ -522,16 +522,12 @@ isIntegralN = f   where     f :: TypeInfo -> Bool-    f TIBit = False-    f TIInt1 = False-    f TIInt2 = False-    f TIInt4 = False-    f TIInt8 = False     f TIBitN = True     f TIIntN1 = True     f TIIntN2 = True     f TIIntN4 = True     f TIIntN8 = True+    f _ = False   getIntegral :: Integral a => TypeInfo -> Get a@@ -576,10 +572,9 @@ isMoneyN = f   where     f :: TypeInfo -> Bool-    f TIMoney4 = False-    f TIMoney8 = False     f TIMoneyN4 = True     f TIMoneyN8 = True+    f _ = False      getMoney :: TypeInfo -> Get Money getMoney TIMoney4 = bytesToMoney4 <$> Get.getInt32le@@ -613,10 +608,9 @@ isUTCTimeN = f   where     f :: TypeInfo -> Bool-    f TIDateTime4 = False-    f TIDateTime8 = False     f TIDateTimeN4 = True     f TIDateTimeN8 = True+    f _ = False      getUTCTime :: TypeInfo -> Get UTCTime getUTCTime TIDateTime4 = bytesToUtc4 <$> Get.getWord16le <*> Get.getWord16le@@ -640,14 +634,14 @@   withValidFloat' :: String -> TypeInfo -> (TypeInfo -> a) -> a-withValidFloat' hn = f+withValidFloat' tn = f   where     f :: TypeInfo -> (TypeInfo -> a) -> a     f ti@TIFlt4 g = g ti     f ti@TIFlt8 g = g ti     f ti@TIFltN4 g = g ti     f ti@TIFltN8 g = g ti-    f ti _ = error $ "withValidFloat': " <> (show ti) <> " is not convertible from/to " <> hn+    f ti _ = error $ "withValidFloat': " <> (show ti) <> " is not convertible from/to " <> tn  withValidFloat = withValidFloat' "Float" withValidDouble = withValidFloat' "Double"@@ -656,10 +650,9 @@ isFloatN = f   where     f :: TypeInfo -> Bool-    f TIFlt4 = False-    f TIFlt8 = False     f TIFltN4 = True     f TIFltN8 = True+    f _ = False      getFloat :: Fractional a => TypeInfo -> Get a getFloat TIFlt4 = realToFrac . wordToFloat <$> Get.getWord32le@@ -729,18 +722,20 @@   -withValidText :: TypeInfo -> (TypeInfo -> a) -> a-withValidText  = f+withValidText' :: String -> TypeInfo -> (TypeInfo -> a) -> a+withValidText' tn = f   where     f :: TypeInfo -> (TypeInfo -> a) -> a     f ti@(TINChar _ _) g = g ti     f ti@(TINVarChar _ _) g = g ti     f ti@(TINText _ _) g = g ti-    f ti _ = error $ "withValidText: " <> (show ti) <> " is not convertible from/to Text"-    +    f ti _ = error $ "withValidText: " <> (show ti) <> " is not convertible from/to " <> tn +withValidText = withValidText' "Text"+withValidString = withValidText' "String"  + runGet :: Get a -> LB.ByteString -> a runGet f bs = Get.runGet f bs @@ -843,8 +838,13 @@   fromRawBytes ti Nothing = withValidText ti $ \_ -> error "Text.fromRawBytes: Null value is not convertible to Text"   toRawBytes ti t = withValidText ti $ \_ -> Just $ LT.encodeUtf16LE t +instance Data String where+  fromRawBytes ti (Just bs) = withValidString ti $ \_ -> LT.unpack $ LT.decodeUtf16LE bs+  fromRawBytes ti Nothing = withValidString ti $ \_ -> error "String.fromRawBytes: Null value is not convertible to String"+  toRawBytes ti s = withValidString ti $ \_ -> Just $ LT.encodeUtf16LE $ LT.pack s  + instance Data (Maybe Bool) where   fromRawBytes ti rb = withValidBool ti $ \vt -> runGetBool vt <$> rb   toRawBytes ti b = withValidBool ti $ \vt ->@@ -927,5 +927,9 @@ instance Data (Maybe LT.Text) where   fromRawBytes ti rb = withValidText ti $ \_ -> LT.decodeUtf16LE <$> rb    toRawBytes ti t = withValidText ti $ \_ -> LT.encodeUtf16LE <$> t++instance Data (Maybe String) where+  fromRawBytes ti rb = withValidString ti $ \_ -> LT.unpack . LT.decodeUtf16LE <$> rb +  toRawBytes ti s = withValidString ti $ \_ -> LT.encodeUtf16LE . LT.pack <$> s  

@@ -1,18 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- Packet Header:   https://msdn.microsoft.com/en-us/library/dd340948.aspx -module Database.Tds.Message.Header ( packetSize-                                   , tdsVersion-                                   , Header (..)-                                   , putMessage-                                   , getMessage+module Database.Tds.Message.Header ( Header (..)+                                   , headerLength                                    ) where -import Control.Applicative((<$>))--import qualified Data.ByteString.Lazy as LB-import qualified Data.ByteString.Builder as BB- import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..)) import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..)) @@ -20,10 +12,7 @@ import qualified Data.Binary.Put as Put import qualified Data.Binary.Get as Get -import Control.Monad.Writer (WriterT(..),runWriterT,tell)-import Control.Monad.Trans (lift) - type Type = Word8 type Status = Word8 type Length = Word16@@ -37,21 +26,7 @@ headerLength :: Integral a => a headerLength = fromIntegral 8 -packetSize :: Integral a => a-packetSize = fromIntegral 4096 -tdsVersion :: Word32-tdsVersion = 0x71000001---- [MEMO]--- tds70Version = 0x70000000--- tds71Version = 0x71000001--- tds72Version = 0x72090002--- tds73Version = 0x730B0003--- tds74Version = 0x74000004--- -- https://msdn.microsoft.com/en-us/library/dd340948.aspx putHeader :: Header -> Put putHeader (Header pt st len spid pcid win) = do@@ -78,40 +53,5 @@   put = putHeader   get = getHeader ---putMessage :: Word8 -> LB.ByteString -> Put-putMessage pt bs = mapM_ f $ split (packetSize -headerLength) bs-  where-    f :: (Bool,LB.ByteString) -> Put-    f (isLast,bs) = do-      let-        len = (fromIntegral $ LB.length bs) + headerLength-        flg = if isLast then 0x01 else 0x00 -- last flag-      put $ Header pt flg len 0 0 0-      Put.putLazyByteString bs---    split :: Int64 -> LB.ByteString -> [(Bool,LB.ByteString)]-    split len lbs =-      let-        (lbs',rem) = LB.splitAt len lbs-      in if LB.null rem-         then [(True,lbs')]-         else (False,lbs'): split len rem-----getMessage :: Get (Word8,LB.ByteString)-getMessage = (\(pt,bs) -> (pt,BB.toLazyByteString bs)) <$> runWriterT f-  where-    f :: WriterT BB.Builder Get Word8-    f = do-      (Header pt flg len _ _ _) <- lift get-      tell =<< BB.byteString <$> (lift $ Get.getByteString (fromIntegral $ len -8))-      if flg == 0x01-        then return pt-        else f