{-# 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 (..) , AltRowData (..) , 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((<>),mempty) import Control.Applicative((<$>),(<*>)) 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) -- [TODO] implement data type data AltMetaData = AltMetaData deriving (Show) -- [TODO] implement data type data AltRowData = AltRowData deriving (Show) type OffsetIdentifier = Word16 type OffsetLength = Word16 data Offset = Offset !OffsetIdentifier !OffsetLength deriving (Show) data MetaData = MetaData !(Maybe ColMetaData) !(Maybe AltMetaData) deriving (Show) type TextPointer = B.ByteString type TimeStamp = Word64 data RowColumnData = RCDOrdinal !RawBytes | RCDLarge !(Maybe TextPointer) !(Maybe TimeStamp) !RawBytes deriving (Show) 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 = Int32 -- [MEMO] TDS 7.2 -> Word64 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 -- [MEMO] TDS 7.2 -> (error:Int32,info:Word32) 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 -- | [\[MS-TDS\] 2.2.7 Packet Data Token Stream Definition](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/67b6113c-d722-42d1-902c-3f6e8de09173) data TokenStream = -- | [\[MS-TDS\] 2.2.7.1 ALTMETADATA](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/004bba4a-8c23-4d7b-ab2c-d9e7ba864cd0) (not supprted) TSAltMetaData !AltMetaData -- | [\[MS-TDS\] 2.2.7.2 ALTROW](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/d1c42761-6a64-43ab-8a55-fccb210ac073) (not supprted) | TSAltRow !AltRowData -- | [\[MS-TDS\] 2.2.7.3 COLINFO](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/aa8466c5-ca3d-48ca-a638-7c1becebe754) | TSColInfo ![ColProperty] -- | [\[MS-TDS\] 2.2.7.4 COLMETADATA](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/58880b9f-381c-43b2-bf8b-0727a98c4f4c) | TSColMetaData !(Maybe ColMetaData) -- | [\[MS-TDS\] 2.2.7.5 DONE](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/3c06f110-98bd-4d5b-b836-b1ba66452cb7) | TSDone !Done -- | [\[MS-TDS\] 2.2.7.6 DONEINPROC](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/43e891c5-f7a1-432f-8f9f-233c4cd96afb) | TSDoneInProc !Done -- | [\[MS-TDS\] 2.2.7.7 DONEPROC](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/65e24140-edea-46e5-b710-209af2016195) | TSDoneProc !Done -- | [\[MS-TDS\] 2.2.7.8 ENVCHANGE](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/2b3eb7e5-d43d-4d1b-bf4d-76b9e3afc791) | TSEnvChange !ECType !ECNewValue !ECOldValue -- | [\[MS-TDS\] 2.2.7.9 ERROR](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/9805e9fa-1f8b-4cf8-8f78-8d2602228635) | TSError !Info -- | [\[MS-TDS\] 2.2.7.12 INFO](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/284bb815-d083-4ed5-b33a-bdc2492e322b) | TSInfo !Info -- | [\[MS-TDS\] 2.2.7.13 LOGINACK](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/490e563d-cc6e-4c86-bb95-ef0186b98032) | TSLoginAck !LAInterface !LATdsVersion !LAProgName !LAProgVersion -- | [\[MS-TDS\] 2.2.7.15 OFFSET](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/8d0b37ff-20c1-439e-8f31-1d7f136249b5) (not tested) | TSOffset !Offset -- | [\[MS-TDS\] 2.2.7.16 ORDER](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/252759be-9d74-4435-809d-d55dd860ea78) | TSOrder ![Word16] -- | [\[MS-TDS\] 2.2.7.17 RETURNSTATUS](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/c719f199-e71b-4187-90b9-94f78bd1870e) | TSReturnStatus !Int32 -- | [\[MS-TDS\] 2.2.7.18 RETURNVALUE](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/7091f6f6-b83d-4ed2-afeb-ba5013dfb18f) | TSReturnValue !ReturnValue -- | [\[MS-TDS\] 2.2.7.19 ROW](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/3840ef93-3b10-4aca-9fd1-a210b8bb6d0c) | TSRow ![RowColumnData] -- | [\[MS-TDS\] 2.2.7.21 SSPI](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/07e2bb7b-8ba6-445f-89b1-cc76d8bfa9c6) (not tested) | TSSSPI !B.ByteString -- | [\[MS-TDS\] 2.2.7.22 TABNAME](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/140e3348-da08-409a-b6c3-f0fc9cee2d6e) | TSTabName ![[T.Text]] deriving (Show) getTokenStreamS :: StateT MetaData Get TokenStream getTokenStreamS = do pt <- lift Get.getWord8 case pt of 0x88 -> getAltMetaDataS 0xd3 -> getAltRowS 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 -> lift getOffset 0xa9 -> lift getOrder 0x79 -> lift getReturnStatus 0xac -> lift getReturnValue 0xd1 -> getRowS 0xed -> lift getSSPI 0xa4 -> lift getTabName _ -> lift $ getOther pt where -- [TODO] find SQL statement that generates this type of packet, implementation getAltMetaDataS :: StateT MetaData Get TokenStream getAltMetaDataS = fail "getTokenStreamS.getAltMetaDataS: packet type ALTMEATADA not supportd" -- return $ TSAltMetaData AltMetaData -- [TODO] find SQL statement that generates this type of packet, implementation getAltRowS :: StateT MetaData Get TokenStream getAltRowS = fail "getTokenStreamS.getAltRowS: packet type ALTROW not supportd" -- return $ TSAltRow AltRowData getColInfo :: Get TokenStream 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) -> (MetaData cmd mamd) 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.getInt32le -- [MEMO] TDS 7.2 -> Word64 -- doneRowCount <- Get.getWord64le return $ TSDone $ Done status curCmd doneRowCount getDoneInProc :: Get TokenStream getDoneInProc = do status <- Get.getWord16le curCmd <- Get.getWord16le doneRowCount <- Get.getInt32le -- [MEMO] TDS 7.2 -> Word64 -- doneRowCount <- Get.getWord64le return $ TSDoneInProc $ Done status curCmd doneRowCount getDoneProc :: Get TokenStream getDoneProc = do status <- Get.getWord16le curCmd <- Get.getWord16le doneRowCount <- Get.getInt32le -- [MEMO] TDS 7.2 -> Word64 -- doneRowCount <- Get.getWord64le return $ TSDoneProc $ Done status curCmd doneRowCount getEnvChange :: Get TokenStream getEnvChange = do slen <- Get.getWord16le envCode <- Get.getWord8 -- [TODO] to be detailed types (old,new) <- case envCode of 0x07 -> do -- [MEMO] report SQL 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.getWord16le -- [MEMO] TDS 7.2 -> Int32 -- line <- Get.getInt32le 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.getWord16le -- [MEMO] TDS 7.2 -> Word32 -- line <- Get.getWord32le 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 -- [TODO] find SQL statement that generates this type of packet, test getOffset :: Get TokenStream getOffset = do ofs <- Offset <$> Get.getWord16le <*> Get.getWord16le 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 return $ TSReturnStatus val getReturnValue :: Get TokenStream getReturnValue = do po <- Get.getWord16le pn <- getText8 st <- Get.getWord8 ut <- Get.getWord16le -- [MEMO] TDS 7.2 -> Word32 -- ut <- Get.getWord32le 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] raise error when Nothing Just (ColMetaData colDatas) <- (\(MetaData mcmd mamd) -> 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 getCDLarge :: TypeInfo -> Get RowColumnData getCDLarge ti = do len <- Get.getWord8 if len == 0 then do -- [MEMO] 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 -- [TODO] find SQL statement that generates this type of packet, test getSSPI :: Get TokenStream getSSPI = do len <- Get.getWord16le bs <- getByteString len return $ TSSSPI bs getTabName :: Get TokenStream getTabName = do len <- fromIntegral <$> Get.getWord16le bs <- Get.getLazyByteString len return $ TSTabName $ Get.runGet (getAllTableNames len) bs where getAllTableNames :: Int64 -> Get [[T.Text]] getAllTableNames len = f where f :: Get [[T.Text]] f = do br <- Get.bytesRead if br >= len then return [] else do x <- getTableName xs <-f return $ x:xs getTableName :: Get [T.Text] getTableName = do numParts <- fromIntegral <$> Get.getWord8 names <- mapM (\_ -> getText16 ) [1..numParts] return names getOther :: Word8 -> Get TokenStream getOther pt = do case pt of 0xae -> -- FEATUREEXTACK -- [MEMO] introduced in TDS 7.4 fail "getTokenStreamS.getOther: packet type FEATUREEXTACK not supportd" 0xee -> -- FEDAUTHINFO -- [MEMO] introduced in TDS 7.4 fail "getTokenStreamS.getOther: packet type FEDAUTHINFO not supportd" 0xd2 -> -- NBCROW -- [MEMO] introduced in TDS 7.3.B fail "getTokenStreamS.getOther: packet type NBCROW not supported" 0xe4 -> -- SESSIONSTATE -- [MEMO] introduced in TDS 7.4 fail "getTokenStreamS.getOther: packet type SESSIONSTATE not supportd" 0x01 -> -- TVP ROW -- https://msdn.microsoft.com/en-us/library/dd304813.aspx -- [MEMO] not here ? -- [MEMO] introduced in TDS 7.3 ? fail "getTokenStreamS.getOther: packet type TVP ROW not supported" _ -> 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 newtype TokenStreams = TokenStreams [TokenStream] deriving (Show) getTokenStreams :: Get TokenStreams getTokenStreams = do rs <- (evalStateT getTokenStreamsS) (MetaData 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