{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- |
-- SQL Server client library implemented in Haskell
--
-- [Usage Example](https://github.com/mitsuji/mssql-simple-example/blob/master/app/Main.hs)


module Database.MSSQLServer.Connection
  (
    -- * Connect with the SQL Server
    -- $use

      ConnectInfo(..)
    , defaultConnectInfo
    , Connection(..)
    , connect
    , connectWithoutEncryption
    , close
    , ProtocolError(..)
    , AuthError(..)
    ) where

import qualified Network.Socket as Socket
import Network.Socket (AddrInfo(..),SocketType(..),Socket(..))
import Network.Socket.ByteString (recv)
import Network.Socket.ByteString.Lazy (sendAll)

import Data.Monoid ((<>),mempty)

import qualified Data.ByteString as B

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T

import qualified Data.Binary.Put as Put
import qualified Data.Binary.Get as Get

import Control.Monad (when)
import Control.Exception (Exception(..),throwIO)

import qualified Network.TLS as TLS
import Network.HostName (getHostName)

import Database.Tds.Message
import Database.Tds.Transport (contextNew)

import Data.Word (Word8,Word32)
import Data.Int (Int32)
import Data.Typeable(Typeable)

data ProtocolError = ProtocolError String
                   deriving (Int -> ProtocolError -> ShowS
[ProtocolError] -> ShowS
ProtocolError -> String
(Int -> ProtocolError -> ShowS)
-> (ProtocolError -> String)
-> ([ProtocolError] -> ShowS)
-> Show ProtocolError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolError] -> ShowS
$cshowList :: [ProtocolError] -> ShowS
show :: ProtocolError -> String
$cshow :: ProtocolError -> String
showsPrec :: Int -> ProtocolError -> ShowS
$cshowsPrec :: Int -> ProtocolError -> ShowS
Show,Typeable)
instance Exception ProtocolError

data AuthError = AuthError !Info
               deriving (Int -> AuthError -> ShowS
[AuthError] -> ShowS
AuthError -> String
(Int -> AuthError -> ShowS)
-> (AuthError -> String)
-> ([AuthError] -> ShowS)
-> Show AuthError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthError] -> ShowS
$cshowList :: [AuthError] -> ShowS
show :: AuthError -> String
$cshow :: AuthError -> String
showsPrec :: Int -> AuthError -> ShowS
$cshowsPrec :: Int -> AuthError -> ShowS
Show,Typeable)
instance Exception AuthError




data ConnectInfo = ConnectInfo { ConnectInfo -> String
connectHost :: !String
                               , ConnectInfo -> String
connectPort :: !String
                               , ConnectInfo -> String
connectDatabase :: !String
                               , ConnectInfo -> String
connectUser :: !String
                               , ConnectInfo -> String
connectPassword :: !String
                               , ConnectInfo -> Word8
connectEncryption :: !Word8
                               , ConnectInfo -> Word32
connectPacketSize :: !Word32
                               , ConnectInfo -> Word8
connectOptionFlags1 :: !Word8
                               , ConnectInfo -> Word8
connectOptionFlags2 :: !Word8
                               , ConnectInfo -> Word8
connectOptionFlags3 :: !Word8
                               , ConnectInfo -> Word8
connectTypeFlags :: !Word8
                               , ConnectInfo -> Int32
connectTimeZone :: !Int32
                               , ConnectInfo -> Word32
connectCollation :: !Collation32
                               , ConnectInfo -> String
connectLanguage :: !String
                               , ConnectInfo -> String
connectAppName :: !String
                               , ConnectInfo -> String
connectServerName :: !String
                               }

defaultConnectInfo :: ConnectInfo
defaultConnectInfo :: ConnectInfo
defaultConnectInfo =
  let
    l7 :: Login7
l7 = Login7
defaultLogin7
  in ConnectInfo :: String
-> String
-> String
-> String
-> String
-> Word8
-> Word32
-> Word8
-> Word8
-> Word8
-> Word8
-> Int32
-> Word32
-> String
-> String
-> String
-> ConnectInfo
ConnectInfo { connectHost :: String
connectHost = String
forall a. Monoid a => a
mempty
                 , connectPort :: String
connectPort = String
forall a. Monoid a => a
mempty
                 , connectDatabase :: String
connectDatabase = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7Database Login7
l7
                 , connectUser :: String
connectUser = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7UserName Login7
l7
                 , connectPassword :: String
connectPassword = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7Password Login7
l7
                 , connectEncryption :: Word8
connectEncryption = Word8
0x00 -- 0x00: ENCRYPT_OFF (Encrypt login packet only), 0x02: ENCRYPT_NOT_SUP (No encryption)
                 , connectPacketSize :: Word32
connectPacketSize = Login7 -> Word32
l7PacketSize Login7
l7
                 , connectOptionFlags1 :: Word8
connectOptionFlags1 = Login7 -> Word8
l7OptionFlags1 Login7
l7
                 , connectOptionFlags2 :: Word8
connectOptionFlags2 = Login7 -> Word8
l7OptionFlags2 Login7
l7
                 , connectOptionFlags3 :: Word8
connectOptionFlags3 = Login7 -> Word8
l7OptionFlags3 Login7
l7
                 , connectTypeFlags :: Word8
connectTypeFlags = Login7 -> Word8
l7TypeFlags Login7
l7
                 , connectTimeZone :: Int32
connectTimeZone = Login7 -> Int32
l7TimeZone Login7
l7
                 , connectCollation :: Word32
connectCollation = Login7 -> Word32
l7Collation Login7
l7
                 , connectLanguage :: String
connectLanguage = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7Language Login7
l7
                 , connectAppName :: String
connectAppName = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7AppName Login7
l7
                 , connectServerName :: String
connectServerName = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7ServerName Login7
l7
                 }

                   
data Connection = Connection Socket Word32


connect :: ConnectInfo -> IO Connection
connect :: ConnectInfo -> IO Connection
connect ci :: ConnectInfo
ci@(ConnectInfo String
host String
port String
_ String
_ String
_ Word8
encrypt Word32
ps Word8
_ Word8
_ Word8
_ Word8
_ Int32
_ Word32
_ String
_ String
_ String
_) = do
  AddrInfo
addr <- String -> String -> IO AddrInfo
resolve String
host String
port
  Socket
sock <- AddrInfo -> IO Socket
connect' AddrInfo
addr
  
  Prelogin [PreloginOption]
plResOpts <- Socket -> Word32 -> Word8 -> IO Prelogin
performPrelogin Socket
sock Word32
ps Word8
encrypt

  PLOEncryption Word8
modeEnc:[PreloginOption]
_  <- case (PreloginOption -> Bool) -> [PreloginOption] -> [PreloginOption]
forall a. (a -> Bool) -> [a] -> [a]
filter PreloginOption -> Bool
isPLOEncryption [PreloginOption]
plResOpts of
                                [] -> ProtocolError -> IO [PreloginOption]
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO [PreloginOption])
-> ProtocolError -> IO [PreloginOption]
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: PLOEncryption is necessary"
                                [PreloginOption]
xs -> [PreloginOption] -> IO [PreloginOption]
forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  PLOMars Word8
modeMars:[PreloginOption]
_ <- case (PreloginOption -> Bool) -> [PreloginOption] -> [PreloginOption]
forall a. (a -> Bool) -> [a] -> [a]
filter PreloginOption -> Bool
isPLOMars [PreloginOption]
plResOpts of
                          [] -> ProtocolError -> IO [PreloginOption]
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO [PreloginOption])
-> ProtocolError -> IO [PreloginOption]
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: PLOMars is necessary"
                          [PreloginOption]
xs -> [PreloginOption] -> IO [PreloginOption]
forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
modeEncWord8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
encrypt)  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO ()) -> ProtocolError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: Server reported unsupported encryption mode"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
modeMarsWord8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word8
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO ()) -> ProtocolError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: Server reported unsupported mars mode"

  Login7
login7 <- ConnectInfo -> IO Login7
newLogin7 ConnectInfo
ci

  TokenStreams
tss <- case Word8
encrypt of
    Word8
0x00 -> do
      ---
      --- TLS handshake
      ---
      Context
tlsContext <- Socket -> String -> IO Context
contextNew Socket
sock String
host
      Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
tlsContext

      --- 
      --- Login with encrypted packet
      --- 
      Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
tlsContext (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps (ClientMessage -> Put) -> ClientMessage -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> ClientMessage
CMLogin7 Login7
login7
      Socket -> Decoder TokenStreams -> IO TokenStreams
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock (Decoder TokenStreams -> IO TokenStreams)
-> Decoder TokenStreams -> IO TokenStreams
forall a b. (a -> b) -> a -> b
$ Get TokenStreams -> Decoder TokenStreams
forall a. Get a -> Decoder a
Get.runGetIncremental Get TokenStreams
forall a. ServerMessage a => Get a
getServerMessage
    Word8
0x02 -> do
      --- 
      --- Login without encryipted packet
      --- 
      Socket -> ByteString -> IO ()
sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps (ClientMessage -> Put) -> ClientMessage -> Put
forall a b. (a -> b) -> a -> b
$ Login7 -> ClientMessage
CMLogin7 Login7
login7
      Socket -> Decoder TokenStreams -> IO TokenStreams
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock (Decoder TokenStreams -> IO TokenStreams)
-> Decoder TokenStreams -> IO TokenStreams
forall a b. (a -> b) -> a -> b
$ Get TokenStreams -> Decoder TokenStreams
forall a. Get a -> Decoder a
Get.runGetIncremental Get TokenStreams
forall a. ServerMessage a => Get a
getServerMessage
      
  --- 
  --- Verify Ack
  --- 
  Login7 -> TokenStreams -> IO ()
validLoginAck Login7
login7 TokenStreams
tss
  
  Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection) -> Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ Socket -> Word32 -> Connection
Connection Socket
sock Word32
ps



connectWithoutEncryption :: ConnectInfo -> IO Connection
connectWithoutEncryption :: ConnectInfo -> IO Connection
connectWithoutEncryption ConnectInfo
ci = ConnectInfo -> IO Connection
connect (ConnectInfo -> IO Connection) -> ConnectInfo -> IO Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo
ci {connectEncryption :: Word8
connectEncryption = Word8
0x02}


close :: Connection -> IO ()
close :: Connection -> IO ()
close (Connection Socket
sock Word32
_ ) = Socket -> IO ()
Socket.close Socket
sock




performPrelogin :: Socket -> Word32 -> Word8 -> IO Prelogin
performPrelogin :: Socket -> Word32 -> Word8 -> IO Prelogin
performPrelogin Socket
sock Word32
ps Word8
enc = do
  -- https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-tds/60f56408-0188-4cd5-8b90-25c6f2423868
  --
  -- Prelogin
  --
  -- [TODO] Threadid support
  -- [TODO] Mars support
  let clientPrelogin :: Prelogin
clientPrelogin = [PreloginOption] -> Prelogin
Prelogin [ Word8 -> Word8 -> BuildVer -> BuildVer -> PreloginOption
PLOVersion Word8
8 Word8
0 BuildVer
341 BuildVer
0
                                , Word8 -> PreloginOption
PLOEncryption Word8
enc
                                , ByteString -> PreloginOption
PLOInstopt ByteString
"MSSQLServer"
                                , Maybe Word32 -> PreloginOption
PLOThreadid (Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
1000) -- [TODO]
                                , Word8 -> PreloginOption
PLOMars Word8
0 -- [TODO]
                                ]
  Socket -> ByteString -> IO ()
sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps (ClientMessage -> Put) -> ClientMessage -> Put
forall a b. (a -> b) -> a -> b
$ Prelogin -> ClientMessage
CMPrelogin Prelogin
clientPrelogin
  Prelogin
serverPrelogin <- Socket -> Decoder Prelogin -> IO Prelogin
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock (Decoder Prelogin -> IO Prelogin)
-> Decoder Prelogin -> IO Prelogin
forall a b. (a -> b) -> a -> b
$ Get Prelogin -> Decoder Prelogin
forall a. Get a -> Decoder a
Get.runGetIncremental Get Prelogin
forall a. ServerMessage a => Get a
getServerMessage
  
  Prelogin -> IO Prelogin
forall (m :: * -> *) a. Monad m => a -> m a
return Prelogin
serverPrelogin


  
newLogin7 :: ConnectInfo -> IO Login7
newLogin7 :: ConnectInfo -> IO Login7
newLogin7 (ConnectInfo String
_ String
_ String
database String
user String
pass Word8
_ Word32
_ Word8
optf1 Word8
optf2 Word8
optf3 Word8
typef Int32
tz Word32
coll String
lang String
app String
serv) = do
  ---
  --- Login7
  ---
  -- [TODO] process ID support
  -- [TODO] MAC address support
  String
hostname <- IO String
getHostName
  let login7 :: Login7
login7 = Login7
defaultLogin7 { l7ClientProgVer :: Word32
l7ClientProgVer = Word32
1
                             , l7OptionFlags1 :: Word8
l7OptionFlags1 = Word8
optf1
                             , l7OptionFlags2 :: Word8
l7OptionFlags2 = Word8
optf2
                             , l7OptionFlags3 :: Word8
l7OptionFlags3 = Word8
optf3
                             , l7TypeFlags :: Word8
l7TypeFlags = Word8
typef
                             , l7TimeZone :: Int32
l7TimeZone = Int32
tz
                             , l7Collation :: Word32
l7Collation = Word32
coll
                             , l7CltIntName :: Text
l7CltIntName = String -> Text
T.pack String
"mssql-simple"
                             , l7Language :: Text
l7Language = String -> Text
T.pack String
lang
                             , l7ClientPID :: Word32
l7ClientPID = Word32
1 -- [TODO]
                             , l7ClientMacAddr :: ByteString
l7ClientMacAddr = [Word8] -> ByteString
B.pack [Word8
0x00,Word8
0x00,Word8
0x00,Word8
0x00,Word8
0x00,Word8
0x00] -- [TODO]
                             , l7ClientHostName :: Text
l7ClientHostName = String -> Text
T.pack String
hostname
                             , l7AppName :: Text
l7AppName = String -> Text
T.pack String
app
                             , l7ServerName :: Text
l7ServerName = String -> Text
T.pack String
serv
                             , l7UserName :: Text
l7UserName = String -> Text
T.pack String
user
                             , l7Password :: Text
l7Password = String -> Text
T.pack String
pass
                             , l7Database :: Text
l7Database = String -> Text
T.pack String
database
                             }
  Login7 -> IO Login7
forall (m :: * -> *) a. Monad m => a -> m a
return Login7
login7



validLoginAck :: Login7 -> TokenStreams -> IO ()
validLoginAck :: Login7 -> TokenStreams -> IO ()
validLoginAck Login7
login7 (TokenStreams [TokenStream]
loginResTokenStreams) = do

  let loginAcks :: [TokenStream]
loginAcks   = (TokenStream -> Bool) -> [TokenStream] -> [TokenStream]
forall a. (a -> Bool) -> [a] -> [a]
filter TokenStream -> Bool
isTSLoginAck [TokenStream]
loginResTokenStreams
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TokenStream] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TokenStream]
loginAcks) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TSError Info
info:[TokenStream]
_ <- case (TokenStream -> Bool) -> [TokenStream] -> [TokenStream]
forall a. (a -> Bool) -> [a] -> [a]
filter TokenStream -> Bool
isTSError [TokenStream]
loginResTokenStreams of
                        [] -> ProtocolError -> IO [TokenStream]
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO [TokenStream])
-> ProtocolError -> IO [TokenStream]
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"validLoginAck: TSError is necessary"
                        [TokenStream]
xs -> [TokenStream] -> IO [TokenStream]
forall (m :: * -> *) a. Monad m => a -> m a
return [TokenStream]
xs
    AuthError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AuthError -> IO ()) -> AuthError -> IO ()
forall a b. (a -> b) -> a -> b
$ Info -> AuthError
AuthError Info
info

  let (TSLoginAck Word8
_ Word32
tdsVersion' Text
_ Word32
_):[TokenStream]
_ = [TokenStream]
loginAcks
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
tdsVersion Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
tdsVersion') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO ()) -> ProtocolError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"validLoginAck: Server reported unsupported tds version"

  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where

    isTSLoginAck :: TokenStream -> Bool
    isTSLoginAck :: TokenStream -> Bool
isTSLoginAck (TSLoginAck{}) = Bool
True
    isTSLoginAck TokenStream
_ = Bool
False

    isTSError :: TokenStream -> Bool
    isTSError :: TokenStream -> Bool
isTSError (TSError{}) = Bool
True
    isTSError TokenStream
_ = Bool
False

    printEnvChange :: TokenStream -> IO ()
    printEnvChange :: TokenStream -> IO ()
printEnvChange (TSEnvChange Word8
t ByteString
o ByteString
n) = do
      String -> IO ()
putStr String
"TSEnvChange: "
      case Word8
t of
        Word8
1 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Database: "   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
2 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Language: "   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
3 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Charset: "    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
4 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"PacketSize: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
5 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"DSLID:      " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
6 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"DSCFlags: "   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
7 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Collaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
o String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
        Word8
8 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"BeginTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
        Word8
9 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CommitTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
o
        Word8
10 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"RollbackTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
o
        Word8
11 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"EnlistDTCTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
o
        Word8
12 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DefactTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
        Word8
13 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"MirrorPartner: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
15 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"PromoteTran: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
        Word8
16 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"TranManAddr: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
        Word8
17 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"TranEndedr: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
o
        Word8
18 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ResetAck: "
        Word8
19 -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"SendsBackInfo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf16LE ByteString
n
        Word8
20 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Routing: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
n
      String -> IO ()
putStrLn String
forall a. Monoid a => a
mempty



isPLOEncryption :: PreloginOption -> Bool
isPLOEncryption :: PreloginOption -> Bool
isPLOEncryption (PLOEncryption{}) = Bool
True
isPLOEncryption PreloginOption
_ = Bool
False

isPLOMars :: PreloginOption -> Bool
isPLOMars :: PreloginOption -> Bool
isPLOMars (PLOMars{}) = Bool
True
isPLOMars PreloginOption
_ = Bool
False

resolve :: String -> String -> IO AddrInfo
resolve String
host String
port = do
  let hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints { addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
  AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just String
port)
  AddrInfo -> IO AddrInfo
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
addr

connect' :: AddrInfo -> IO Socket
connect' AddrInfo
addr = do
  Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
  Socket -> SockAddr -> IO ()
Socket.connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
  Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

readMessage :: Socket -> Get.Decoder a -> IO a
readMessage :: Socket -> Decoder a -> IO a
readMessage Socket
sock Decoder a
decoder = do
  ByteString
bs <- Socket -> Int -> IO ByteString
recv Socket
sock Int
512 -- [TODO] optimize
  case Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
Get.pushChunk Decoder a
decoder ByteString
bs of
    Get.Done ByteString
_ ByteOffset
_ a
msg -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
msg
    Decoder a
decoder' -> Socket -> Decoder a -> IO a
forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock Decoder a
decoder'




-- $use
-- 'connect' and 'close' function could be used as follows.
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Main where
-- >
-- > import Network.Socket (withSocketsDo)
-- > import Control.Exception (bracket)
-- >
-- > import Database.MSSQLServer.Connection
-- > import Database.MSSQLServer.Query
-- >
-- > main :: IO ()
-- > main = do
-- >   let info = defaultConnectInfo { connectHost = "192.168.0.1"
-- >                                 , connectPort = "1433"
-- >                                 , connectDatabase = "some_database"
-- >                                 , connectUser = "some_user"
-- >                                 , connectPassword = "some_password"
-- >                                 }
-- >   withSocketsDo $
-- >     bracket (connect info) close $ \conn -> do
-- >     rs <- sql conn "SELECT 2 + 2" :: IO [Only Int]
-- >     print rs