ms-tds (empty) → 0.1.0.0
raw patch · 20 files changed
+3250/−0 lines, 20 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, data-default-class, ms-tds, mtl, network, text, time, tls, uuid-types, x509-store, x509-system
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +119/−0
- Setup.hs +2/−0
- ms-tds.cabal +87/−0
- src/Database/Tds/Message.hs +253/−0
- src/Database/Tds/Message/Client.hs +321/−0
- src/Database/Tds/Message/DataStream.hs +914/−0
- src/Database/Tds/Message/Header.hs +49/−0
- src/Database/Tds/Message/Prelogin.hs +201/−0
- src/Database/Tds/Message/Server.hs +561/−0
- src/Database/Tds/Primitives/Collation.hs +35/−0
- src/Database/Tds/Primitives/DateTime.hs +50/−0
- src/Database/Tds/Primitives/Decimal.hs +202/−0
- src/Database/Tds/Primitives/Fixed.hs +212/−0
- src/Database/Tds/Primitives/Float.hs +46/−0
- src/Database/Tds/Primitives/Money.hs +38/−0
- src/Database/Tds/Primitives/Null.hs +7/−0
- src/Database/Tds/Transport.hs +118/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for ms-tds++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Takamasa Mitsuji (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,119 @@+# ms-tds: TDS Protocol implemented in Haskell++This library is a Haskell implementation of the Tabular Data Stream (TSD) protocol+used by Microsoft SQL Server and others.+++## Related projects++* [mssql-simple](https://github.com/mitsuji/mssql-simple)+ : SQL Server client library implemented in Haskell + https://github.com/mitsuji/mssql-simple+ +* [mssql-simple-example](https://github.com/mitsuji/mssql-simple-example)+ : Usage example of mssql-simple + https://github.com/mitsuji/mssql-simple-example+++## Advantage++* ODBC independent++* Implemented only with Haskell (Independent of other languages and environments)++* Supports encryption at login++* Implemented as+ [binary](http://hackage.haskell.org/package/binary)+ package compatible data types++* Intended for use in both Client library and Server library implementations++* 7.1 Revision 1 (SQL Server 2000 SP1 and later)++* Tested with SQL Server 2008 R2++++## Todo++* Write tests+ * Write general tests+ * Test legacy data types+++* Transaction support+++* Implement data types+ * AltMetaData+ * AltRow+ * ColInfo+++* Implement [Binary.put](http://hackage.haskell.org/package/binary-0.10.0.0/docs/Data-Binary.html#v:put)+ interface of+ * TokenStreams+++* Implement [Binary.get](http://hackage.haskell.org/package/binary-0.10.0.0/docs/Data-Binary.html#v:get)+ interface of+ * Login7+ * SqlBatch+ * RpcRequest+++* Implement more detailed types+ * Collation(DataStream)+ * GUID(Prelogin,DataStream)+ * NONCE(Prelogin)+ * TimeStamp(RCDlarge)+ * Login7: TDS Version+ * Login7: client program version+ * Login7: timezone+ * Login7: language+ * Login7: collation+ * RpcReqBatchProcId: ProcID+ * TSEnvChange: Type+ * TSLoginAck: Interface+ * TSReturnValue: Status+++* Implement Flag interfaces+ * Header status+ * PLOEncription+ * PLOMars+ * Login7 flag1+ * Login7 flag2+ * Login7 sql type+ * Login7 flag3+ * RpcReqBatchProcId OptionFlags+ * RpcReqBatchPhrocName OptionFlags+ * RpcReqBatchParam StatusFlag+ * AltMetaDta Flags+ * MetaColumnData Flags+ * TSDone status+ * TSDoneInProc status+ * TSDoneProc status+ * TSReturnValue Flags+++* ETC+ * Encrypt entire connection support+ * Mars support+ * SSPI support+ * FedAuth support+ * Variable PacketSize support+ * TDS protocol versions other than 7.1++ * Attention + https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/dc28579f-49b1-4a78-9c5f-63fbda002d2e+ + * Bulk Load + https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/88176081-df75-4b24-bcfb-4c16ff03cbfa++ * Distributed Transaction + https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/b4b78564-5440-4fc0-b5ef-c9e1925aaefe+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ms-tds.cabal view
@@ -0,0 +1,87 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 0882fb2272f167b6bbf45e2945afdaa18166e53c206f1b97c6ecea2801c611d6++name: ms-tds+version: 0.1.0.0+description: Please see the README on GitHub at <https://github.com/mitsuji/ms-tds#readme>+homepage: https://github.com/mitsuji/ms-tds#readme+bug-reports: https://github.com/mitsuji/ms-tds/issues+author: Takamasa Mitsuji+maintainer: tkms@mitsuji.org+copyright: 2019 Takamasa Mitsuji+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/mitsuji/ms-tds++library+ exposed-modules:+ Database.Tds.Message+ Database.Tds.Message.Client+ Database.Tds.Message.DataStream+ Database.Tds.Message.Header+ Database.Tds.Message.Prelogin+ Database.Tds.Message.Server+ Database.Tds.Primitives.Collation+ Database.Tds.Primitives.DateTime+ Database.Tds.Primitives.Decimal+ Database.Tds.Primitives.Fixed+ Database.Tds.Primitives.Float+ Database.Tds.Primitives.Money+ Database.Tds.Primitives.Null+ Database.Tds.Transport+ other-modules:+ Paths_ms_tds+ hs-source-dirs:+ src+ build-depends:+ array+ , base >=4.7 && <5+ , binary+ , bytestring+ , data-default-class+ , mtl+ , network+ , text+ , time+ , tls+ , uuid-types+ , x509-store+ , x509-system+ default-language: Haskell2010++test-suite tds-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_ms_tds+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ array+ , base >=4.7 && <5+ , binary+ , bytestring+ , data-default-class+ , ms-tds+ , mtl+ , network+ , text+ , time+ , tls+ , uuid-types+ , x509-store+ , x509-system+ default-language: Haskell2010
+ src/Database/Tds/Message.hs view
@@ -0,0 +1,253 @@+module Database.Tds.Message ( -- * Client Message+ ClientMessage (..)+ + -- ** Login+ , Login7 (..)+ , defaultLogin7+ + -- ** SQL Batch+ , SqlBatch (..)+ + -- ** RPC Request+ , RpcRequest (..)+ + , RpcReqBatch (..)+ , ProcID (..)+ , ProcName (..)+ , OptionFlags (..)++ , RpcReqBatchParam (..)+ , ParamName (..)+ , StatusFlag (..)+ + -- * Server Message+ , ServerMessage (..)+ , ServerMessageInstance (..)+ + , TokenStreams (..)+ , TokenStream (..)+ + -- ** AltMetaData+ , AltMetaData (..)+ + -- ** ColProperty+ , ColProperty (..)+ , CPColNum (..)+ , CPTableNum (..)+ , CPStatus (..)+ , CPColName (..)+ + -- ** ColMetaData+ , ColMetaData (..)+ , MetaColumnData (..)+ , MCDUserType (..)+ , MCDFlags (..)+ , MCDTableName (..)+ , MCDColName (..)++ -- ** Done, DoneInProc, DoneProc+ , Done (..)+ , DoneStatus (..)+ , DoneCurCmd (..)+ , DoneRowCount (..)+ + -- ** EnvChange+ , ECType (..)+ , ECNewValue (..)+ , ECOldValue (..)++ -- ** Error, Info+ , Info (..)+ , InfoNumber (..)+ , InfoState (..)+ , InfoClass (..)+ , InfoMsgText (..)+ , InfoServerName (..)+ , InfoProcName (..)+ , InfoLineNumber (..)+ + -- ** LoginAck+ , LAInterface (..)+ , LATdsVersion (..)+ , LAProgName (..)+ , LAProgVersion (..)+ + -- ** Offset+ , OffsetIdentifier (..)+ , OffsetLength (..)+ , Offset (..)+ + -- ** ReturnValue+ , ReturnValue (..)+ , RVParamOrdinal (..)+ , RVParamName (..)+ , RVStatus (..)+ , RVUserType (..)+ , RVFlags (..)+ + -- ** Row+ , RowColumnData (..)+ , TextPointer (..)+ , TimeStamp (..)++ -- * Primitives+ , TypeInfo (..)+ , RawBytes (..)+ , Data (..)++ , Null (..)+ + , Precision (..)+ , Scale (..)+ , Decimal (..)+ , Money (..)+ + , Collation (..)+ , Collation32 (..)+ , SortId (..)++ + -- * Prelogin+ , Prelogin (..)+ , PreloginOption (..)+ , MajorVer (..)+ , MinorVer (..)+ , BuildVer (..)+ , SubBuildVer (..)+ , Threadid (..)+ , Connid (..)+ , Activity (..)+ , Sequence (..)+ , Nonce (..)+ + ) where++import Data.Monoid((<>))++import qualified Data.ByteString as B+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(..))++import Data.Binary (Put(..),Get(..),Binary(..),decode,encode)+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+import Database.Tds.Primitives.Collation++import Database.Tds.Message.Header+import Database.Tds.Message.DataStream+import Database.Tds.Message.Prelogin+import Database.Tds.Message.Client+import Database.Tds.Message.Server++++++putMessage :: Word8 -> LB.ByteString -> Put+putMessage pt bs = mapM_ (f pt) $ split packetSize bs+ where+ f :: Word8 -> B.ByteString -> Put+ f pt 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++ + split :: Int64 -> LB.ByteString -> [B.ByteString]+ split len lbs =+ let+ (lbs',rem) = LB.splitAt (len + 8) lbs+ bs = LB.toStrict lbs'+ in if LB.null rem+ then [bs]+ else+ let bss = split len rem+ in bs:bss + + -- [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 (len -8))+ if flg == 0x01+ then return pt+ else f+++++data ClientMessage = CMPrelogin !Prelogin+ | CMLogin7 !Login7+ | CMSqlBatch !SqlBatch+ | CMRpcRequest !RpcRequest+ deriving (Show)++putClientMessage :: ClientMessage -> Put+putClientMessage 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++getClientMessage :: Get ClientMessage+getClientMessage = do+ (pt,bs) <- getMessage+ case pt of+ 0x12 -> return $ CMPrelogin $ decode bs+ 0x10 -> return $ CMLogin7 $ decode bs+ 0x01 -> return $ CMSqlBatch $ decode bs+ 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++putServerMessageInstance :: ServerMessageInstance a => a -> Put+putServerMessageInstance x =+ putMessage 0x04 $ encode x++getServerMessageInstance :: ServerMessageInstance a => Get a+getServerMessageInstance = do+ (pt,bs) <- getMessage+ case pt of+ 0x04 -> return $ decode bs+ _ -> fail "getServerMessageInstance: invalid packet type"+++newtype ServerMessage a = ServerMessage a+ deriving (Show)++instance (ServerMessageInstance a) => Binary (ServerMessage a) where+ put (ServerMessage x) = putServerMessageInstance x+ get = ServerMessage <$> getServerMessageInstance++
+ src/Database/Tds/Message/Client.hs view
@@ -0,0 +1,321 @@+{-# OPTIONS_HADDOCK hide #-}+-- Stream Types: https://msdn.microsoft.com/en-us/library/dd303435.aspx+-- Data Types: https://msdn.microsoft.com/en-us/library/dd305325.aspx+-- Data Stream: https://msdn.microsoft.com/en-us/library/dd340794.aspx+-- Client Messages: https://msdn.microsoft.com/en-us/library/dd341027.aspx+++module Database.Tds.Message.Client ( Login7 (..)+ , defaultLogin7+ + , SqlBatch (..)+ + , RpcRequest (..)+ + , RpcReqBatch (..)+ , ProcID (..)+ , ProcName (..)+ , OptionFlags (..)+ + , RpcReqBatchParam (..)+ , ParamName (..)+ , StatusFlag (..)+ + ) where++import Data.Monoid((<>))++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))+import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))++import Data.Binary (Put(..),Get(..),Binary(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get++import Data.Bits ((.&.),(.|.),xor,shift)++import Control.Monad (foldM,foldM_)++import Database.Tds.Message.Prelogin+import Database.Tds.Message.DataStream+import Database.Tds.Primitives.Collation+++++data Login7 = Login7 { l7TdsVersion :: !Word32+ , l7PacketSize :: !Word32+ , l7ClientProgVer :: !Word32+ , l7ConnectionID :: !Word32+ , l7OptionFlags1 :: !Word8+ , l7OptionFlags2 :: !Word8+ , l7OptionFlags3 :: !Word8+ , l7TypeFlags :: !Word8+ , l7TimeZone :: !Word32+ , l7Collation :: !Collation32+ , l7CltIntName :: !T.Text+ , l7Language :: !T.Text+ , l7ClientPID :: !Word32+ , l7ClientMacAddr :: !B.ByteString+ , l7ClientHostName :: !T.Text+ , l7AppName :: !T.Text+ , l7ServerName :: !T.Text+ , l7UserName :: !T.Text+ , l7Password :: !T.Text+ , l7Database :: !T.Text+ }+ deriving (Show)++defaultLogin7 :: Login7+defaultLogin7 = Login7 { l7TdsVersion = 0x71000001+ , l7PacketSize = 4096+ , l7ClientProgVer = 0x0683f2f8+ , l7ConnectionID = 0+ , l7OptionFlags1 = 0x80 + 0x40 + 0x20+ , l7OptionFlags2 = 0+ , l7OptionFlags3 = 0+ , l7TypeFlags = 0+ , l7TimeZone = -120+-- , l7Collation = 0x36040000+ , l7Collation = 0x1104d000+ , l7CltIntName = T.pack "DB-Library" -- "OLEDB", "ODBC"+ , l7Language = mempty+-- , l7Language = T.pack "us_english"+ , l7ClientPID = 0+ , l7ClientMacAddr = mempty+ , l7ClientHostName = mempty+ , l7AppName = mempty+ , l7ServerName = mempty+ , l7UserName = mempty+ , l7Password = mempty+ , l7Database = mempty+ }+++login7Bytes1 :: Login7 -> [B.ByteString]+login7Bytes1 x =+ let+ clientHostName = T.encodeUtf16LE $ l7ClientHostName x+ userName = T.encodeUtf16LE $ l7UserName x+ password = cryptPassword $ T.encodeUtf16LE $ l7Password x+ appName = T.encodeUtf16LE $ l7AppName x+ serverName = T.encodeUtf16LE $ l7ServerName x+ unused = mempty+ libraryName = T.encodeUtf16LE $ l7CltIntName x+ language = T.encodeUtf16LE $ l7Language x+ database = T.encodeUtf16LE $ l7Database x++ in [ clientHostName+ , userName+ , password+ , appName+ , serverName+ , unused+ , libraryName+ , language+ , database+ ]+ where+ cryptPassword :: B.ByteString -> B.ByteString+ cryptPassword bs =+ let+ bs' = B.unpack bs+ in B.pack $ map (\x -> (shift x 4 .|. shift x (-4)) `xor` 0xa5) bs'+ ++login7Bytes2 :: Login7 -> [B.ByteString]+login7Bytes2 x =+ let+ sspi = mempty+ atachDBFile = mempty+-- changePassword = mempty -- TDS 7.2+ in [ sspi+ , atachDBFile+-- , changePassword -- TDS 7.2+ ]+++login7HeaderLength :: Int+login7HeaderLength =+ let+ hLen = 4 -- payload length+ + 4 -- TDS Version+ + 4 -- packet size+ + 4 -- client program version+ + 4 -- client pid+ + 4 -- connection id+ + 1 -- flag1+ + 1 -- flag2+ + 1 -- SQL type+ + 1 -- flag3+ + 4 -- time zone+ + 4 -- collation+ + 4 -- idx client hostname + + 4 -- idx username+ + 4 -- idx password+ + 4 -- idx app name+ + 4 -- idx server name+ + 4 -- idx unused+ + 4 -- idx library name+ + 4 -- idx language+ + 4 -- idx database+ + 6 -- client mac addr+ + 4 -- idx SSPI+ + 4 -- idx AtachDBFile+-- + 4 -- idx ChangePassword -- TDS 7.2 +-- + 4 -- SSPI_long -- TDS 7.2+ in hLen+++login7Length :: Login7 -> Int+login7Length x =+ let+ bLen = sum $ map B.length $ login7Bytes1 x <> login7Bytes2 x+ in login7HeaderLength + bLen+++-- https://msdn.microsoft.com/en-us/library/dd304019.aspx+putLogin7 :: Login7 -> Put+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.putWord32le $ 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+ foldM_ putIndex offs bytes2 -- index 2nd-half+ +-- Put.putWord32le 0 -- SSPI long -- TDS 7.2++ mapM_ Put.putByteString $ bytes1 <> bytes2 -- datas++ where+ putIndex :: Int -> B.ByteString -> Put.PutM Int+ putIndex offs bs = do+ let+ len = B.length bs+ Put.putWord16le $ fromIntegral offs+ Put.putWord16le $ fromIntegral $ len `div` 2+ return $ offs+len++ plLen = login7Length x+ plHLen = login7HeaderLength+ bytes1 = login7Bytes1 x+ bytes2 = login7Bytes2 x+ ++getLogin7 :: Get Login7+getLogin7 = undefined -- [TODO] implement get function+++instance Binary Login7 where+ put = putLogin7+ get = getLogin7+ +++++newtype SqlBatch = SqlBatch T.Text+ deriving (Show)+++putSqlBatch :: SqlBatch -> Put+putSqlBatch (SqlBatch sql) = Put.putByteString $ T.encodeUtf16LE sql++getSqlBatch :: Get SqlBatch+getSqlBatch = undefined -- [TODO] implement get function+++instance Binary SqlBatch where+ put = putSqlBatch+ get = getSqlBatch++++type ParamName = T.Text+type StatusFlag = Word8++data RpcReqBatchParam = RpcReqBatchParam !ParamName !StatusFlag !TypeInfo !RawBytes+ deriving (Show)+++type ProcID = Word16+type ProcName = T.Text+type OptionFlags = Word16++data RpcReqBatch = RpcReqBatchProcId !ProcID !OptionFlags ![RpcReqBatchParam]+ | RpcReqBatchProcName !ProcName !OptionFlags ![RpcReqBatchParam]+ deriving (Show)+++newtype RpcRequest = RpcRequest [RpcReqBatch]+ deriving (Show)+ ++++++putRpcReqBatch :: RpcReqBatch -> Put+putRpcReqBatch (RpcReqBatchProcId pid flgs pds) = do+ Put.putWord16le 0xffff+ Put.putWord16le pid+ Put.putWord16le flgs+ mapM_ putRpcReqBatchParam pds+ +putRpcReqBatch (RpcReqBatchProcName pn flgs pds) = do+ Put.putWord16le $ fromIntegral $ T.length pn -- [MEMO] text length+ Put.putByteString $ T.encodeUtf16LE pn+ Put.putWord16le flgs+ mapM_ putRpcReqBatchParam pds+ ++putRpcReqBatchParam :: RpcReqBatchParam -> Put+putRpcReqBatchParam (RpcReqBatchParam pn sf ti val) = do+ Put.putWord8 $ fromIntegral $ T.length pn -- [MEMO] text length+ Put.putByteString $ T.encodeUtf16LE pn+ Put.putWord8 sf+ put ti+ putRawBytes ti val+ return ()+++putRpcRequest :: RpcRequest -> Put+putRpcRequest (RpcRequest bts) = mapM_ (\bt -> putRpcReqBatch bt >> Put.putWord8 0x80) bts -- [MEMO] split by 0x80++getRpcRequest :: Get RpcRequest+getRpcRequest = undefined -- [TODO] implement get function+++instance Binary RpcRequest where+ put = putRpcRequest+ get = getRpcRequest+++
+ src/Database/Tds/Message/DataStream.hs view
@@ -0,0 +1,914 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleInstances #-}+-- Stream Types: https://msdn.microsoft.com/en-us/library/dd303435.aspx+-- Data Types: https://msdn.microsoft.com/en-us/library/dd305325.aspx+-- Data Stream: https://msdn.microsoft.com/en-us/library/dd340794.aspx+++module Database.Tds.Message.DataStream ( TypeInfo (..)+ , RawBytes (..)+ , getRawBytes+ , putRawBytes+ , Data (..)+ ) where++import Data.Monoid((<>))++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))+import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))++import Data.Binary (Put(..),Get(..),Binary(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get++import Data.Time (UTCTime(..))+import Data.UUID.Types (UUID)+import qualified Data.UUID.Types as UUID++import Database.Tds.Primitives.Null+import Database.Tds.Primitives.Money+import Database.Tds.Primitives.DateTime+import Database.Tds.Primitives.Float+import Database.Tds.Primitives.Decimal+import Database.Tds.Primitives.Collation++++++data TypeInfo = TINull -- 0x1f+ | TIBit -- 0x32+ | TIInt1 -- 0x30+ | TIInt2 -- 0x34+ | TIInt4 -- 0x38+ | TIInt8 -- 0x7f+ | TIMoney4 -- 0x7a+ | TIMoney8 -- 0x3c+ | TIDateTime4 -- 0x3a+ | TIDateTime8 -- 0x3d+ | TIFlt4 -- 0x3b+ | TIFlt8 -- 0x3e+ + | TIBitN -- 0x68+ | TIIntN1 -- 0x26+ | TIIntN2 -- 0x26+ | TIIntN4 -- 0x26+ | TIIntN8 -- 0x26+ | TIMoneyN4 -- 0x6e+ | TIMoneyN8 -- 0x6e+ | TIDateTimeN4 -- 0x6f+ | TIDateTimeN8 -- 0x6f+ | TIFltN4 -- 0x6d+ | TIFltN8 -- 0x6d+ + | TIGUID -- 0x24+ | TIDecimalN !Precision !Scale -- 0x6a, 0x37(legacy)+ | TINumericN !Precision !Scale -- 0x6c, 0x3f(legacy)+ + | TIChar !Word8 -- 0x2f(legacy) -- [TODO] test+ | TIVarChar !Word8 -- 0x27(legacy) -- [TODO] test+ | TIBigChar !Word16 !Collation -- 0xaf+ | TIBigVarChar !Word16 !Collation -- 0xa7+ | TIText !Word32 !Collation -- 0x23+ + | TINChar !Word16 !Collation -- 0xef+ | TINVarChar !Word16 !Collation -- 0xe7+ | TINText !Word32 !Collation -- 0x63+ + | TIBinary !Word8 -- 0x2d(legacy) -- [TODO] test+ | TIVarBinary !Word8 -- 0x25(legacy) -- [TODO] test+ | TIBigBinary !Word16 -- 0xad+ | TIBigVarBinary !Word16 -- 0xa5+ | TIImage !Word32 -- 0x22+ deriving (Show)+++-- https://msdn.microsoft.com/en-us/library/dd358284.aspx+-- https://msdn.microsoft.com/en-us/library/dd305325.aspx+getTypeInfo :: Get TypeInfo+getTypeInfo = f =<< Get.getWord8+ where+ f :: Word8 -> Get TypeInfo+ f 0x1f = return TINull+ f 0x32 = return TIBit+ f 0x30 = return TIInt1+ f 0x34 = return TIInt2+ f 0x38 = return TIInt4+ f 0x7f = return TIInt8+ f 0x7a = return TIMoney4+ f 0x3c = return TIMoney8+ f 0x3a = return TIDateTime4+ f 0x3d = return TIDateTime8+ f 0x3b = return TIFlt4+ f 0x3e = return TIFlt8++ f 0x68 = do+ _ <- Get.getWord8+ return TIBitN++ f 0x26 = do+ len <- Get.getWord8+ case len of+ 1 -> return TIIntN1+ 2 -> return TIIntN2+ 4 -> return TIIntN4+ 8 -> return TIIntN8+ _ -> fail "getTypeInfo: invalid data length"++ f 0x6e = do+ len <- Get.getWord8+ case len of+ 4 -> return TIMoneyN4+ 8 -> return TIMoneyN8+ _ -> fail "getTypeInfo: invalid data length"++ f 0x6f = do+ len <- Get.getWord8+ case len of+ 4 -> return TIDateTimeN4+ 8 -> return TIDateTimeN8+ _ -> fail "getTypeInfo: invalid data length"+ + f 0x6d = do+ len <- Get.getWord8+ case len of+ 4 -> return TIFltN4+ 8 -> return TIFltN8+ _ -> fail "getTypeInfo: invalid data length"+ + f 0x24 = do+ len <- Get.getWord8 -- 0x10 (16byte)+ case len of+ 16 -> return TIGUID+ _ -> fail "getTypeInfo: invalid data length"+ + f 0x37 = f 0x6a+ f 0x6a = do+ _ <- Get.getWord8+ TIDecimalN <$> Get.getWord8 -- precision+ <*> Get.getWord8 -- scale++ f 0x3f = f 0x6c+ f 0x6c = do+ _ <- Get.getWord8+ TINumericN <$> Get.getWord8 -- precision+ <*> Get.getWord8 -- scale++ -- [TODO] test+ -- [MEMO] no collation+ f 0x2f = TIChar <$> Get.getWord8++ -- [TODO] test+ -- [MEMO] no collation+ f 0x27 = TIVarChar <$> Get.getWord8++ f 0xaf = TIBigChar <$> Get.getWord16le+ <*> getCollation -- collation++ f 0xa7 = TIBigVarChar <$> Get.getWord16le+ <*> getCollation -- collation++ f 0x23 = TIText <$> Get.getWord32le+ <*> getCollation -- collation++ f 0xef = TINChar <$> Get.getWord16le+ <*> getCollation -- collation++ f 0xe7 = TINVarChar <$> Get.getWord16le+ <*> getCollation -- collation++ f 0x63 = TINText <$> Get.getWord32le+ <*> getCollation -- collation++ -- [TODO] test+ f 0x2d = TIBinary <$> Get.getWord8++ -- [TODO] test+ f 0x25 = TIVarBinary <$> Get.getWord8++ f 0xad = TIBigBinary <$> Get.getWord16le++ f 0xa5 = TIBigVarBinary <$> Get.getWord16le++ f 0x22 = TIImage <$> Get.getWord32le++++-- https://msdn.microsoft.com/en-us/library/dd358284.aspx+-- https://msdn.microsoft.com/en-us/library/dd305325.aspx+putTypeInfo :: TypeInfo -> Put+putTypeInfo (TINull ) = Put.putWord8 0x1f -- [TODO] test+putTypeInfo (TIBit ) = Put.putWord8 0x32+putTypeInfo (TIInt1 ) = Put.putWord8 0x30+putTypeInfo (TIInt2 ) = Put.putWord8 0x34+putTypeInfo (TIInt4 ) = Put.putWord8 0x38+putTypeInfo (TIInt8 ) = Put.putWord8 0x7f+putTypeInfo (TIMoney4 ) = Put.putWord8 0x7a+putTypeInfo (TIMoney8 ) = Put.putWord8 0x3c+putTypeInfo (TIDateTime4) = Put.putWord8 0x3a+putTypeInfo (TIDateTime8) = Put.putWord8 0x3d+putTypeInfo (TIFlt4 ) = Put.putWord8 0x3b+putTypeInfo (TIFlt8 ) = Put.putWord8 0x3e++putTypeInfo (TIBitN ) = Put.putWord8 0x68 >> Put.putWord8 1+putTypeInfo (TIIntN1 ) = Put.putWord8 0x26 >> Put.putWord8 1+putTypeInfo (TIIntN2 ) = Put.putWord8 0x26 >> Put.putWord8 2+putTypeInfo (TIIntN4 ) = Put.putWord8 0x26 >> Put.putWord8 4+putTypeInfo (TIIntN8 ) = Put.putWord8 0x26 >> Put.putWord8 8+putTypeInfo (TIMoneyN4 ) = Put.putWord8 0x6e >> Put.putWord8 4+putTypeInfo (TIMoneyN8 ) = Put.putWord8 0x6e >> Put.putWord8 8+putTypeInfo (TIDateTimeN4) = Put.putWord8 0x6f >> Put.putWord8 4+putTypeInfo (TIDateTimeN8) = Put.putWord8 0x6f >> Put.putWord8 8+putTypeInfo (TIFltN4 ) = Put.putWord8 0x6d >> Put.putWord8 4+putTypeInfo (TIFltN8 ) = Put.putWord8 0x6d >> Put.putWord8 8++putTypeInfo (TIGUID) = Put.putWord8 0x24 >> Put.putWord8 16+putTypeInfo (TIDecimalN p s) = do+ Put.putWord8 0x6a+ Put.putWord8 $ precisionToLen p -- [TODO] test+ Put.putWord8 p+ Put.putWord8 s+putTypeInfo (TINumericN p s) = do+ Put.putWord8 0x6c+ Put.putWord8 $ precisionToLen p -- [TODO] test+ Put.putWord8 p+ Put.putWord8 s+++putTypeInfo (TIChar len) = do -- [TODO] test+ Put.putWord8 0x2f+ Put.putWord8 len+ -- [MEMO] no collation++putTypeInfo (TIVarChar len) = do -- [TODO] test+ Put.putWord8 0x27+ Put.putWord8 len+ -- [MEMO] no collation+ +putTypeInfo (TIBigChar len col) = do+ Put.putWord8 0xaf+ Put.putWord16le len+ putCollation col+ +putTypeInfo (TIBigVarChar len col) = do+ Put.putWord8 0xa7+ Put.putWord16le len+ putCollation col++putTypeInfo (TIText len col) = do+ Put.putWord8 0x23+ Put.putWord32le len+ putCollation col+++putTypeInfo (TINChar len col) = do+ Put.putWord8 0xef+ Put.putWord16le len+ putCollation col+ +putTypeInfo (TINVarChar len col) = do+ Put.putWord8 0xe7+ Put.putWord16le len+ putCollation col++putTypeInfo (TINText len col) = do+ Put.putWord8 0x63+ Put.putWord32le len+ putCollation col+++putTypeInfo (TIBinary len) = do -- [TODO] test+ Put.putWord8 0x2d+ Put.putWord8 len++putTypeInfo (TIVarBinary len) = do -- [TODO] test+ Put.putWord8 0x25+ Put.putWord8 len+ +putTypeInfo (TIBigBinary len) = do+ Put.putWord8 0xad+ Put.putWord16le len+ +putTypeInfo (TIBigVarBinary len) = do+ Put.putWord8 0xa5+ Put.putWord16le len++putTypeInfo (TIImage len) = do+ Put.putWord8 0x22+ Put.putWord32le len++ +instance Binary TypeInfo where+ put = putTypeInfo+ get = getTypeInfo+++++type RawBytes = Maybe B.ByteString++getRawBytes :: TypeInfo -> Get RawBytes+getRawBytes = f+ where++ get8n :: Get RawBytes+ get8n = do+ len <- Get.getWord8+ if len == 0+ then return Nothing+ else Just <$> (Get.getByteString $ fromIntegral len)+ + get8s :: Get RawBytes+ get8s = do+ len <- Get.getWord8+ if len == 0xff+ then return Nothing+ else Just <$> (Get.getByteString $ fromIntegral len)+ + get16s :: Get RawBytes+ get16s = do+ len <- Get.getWord16le+ if len == 0xffff+ then return Nothing+ else Just <$> (Get.getByteString $ fromIntegral len)+ + get32s :: Get RawBytes+ get32s = do+ len <- Get.getWord32le+ if len == 0xffffffff+ then return Nothing+ else Just <$> (Get.getByteString $ fromIntegral len)++ f :: TypeInfo -> Get RawBytes+ f TINull = return Nothing+ f TIBit = Just <$> Get.getByteString 1+ f TIInt1 = Just <$> Get.getByteString 1+ f TIInt2 = Just <$> Get.getByteString 2+ f TIInt4 = Just <$> Get.getByteString 4+ f TIInt8 = Just <$> Get.getByteString 8+ f TIMoney4 = Just <$> Get.getByteString 4+ f TIMoney8 = Just <$> Get.getByteString 8+ f TIDateTime4 = Just <$> Get.getByteString 4+ f TIDateTime8 = Just <$> Get.getByteString 8+ f TIFlt4 = Just <$> Get.getByteString 4+ f TIFlt8 = Just <$> Get.getByteString 8++ f TIBitN = get8n+ f TIIntN1 = get8n+ f TIIntN2 = get8n+ f TIIntN4 = get8n+ f TIIntN8 = get8n+ f TIMoneyN4 = get8n+ f TIMoneyN8 = get8n+ f TIDateTimeN4 = get8n+ f TIDateTimeN8 = get8n+ f TIFltN4 = get8n+ f TIFltN8 = get8n+ + f TIGUID = get8n+ + f (TIDecimalN _ _) = get8n+ f (TINumericN _ _) = get8n++ f (TIChar _) = get8s+ f (TIVarChar _) = get8s+ f (TIBigChar _ _) = get16s+ f (TIBigVarChar _ _) = get16s+ f (TIText _ _) = get32s++ f (TINChar _ _) = get16s+ f (TINVarChar _ _) = get16s+ f (TINText _ _) = get32s+ + f (TIBinary _) = get8s+ f (TIVarBinary _) = get8s+ f (TIBigBinary _) = get16s+ f (TIBigVarBinary _) = get16s+ f (TIImage _) = get32s+++putRawBytes :: TypeInfo -> RawBytes -> Put+putRawBytes = g+ where++ put8n :: RawBytes -> Put+ put8n Nothing = Put.putWord8 0+ put8n (Just bs) = do+ Put.putWord8 $ fromIntegral $ B.length bs+ Put.putByteString bs+ + put8s :: RawBytes -> Put+ put8s Nothing = Put.putWord8 0xff+ put8s (Just bs) = do+ Put.putWord8 $ fromIntegral $ B.length bs+ Put.putByteString bs+ + put16s :: RawBytes -> Put+ put16s Nothing = Put.putWord16le 0xffff+ put16s (Just bs) = do+ Put.putWord16le $ fromIntegral $ B.length bs+ Put.putByteString bs+ + put32s :: RawBytes -> Put+ put32s Nothing = Put.putWord32le 0xffffffff+ put32s (Just bs) = do+ Put.putWord32le $ fromIntegral $ B.length bs+ Put.putByteString bs+ ++ g :: TypeInfo -> RawBytes -> Put+ g TINull _ = return ()+ + g TIBit Nothing = error "putRawBytes: Nothing is not convertible to TIBit"+ g TIInt1 Nothing = error "putRawBytes: Nothing is not convertible to TIInt1"+ g TIInt2 Nothing = error "putRawBytes: Nothing is not convertible to TIInt2"+ g TIInt4 Nothing = error "putRawBytes: Nothing is not convertible to TIInt4"+ g TIInt8 Nothing = error "putRawBytes: Nothing is not convertible to TIInt8"+ g TIMoney4 Nothing = error "putRawBytes: Nothing is not convertible to TIMoney4"+ g TIMoney8 Nothing = error "putRawBytes: Nothing is not convertible to TIMoney8"+ g TIDateTime4 Nothing = error "putRawBytes: Nothing is not convertible to TIDateTime4"+ g TIDateTime8 Nothing = error "putRawBytes: Nothing is not convertible to TIDateTime8"+ g TIFlt4 Nothing = error "putRawBytes: Nothing is not convertible to TIFlt4"+ g TIFlt8 Nothing = error "putRawBytes: Nothing is not convertible to TIFlt8"+ + g TIBit (Just bs) = Put.putByteString bs+ g TIInt1 (Just bs) = Put.putByteString bs+ g TIInt2 (Just bs) = Put.putByteString bs+ g TIInt4 (Just bs) = Put.putByteString bs+ g TIInt8 (Just bs) = Put.putByteString bs+ g TIMoney4 (Just bs) = Put.putByteString bs+ g TIMoney8 (Just bs) = Put.putByteString bs+ g TIDateTime4 (Just bs) = Put.putByteString bs+ g TIDateTime8 (Just bs) = Put.putByteString bs+ g TIFlt4 (Just bs) = Put.putByteString bs+ g TIFlt8 (Just bs) = Put.putByteString bs++ g TIBitN rb = put8n rb+ g TIIntN1 rb = put8n rb+ g TIIntN2 rb = put8n rb+ g TIIntN4 rb = put8n rb+ g TIIntN8 rb = put8n rb+ g TIMoneyN4 rb = put8n rb+ g TIMoneyN8 rb = put8n rb+ g TIDateTimeN4 rb = put8n rb+ g TIDateTimeN8 rb = put8n rb+ g TIFltN4 rb = put8n rb+ g TIFltN8 rb = put8n rb+ + g TIGUID rb = put8n rb++ g (TIDecimalN _ _) rb = put8n rb+ g (TINumericN _ _) rb = put8n rb++ g (TIChar _) rb = put8s rb+ g (TIVarChar _) rb = put8s rb+ g (TIBigChar _ _) rb = put16s rb+ g (TIBigVarChar _ _) rb = put16s rb+ g (TIText _ _) rb = put32s rb++ g (TINChar _ _) rb = put16s rb+ g (TINVarChar _ _) rb = put16s rb+ g (TINText _ _) rb = put32s rb++ g (TIBinary _) rb = put8s rb+ g (TIVarBinary _) rb = put8s rb+ g (TIBigBinary _) rb = put16s rb+ g (TIBigVarBinary _) rb = put16s rb+ g (TIImage _) rb = put32s rb++++ +validNull :: TypeInfo -> a -> a+validNull = f+ where+ f :: TypeInfo -> a -> a+ f TINull x = x+ f ti _ = error $ "validNull: " <> (show ti) <> " is not convertible from/to Null"++++validIntegral :: String -> TypeInfo -> a -> a+validIntegral ht ti x = f ti x+ where+ f :: TypeInfo -> a -> a+ f TIBit x = x+ f TIInt1 x = x+ f TIInt2 x = x+ f TIInt4 x = x+ f TIInt8 x = x+ f TIBitN x = x+ f TIIntN1 x = x+ f TIIntN2 x = x + f TIIntN4 x = x+ f TIIntN8 x = x+ f _ _ = error $ "validIntegral: " <> (show ti) <> " is not convertible from/to " <> ht++validBool = validIntegral "Bool"+validInt = validIntegral "Int"+validInteger = validIntegral "Integer"+validMaybeBool = validIntegral "(Maybe Bool)"+validMaybeInt = validIntegral "(Maybe Int)"+validMaybeInteger = validIntegral "(Maybe Integer)"++isIntegralN :: TypeInfo -> Bool+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+++getIntegral :: Integral a => TypeInfo -> Get a+getIntegral TIBit = fromIntegral <$> Get.getWord8+getIntegral TIInt1 = fromIntegral <$> Get.getInt8+getIntegral TIInt2 = fromIntegral <$> Get.getInt16le+getIntegral TIInt4 = fromIntegral <$> Get.getInt32le+getIntegral TIInt8 = fromIntegral <$> Get.getInt64le+getIntegral TIBitN = getIntegral TIBit+getIntegral TIIntN1 = getIntegral TIInt1+getIntegral TIIntN2 = getIntegral TIInt2+getIntegral TIIntN4 = getIntegral TIInt4+getIntegral TIIntN8 = getIntegral TIInt8+++putIntegral :: Integral a => TypeInfo -> a -> Put+putIntegral TIBit i = Put.putWord8 $ fromIntegral i+putIntegral TIInt1 i = Put.putInt8 $ fromIntegral i+putIntegral TIInt2 i = Put.putInt16le $ fromIntegral i+putIntegral TIInt4 i = Put.putInt32le $ fromIntegral i+putIntegral TIInt8 i = Put.putInt64le $ fromIntegral i+putIntegral TIBitN i = putIntegral TIBit i+putIntegral TIIntN1 i = putIntegral TIInt1 i+putIntegral TIIntN2 i = putIntegral TIInt2 i+putIntegral TIIntN4 i = putIntegral TIInt4 i+putIntegral TIIntN8 i = putIntegral TIInt8 i++++ +validMoney :: TypeInfo -> a -> a+validMoney = f+ where+ f :: TypeInfo -> a -> a+ f TIMoney4 x = x+ f TIMoney8 x = x+ f TIMoneyN4 x = x+ f TIMoneyN8 x = x+ f ti _ = error $ "validMoney: " <> (show ti) <> " is not convertible from/to Money"++isMoneyN :: TypeInfo -> Bool+isMoneyN = f+ where+ f :: TypeInfo -> Bool+ f TIMoney4 = False+ f TIMoney8 = False+ f TIMoneyN4 = True+ f TIMoneyN8 = True+ +getMoney :: TypeInfo -> Get Money+getMoney TIMoney4 = bytesToMoney4 <$> Get.getInt32le+getMoney TIMoney8 = bytesToMoney8 <$> Get.getInt32le <*> Get.getInt32le+getMoney TIMoneyN4 = getMoney TIMoney4+getMoney TIMoneyN8 = getMoney TIMoney8++putMoney :: TypeInfo -> Money -> Put+putMoney TIMoney4 f = Put.putInt32le $ moneyToBytes4 f+putMoney TIMoney8 f = do+ let (m,l) = moneyToBytes8 f+ Put.putInt32le m+ Put.putInt32le l+putMoney TIMoneyN4 f = putMoney TIMoney4 f+putMoney TIMoneyN8 f = putMoney TIMoney8 f+++ ++validUTCTime :: TypeInfo -> a -> a+validUTCTime = f+ where+ f :: TypeInfo -> a -> a+ f TIDateTime4 x = x+ f TIDateTime8 x = x+ f TIDateTimeN4 x = x+ f TIDateTimeN8 x = x+ f ti _ = error $ "validUTCTime: " <> (show ti) <> " is not convertible from/to UTCTime"++isUTCTimeN :: TypeInfo -> Bool+isUTCTimeN = f+ where+ f :: TypeInfo -> Bool+ f TIDateTime4 = False+ f TIDateTime8 = False+ f TIDateTimeN4 = True+ f TIDateTimeN8 = True+ +getUTCTime :: TypeInfo -> Get UTCTime+getUTCTime TIDateTime4 = bytesToUtc4 <$> Get.getWord16le <*> Get.getWord16le+getUTCTime TIDateTime8 = bytesToUtc8 <$> Get.getInt32le <*> Get.getWord32le+getUTCTime TIDateTimeN4 = getUTCTime TIDateTime4+getUTCTime TIDateTimeN8 = getUTCTime TIDateTime8++putUTCTime :: TypeInfo -> UTCTime -> Put+putUTCTime TIDateTime4 time = do+ let (wday,wmin) = utcToBytes4 time+ Put.putWord16le wday+ Put.putWord16le wmin+putUTCTime TIDateTime8 time = do+ let (iday,w3hsec) = utcToBytes8 time+ Put.putInt32le iday+ Put.putWord32le w3hsec+putUTCTime TIDateTimeN4 time = putUTCTime TIDateTime4 time+putUTCTime TIDateTimeN8 time = putUTCTime TIDateTime8 time+++++validFloat' :: String -> TypeInfo -> a -> a+validFloat' hn ti x = f ti x+ where+ f :: TypeInfo -> a -> a+ f TIFlt4 x = x+ f TIFlt8 x = x+ f TIFltN4 x = x+ f TIFltN8 x = x+ f ti _ = error $ "validFloat': " <> (show ti) <> " is not convertible from/to " <> hn++validFloat = validFloat' "Float"+validDouble = validFloat' "Double"+validMaybeFloat = validFloat' "(Maybe Float)"+validMaybeDouble = validFloat' "(Maybe Double)"++isFloatN :: TypeInfo -> Bool+isFloatN = f+ where+ f :: TypeInfo -> Bool+ f TIFlt4 = False+ f TIFlt8 = False+ f TIFltN4 = True+ f TIFltN8 = True+ +getFloat :: Fractional a => TypeInfo -> Get a+getFloat TIFlt4 = realToFrac . wordToFloat <$> Get.getWord32le+getFloat TIFlt8 = realToFrac . wordToDouble <$> Get.getWord64le+getFloat TIFltN4 = getFloat TIFlt4+getFloat TIFltN8 = getFloat TIFlt8++putFloat :: Real a => TypeInfo -> a -> Put+putFloat TIFlt4 f = Put.putWord32le $ floatToWord $ realToFrac f+putFloat TIFlt8 f = Put.putWord64le $ doubleToWord $ realToFrac f+putFloat TIFltN4 f = putFloat TIFlt4 f+putFloat TIFltN8 f = putFloat TIFlt8 f+++++validDecimal :: TypeInfo -> a -> a+validDecimal = f+ where+ f :: TypeInfo -> a -> a+ f (TIDecimalN _ _) x = x+ f (TINumericN _ _) x = x+ f ti _ = error $ "validDecimal: " <> (show ti) <> " is not convertible from/to Decimal"++-- https://msdn.microsoft.com/en-us/library/ee780893.aspx+-- [MEMO] sign byte + signed bytes+getDecimal :: Int -> Precision -> Scale -> Get Decimal+getDecimal len p s = + bytesToDecimal p s <$> Get.getWord8 <*> (Get.getByteString $ fromIntegral $ len -1)++putDecimal :: Decimal -> Put+putDecimal dec = do -- [TODO] test+ let (s,bs) = decimalToBytes dec+ Put.putWord8 s+ Put.putByteString bs+++++validUUID :: TypeInfo -> a -> a+validUUID = f+ where+ f :: TypeInfo -> a -> a+ f TIGUID x = x+ f ti _ = error $ "validUUID: " <> (show ti) <> " is not convertible from/to UUID"+++++validByteString :: TypeInfo -> a -> a+validByteString = f+ where+ f :: TypeInfo -> a -> a+ f (TIChar _) x = x+ f (TIVarChar _) x = x+ f (TIBigChar _ _) x = x+ f (TIBigVarChar _ _) x = x+ f (TIText _ _) x = x+ f (TIBinary _) x = x+ f (TIVarBinary _) x = x+ f (TIBigBinary _) x = x+ f (TIBigVarBinary _) x = x+ f (TIImage _) x = x+ f ti _ = error $ "validByteString: " <> (show ti) <> " is not convertible from/to ByteString"+ ++++validText :: TypeInfo -> a -> a+validText = f+ where+ f :: TypeInfo -> a -> a+ f (TINChar _ _) x = x+ f (TINVarChar _ _) x = x+ f (TINText _ _) x= x+ f ti _ = error $ "validText: " <> (show ti) <> " is not convertible from/to Text"+ ++++runGet :: Get a -> B.ByteString -> a+runGet f bs = Get.runGet f $ LB.fromStrict bs++runPut :: Put -> B.ByteString+runPut f = LB.toStrict $ Put.runPut f+++runGetBool :: TypeInfo -> B.ByteString -> Bool+runGetBool ti bs = (/=0) $ runGet (getIntegral ti) bs++runPutBool :: TypeInfo -> Bool -> B.ByteString+runPutBool ti b = runPut $ putIntegral ti $ if b then 1 else 0++++-- [TODO] check nullable flag++class Data a where+ fromRawBytes :: TypeInfo -> RawBytes -> a+ toRawBytes :: TypeInfo -> a -> RawBytes+++instance Data Null where+ fromRawBytes ti rb = validNull ti $ f rb+ where+ f Nothing = Null+ f _ = error "Null.fromRawBytes: non-Null value is not convertible to Null"+ toRawBytes ti _ = validNull ti $ Nothing++instance Data Bool where+ fromRawBytes ti (Just bs) = validBool ti $ runGetBool ti bs+ fromRawBytes ti Nothing = validBool ti $ error "Bool.fromRawBytes: Null value is not convertible to Bool"+ toRawBytes ti b = validBool ti $ Just $ runPutBool ti b++instance Data Int where+ fromRawBytes ti (Just bs) = validInt ti $ runGet (getIntegral ti) bs+ fromRawBytes ti Nothing = validInt ti $ error "Int.fromRawBytes: Null value is not convertible to Int"+ toRawBytes ti i = validInt ti $ Just $ runPut $ putIntegral ti i++instance Data Integer where+ fromRawBytes ti (Just bs) = validInteger ti $ runGet (getIntegral ti) bs+ fromRawBytes ti Nothing = validInteger ti $ error "Integer.fromRawBytes: Null value is not convertible to Integer"+ toRawBytes ti i = validInteger ti $ Just $ runPut $ putIntegral ti i++instance Data Money where+ fromRawBytes ti (Just bs) = validMoney ti $ runGet (getMoney ti) bs+ fromRawBytes ti Nothing = validMoney ti $ error "Money.fromRawBytes: Null value is not convertible to Money"+ toRawBytes ti m = validMoney ti $ Just $ runPut $ putMoney ti m+ +instance Data UTCTime where+ fromRawBytes ti (Just bs) = validUTCTime ti $ runGet (getUTCTime ti) bs+ fromRawBytes ti Nothing = validUTCTime ti $ error "UTCTime.fromRawBytes: Null value is not convertible to UTCTime"+ toRawBytes ti dt = validUTCTime ti $ Just $ runPut $ putUTCTime ti dt++instance Data Float where+ fromRawBytes ti (Just bs) = validFloat ti $ runGet (getFloat ti) bs+ fromRawBytes ti Nothing = validFloat ti $ error "Float.fromRawBytes: Null value is not convertible to Float"+ toRawBytes ti f = validFloat ti $ Just $ runPut $ putFloat ti f++instance Data Double where+ fromRawBytes ti (Just bs) = validDouble ti $ runGet (getFloat ti) bs+ fromRawBytes ti Nothing = validDouble ti $ error "Double.fromRawBytes: Null value is not convertible to Double"+ toRawBytes ti f = validDouble ti $ Just $ runPut $ putFloat ti f++instance Data Decimal where+ fromRawBytes ti (Just bs) = validDecimal ti $+ let (p,s) = ps ti+ in runGet (getDecimal (B.length bs) p s) bs+ where+ ps :: TypeInfo -> (Precision,Scale)+ ps (TIDecimalN p s) = (p,s)+ ps (TINumericN p s) = (p,s)+ fromRawBytes ti Nothing = validDecimal ti $ error "Decimal.fromRawBytes: Null value is not convertible to Decimal"+ toRawBytes ti dec = validDecimal ti $ Just $ runPut $ putDecimal dec+ +instance Data UUID where+ fromRawBytes ti (Just bs) = validUUID ti $ case UUID.fromByteString $ LB.fromStrict bs of+ Nothing -> error "UUID.fromRawBytes: UUID.fromBtyteString error"+ Just (uuid) -> uuid+ fromRawBytes ti Nothing = validUUID ti $ error "UUID.fromRawBytes: Null value is not convertible to UUID"+ toRawBytes ti uuid = validUUID ti $ Just $ LB.toStrict $ UUID.toByteString uuid++instance Data B.ByteString where+ fromRawBytes ti (Just bs) = validByteString ti $ bs+ fromRawBytes ti Nothing = validByteString ti $ error "ByteString.fromRawBytes: Null value is not convertible to ByteString"+ toRawBytes ti bs = validByteString ti $ Just $ bs++instance Data T.Text where+ fromRawBytes ti (Just bs) = validText ti $ T.decodeUtf16LE bs+ fromRawBytes ti Nothing = validText ti $ error "Text.fromRawBytes: Null value is not convertible to Text"+ toRawBytes ti t = validText ti $ Just $ T.encodeUtf16LE t++++instance Data (Maybe Bool) where+ fromRawBytes ti rb = validMaybeBool ti $ runGetBool ti <$> rb+ toRawBytes ti b = validMaybeBool ti $+ case b of+ Nothing | (not . isIntegralN) ti -> error $ "(Maybe Bool).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPutBool ti <$> b++instance Data (Maybe Int) where+ fromRawBytes ti rb = validMaybeInt ti $ (runGet (getIntegral ti)) <$> rb+ toRawBytes ti i = validMaybeInt ti $+ case i of+ Nothing | (not . isIntegralN) ti -> error $ "(Maybe Int).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putIntegral ti) <$> i++instance Data (Maybe Integer) where+ fromRawBytes ti rb = validMaybeInteger ti $ (runGet (getIntegral ti)) <$> rb+ toRawBytes ti i = validMaybeInteger ti $+ case i of+ Nothing | (not . isIntegralN) ti -> error $ "(Maybe Integer).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putIntegral ti) <$> i++instance Data (Maybe Money) where+ fromRawBytes ti rb = validMoney ti $ (runGet (getMoney ti)) <$> rb+ toRawBytes ti m = validMoney ti $+ case m of+ Nothing | (not . isMoneyN) ti -> error $ "(Maybe Money).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putMoney ti) <$> m++instance Data (Maybe UTCTime) where+ fromRawBytes ti rb = validUTCTime ti $ (runGet (getUTCTime ti)) <$> rb+ toRawBytes ti dt = validUTCTime ti $+ case dt of+ Nothing | (not . isUTCTimeN) ti -> error $ "(Maybe UTCTime).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putUTCTime ti) <$> dt++instance Data (Maybe Float) where+ fromRawBytes ti rb = validMaybeFloat ti $ (runGet (getFloat ti)) <$> rb+ toRawBytes ti f = validMaybeFloat ti $+ case f of+ Nothing | (not . isFloatN) ti -> error $ "(Maybe Float).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putFloat ti) <$> f++instance Data (Maybe Double) where+ fromRawBytes ti rb = validMaybeDouble ti $ (runGet (getFloat ti)) <$> rb+ toRawBytes ti f = validMaybeDouble ti $+ case f of+ Nothing | (not . isFloatN) ti -> error $ "(Maybe Double).toRawBytes: Nothing is not convertible to " <> (show ti)+ _ -> runPut . (putFloat ti) <$> f++instance Data (Maybe Decimal) where+ fromRawBytes ti rb = validDecimal ti $+ let (p,s) = ps ti+ in (\bs -> runGet (getDecimal (B.length bs) p s) bs) <$> rb+ where+ ps :: TypeInfo -> (Precision,Scale)+ ps (TIDecimalN p s) = (p,s)+ ps (TINumericN p s) = (p,s)+ toRawBytes ti dec = validDecimal ti $ runPut . putDecimal <$> dec++instance Data (Maybe UUID) where+ fromRawBytes ti rb = validUUID ti $ f <$> rb+ where+ f :: B.ByteString -> UUID+ f bs = case UUID.fromByteString $ LB.fromStrict bs of+ Nothing -> error "(Maybe UUID).fromRawBytes: UUID.fromBtyteString error"+ Just (uuid) -> uuid+ toRawBytes ti m = validUUID ti $ (LB.toStrict . UUID.toByteString) <$> m++instance Data (Maybe B.ByteString) where+ fromRawBytes ti rb = validByteString ti $ rb+ toRawBytes ti bs = validByteString ti $ bs+ +instance Data (Maybe T.Text) where+ fromRawBytes ti rb = validText ti $ T.decodeUtf16LE <$> rb + toRawBytes ti t = validText ti $ T.encodeUtf16LE <$> t++
+ src/Database/Tds/Message/Header.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS_HADDOCK hide #-}+-- Packet Header: https://msdn.microsoft.com/en-us/library/dd340948.aspx++module Database.Tds.Message.Header ( Header (..)+ ) where++import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))+import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))++import Data.Binary (Put(..),Get(..),Binary(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get+++type Type = Word8+type Status = Word8+type Length = Int+type SPID = Word16+type PacketID = Word8+type Window = Word8++data Header = Header !Type !Status !Length !SPID !PacketID !Window+++-- https://msdn.microsoft.com/en-us/library/dd340948.aspx+putHeader :: Header -> Put+putHeader (Header pt st len spid pcid win) = do+ Put.putWord8 pt -- packet type+ Put.putWord8 st -- packet status -- [TODO] flags+ Put.putWord16be $ fromIntegral $ len -- packet len+ Put.putWord16be spid -- SPID+ Put.putWord8 pcid -- PacketID+ Put.putWord8 win -- Window++-- https://msdn.microsoft.com/en-us/library/dd340948.aspx+getHeader :: Get Header+getHeader = do+ pt <- Get.getWord8 -- packet type+ st <- Get.getWord8 -- packet status -- [TODO] flags+ len <- Get.getWord16be -- packet len+ spid <- Get.getWord16be -- SPID+ pcid <- Get.getWord8 -- PacketIK+ win <- Get.getWord8 -- Window+ return $ Header pt st (fromIntegral len) spid pcid win+++instance Binary Header where+ put = putHeader+ get = getHeader
+ src/Database/Tds/Message/Prelogin.hs view
@@ -0,0 +1,201 @@+{-# OPTIONS_HADDOCK hide #-}+-- PRELOGIN: https://msdn.microsoft.com/en-us/library/dd357559.aspx++module Database.Tds.Message.Prelogin ( Prelogin (..)+ , PreloginOption (..)+ , MajorVer (..)+ , MinorVer (..)+ , BuildVer (..)+ , SubBuildVer (..)+ , Threadid (..)+ , Connid (..)+ , Activity (..)+ , Sequence (..)+ , Nonce (..)+ ) where++import Data.Monoid((<>))++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))+import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))++import Data.Binary (Put(..),Get(..),Binary(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get++import Control.Monad (forM_,foldM_)+import Data.Foldable (maximumBy)+++++type MajorVer = Word8+type MinorVer = Word8+type BuildVer = Word16+type SubBuildVer = Word16+type Threadid = Word32+type Connid = B.ByteString -- 16byte GUID+type Activity = B.ByteString -- 16byte GUID+type Sequence = Word32+type Nonce = B.ByteString -- 32byte NONCE+++data PreloginOption = PLOVersion !MajorVer !MinorVer !BuildVer !SubBuildVer+ | PLOEncription !Word8 -- [TODO] flags+ | PLOInstopt !B.ByteString+ | PLOThreadid !(Maybe Threadid)+ | PLOMars !Word8 -- MARS(Multiple Active Result Sets) supprt -- [TODO] flags+ | PLOTraceid !Connid !Activity !Sequence+ | PLOFedAuthRequired !Word8+ | PLONonceOpt !Nonce+ deriving (Show)++newtype Prelogin = Prelogin [PreloginOption]+ deriving (Show)+++preloginOptionsIndexOffset :: [a] -> Int+preloginOptionsIndexOffset ops = (5 * length ops) + 1++preloginOptionPayloadLength :: PreloginOption -> Int+preloginOptionPayloadLength = f+ where+ f (PLOVersion _ _ _ _) = 1 + 1 + 4+ f (PLOEncription _) = 1+ f (PLOInstopt io) = B.length io + 1+ f (PLOThreadid _) = 4+ f (PLOMars _) = 1+ f (PLOTraceid _ _ _) = 16 + 16 + 4 -- [TODO] Test+ f (PLOFedAuthRequired _) = 1 -- [TODO] Test+ f (PLONonceOpt _) = 32 -- [TODO] Test++-- https://msdn.microsoft.com/en-us/library/dd357559.aspx+putPrelogin :: Prelogin -> Put+putPrelogin (Prelogin ops) = do+ foldM_ putIndex (preloginOptionsIndexOffset ops) ops+ Put.putWord8 0xff -- terminate+ forM_ ops putOpt+ where+ putIndex :: Int -> PreloginOption -> Put.PutM Int+ putIndex offs op = do+ let+ ot = case op of+ PLOVersion _ _ _ _ -> 0x00+ PLOEncription _ -> 0x01+ PLOInstopt _ -> 0x02+ PLOThreadid _ -> 0x03+ PLOMars _ -> 0x04+ PLOTraceid _ _ _ -> 0x05 -- [TODO] Test+ PLOFedAuthRequired _ -> 0x06 -- [TODO] Test+ PLONonceOpt _ -> 0x07 -- [TODO] Test+ len = preloginOptionPayloadLength op+ Put.putWord8 ot+ Put.putWord16be $ fromIntegral offs+ Put.putWord16be $ fromIntegral len+ return $ offs+len+ + putOpt :: PreloginOption -> Put+ putOpt (PLOVersion ma mi b sb) = do+ Put.putWord8 ma+ Put.putWord8 mi+ Put.putWord16be b+ Put.putWord16be sb+ + putOpt (PLOEncription enc) = Put.putWord8 enc+ + putOpt (PLOInstopt io) = do+ Put.putByteString io+ Put.putWord8 0+ + putOpt (PLOThreadid Nothing) = return ()+ putOpt (PLOThreadid (Just tid)) = Put.putWord32le tid+ + putOpt (PLOMars mars) = Put.putWord8 mars++ -- [TODO] Test+ putOpt (PLOTraceid ci ac se) = do+ Put.putByteString ci+ Put.putByteString ac+ Put.putWord32le se+ + -- [TODO] Test+ putOpt (PLOFedAuthRequired b) = Put.putWord8 b++ -- [TODO] Test+ putOpt (PLONonceOpt opt) = Put.putByteString opt++++-- https://msdn.microsoft.com/en-us/library/dd340710.aspx+getPrelogin :: Get Prelogin+getPrelogin = do+ idcs <- getIndices+ -- [MEMO] calc totallen from max offset+ let (_,maxoffs,maxoffslen) = maximumBy (\(_,offs1,_) (_,offs2,_) -> compare offs1 offs2) idcs+ let totalLen = maxoffs + maxoffslen+ let offs0 = preloginOptionsIndexOffset idcs+ payl <- Get.getLazyByteString $ fromIntegral $ (fromIntegral totalLen) - offs0++ return $ Prelogin $ flip fmap idcs $ \(ot,offs,len) ->+ Get.runGet (getOpt ot len) $ LB.drop (fromIntegral $ offs - offs0) payl+ + where+ getIndices :: Get [(Word8,Int,Int)]+ getIndices = do+ ot <- Get.getWord8+ if ot == 0xff+ then return []+ else do index <- getIndex ot+ indices <- getIndices+ return $ index:indices+ where+ getIndex :: Word8 -> Get (Word8,Int,Int)+ getIndex ot = do+ offs <- fromIntegral <$> Get.getWord16be -- offset+ len <- fromIntegral <$> Get.getWord16be -- len+ return (ot,offs,len)+ + + + getOpt :: Word8 -> Int -> Get PreloginOption+ + getOpt 0x00 _ = PLOVersion <$> Get.getWord8+ <*> Get.getWord8+ <*> Get.getWord16be+ <*> Get.getWord16be+ + getOpt 0x01 _ = PLOEncription <$> Get.getWord8+ + getOpt 0x02 len = -- [MEMO] null terminated string+ if len == 1+ then return $ PLOInstopt mempty+ else do bs <- Get.getByteString $ len -1+ return $ PLOInstopt bs+ + getOpt 0x03 len = do+ if len == 0+ then return $ PLOThreadid Nothing+ else PLOThreadid . Just <$> Get.getWord32le++ getOpt 0x04 _ = PLOMars <$> Get.getWord8+ + -- [TODO] Test+ getOpt 0x05 _ = PLOTraceid <$> Get.getByteString 16+ <*> Get.getByteString 16+ <*> Get.getWord32le++ -- [TODO] Test+ getOpt 0x06 _ = PLOFedAuthRequired <$> Get.getWord8+ + -- [TODO] Test+ getOpt 0x07 _ = PLONonceOpt <$> Get.getByteString 32+ +++instance Binary Prelogin where+ put = putPrelogin+ get = getPrelogin+
+ src/Database/Tds/Message/Server.hs view
@@ -0,0 +1,561 @@+{-# OPTIONS_HADDOCK hide #-}+-- Stream Types: https://msdn.microsoft.com/en-us/library/dd303435.aspx+-- Data Types: https://msdn.microsoft.com/en-us/library/dd305325.aspx+-- Data Stream: https://msdn.microsoft.com/en-us/library/dd340794.aspx+-- Server Messages: https://msdn.microsoft.com/en-us/library/dd357167.aspx+++module Database.Tds.Message.Server ( TokenStreams (..)+ , TokenStream (..)+ + , AltMetaData (..)+ + , ColProperty (..)+ , CPColNum (..)+ , CPTableNum (..)+ , CPStatus (..)+ , CPColName (..)++ , ColMetaData (..)+ , MetaColumnData (..)+ , MCDUserType (..)+ , MCDFlags (..)+ , MCDTableName (..)+ , MCDColName (..)++ , Done (..)+ , DoneStatus (..)+ , DoneCurCmd (..)+ , DoneRowCount (..)++ , ECType (..)+ , ECNewValue (..)+ , ECOldValue (..)++ , Info (..)+ , InfoNumber (..)+ , InfoState (..)+ , InfoClass (..)+ , InfoMsgText (..)+ , InfoServerName (..)+ , InfoProcName (..)+ , InfoLineNumber (..)++ , LAInterface (..)+ , LATdsVersion (..)+ , LAProgName (..)+ , LAProgVersion (..)+ + , Offset (..)+ , OffsetIdentifier (..)+ , OffsetLength (..)+ + , ReturnValue (..)+ , RVParamOrdinal (..)+ , RVParamName (..)+ , RVStatus (..)+ , RVUserType (..)+ , RVFlags (..)+ + , RowColumnData (..)+ , TextPointer (..)+ , TimeStamp (..)++ ) where++import Data.Monoid((<>))++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))+import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))++import Data.Binary (Put(..),Get(..),Binary(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get++import Data.Bits ((.&.),(.|.),xor,shift)++import Control.Monad.State (StateT(..),evalStateT,put,get,modify)+import Control.Monad.Trans (lift)++import Database.Tds.Message.Prelogin+import Database.Tds.Message.DataStream++++type MCDUserType = Word16+type MCDFlags = Word16+type MCDTableName = T.Text+type MCDColName = T.Text++data MetaColumnData = MetaColumnData !MCDUserType !MCDFlags !TypeInfo !(Maybe MCDTableName) !MCDColName+ deriving (Show)+++type RVParamOrdinal = Word16+type RVParamName = T.Text+type RVStatus = Word8+type RVUserType = Word16 -- [MEMO] TDS 7.2 -> Word32+type RVFlags = Word16++data ReturnValue = ReturnValue !RVParamOrdinal !RVParamName !RVStatus !RVUserType !RVFlags !TypeInfo !RawBytes+ deriving (Show)+++-- [MEMO] not newtype for (TDS 7.4 CekTable)+data ColMetaData = ColMetaData ![MetaColumnData]+ deriving (Show)+++data AltMetaData = AltMetaData+ deriving (Show)+++type OffsetIdentifier = Word16+type OffsetLength = Word16++data Offset = Offset !OffsetIdentifier !OffsetLength+ deriving (Show)+++data MetaData = MetaData !(Maybe ColMetaData) !(Maybe AltMetaData) !(Maybe Offset)+ deriving (Show)++++type TextPointer = B.ByteString+type TimeStamp = Word64++data RowColumnData = RCDOrdinal !RawBytes+ | RCDLarge !(Maybe TextPointer) !(Maybe TimeStamp) !RawBytes+ deriving (Show)+++-- COLMETADATA_TOKEN, ALTMETDATA_TOKEN, OFFSET_TOKEN++type CPColNum = Word8+type CPTableNum = Word8+type CPStatus = Word8+type CPColName = T.Text+data ColProperty = ColProperty !CPColNum !CPTableNum !CPStatus !(Maybe CPColName)+ deriving (Show)++type DoneStatus = Word16+type DoneCurCmd = Word16+type DoneRowCount = Word32 -- Word64 -- TDS 7.2+data Done = Done !DoneStatus !DoneCurCmd !DoneRowCount+ deriving (Show)++type ECType = Word8 -- [TODO] To be detailed+type ECNewValue = B.ByteString+type ECOldValue = B.ByteString++type InfoNumber = Int32+type InfoState = Word8+type InfoClass = Word8+type InfoMsgText = T.Text+type InfoServerName = T.Text+type InfoProcName = T.Text+type InfoLineNumber = Word16 -- Word32 -- TDS 7.2+data Info = Info !InfoNumber !InfoState !InfoClass !InfoMsgText !InfoServerName !InfoProcName !InfoLineNumber+ deriving (Show)++type LAInterface = Word8+type LATdsVersion = Word32+type LAProgName = T.Text+type LAProgVersion = Word32 -- [TODO] split bytes++data TokenStream = TSAltMetaData !AltMetaData++ | TSAltRow+ + | TSColInfo ![ColProperty]+ + | TSColMetaData !(Maybe ColMetaData)++ | TSDone !Done++ | TSDoneInProc !Done++ | TSDoneProc !Done++ | TSEnvChange !ECType !ECNewValue !ECOldValue++ | TSError !Info++ | TSInfo !Info++ | TSLoginAck !LAInterface !LATdsVersion !LAProgName !LAProgVersion++ | TSOffset !Offset+ + | TSOrder ![Word16]+ + | TSReturnStatus !Int32+ + | TSReturnValue !ReturnValue+ + | TSRow ![RowColumnData]+ + | TSSSPI !B.ByteString+ + | TSTabName + + | TSOther !Word8+ + deriving (Show)+++getTokenStreamS :: StateT MetaData Get TokenStream+getTokenStreamS = do+ pt <- lift Get.getWord8+ case pt of+ 0x88 -> lift getAltMetaData -- [TODO] State Monad+ 0xd3 -> lift getAltRow -- [TODO] State Monad+ 0xa5 -> lift getColInfo+ 0x81 -> getColMetaDataS+ 0xfd -> lift getDone+ 0xff -> lift getDoneInProc+ 0xfe -> lift getDoneProc+ 0xe3 -> lift getEnvChange+ 0xaa -> lift getError+ 0xab -> lift getInfo+ 0xad -> lift getLoginAck+ 0x78 -> getOffsetS+ 0xa9 -> lift getOrder+ 0x79 -> lift getReturnStatus+ 0xac -> lift getReturnValue+ 0xd1 -> getRowS+ 0xed -> lift getSSPI+ 0xa4 -> lift getTabName+ _ -> lift $ getOther pt+ where++ getAltMetaData :: Get TokenStream -- [TODO] implementation, SQL statement that generates totals+ getAltMetaData = return $ TSAltMetaData AltMetaData+ + getAltRow :: Get TokenStream -- [TODO] implementation, SQL statement that generates totals+ getAltRow = return TSAltRow+ + getColInfo :: Get TokenStream -- [TODO] test, sp_cursoropen, and sp_cursorfetch+ getColInfo = do+ len <- fromIntegral <$> Get.getWord16le+ bs <- Get.getLazyByteString len+ return $ TSColInfo $ Get.runGet (getColProperties len) bs+ where+ getColProperties :: Int64 -> Get [ColProperty]+ getColProperties len = f+ where+ f :: Get [ColProperty]+ f = do+ br <- Get.bytesRead+ if br >= len+ then return []+ else do x <- getColProperty+ xs <- f+ return $ x:xs+ + getColProperty :: Get ColProperty+ getColProperty = do+ colNum <- Get.getWord8+ tableNum <- Get.getWord8+ status <- Get.getWord8+ colName <- if (status .&. 0x20 /= 0x00) -- [MEMO] DIFFERENT_NAME+ then Just <$> getText8+ else return Nothing+ return $ ColProperty colNum tableNum status colName+ + + getColMetaDataS :: StateT MetaData Get TokenStream+ getColMetaDataS = do+ cols <- lift Get.getWord16le+ if cols == 0xffff+ then return $ TSColMetaData Nothing+ else do cmd <- lift $ Just . ColMetaData <$> getColumnDatas (fromIntegral cols) 0+ modify $ \(MetaData _ mamd mofs) -> (MetaData cmd mamd mofs)+ return $ TSColMetaData cmd+ where+ getColumnDatas :: Int -> Int -> Get [MetaColumnData]+ getColumnDatas max cnt =+ if cnt >= max+ then return []+ else do x <- getColumnData+ xs <- getColumnDatas max (cnt+1)+ return $ x:xs+ + getColumnData :: Get MetaColumnData+ getColumnData = do+ userType <- Get.getWord16le+ flags <- Get.getWord16le+ typeInfo <- Data.Binary.get+ maybeTableName <- case typeInfo of+ TIText{} -> Just <$> getText16+ TINText{} -> Just <$> getText16+ TIImage{} -> Just <$> getText16+ _ -> return Nothing+ col <- getText8+ + return $ MetaColumnData userType flags typeInfo maybeTableName col++++ getDone :: Get TokenStream+ getDone = do+ status <- Get.getWord16le+ curCmd <- Get.getWord16le+-- doneRowCount <- Get.getWord64le+ doneRowCount <- Get.getWord32le -- [MEMO] lte TDS 7.1 Int32+ return $ TSDone $ Done status curCmd doneRowCount+ + getDoneInProc :: Get TokenStream+ getDoneInProc = do+ status <- Get.getWord16le+ curCmd <- Get.getWord16le+-- doneRowCount <- Get.getWord64le+ doneRowCount <- Get.getWord32le -- [TODO] lte TDS 7.1 Int32+ return $ TSDoneInProc $ Done status curCmd doneRowCount+ + getDoneProc :: Get TokenStream+ getDoneProc = do+ status <- Get.getWord16le+ curCmd <- Get.getWord16le+-- doneRowCount <- Get.getWord64le+ doneRowCount <- Get.getWord32le -- [TODO] lte 7.1 Int32+ return $ TSDoneProc $ Done status curCmd doneRowCount+ ++ getEnvChange :: Get TokenStream+ getEnvChange = do+ slen <- Get.getWord16le+ envCode <- Get.getWord8+ -- [TODO] split Type implementation+ (old,new) <- case envCode of+ 0x07 -> do -- [TODO] collation+ oldLen <- Get.getWord8+ old <- getByteString oldLen+ newLen <- Get.getWord8+ new <- getByteString newLen+ return (old,new)+ _ -> do+ oldLen <- Get.getWord8+ old <- getByteString $ oldLen * 2+ newLen <- Get.getWord8+ new <- getByteString $ newLen * 2+ return (old,new)+ return $ TSEnvChange envCode old new+++ + getError :: Get TokenStream+ getError = do+ slen <- Get.getWord16le+ number <- Get.getInt32le+ state <- Get.getWord8+ mclass <- Get.getWord8+ message <- getText16+ server <- getText8+ process <- getText8++-- line <- Get.getWord32le -- TDS 7.2+ line <- Get.getWord16le+ + return $ TSError $ Info number state mclass message server process line+++ getInfo :: Get TokenStream+ getInfo = do+ slen <- Get.getWord16le+ number <- Get.getInt32le+ state <- Get.getWord8+ mclass <- Get.getWord8+ message <- getText16+ server <- getText8+ process <- getText8++-- line <- Get.getWord32le -- TDS 7.2+ line <- Get.getWord16le+ + return $ TSInfo $ Info number state mclass message server process line+++ getLoginAck :: Get TokenStream+ getLoginAck = do+ slen <- Get.getWord16le+ interface <- Get.getWord8+ tdsVer <- Get.getWord32be+ serverLen <- Get.getWord8+ bserver <- getByteString $ serverLen * 2+ let+ bserver' = B.take (B.length bserver -4) bserver+ server = T.decodeUtf16LE bserver'+ servVer <- Get.getWord32be+ return $ TSLoginAck interface tdsVer server servVer+++ getOffsetS :: StateT MetaData Get TokenStream -- [TODO] test+ getOffsetS = do+ ofs <- lift $ Offset <$> Get.getWord16le <*> Get.getWord16le+ modify $ \(MetaData mcmd mamd _) -> (MetaData mcmd mamd (Just ofs))+ return $ TSOffset ofs++ getOrder :: Get TokenStream+ getOrder = do+ len <- Get.getWord16le+ nums <- mapM (\_ -> Get.getWord16le) [1..(div len 2)]+ return $ TSOrder nums++ getReturnStatus :: Get TokenStream+ getReturnStatus = do+ val <- Get.getInt32le -- Value+ return $ TSReturnStatus val++ getReturnValue :: Get TokenStream -- [TODO] test+ getReturnValue = do+ po <- Get.getWord16le+ pn <- getText8+ st <- Get.getWord8+ ut <- Get.getWord16le+ fl <- Get.getWord16le+ ti <- Data.Binary.get+ vl <- getRawBytes ti+ return $ TSReturnValue $ ReturnValue po pn st ut fl ti vl+++ getRowS :: StateT MetaData Get TokenStream+ getRowS = do+ -- [TODO] error check+ Just (ColMetaData colDatas) <- (\(MetaData mcmd mamd mofs) -> mcmd) <$> Control.Monad.State.get+ datas <- lift $ mapM (getColumnData . (\(MetaColumnData _ _ ti _ _) -> ti)) colDatas+ return $ TSRow datas+ where+ getColumnData :: TypeInfo -> Get RowColumnData+ getColumnData ti = do+ case ti of+ TIText{} -> getCDLarge ti+ TINText{} -> getCDLarge ti+ TIImage{} -> getCDLarge ti+ _ -> RCDOrdinal <$> getRawBytes ti++ -- [TODO] test when text,ntext,image is Null+ getCDLarge :: TypeInfo -> Get RowColumnData+ getCDLarge ti = do+ len <- Get.getWord8+ if len == 0+ then do+ -- [TODO] should read 32bit ?+ case ti of+ TIText{} -> return $ RCDLarge Nothing Nothing Nothing+ TINText{} -> return $ RCDLarge Nothing Nothing Nothing+ TIImage{} -> return $ RCDLarge Nothing Nothing Nothing+ else do tp <- getByteString len+ ts <- Get.getWord64le+ dt <- getRawBytes ti+ return $ RCDLarge (Just tp) (Just ts) dt+++ getSSPI :: Get TokenStream -- [TODO] test+ getSSPI = do+ len <- Get.getWord16le+ bs <- getByteString len+ return $ TSSSPI bs+ + getTabName :: Get TokenStream -- [TODO] test, sp_cursoropen+ getTabName = return $ TSTabName++ + + getOther :: Word8 -> Get TokenStream+ getOther pt = do+ case pt of+ 0xae -> do+ -- FEATUREEXTACK+ -- [MEMO] introduced in TDS 7.4+ return $ TSOther pt+ 0xee -> do+ -- FEDAUTHINFO+ -- [MEMO] introduced in TDS 7.4+ return $ TSOther pt+ 0xd2 -> do+ -- NBCROW+ -- [MEMO] introduced in TDS 7.3.B+ return $ TSOther pt+ 0xe4 -> do+ -- SESSIONSTATE+ -- [MEMO] introduced in TDS 7.4+ return $ TSOther pt+ 0x01 -> do+ -- TVP ROW+ -- https://msdn.microsoft.com/en-us/library/dd304813.aspx+ -- [MEMO] not here ?+ -- [MEMO] introduced in TDS 7.3 ?+ return $ TSOther pt+ _ -> fail "getTokenStreamS.getOther: invalid packet type"+++ ++++getTokenStreamsS :: StateT MetaData Get [TokenStream]+getTokenStreamsS = f+ where+ f :: StateT MetaData Get [TokenStream]+ f = do+ x <- getTokenStreamS+ if final x+ then return $ x : []+ else do xs <- f+ return $ x : xs++ final :: TokenStream -> Bool+ final (TSDone (Done st _ _)) = not $ containsMoreBit st+ final (TSDoneInProc (Done st _ _)) = not $ containsMoreBit st+ final (TSDoneProc (Done st _ _)) = not $ containsMoreBit st+ final _ = False++ containsMoreBit :: Word16 -> Bool+ containsMoreBit st = st .&. 0x01 == 0x01 -- [MEMO] 0x1 more bit++++-- [MEMO] Lazyness?+newtype TokenStreams = TokenStreams [TokenStream]+ deriving (Show)++++getTokenStreams :: Get TokenStreams+getTokenStreams = do+ rs <- (evalStateT getTokenStreamsS) (MetaData Nothing Nothing Nothing)+ return $ TokenStreams rs+++putTokenStreams :: TokenStreams -> Put+putTokenStreams = undefined -- [TODO] implement put function++++instance Binary TokenStreams where+ put = putTokenStreams+ get = getTokenStreams+++++getByteString :: Integral a => a -> Get B.ByteString+getByteString len = Get.getByteString $ fromIntegral len++getText :: Integral a => a -> Get T.Text+getText len = T.decodeUtf16LE <$> getByteString len++getText8 :: Get T.Text+getText8 = Get.getWord8 >>= \len -> getText $ len * 2++getText16 :: Get T.Text+getText16 = Get.getWord16le >>= \len -> getText $ len * 2+
+ src/Database/Tds/Primitives/Collation.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_HADDOCK hide #-}+-- https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/3d29e8dc-218a-42c6-9ba4-947ebca9fd7e++module Database.Tds.Primitives.Collation ( Collation32 (..)+ , SortId (..)+ , Collation (..)+ , getCollation+ , putCollation+ ) where++import Data.Word (Word8(..),Word32(..))++import Data.Binary (Put(..),Get(..))+import qualified Data.Binary.Put as Put+import qualified Data.Binary.Get as Get+++type Collation32 = Word32+type SortId = Word8++data Collation = Collation !Collation32 !SortId+ deriving (Show)+++getCollation :: Get Collation+getCollation = do+ coll <- Get.getWord32be+ sort <- Get.getWord8+ return $ Collation coll sort++putCollation :: Collation -> Put+putCollation (Collation coll sort) = do+ Put.putWord32be coll+ Put.putWord8 sort+
+ src/Database/Tds/Primitives/DateTime.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_HADDOCK hide #-}+-- https://msdn.microsoft.com/en-us/library/ee780895.aspx++module Database.Tds.Primitives.DateTime ( bytesToUtc4+ , bytesToUtc8+ , utcToBytes4+ , utcToBytes8+ ) where+++import Data.Word (Word16(..),Word32(..))+import Data.Int (Int32(..))++import Data.Time (UTCTime(..))+import Data.Time.Calendar (addDays,diffDays,fromGregorian)++bytesToUtc4 :: Word16 -> Word16 -> UTCTime+bytesToUtc4 wday wmin =+ -- date: the number of days since January 1, 1900.+ -- time: the number of minutes elapsed since 12 AM that day.+ let+ date = addDays (fromIntegral wday) (fromGregorian 1900 1 1)+ time = (fromIntegral wmin) * 60+ in UTCTime date time++bytesToUtc8 :: Int32 -> Word32 -> UTCTime+bytesToUtc8 iday w3hsec =+ -- date: the number of days since January 1, 1900.+ -- time: the number of one three-hundredths of a second (300 counts per second) elapsed since 12 AM that day.+ let+ date = addDays (fromIntegral iday) (fromGregorian 1900 1 1)+ time = (fromIntegral w3hsec) / 300+ in UTCTime date time+++utcToBytes4 :: UTCTime -> (Word16,Word16)+utcToBytes4 (UTCTime date time) =+ let+ wday = fromIntegral $ diffDays (fromGregorian 1900 1 1) date+ wmin = truncate $ time / 60+ in (wday,wmin)++utcToBytes8 :: UTCTime -> (Int32,Word32)+utcToBytes8 (UTCTime date time) =+ let+ iday = fromIntegral $ diffDays (fromGregorian 1900 1 1) date+ w3hsec = truncate $ time * 300+ in (iday,w3hsec)++
+ src/Database/Tds/Primitives/Decimal.hs view
@@ -0,0 +1,202 @@+{-# OPTIONS_HADDOCK hide #-}+-- https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/5e02042c-a741-4b5a-b91d-af5e236c5252++module Database.Tds.Primitives.Decimal ( Precision (..)+ , Scale (..)+ , Decimal (..)+ , precisionToLen+ , bytesToDecimal+ , decimalToBytes+ ) where++import Data.Word (Word8(..))+import Data.Int (Int32(..))+import Data.Fixed (Fixed(..))+import Data.Bits ((.&.),(.|.),shift)+import qualified Data.ByteString as B+import Database.Tds.Primitives.Fixed++type Precision = Word8+type Scale = Word8+++precisionToLen :: Precision -> Word8+precisionToLen p =+ case p of+ _ | 1 <= p && p <= 9 -> 4+ _ | 10 <= p && p <= 19 -> 8+ _ | 20 <= p && p <= 28 -> 12+ _ | 29 <= p && p <= 38 -> 16+ _ -> error "precisionToLen: invalid Precision"+++-- [MEMO] Correctness is not sure...+-- [TODO] Test+data Decimal = DecimalS0 !Precision !Fixed0+ | DecimalS1 !Precision !Fixed1+ | DecimalS2 !Precision !Fixed2+ | DecimalS3 !Precision !Fixed3+ | DecimalS4 !Precision !Fixed4+ | DecimalS5 !Precision !Fixed5+ | DecimalS6 !Precision !Fixed6+ | DecimalS7 !Precision !Fixed7+ | DecimalS8 !Precision !Fixed8+ | DecimalS9 !Precision !Fixed9+ | DecimalS10 !Precision !Fixed10+ | DecimalS11 !Precision !Fixed11+ | DecimalS12 !Precision !Fixed12+ | DecimalS13 !Precision !Fixed13+ | DecimalS14 !Precision !Fixed14+ | DecimalS15 !Precision !Fixed15+ | DecimalS16 !Precision !Fixed16+ | DecimalS17 !Precision !Fixed17+ | DecimalS18 !Precision !Fixed18+ | DecimalS19 !Precision !Fixed19+ | DecimalS20 !Precision !Fixed20+ | DecimalS21 !Precision !Fixed21+ | DecimalS22 !Precision !Fixed22+ | DecimalS23 !Precision !Fixed23+ | DecimalS24 !Precision !Fixed24+ | DecimalS25 !Precision !Fixed25+ | DecimalS26 !Precision !Fixed26+ | DecimalS27 !Precision !Fixed27+ | DecimalS28 !Precision !Fixed28+ | DecimalS29 !Precision !Fixed29+ | DecimalS30 !Precision !Fixed30+ | DecimalS31 !Precision !Fixed31+ | DecimalS32 !Precision !Fixed32+ | DecimalS33 !Precision !Fixed33+ | DecimalS34 !Precision !Fixed34+ | DecimalS35 !Precision !Fixed35+ | DecimalS36 !Precision !Fixed36+ | DecimalS37 !Precision !Fixed37+ | DecimalS38 !Precision !Fixed38+ deriving (Show)+++bytesToDecimal :: Precision -> Scale -> Word8 -> B.ByteString -> Decimal+bytesToDecimal p s sign bs =+ let+ sign' = if sign == 0x01 then 1 else -1+ i = bytesToInteger bs+ in integerToDecimal p s $ sign' * i+++-- [MEMO] signed, little endian+bytesToInteger :: B.ByteString -> Integer+bytesToInteger = B.foldl' f 0 . B.reverse+ where+ f a b = a `shift` 8 .|. fromIntegral b++integerToDecimal :: Precision -> Scale -> Integer -> Decimal+integerToDecimal p s i =+ case s of+ 0 -> DecimalS0 p $ MkFixed i + 1 -> DecimalS1 p $ MkFixed i + 2 -> DecimalS2 p $ MkFixed i + 3 -> DecimalS3 p $ MkFixed i + 4 -> DecimalS4 p $ MkFixed i + 5 -> DecimalS5 p $ MkFixed i + 6 -> DecimalS6 p $ MkFixed i + 7 -> DecimalS7 p $ MkFixed i + 8 -> DecimalS8 p $ MkFixed i + 9 -> DecimalS9 p $ MkFixed i ++ 10 -> DecimalS10 p $ MkFixed i+ 11 -> DecimalS11 p $ MkFixed i+ 12 -> DecimalS12 p $ MkFixed i+ 13 -> DecimalS13 p $ MkFixed i+ 14 -> DecimalS14 p $ MkFixed i+ 15 -> DecimalS15 p $ MkFixed i+ 16 -> DecimalS16 p $ MkFixed i+ 17 -> DecimalS17 p $ MkFixed i+ 18 -> DecimalS18 p $ MkFixed i+ 19 -> DecimalS19 p $ MkFixed i++ 20 -> DecimalS20 p $ MkFixed i+ 21 -> DecimalS21 p $ MkFixed i+ 22 -> DecimalS22 p $ MkFixed i+ 23 -> DecimalS23 p $ MkFixed i+ 24 -> DecimalS24 p $ MkFixed i+ 25 -> DecimalS25 p $ MkFixed i+ 26 -> DecimalS26 p $ MkFixed i+ 27 -> DecimalS27 p $ MkFixed i+ 28 -> DecimalS28 p $ MkFixed i+ 29 -> DecimalS29 p $ MkFixed i++ 30 -> DecimalS30 p $ MkFixed i+ 31 -> DecimalS31 p $ MkFixed i+ 32 -> DecimalS32 p $ MkFixed i+ 33 -> DecimalS33 p $ MkFixed i+ 34 -> DecimalS34 p $ MkFixed i+ 35 -> DecimalS35 p $ MkFixed i+ 36 -> DecimalS36 p $ MkFixed i+ 37 -> DecimalS37 p $ MkFixed i+ 38 -> DecimalS38 p $ MkFixed i++ _ -> error "integerToDecimal: invalid scale"+++-- [MEMO] signed, little endian+integerToBytes :: Word8 -> Integer -> B.ByteString+integerToBytes len i = B.pack $ f len i+ where+ f :: Word8 -> Integer -> [Word8]+ f 0 _ = []+ f len i =+ let+ (d,m) = divMod i 0xff+ in (fromIntegral m) : f (len-1) d+++decimalToBytes :: Decimal -> (Word8,B.ByteString)+decimalToBytes dec =+ let+ (p,i) = int dec+ sign = if signum i == -1 then 0x00 else 0x01+ bs = integerToBytes (precisionToLen p) $ abs i+ in (sign,bs)+ where+ int :: Decimal -> (Precision,Integer)+ int (DecimalS0 p (MkFixed i)) = (p,i)+ int (DecimalS1 p (MkFixed i)) = (p,i)+ int (DecimalS2 p (MkFixed i)) = (p,i)+ int (DecimalS3 p (MkFixed i)) = (p,i)+ int (DecimalS4 p (MkFixed i)) = (p,i)+ int (DecimalS5 p (MkFixed i)) = (p,i)+ int (DecimalS6 p (MkFixed i)) = (p,i)+ int (DecimalS7 p (MkFixed i)) = (p,i)+ int (DecimalS8 p (MkFixed i)) = (p,i)+ int (DecimalS9 p (MkFixed i)) = (p,i)+ int (DecimalS10 p (MkFixed i)) = (p,i)+ int (DecimalS11 p (MkFixed i)) = (p,i)+ int (DecimalS12 p (MkFixed i)) = (p,i)+ int (DecimalS13 p (MkFixed i)) = (p,i)+ int (DecimalS14 p (MkFixed i)) = (p,i)+ int (DecimalS15 p (MkFixed i)) = (p,i)+ int (DecimalS16 p (MkFixed i)) = (p,i)+ int (DecimalS17 p (MkFixed i)) = (p,i)+ int (DecimalS18 p (MkFixed i)) = (p,i)+ int (DecimalS19 p (MkFixed i)) = (p,i)+ int (DecimalS20 p (MkFixed i)) = (p,i)+ int (DecimalS21 p (MkFixed i)) = (p,i)+ int (DecimalS22 p (MkFixed i)) = (p,i)+ int (DecimalS23 p (MkFixed i)) = (p,i)+ int (DecimalS24 p (MkFixed i)) = (p,i)+ int (DecimalS25 p (MkFixed i)) = (p,i)+ int (DecimalS26 p (MkFixed i)) = (p,i)+ int (DecimalS27 p (MkFixed i)) = (p,i)+ int (DecimalS28 p (MkFixed i)) = (p,i)+ int (DecimalS29 p (MkFixed i)) = (p,i)+ int (DecimalS30 p (MkFixed i)) = (p,i)+ int (DecimalS31 p (MkFixed i)) = (p,i)+ int (DecimalS32 p (MkFixed i)) = (p,i)+ int (DecimalS33 p (MkFixed i)) = (p,i)+ int (DecimalS34 p (MkFixed i)) = (p,i)+ int (DecimalS35 p (MkFixed i)) = (p,i)+ int (DecimalS36 p (MkFixed i)) = (p,i)+ int (DecimalS37 p (MkFixed i)) = (p,i)+ int (DecimalS38 p (MkFixed i)) = (p,i)+++
+ src/Database/Tds/Primitives/Fixed.hs view
@@ -0,0 +1,212 @@+module Database.Tds.Primitives.Fixed ( Fixed0 (..)+ , Fixed1 (..)+ , Fixed2 (..)+ , Fixed3 (..)+ , Fixed4 (..)+ , Fixed5 (..)+ , Fixed6 (..)+ , Fixed7 (..)+ , Fixed8 (..)+ , Fixed9 (..)+ , Fixed10 (..)+ , Fixed11 (..)+ , Fixed12 (..)+ , Fixed13 (..)+ , Fixed14 (..)+ , Fixed15 (..)+ , Fixed16 (..)+ , Fixed17 (..)+ , Fixed18 (..)+ , Fixed19 (..)+ , Fixed20 (..)+ , Fixed21 (..)+ , Fixed22 (..)+ , Fixed23 (..)+ , Fixed24 (..)+ , Fixed25 (..)+ , Fixed26 (..)+ , Fixed27 (..)+ , Fixed28 (..)+ , Fixed29 (..)+ , Fixed30 (..)+ , Fixed31 (..)+ , Fixed32 (..)+ , Fixed33 (..)+ , Fixed34 (..)+ , Fixed35 (..)+ , Fixed36 (..)+ , Fixed37 (..)+ , Fixed38 (..)+ , Exp0 (..)+ , Exp1 (..)+ , Exp2 (..)+ , Exp3 (..)+ , Exp4 (..)+ , Exp5 (..)+ , Exp6 (..)+ , Exp7 (..)+ , Exp8 (..)+ , Exp9 (..)+ , Exp10 (..)+ , Exp11 (..)+ , Exp12 (..)+ , Exp13 (..)+ , Exp14 (..)+ , Exp15 (..)+ , Exp16 (..)+ , Exp17 (..)+ , Exp18 (..)+ , Exp19 (..)+ , Exp20 (..)+ , Exp21 (..)+ , Exp22 (..)+ , Exp23 (..)+ , Exp24 (..)+ , Exp25 (..)+ , Exp26 (..)+ , Exp27 (..)+ , Exp28 (..)+ , Exp29 (..)+ , Exp30 (..)+ , Exp31 (..)+ , Exp32 (..)+ , Exp33 (..)+ , Exp34 (..)+ , Exp35 (..)+ , Exp36 (..)+ , Exp37 (..)+ , Exp38 (..)+ ) where+++import Data.Fixed (HasResolution(..),Fixed(..))++data Exp0+data Exp1+data Exp2+data Exp3+data Exp4+data Exp5+data Exp6+data Exp7+data Exp8+data Exp9++data Exp10+data Exp11+data Exp12+data Exp13+data Exp14+data Exp15+data Exp16+data Exp17+data Exp18+data Exp19++data Exp20+data Exp21+data Exp22+data Exp23+data Exp24+data Exp25+data Exp26+data Exp27+data Exp28+data Exp29++data Exp30+data Exp31+data Exp32+data Exp33+data Exp34+data Exp35+data Exp36+data Exp37+data Exp38++instance HasResolution Exp0 where resolution _ = 1+instance HasResolution Exp1 where resolution _ = 10+instance HasResolution Exp2 where resolution _ = 100+instance HasResolution Exp3 where resolution _ = 1000+instance HasResolution Exp4 where resolution _ = 10000+instance HasResolution Exp5 where resolution _ = 100000+instance HasResolution Exp6 where resolution _ = 1000000+instance HasResolution Exp7 where resolution _ = 10000000+instance HasResolution Exp8 where resolution _ = 100000000+instance HasResolution Exp9 where resolution _ = 1000000000++instance HasResolution Exp10 where resolution _ = 10000000000+instance HasResolution Exp11 where resolution _ = 100000000000+instance HasResolution Exp12 where resolution _ = 1000000000000+instance HasResolution Exp13 where resolution _ = 10000000000000+instance HasResolution Exp14 where resolution _ = 100000000000000+instance HasResolution Exp15 where resolution _ = 1000000000000000+instance HasResolution Exp16 where resolution _ = 10000000000000000+instance HasResolution Exp17 where resolution _ = 100000000000000000+instance HasResolution Exp18 where resolution _ = 1000000000000000000+instance HasResolution Exp19 where resolution _ = 10000000000000000000++instance HasResolution Exp20 where resolution _ = 100000000000000000000+instance HasResolution Exp21 where resolution _ = 1000000000000000000000+instance HasResolution Exp22 where resolution _ = 10000000000000000000000+instance HasResolution Exp23 where resolution _ = 100000000000000000000000+instance HasResolution Exp24 where resolution _ = 1000000000000000000000000+instance HasResolution Exp25 where resolution _ = 10000000000000000000000000+instance HasResolution Exp26 where resolution _ = 100000000000000000000000000+instance HasResolution Exp27 where resolution _ = 1000000000000000000000000000+instance HasResolution Exp28 where resolution _ = 10000000000000000000000000000+instance HasResolution Exp29 where resolution _ = 100000000000000000000000000000++instance HasResolution Exp30 where resolution _ = 1000000000000000000000000000000+instance HasResolution Exp31 where resolution _ = 10000000000000000000000000000000+instance HasResolution Exp32 where resolution _ = 100000000000000000000000000000000+instance HasResolution Exp33 where resolution _ = 1000000000000000000000000000000000+instance HasResolution Exp34 where resolution _ = 10000000000000000000000000000000000+instance HasResolution Exp35 where resolution _ = 100000000000000000000000000000000000+instance HasResolution Exp36 where resolution _ = 1000000000000000000000000000000000000+instance HasResolution Exp37 where resolution _ = 10000000000000000000000000000000000000+instance HasResolution Exp38 where resolution _ = 100000000000000000000000000000000000000++type Fixed0 = Fixed Exp0+type Fixed1 = Fixed Exp1+type Fixed2 = Fixed Exp2+type Fixed3 = Fixed Exp3+type Fixed4 = Fixed Exp4+type Fixed5 = Fixed Exp5+type Fixed6 = Fixed Exp6+type Fixed7 = Fixed Exp7+type Fixed8 = Fixed Exp8+type Fixed9 = Fixed Exp9++type Fixed10 = Fixed Exp10+type Fixed11 = Fixed Exp11+type Fixed12 = Fixed Exp12+type Fixed13 = Fixed Exp13+type Fixed14 = Fixed Exp14+type Fixed15 = Fixed Exp15+type Fixed16 = Fixed Exp16+type Fixed17 = Fixed Exp17+type Fixed18 = Fixed Exp18+type Fixed19 = Fixed Exp19++type Fixed20 = Fixed Exp20+type Fixed21 = Fixed Exp21+type Fixed22 = Fixed Exp22+type Fixed23 = Fixed Exp23+type Fixed24 = Fixed Exp24+type Fixed25 = Fixed Exp25+type Fixed26 = Fixed Exp26+type Fixed27 = Fixed Exp27+type Fixed28 = Fixed Exp28+type Fixed29 = Fixed Exp29++type Fixed30 = Fixed Exp30+type Fixed31 = Fixed Exp31+type Fixed32 = Fixed Exp32+type Fixed33 = Fixed Exp33+type Fixed34 = Fixed Exp34+type Fixed35 = Fixed Exp35+type Fixed36 = Fixed Exp36+type Fixed37 = Fixed Exp37+type Fixed38 = Fixed Exp38+
+ src/Database/Tds/Primitives/Float.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}++-- | This module was written based on+-- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+-- Implements casting via a 1-elemnt STUArray, as described in+-- <http://stackoverflow.com/a/7002812/263061>.+module Database.Tds.Primitives.Float+ ( floatToWord+ , wordToFloat+ , doubleToWord+ , wordToDouble+ ) where++import Data.Word (Word32, Word64)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import GHC.ST (runST, ST)++-- | Reinterpret-casts a `Float` to a `Word32`.+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)+{-# INLINE floatToWord #-}++-- | Reinterpret-casts a `Word32` to a `Float`.+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}++-- | Reinterpret-casts a `Double` to a `Word64`.+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+{-# INLINE doubleToWord #-}++-- | Reinterpret-casts a `Word64` to a `Double`.+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)+{-# INLINE wordToDouble #-}++cast :: (MArray (STUArray s) a (ST s),+ MArray (STUArray s) b (ST s)) => a -> ST s b+cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+{-# INLINE cast #-}+
+ src/Database/Tds/Primitives/Money.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_HADDOCK hide #-}+-- https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/1266679d-cd6e-492a-b2b2-3a9ba004196d++module Database.Tds.Primitives.Money ( Money (..)+ , moneyToBytes4+ , moneyToBytes8+ , bytesToMoney4+ , bytesToMoney8+ ) where++import Data.Int (Int32(..))+import Data.Fixed (Fixed(..))+import Data.Bits ((.&.),shift)+import Database.Tds.Primitives.Fixed++type Money = Fixed4++bytesToMoney4 :: Int32 -> Money+bytesToMoney4 i = MkFixed $ fromIntegral i++bytesToMoney8 :: Int32 -> Int32 -> Money+bytesToMoney8 m l =+ let+ m' = fromIntegral m+ l' = fromIntegral l+ in MkFixed $ (shift m' 32) + l'+++moneyToBytes4 :: Money -> Int32+moneyToBytes4 (MkFixed i) = fromIntegral i++moneyToBytes8 :: Money -> (Int32,Int32)+moneyToBytes8 (MkFixed i) =+ let+ m = shift i (-32)+ l = i .&. 0xffffffff+ in (fromIntegral m, fromIntegral l)+
+ src/Database/Tds/Primitives/Null.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_HADDOCK hide #-}++module Database.Tds.Primitives.Null ( Null (..)+ ) where++data Null = Null+ deriving (Show)
+ src/Database/Tds/Transport.hs view
@@ -0,0 +1,118 @@++module Database.Tds.Transport (contextNew) where++import Data.Monoid((<>))++import Network.Socket (Socket,close)+import Network.Socket.ByteString (recv,sendAll)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB++import Data.Binary (decode,encode)++import Data.Default.Class (def)+import qualified Network.TLS as TLS+import Network.TLS (ClientParams(..),Supported(..),Shared(..),ValidationCache(..),ValidationCacheResult(..))+import Network.TLS.Extra.Cipher (ciphersuite_default)+import Data.X509.CertificateStore (CertificateStore(..))+import System.X509 (getSystemCertificateStore)++import Control.Concurrent(MVar(..),newMVar,readMVar,modifyMVar_)++import Database.Tds.Message.Header+++contextNew :: Socket -> TLS.HostName -> IO TLS.Context+contextNew sock host = do+ certStore <- getSystemCertificateStore+ sock' <- newSecureSocket sock+ TLS.contextNew sock' $ getTlsParams host certStore+ +++data SecureSocket = SecureSocket{ getSocket::Socket+ , getSendBuff::MVar B.ByteString+ , getSendStep::MVar Int+ , getRecvBuff::MVar B.ByteString+ }+ +newSecureSocket sock = SecureSocket sock <$> newMVar mempty <*> newMVar 0 <*> newMVar mempty+++instance TLS.HasBackend SecureSocket where+ initializeBackend sock' = return ()+ getBackend sock' = TLS.Backend flush (close sock) sendAll' recvAll+ where+ sock = getSocket sock'+ + flush = return()+ + -- [MEMO] Put them into TDS packets at regular intervals+ -- [TODO] Consider a better implementation+ sendAll' bs = do+ step <- readMVar (getSendStep sock')+ case step of+ 0 -> sendAll sock $ (header bs) <> bs --0x16+ 1 -> appendBuff -- 0x16+ 2 -> appendBuff -- 0x14+ 3 -> do+ buff <- readMVar (getSendBuff sock')+ let bs' = buff <> bs+ sendAll sock $ (header bs') <> bs' -- 0x16+ modifyMVar_ (getSendBuff sock') (\_ -> return mempty)+ _ -> sendAll sock bs -- 0x17+ 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+ + -- [MEMO] This doesn't work+ -- [MEMO] Want to do this+ sendAll'' bs = do+ case B.head bs of+ 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+ ++ -- [MEMO] Remove TDS header+ -- [MEMO] Receive as much as possible from the source. and return only sink's requested size for each turn.+ -- [TODO] Consider a better implementation+ recvAll len = do+ buff <- readMVar (getRecvBuff sock')+ if B.null buff+ then recvDropBuff+ else dropBuff+ + where+ recvDropBuff = do+ header <- recv sock 8+ let (Header _ _ totalLen _ _ _) = decode $ LB.fromStrict header+ body <- recv sock $ totalLen -8+ let bs = B.take len body+ modifyMVar_ (getRecvBuff sock') (\_ -> return $ B.drop len body)+ return bs+ + dropBuff = do+ buff <- readMVar (getRecvBuff sock')+ let bs = B.take len buff+ modifyMVar_ (getRecvBuff sock') (\_ -> return $ B.drop len buff)+ return bs++ ++getTlsParams :: TLS.HostName -> CertificateStore -> ClientParams+getTlsParams host store =+ (TLS.defaultParamsClient host mempty) { clientSupported = def { supportedVersions = [TLS.TLS10]+ , supportedCiphers = ciphersuite_default+ , supportedEmptyPacket = False+ }+ , clientShared = def { sharedCAStore = store+ , sharedValidationCache = validateCache+ }+ }+ where+ validateCache = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ())+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"