{-# 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
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
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 -> 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 = forall a. Monoid a => a
mempty
                 , connectPort :: String
connectPort = forall a. Monoid a => a
mempty
                 , connectDatabase :: String
connectDatabase = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7Database Login7
l7
                 , connectUser :: String
connectUser = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7UserName Login7
l7
                 , connectPassword :: String
connectPassword = Text -> String
T.unpack 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 forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7Language Login7
l7
                 , connectAppName :: String
connectAppName = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Login7 -> Text
l7AppName Login7
l7
                 , connectServerName :: String
connectServerName = Text -> String
T.unpack 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 forall a. (a -> Bool) -> [a] -> [a]
filter PreloginOption -> Bool
isPLOEncryption [PreloginOption]
plResOpts of
                                [] -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: PLOEncryption is necessary"
                                [PreloginOption]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  PLOMars ECType
modeMars:[PreloginOption]
_ <- case forall a. (a -> Bool) -> [a] -> [a]
filter PreloginOption -> Bool
isPLOMars [PreloginOption]
plResOpts of
                          [] -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: PLOMars is necessary"
                          [PreloginOption]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return [PreloginOption]
xs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ECType
modeEncforall a. Eq a => a -> a -> Bool
/=ECType
encrypt)  forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"connect: Server reported unsupported encryption mode"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ECType
modeMarsforall a. Eq a => a -> a -> Bool
/=ECType
0) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO 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
      forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
tlsContext

      --- 
      --- Login with encrypted packet
      --- 
      forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
tlsContext forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps forall a b. (a -> b) -> a -> b
$ Login7 -> ClientMessage
CMLogin7 Login7
login7
      forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock forall a b. (a -> b) -> a -> b
$ forall a. Get a -> Decoder a
Get.runGetIncremental forall a. ServerMessage a => Get a
getServerMessage
    ECType
0x02 -> do
      --- 
      --- Login without encryipted packet
      --- 
      Socket -> ByteString -> IO ()
sendAll Socket
sock forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps forall a b. (a -> b) -> a -> b
$ Login7 -> ClientMessage
CMLogin7 Login7
login7
      forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock forall a b. (a -> b) -> a -> b
$ forall a. Get a -> Decoder a
Get.runGetIncremental forall a. ServerMessage a => Get a
getServerMessage
      
  --- 
  --- Verify Ack
  --- 
  Login7 -> TokenStreams -> IO ()
validLoginAck Login7
login7 TokenStreams
tss
  
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ ConnectInfo
ci {connectEncryption :: ECType
connectEncryption = ECType
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 (forall a. a -> Maybe a
Just Word32
1000) -- [TODO]
                                , ECType -> PreloginOption
PLOMars ECType
0 -- [TODO]
                                ]
  Socket -> ByteString -> IO ()
sendAll Socket
sock forall a b. (a -> b) -> a -> b
$ Put -> ByteString
Put.runPut forall a b. (a -> b) -> a -> b
$ Word32 -> ClientMessage -> Put
putClientMessage Word32
ps forall a b. (a -> b) -> a -> b
$ Prelogin -> ClientMessage
CMPrelogin Prelogin
clientPrelogin
  Prelogin
serverPrelogin <- forall a. Socket -> Decoder a -> IO a
readMessage Socket
sock forall a b. (a -> b) -> a -> b
$ forall a. Get a -> Decoder a
Get.runGetIncremental forall a. ServerMessage a => Get a
getServerMessage
  
  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 :: Word32
l7ClientProgVer = Word32
1
                             , l7OptionFlags1 :: ECType
l7OptionFlags1 = ECType
optf1
                             , l7OptionFlags2 :: ECType
l7OptionFlags2 = ECType
optf2
                             , l7OptionFlags3 :: ECType
l7OptionFlags3 = ECType
optf3
                             , l7TypeFlags :: ECType
l7TypeFlags = ECType
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 :: ECNewValue
l7ClientMacAddr = [ECType] -> ECNewValue
B.pack [ECType
0x00,ECType
0x00,ECType
0x00,ECType
0x00,ECType
0x00,ECType
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
                             }
  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   = forall a. (a -> Bool) -> [a] -> [a]
filter TokenStream -> Bool
isTSLoginAck [TokenStream]
loginResTokenStreams
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TokenStream]
loginAcks) forall a b. (a -> b) -> a -> b
$ do
    TSError Info
info:[TokenStream]
_ <- case forall a. (a -> Bool) -> [a] -> [a]
filter TokenStream -> Bool
isTSError [TokenStream]
loginResTokenStreams of
                        [] -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError String
"validLoginAck: TSError is necessary"
                        [TokenStream]
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return [TokenStream]
xs
    forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Info -> AuthError
AuthError Info
info

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

  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 forall a b. (a -> b) -> a -> b
$ Text
"Database: "   forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
2 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"Language: "   forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
3 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"Charset: "    forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
4 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"PacketSize: " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
o forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
5 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"DSLID:      " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
6 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"DSCFlags: "   forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
7 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"Collaction: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
o forall a. Semigroup a => a -> a -> a
<> String
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
        ECType
8 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"BeginTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
        ECType
9 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"CommitTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
o
        ECType
10 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"RollbackTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
o
        ECType
11 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"EnlistDTCTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
o
        ECType
12 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"DefactTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
        ECType
13 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"MirrorPartner: " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
15 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"PromoteTran: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
        ECType
16 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"TranManAddr: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
        ECType
17 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"TranEndedr: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
o
        ECType
18 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"ResetAck: "
        ECType
19 -> Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ Text
"SendsBackInfo: " forall a. Semigroup a => a -> a -> a
<> ECNewValue -> Text
T.decodeUtf16LE ECNewValue
n
        ECType
20 -> String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"Routing: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ECNewValue
n
      String -> IO ()
putStrLn 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 (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
host) (forall a. a -> Maybe a
Just String
port)
  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 forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
  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 forall a. Decoder a -> ECNewValue -> Decoder a
Get.pushChunk Decoder a
decoder ECNewValue
bs of
    Get.Done ECNewValue
_ ByteOffset
_ a
msg -> forall (m :: * -> *) a. Monad m => a -> m a
return a
msg
    Decoder a
decoder' -> 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