diff --git a/ms-tds.cabal b/ms-tds.cabal --- a/ms-tds.cabal +++ b/ms-tds.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 62ef4732f490b492580886e66b1c89efb43e06a9d005a2c6f326e6b1ea894943 +-- hash: 49394a8278191a141ae8a27d9e19f2c2d1bbab3d689aa2454d6b9b44ae2312e9 name: ms-tds -version: 0.1.0.4 +version: 0.2.0.0 synopsis: TDS Protocol implemented in Haskell description: Please see the README on GitHub at category: Database diff --git a/src/Database/Tds/Message.hs b/src/Database/Tds/Message.hs --- a/src/Database/Tds/Message.hs +++ b/src/Database/Tds/Message.hs @@ -2,8 +2,25 @@ ClientMessage (..) -- ** Login - , Login7 (..) + , Login7 , defaultLogin7 + , l7ConnectionID + , l7OptionFlags1 + , l7OptionFlags2 + , l7OptionFlags3 + , l7TypeFlags + , l7TimeZone + , l7Collation + , l7Language + , l7ClientPID + , l7ClientMacAddr + , l7ClientHostName + , l7AppName + , l7ServerName + , l7UserName + , l7Password + , l7Database + , tdsVersion -- ** SQL Batch , SqlBatch (..) @@ -133,11 +150,7 @@ ) where -import Control.Applicative((<$>),(<*>)) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Builder as BB +import Control.Applicative((<$>)) import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..)) import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..)) @@ -146,9 +159,6 @@ 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 @@ -161,45 +171,6 @@ import Database.Tds.Message.Server - - - -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 - - -- [MEMO] 4096 - packetSize :: Integral a => a - packetSize = fromIntegral $ l7PacketSize defaultLogin7 - - - -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 diff --git a/src/Database/Tds/Message/Client.hs b/src/Database/Tds/Message/Client.hs --- a/src/Database/Tds/Message/Client.hs +++ b/src/Database/Tds/Message/Client.hs @@ -5,8 +5,24 @@ -- Client Messages: https://msdn.microsoft.com/en-us/library/dd341027.aspx -module Database.Tds.Message.Client ( Login7 (..) +module Database.Tds.Message.Client ( Login7 , defaultLogin7 + , l7ConnectionID + , l7OptionFlags1 + , l7OptionFlags2 + , l7OptionFlags3 + , l7TypeFlags + , l7TimeZone + , l7Collation + , l7Language + , l7ClientPID + , l7ClientMacAddr + , l7ClientHostName + , l7AppName + , l7ServerName + , l7UserName + , l7Password + , l7Database , SqlBatch (..) @@ -42,6 +58,7 @@ 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 @@ -74,22 +91,20 @@ deriving (Show) defaultLogin7 :: Login7 -defaultLogin7 = Login7 { l7TdsVersion = 0x71000001 - , l7PacketSize = 4096 - , l7ClientProgVer = 0x0683f2f8 +defaultLogin7 = Login7 { l7TdsVersion = tdsVersion + , l7PacketSize = packetSize + , l7ClientProgVer = 0x0683f2f8 -- [MEMO] 0x00000007 , l7ConnectionID = 0 , l7OptionFlags1 = 0x80 + 0x40 + 0x20 - , l7OptionFlags2 = 0 + , l7OptionFlags2 = 0 -- [MEMO] 0x02 + 0x01 + + , l7OptionFlags3 = 0 , l7TypeFlags = 0 --- , l7TimeZone = -120 - , l7TimeZone = 0 --- , l7Collation = 0x36040000 --- , l7Collation = 0x1104d000 - , l7Collation = 0x00000000 - , l7CltIntName = T.pack "DB-Library" -- "OLEDB", "ODBC" - , l7Language = mempty --- , l7Language = T.pack "us_english" + , l7TimeZone = 0 -- [MEMO] -120 + , l7Collation = 0x00000000 -- [MEMO] 0x36040000, 0x1104d000, 0x09040000 + , l7CltIntName = T.pack "DB-Library" -- [MDMO] "OLEDB", "ODBC" + , l7Language = mempty -- [MEMO] "us_english" , l7ClientPID = 0 , l7ClientMacAddr = mempty , l7ClientHostName = mempty @@ -188,26 +203,16 @@ putLogin7 x = do Put.putWord32le $ fromIntegral plLen -- payload length Put.putWord32le $ l7TdsVersion x --- enum { --- tds70Version = 0x70000000, --- tds71Version = 0x71000001, --- tds72Version = 0x72090002, --- tds73Version = 0x730B0003, --- tds74Version = 0x74000004, --- }; Put.putWord32le $ l7PacketSize x -- packet size Put.putWord32le $ l7ClientProgVer x -- client program version --- Put.putWord32be 0x00000007 -- client program version Put.putWord32le $ l7ClientPID x -- client pid Put.putWord32le $ l7ConnectionID x -- connect id Put.putWord8 $ l7OptionFlags1 x -- flag1 Put.putWord8 $ l7OptionFlags2 x -- flag2 --- Put.putWord8 $ 0x02 + 0x01 -- flag2 Put.putWord8 $ l7TypeFlags x -- sql type Put.putWord8 $ l7OptionFlags3 x -- flag3 Put.putInt32le $ l7TimeZone x -- tz Put.putWord32be $ l7Collation x -- collation --- Put.putWord32be $ 0x09040000 -- collation offs <- foldM putIndex plHLen bytes1 -- index 1st-half Put.putByteString $ l7ClientMacAddr x -- mac address diff --git a/src/Database/Tds/Message/Header.hs b/src/Database/Tds/Message/Header.hs --- a/src/Database/Tds/Message/Header.hs +++ b/src/Database/Tds/Message/Header.hs @@ -1,10 +1,18 @@ {-# OPTIONS_HADDOCK hide #-} -- Packet Header: https://msdn.microsoft.com/en-us/library/dd340948.aspx -module Database.Tds.Message.Header ( Header (..) - , headerLength +module Database.Tds.Message.Header ( packetSize + , tdsVersion + , Header (..) + , putMessage + , getMessage ) 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(..)) @@ -12,7 +20,10 @@ 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 @@ -23,6 +34,24 @@ data Header = Header !Type !Status !Length !SPID !PacketID !Window +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 @@ -50,7 +79,39 @@ get = getHeader -headerLength :: Integral a => a -headerLength = fromIntegral 8 + +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 diff --git a/src/Database/Tds/Message/Prelogin.hs b/src/Database/Tds/Message/Prelogin.hs --- a/src/Database/Tds/Message/Prelogin.hs +++ b/src/Database/Tds/Message/Prelogin.hs @@ -46,7 +46,7 @@ data PreloginOption = PLOVersion !MajorVer !MinorVer !BuildVer !SubBuildVer - | PLOEncription !Word8 -- [TODO] flags + | PLOEncryption !Word8 -- [TODO] flags | PLOInstopt !B.ByteString | PLOThreadid !(Maybe Threadid) | PLOMars !Word8 -- MARS(Multiple Active Result Sets) supprt -- [TODO] flags @@ -67,7 +67,7 @@ preloginOptionPayloadLength = f where f (PLOVersion _ _ _ _) = 1 + 1 + 4 - f (PLOEncription _) = 1 + f (PLOEncryption _) = 1 f (PLOInstopt io) = B.length io + 1 f (PLOThreadid _) = 4 f (PLOMars _) = 1 @@ -87,7 +87,7 @@ let ot = case op of PLOVersion _ _ _ _ -> 0x00 - PLOEncription _ -> 0x01 + PLOEncryption _ -> 0x01 PLOInstopt _ -> 0x02 PLOThreadid _ -> 0x03 PLOMars _ -> 0x04 @@ -107,7 +107,7 @@ Put.putWord16be b Put.putWord16be sb - putOpt (PLOEncription enc) = Put.putWord8 enc + putOpt (PLOEncryption enc) = Put.putWord8 enc putOpt (PLOInstopt io) = do Put.putByteString io @@ -170,7 +170,7 @@ <*> Get.getWord16be <*> Get.getWord16be - getOpt 0x01 _ = PLOEncription <$> Get.getWord8 + getOpt 0x01 _ = PLOEncryption <$> Get.getWord8 getOpt 0x02 len = -- [MEMO] null terminated string if len == 1