{-# 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
$cshowsPrec :: Int -> ProtocolError -> ShowS
showsPrec :: Int -> ProtocolError -> ShowS
$cshow :: ProtocolError -> String
show :: ProtocolError -> String
$cshowList :: [ProtocolError] -> ShowS
showList :: [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
$cshowsPrec :: Int -> AuthError -> ShowS
showsPrec :: Int -> AuthError -> ShowS
$cshow :: AuthError -> String
show :: AuthError -> String
$cshowList :: [AuthError] -> ShowS
showList :: [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 -> ECType
connectEncryption :: !Word8
                               , ConnectInfo -> Word32
connectPacketSize :: !Word32
                               , ConnectInfo -> ECType
connectOptionFlags1 :: !Word8
                               , ConnectInfo -> ECType
connectOptionFlags2 :: !Word8
                               , ConnectInfo -> ECType
connectOptionFlags3 :: !Word8
                               , ConnectInfo -> ECType
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 { 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 :: ECType
connectEncryption = ECType
0x00 -- 0x00: ENCRYPT_OFF (Encrypt login packet only), 0x02: ENCRYPT_NOT_SUP (No encryption)
                 , connectPacketSize :: Word32
connectPacketSize = Login7 -> Word32
l7PacketSize Login7
l7
                 , connectOptionFlags1 :: ECType
connectOptionFlags1 = Login7 -> ECType
l7OptionFlags1 Login7
l7
                 , connectOptionFlags2 :: ECType
connectOptionFlags2 = Login7 -> ECType
l7OptionFlags2 Login7
l7
                 , connectOptionFlags3 :: ECType
connectOptionFlags3 = Login7 -> ECType
l7OptionFlags3 Login7
l7
                 , connectTypeFlags :: ECType
connectTypeFlags = Login7 -> ECType
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
_ ECType
encrypt Word32
ps ECType
_ ECType
_ ECType
_ ECType
_ 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 -> ECType -> IO Prelogin
performPrelogin Socket
sock Word32
ps ECType
encrypt

  PLOEncryption ECType
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  PLOMars ECType
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ECType
modeEncECType -> ECType -> Bool
forall a. Eq a => a -> a -> Bool
/=ECType
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 (ECType
modeMarsECType -> ECType -> Bool
forall a. Eq a => a -> a -> Bool
/=ECType
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 ECType
encrypt of
    ECType
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
    ECType
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 a. a -> IO a
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 = 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 -> ECType -> IO Prelogin
performPrelogin Socket
sock Word32
ps ECType
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 [ ECType -> ECType -> BuildVer -> BuildVer -> PreloginOption
PLOVersion ECType
8 ECType
0 BuildVer
341 BuildVer
0
                                , ECType -> PreloginOption
PLOEncryption ECType
enc
                                , ECNewValue -> PreloginOption
PLOInstopt ECNewValue
"MSSQLServer"
                                , Maybe Word32 -> PreloginOption
PLOThreadid (Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
1000) -- [TODO]
                                , ECType -> PreloginOption
PLOMars ECType
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 a. a -> IO a
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 ECType
_ Word32
_ ECType
optf1 ECType
optf2 ECType
optf3 ECType
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 = 1
                             , l7OptionFlags1 = optf1
                             , l7OptionFlags2 = optf2
                             , l7OptionFlags3 = optf3
                             , l7TypeFlags = typef
                             , l7TimeZone = tz
                             , l7Collation = coll
                             , l7CltIntName = T.pack "mssql-simple"
                             , l7Language = T.pack lang
                             , l7ClientPID = 1 -- [TODO]
                             , l7ClientMacAddr = B.pack [0x00,0x00,0x00,0x00,0x00,0x00] -- [TODO]
                             , l7ClientHostName = T.pack hostname
                             , l7AppName = T.pack app
                             , l7ServerName = T.pack serv
                             , l7UserName = T.pack user
                             , l7Password = T.pack pass
                             , l7Database = T.pack database
                             }
  Login7 -> IO Login7
forall a. a -> IO a
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 a. [a] -> 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 a. a -> IO a
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 ECType
_ 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 a. a -> IO a
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 ECType
t ECNewValue
o ECNewValue
n) = do
      String -> IO ()
putStr String
"TSEnvChange: "
      case ECType
t of
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
o String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
o
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
o
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
o
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
n
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
o
        ECType
18 -> String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ResetAck: "
        ECType
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
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
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
<> ECNewValue -> String
forall a. Show a => a -> String
show ECNewValue
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 = 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

readMessage :: Socket -> Get.Decoder a -> IO a
readMessage :: forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock Decoder a
decoder = do
  ECNewValue
bs <- Socket -> Int -> IO ECNewValue
recv Socket
sock Int
512 -- [TODO] optimize
  case Decoder a -> ECNewValue -> Decoder a
forall a. Decoder a -> ECNewValue -> Decoder a
Get.pushChunk Decoder a
decoder ECNewValue
bs of
    Get.Done ECNewValue
_ ByteOffset
_ a
msg -> a -> IO a
forall a. 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