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: 7a16a4896946efbb08b77d4048e4df5747570955336beaa0212bc14a8260c7cc +-- hash: 62ef4732f490b492580886e66b1c89efb43e06a9d005a2c6f326e6b1ea894943 name: ms-tds -version: 0.1.0.3 +version: 0.1.0.4 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 @@ -133,7 +133,6 @@ ) where -import Data.Monoid((<>),mempty) import Control.Applicative((<$>),(<*>)) import qualified Data.ByteString as B @@ -166,27 +165,24 @@ putMessage :: Word8 -> LB.ByteString -> Put -putMessage pt bs = mapM_ (f pt) $ split packetSize bs +putMessage pt bs = mapM_ f $ split (packetSize -headerLength) bs where - f :: Word8 -> B.ByteString -> Put - f pt bs = do + f :: (Bool,LB.ByteString) -> Put + f (isLast,bs) = do let - len = B.length bs - flg = if len < (packetSize -8) then 0x01 else 0x00 -- last flag - put $ Header pt flg (len +8) 0 0 0 - Put.putByteString bs + 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 -> [B.ByteString] + split :: Int64 -> LB.ByteString -> [(Bool,LB.ByteString)] split len lbs = let - (lbs',rem) = LB.splitAt (len + 8) lbs - bs = LB.toStrict lbs' + (lbs',rem) = LB.splitAt len lbs in if LB.null rem - then [bs] - else - let bss = split len rem - in bs:bss + then [(True,lbs')] + else (False,lbs'): split len rem -- [MEMO] 4096 packetSize :: Integral a => a @@ -200,7 +196,7 @@ f :: WriterT BB.Builder Get Word8 f = do (Header pt flg len _ _ _) <- lift get - tell =<< BB.byteString <$> (lift $ Get.getByteString (len -8)) + 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 @@ -23,7 +23,7 @@ ) where -import Data.Monoid((<>),mempty) +import Data.Monoid(mempty) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -179,7 +179,7 @@ login7Length :: Login7 -> Int login7Length x = let - bLen = sum $ map B.length $ login7Bytes1 x <> login7Bytes2 x + bLen = (sum $ map B.length $ login7Bytes1 x) + (sum $ map B.length $ login7Bytes2 x) in login7HeaderLength + bLen @@ -215,7 +215,8 @@ -- Put.putWord32le 0 -- SSPI long -- TDS 7.2 - mapM_ Put.putByteString $ bytes1 <> bytes2 -- datas + mapM_ Put.putByteString $ bytes1 + mapM_ Put.putByteString $ bytes2 where putIndex :: Int -> B.ByteString -> Put.PutM Int 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 @@ -2,6 +2,7 @@ -- Packet Header: https://msdn.microsoft.com/en-us/library/dd340948.aspx module Database.Tds.Message.Header ( Header (..) + , headerLength ) where import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..)) @@ -14,7 +15,7 @@ type Type = Word8 type Status = Word8 -type Length = Int +type Length = Word16 type SPID = Word16 type PacketID = Word8 type Window = Word8 @@ -41,9 +42,15 @@ spid <- Get.getWord16be -- SPID pcid <- Get.getWord8 -- PacketIK win <- Get.getWord8 -- Window - return $ Header pt st (fromIntegral len) spid pcid win + return $ Header pt st len spid pcid win instance Binary Header where put = putHeader get = getHeader + + +headerLength :: Integral a => a +headerLength = fromIntegral 8 + + 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 @@ -14,7 +14,8 @@ , Nonce (..) ) where -import Data.Monoid((<>),mempty) +import Data.Monoid(mempty) + import Control.Applicative((<$>),(<*>)) import qualified Data.ByteString as B diff --git a/src/Database/Tds/Message/Server.hs b/src/Database/Tds/Message/Server.hs --- a/src/Database/Tds/Message/Server.hs +++ b/src/Database/Tds/Message/Server.hs @@ -64,7 +64,6 @@ ) where -import Data.Monoid((<>),mempty) import Control.Applicative((<$>),(<*>)) import qualified Data.ByteString as B diff --git a/src/Database/Tds/Transport.hs b/src/Database/Tds/Transport.hs --- a/src/Database/Tds/Transport.hs +++ b/src/Database/Tds/Transport.hs @@ -73,7 +73,7 @@ modifyMVar_ (getSendStep sock') (return . (+1)) where appendBuff = modifyMVar_ (getSendBuff sock') (return . (<>bs)) - header bs = LB.toStrict $ encode $ Header 0x12 1 (B.length bs +8) 0 0 0 + header bs = LB.toStrict $ encode $ Header 0x12 1 (fromIntegral $ B.length bs +8) 0 0 0 -- [MEMO] This doesn't work -- [MEMO] Want to do this @@ -82,7 +82,7 @@ 0x17 -> sendAll sock bs _ -> sendAll sock $ (header bs) <> bs where - header bs = LB.toStrict $ encode $ Header 0x12 1 (B.length bs +8) 0 0 0 + header bs = LB.toStrict $ encode $ Header 0x12 1 (fromIntegral $ B.length bs +8) 0 0 0 -- [MEMO] Remove TDS header @@ -98,7 +98,7 @@ recvDropBuff = do header <- recv sock 8 let (Header _ _ totalLen _ _ _) = decode $ LB.fromStrict header - body <- recv sock $ totalLen -8 + body <- recv sock $ fromIntegral $ totalLen -8 let bs = B.take len body modifyMVar_ (getRecvBuff sock') (\_ -> return $ B.drop len body) return bs