module Database.Tds.Message ( -- * Client Message
                              ClientMessage (..)
                            , getClientMessage
                            , putClientMessage
                              
                            -- ** Login
                            , Login7
                            , tdsVersion
                            , defaultLogin7
                            , l7PacketSize
                            , l7ClientProgVer
                            , l7ConnectionID
                            , l7OptionFlags1
                            , l7OptionFlags2
                            , l7OptionFlags3
                            , l7TypeFlags
                            , l7TimeZone
                            , l7Collation
                            , l7CltIntName
                            , l7Language
                            , l7ClientPID
                            , l7ClientMacAddr
                            , l7ClientHostName
                            , l7AppName
                            , l7ServerName
                            , l7UserName
                            , l7Password
                            , l7Database
                            
                            -- ** SQL Batch
                            , SqlBatch (..)
                            
                            -- ** RPC Request
                            , RpcRequest (..)
                            
                            , RpcReqBatch (..)
                            , ProcID (..)
                            , ProcName (..)
                            , OptionFlags (..)

                            , RpcReqBatchParam (..)
                            , ParamName (..)
                            , StatusFlag (..)
                            
                            -- * Server Message
                            , ServerMessage (..)
                            , getServerMessage
                            , putServerMessage
                            
                            , TokenStreams (..)
                            , TokenStream (..)
                            
                            -- ** AltMetaData
                            , AltMetaData (..)
                            
                            -- ** AltRowData
                            , AltRowData (..)

                            -- ** 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 (..)
                            , Money (..)
                            
                            , Collation (..)
                            , Collation32 (..)
                            , SortId (..)

                              
                            -- * Prelogin
                            , Prelogin (..)
                            , PreloginOption (..)
                            , MajorVer (..)
                            , MinorVer (..)
                            , BuildVer (..)
                            , SubBuildVer (..)
                            , Threadid (..)
                            , Connid (..)
                            , Activity (..)
                            , Sequence (..)
                            , Nonce (..)
                            
                            ) where

import Control.Applicative((<$>))

import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Builder as BB

import Data.Word (Word8(..),Word16(..),Word32(..),Word64(..))
import Data.Int (Int8(..),Int16(..),Int32(..),Int64(..))

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 :: Word32 -> Word8 -> LB.ByteString -> Put
putMessage :: Word32 -> Word8 -> ByteString -> Put
putMessage Word32
ps Word8
pt ByteString
bs = ((Bool, ByteString) -> Put) -> [(Bool, ByteString)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool, ByteString) -> Put
f ([(Bool, ByteString)] -> Put) -> [(Bool, ByteString)] -> Put
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteString -> [(Bool, ByteString)]
split (Word32
ps Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
forall a. Integral a => a
headerLength) ByteString
bs
  where
    f :: (Bool,LB.ByteString) -> Put
    f :: (Bool, ByteString) -> Put
f (Bool
isLast,ByteString
bs) = do
      let
        len :: Length
len = (Int64 -> Length
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Length) -> Int64 -> Length
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LB.length ByteString
bs) Length -> Length -> Length
forall a. Num a => a -> a -> a
+ Length
forall a. Integral a => a
headerLength
        flg :: Word8
flg = if Bool
isLast then Word8
0x01 else Word8
0x00 -- last flag
      Header -> Put
forall t. Binary t => t -> Put
put (Header -> Put) -> Header -> Put
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Length -> Length -> Word8 -> Word8 -> Header
Header Word8
pt Word8
flg Length
len Length
0 Word8
0 Word8
0
      ByteString -> Put
Put.putLazyByteString ByteString
bs

  
    split :: Word32 -> LB.ByteString -> [(Bool,LB.ByteString)]
    split :: Word32 -> ByteString -> [(Bool, ByteString)]
split Word32
len ByteString
lbs =
      let
        (ByteString
lbs',ByteString
rem) = Int64 -> ByteString -> (ByteString, ByteString)
LB.splitAt (Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) ByteString
lbs
      in if ByteString -> Bool
LB.null ByteString
rem
         then [(Bool
True,ByteString
lbs')]
         else (Bool
False,ByteString
lbs')(Bool, ByteString) -> [(Bool, ByteString)] -> [(Bool, ByteString)]
forall a. a -> [a] -> [a]
: Word32 -> ByteString -> [(Bool, ByteString)]
split Word32
len ByteString
rem


getMessage :: Get (Word8,LB.ByteString)
getMessage :: Get (Word8, ByteString)
getMessage = (\(Word8
pt,Builder
bs) -> (Word8
pt,Builder -> ByteString
BB.toLazyByteString Builder
bs)) ((Word8, Builder) -> (Word8, ByteString))
-> Get (Word8, Builder) -> Get (Word8, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT Builder Get Word8 -> Get (Word8, Builder)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT Builder Get Word8
f
  where
    f :: WriterT BB.Builder Get Word8
    f :: WriterT Builder Get Word8
f = do
      (Header Word8
pt Word8
flg Length
len Length
_ Word8
_ Word8
_) <- Get Header -> WriterT Builder Get Header
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Header
forall t. Binary t => Get t
get
      Builder -> WriterT Builder Get ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Builder -> WriterT Builder Get ())
-> WriterT Builder Get Builder -> WriterT Builder Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Builder
BB.byteString (ByteString -> Builder)
-> WriterT Builder Get ByteString -> WriterT Builder Get Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get ByteString -> WriterT Builder Get ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get ByteString -> WriterT Builder Get ByteString)
-> Get ByteString -> WriterT Builder Get ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
Get.getByteString (Length -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Length -> Int) -> Length -> Int
forall a b. (a -> b) -> a -> b
$ Length
len Length -> Length -> Length
forall a. Num a => a -> a -> a
-Length
8))
      if Word8
flg Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x01
        then Word8 -> WriterT Builder Get Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
pt
        else WriterT Builder Get Word8
f




-- | [\[MS-TDS\] 2.2.1 Client Messages](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/7ea9ee1a-b461-41f2-9004-141c0e712935)
data ClientMessage = CMPrelogin !Prelogin
                   | CMLogin7 !Login7
                   | CMSqlBatch !SqlBatch
                   | CMRpcRequest !RpcRequest
                   deriving (Int -> ClientMessage -> ShowS
[ClientMessage] -> ShowS
ClientMessage -> String
(Int -> ClientMessage -> ShowS)
-> (ClientMessage -> String)
-> ([ClientMessage] -> ShowS)
-> Show ClientMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientMessage] -> ShowS
$cshowList :: [ClientMessage] -> ShowS
show :: ClientMessage -> String
$cshow :: ClientMessage -> String
showsPrec :: Int -> ClientMessage -> ShowS
$cshowsPrec :: Int -> ClientMessage -> ShowS
Show)

putClientMessage :: Word32 -> ClientMessage -> Put
putClientMessage :: Word32 -> ClientMessage -> Put
putClientMessage Word32
ps ClientMessage
x =
  let (Word8
pt,ByteString
bs) = case ClientMessage
x of
        CMPrelogin   Prelogin
pr -> (Word8
0x12,Prelogin -> ByteString
forall a. Binary a => a -> ByteString
encode Prelogin
pr)
        CMLogin7     Login7
l7 -> (Word8
0x10,Login7 -> ByteString
forall a. Binary a => a -> ByteString
encode Login7
l7)
        CMSqlBatch   SqlBatch
b  -> (Word8
0x01,SqlBatch -> ByteString
forall a. Binary a => a -> ByteString
encode SqlBatch
b)
        CMRpcRequest RpcRequest
r  -> (Word8
0x03,RpcRequest -> ByteString
forall a. Binary a => a -> ByteString
encode RpcRequest
r)
  in Word32 -> Word8 -> ByteString -> Put
putMessage Word32
ps Word8
pt ByteString
bs

getClientMessage :: Get ClientMessage
getClientMessage :: Get ClientMessage
getClientMessage = do
  (Word8
pt,ByteString
bs) <- Get (Word8, ByteString)
getMessage
  case Word8
pt of
    Word8
0x12 -> ClientMessage -> Get ClientMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientMessage -> Get ClientMessage)
-> ClientMessage -> Get ClientMessage
forall a b. (a -> b) -> a -> b
$ Prelogin -> ClientMessage
CMPrelogin   (Prelogin -> ClientMessage) -> Prelogin -> ClientMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> Prelogin
forall a. Binary a => ByteString -> a
decode ByteString
bs
    Word8
0x10 -> ClientMessage -> Get ClientMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientMessage -> Get ClientMessage)
-> ClientMessage -> Get ClientMessage
forall a b. (a -> b) -> a -> b
$ Login7 -> ClientMessage
CMLogin7     (Login7 -> ClientMessage) -> Login7 -> ClientMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> Login7
forall a. Binary a => ByteString -> a
decode ByteString
bs
    Word8
0x01 -> ClientMessage -> Get ClientMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientMessage -> Get ClientMessage)
-> ClientMessage -> Get ClientMessage
forall a b. (a -> b) -> a -> b
$ SqlBatch -> ClientMessage
CMSqlBatch   (SqlBatch -> ClientMessage) -> SqlBatch -> ClientMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> SqlBatch
forall a. Binary a => ByteString -> a
decode ByteString
bs
    Word8
0x03 -> ClientMessage -> Get ClientMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientMessage -> Get ClientMessage)
-> ClientMessage -> Get ClientMessage
forall a b. (a -> b) -> a -> b
$ RpcRequest -> ClientMessage
CMRpcRequest (RpcRequest -> ClientMessage) -> RpcRequest -> ClientMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> RpcRequest
forall a. Binary a => ByteString -> a
decode ByteString
bs
    Word8
_ -> String -> Get ClientMessage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"getClientMessage: invalid packet type"




-- | [\[MS-TDS\] 2.2.2 Server Messages](https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/342f4cbb-2b4b-489c-8b63-f99b12021a94)
class Binary a => ServerMessage a
instance ServerMessage Prelogin
instance ServerMessage TokenStreams

putServerMessage :: ServerMessage a => Word32 -> a -> Put
putServerMessage :: Word32 -> a -> Put
putServerMessage Word32
ps a
x =
  Word32 -> Word8 -> ByteString -> Put
putMessage Word32
ps Word8
0x04 (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Binary a => a -> ByteString
encode a
x

getServerMessage :: ServerMessage a => Get a
getServerMessage :: Get a
getServerMessage = do
  (Word8
pt,ByteString
bs) <- Get (Word8, ByteString)
getMessage
  case Word8
pt of
    Word8
0x04 -> a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Get a) -> a -> Get a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Binary a => ByteString -> a
decode ByteString
bs
    Word8
_ -> String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"getServerMessage: invalid packet type"