-- | MSSQL Connection Pooling
module Database.MSSQL.Pool
  ( -- * Types
    ConnectionString (..),
    ConnectionOptions (..),
    MSSQLPool (..),

    -- * Functions
    initMSSQLPool,
    drainMSSQLPool,
    withMSSQLPool,
  )
where

import Control.Exception.Lifted
import Control.Monad.Trans.Control
import Data.Aeson
import Data.Pool qualified as Pool
import Database.ODBC.SQLServer qualified as ODBC
import Hasura.Prelude (Generic, Text)
import Prelude

-- | ODBC connection string for MSSQL server
newtype ConnectionString = ConnectionString {ConnectionString -> Text
unConnectionString :: Text}
  deriving (Int -> ConnectionString -> ShowS
[ConnectionString] -> ShowS
ConnectionString -> String
(Int -> ConnectionString -> ShowS)
-> (ConnectionString -> String)
-> ([ConnectionString] -> ShowS)
-> Show ConnectionString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionString] -> ShowS
$cshowList :: [ConnectionString] -> ShowS
show :: ConnectionString -> String
$cshow :: ConnectionString -> String
showsPrec :: Int -> ConnectionString -> ShowS
$cshowsPrec :: Int -> ConnectionString -> ShowS
Show, ConnectionString -> ConnectionString -> Bool
(ConnectionString -> ConnectionString -> Bool)
-> (ConnectionString -> ConnectionString -> Bool)
-> Eq ConnectionString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionString -> ConnectionString -> Bool
$c/= :: ConnectionString -> ConnectionString -> Bool
== :: ConnectionString -> ConnectionString -> Bool
$c== :: ConnectionString -> ConnectionString -> Bool
Eq, [ConnectionString] -> Value
[ConnectionString] -> Encoding
ConnectionString -> Value
ConnectionString -> Encoding
(ConnectionString -> Value)
-> (ConnectionString -> Encoding)
-> ([ConnectionString] -> Value)
-> ([ConnectionString] -> Encoding)
-> ToJSON ConnectionString
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ConnectionString] -> Encoding
$ctoEncodingList :: [ConnectionString] -> Encoding
toJSONList :: [ConnectionString] -> Value
$ctoJSONList :: [ConnectionString] -> Value
toEncoding :: ConnectionString -> Encoding
$ctoEncoding :: ConnectionString -> Encoding
toJSON :: ConnectionString -> Value
$ctoJSON :: ConnectionString -> Value
ToJSON, Value -> Parser [ConnectionString]
Value -> Parser ConnectionString
(Value -> Parser ConnectionString)
-> (Value -> Parser [ConnectionString])
-> FromJSON ConnectionString
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ConnectionString]
$cparseJSONList :: Value -> Parser [ConnectionString]
parseJSON :: Value -> Parser ConnectionString
$cparseJSON :: Value -> Parser ConnectionString
FromJSON, (forall x. ConnectionString -> Rep ConnectionString x)
-> (forall x. Rep ConnectionString x -> ConnectionString)
-> Generic ConnectionString
forall x. Rep ConnectionString x -> ConnectionString
forall x. ConnectionString -> Rep ConnectionString x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConnectionString x -> ConnectionString
$cfrom :: forall x. ConnectionString -> Rep ConnectionString x
Generic)

data ConnectionOptions = ConnectionOptions
  { ConnectionOptions -> Int
_coConnections :: Int,
    ConnectionOptions -> Int
_coStripes :: Int,
    ConnectionOptions -> Int
_coIdleTime :: Int
  }
  deriving (Int -> ConnectionOptions -> ShowS
[ConnectionOptions] -> ShowS
ConnectionOptions -> String
(Int -> ConnectionOptions -> ShowS)
-> (ConnectionOptions -> String)
-> ([ConnectionOptions] -> ShowS)
-> Show ConnectionOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionOptions] -> ShowS
$cshowList :: [ConnectionOptions] -> ShowS
show :: ConnectionOptions -> String
$cshow :: ConnectionOptions -> String
showsPrec :: Int -> ConnectionOptions -> ShowS
$cshowsPrec :: Int -> ConnectionOptions -> ShowS
Show, ConnectionOptions -> ConnectionOptions -> Bool
(ConnectionOptions -> ConnectionOptions -> Bool)
-> (ConnectionOptions -> ConnectionOptions -> Bool)
-> Eq ConnectionOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionOptions -> ConnectionOptions -> Bool
$c/= :: ConnectionOptions -> ConnectionOptions -> Bool
== :: ConnectionOptions -> ConnectionOptions -> Bool
$c== :: ConnectionOptions -> ConnectionOptions -> Bool
Eq)

-- | ODBC connection pool
newtype MSSQLPool = MSSQLPool (Pool.Pool ODBC.Connection)

-- | Initialize an MSSQL pool with given connection configuration
initMSSQLPool ::
  ConnectionString ->
  ConnectionOptions ->
  IO MSSQLPool
initMSSQLPool :: ConnectionString -> ConnectionOptions -> IO MSSQLPool
initMSSQLPool (ConnectionString Text
connString) ConnectionOptions {Int
_coIdleTime :: Int
_coStripes :: Int
_coConnections :: Int
_coIdleTime :: ConnectionOptions -> Int
_coStripes :: ConnectionOptions -> Int
_coConnections :: ConnectionOptions -> Int
..} = do
  Pool Connection -> MSSQLPool
MSSQLPool
    (Pool Connection -> MSSQLPool)
-> IO (Pool Connection) -> IO MSSQLPool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool
      (Text -> IO Connection
forall (m :: * -> *). MonadIO m => Text -> m Connection
ODBC.connect Text
connString)
      Connection -> IO ()
forall (m :: * -> *). MonadIO m => Connection -> m ()
ODBC.close
      Int
_coStripes
      (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_coIdleTime)
      Int
_coConnections

-- | Destroy all pool resources
drainMSSQLPool :: MSSQLPool -> IO ()
drainMSSQLPool :: MSSQLPool -> IO ()
drainMSSQLPool (MSSQLPool Pool Connection
pool) =
  Pool Connection -> IO ()
forall a. Pool a -> IO ()
Pool.destroyAllResources Pool Connection
pool

withMSSQLPool ::
  (MonadBaseControl IO m) =>
  MSSQLPool ->
  (ODBC.Connection -> m a) ->
  m (Either ODBC.ODBCException a)
withMSSQLPool :: MSSQLPool -> (Connection -> m a) -> m (Either ODBCException a)
withMSSQLPool (MSSQLPool Pool Connection
pool) Connection -> m a
action = do
  m a -> m (Either ODBCException a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either ODBCException a))
-> m a -> m (Either ODBCException a)
forall a b. (a -> b) -> a -> b
$ Pool Connection -> (Connection -> m a) -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource Pool Connection
pool Connection -> m a
action