diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for ms-tds + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ms-tds.cabal b/ms-tds.cabal new file mode 100644 --- /dev/null +++ b/ms-tds.cabal @@ -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 +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 diff --git a/src/Database/Tds/Message.hs b/src/Database/Tds/Message.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message.hs @@ -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 + + diff --git a/src/Database/Tds/Message/Client.hs b/src/Database/Tds/Message/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message/Client.hs @@ -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 + + + diff --git a/src/Database/Tds/Message/DataStream.hs b/src/Database/Tds/Message/DataStream.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message/DataStream.hs @@ -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 + + diff --git a/src/Database/Tds/Message/Header.hs b/src/Database/Tds/Message/Header.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message/Header.hs @@ -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 diff --git a/src/Database/Tds/Message/Prelogin.hs b/src/Database/Tds/Message/Prelogin.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message/Prelogin.hs @@ -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 + diff --git a/src/Database/Tds/Message/Server.hs b/src/Database/Tds/Message/Server.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Message/Server.hs @@ -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 + diff --git a/src/Database/Tds/Primitives/Collation.hs b/src/Database/Tds/Primitives/Collation.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Collation.hs @@ -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 + diff --git a/src/Database/Tds/Primitives/DateTime.hs b/src/Database/Tds/Primitives/DateTime.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/DateTime.hs @@ -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) + + diff --git a/src/Database/Tds/Primitives/Decimal.hs b/src/Database/Tds/Primitives/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Decimal.hs @@ -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) + + + diff --git a/src/Database/Tds/Primitives/Fixed.hs b/src/Database/Tds/Primitives/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Fixed.hs @@ -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 + diff --git a/src/Database/Tds/Primitives/Float.hs b/src/Database/Tds/Primitives/Float.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Float.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + +-- | This module was written based on +-- . +-- +-- Implements casting via a 1-elemnt STUArray, as described in +-- . +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 #-} + diff --git a/src/Database/Tds/Primitives/Money.hs b/src/Database/Tds/Primitives/Money.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Money.hs @@ -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) + diff --git a/src/Database/Tds/Primitives/Null.hs b/src/Database/Tds/Primitives/Null.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Primitives/Null.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Database.Tds.Primitives.Null ( Null (..) + ) where + +data Null = Null + deriving (Show) diff --git a/src/Database/Tds/Transport.hs b/src/Database/Tds/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Database/Tds/Transport.hs @@ -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 ()) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"