module Database.Tds.Message (
ClientMessage (..)
, getClientMessage
, putClientMessage
, Login7
, tdsVersion
, defaultLogin7
, l7PacketSize
, l7ClientProgVer
, l7ConnectionID
, l7OptionFlags1
, l7OptionFlags2
, l7OptionFlags3
, l7TypeFlags
, l7TimeZone
, l7Collation
, l7CltIntName
, l7Language
, l7ClientPID
, l7ClientMacAddr
, l7ClientHostName
, l7AppName
, l7ServerName
, l7UserName
, l7Password
, l7Database
, SqlBatch (..)
, RpcRequest (..)
, RpcReqBatch (..)
, ProcID (..)
, ProcName (..)
, OptionFlags (..)
, RpcReqBatchParam (..)
, ParamName (..)
, StatusFlag (..)
, ServerMessage (..)
, getServerMessage
, putServerMessage
, 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 (..)
, OffsetIdentifier (..)
, OffsetLength (..)
, Offset (..)
, ReturnValue (..)
, RVParamOrdinal (..)
, RVParamName (..)
, RVStatus (..)
, RVUserType (..)
, RVFlags (..)
, RowColumnData (..)
, TextPointer (..)
, TimeStamp (..)
, TypeInfo (..)
, RawBytes (..)
, Data (..)
, Null (..)
, Precision (..)
, Scale (..)
, Money (..)
, Collation (..)
, Collation32 (..)
, SortId (..)
, 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
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
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"
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"