2022-03-16 03:39:21 +03:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2022-01-14 17:08:17 +03:00
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
|
2022-01-03 20:16:24 +03:00
|
|
|
-- | MSSQL Connection
|
|
|
|
--
|
|
|
|
-- This module handles the connection against an MS SQL Server.
|
|
|
|
-- It defines the connection string, connection pool, default settings,
|
|
|
|
-- and conversion functions between MSSQL and graphql-engine.
|
2021-11-04 19:08:33 +03:00
|
|
|
module Hasura.Backends.MSSQL.Connection
|
|
|
|
( MSSQLConnConfiguration (MSSQLConnConfiguration),
|
2022-01-04 14:53:50 +03:00
|
|
|
MSSQLSourceConfig (MSSQLSourceConfig, _mscExecCtx),
|
|
|
|
MSSQLExecCtx (..),
|
2022-02-24 11:13:19 +03:00
|
|
|
MonadMSSQLTx (..),
|
2021-11-04 19:08:33 +03:00
|
|
|
createMSSQLPool,
|
|
|
|
getEnv,
|
|
|
|
odbcValueToJValue,
|
2022-01-04 14:53:50 +03:00
|
|
|
mkMSSQLExecCtx,
|
2022-04-21 10:19:37 +03:00
|
|
|
runMSSQLSourceReadTx,
|
|
|
|
runMSSQLSourceWriteTx,
|
2021-11-04 19:08:33 +03:00
|
|
|
)
|
|
|
|
where
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2022-02-24 11:13:19 +03:00
|
|
|
import Control.Monad.Morph (hoist)
|
2021-10-22 17:49:15 +03:00
|
|
|
import Control.Monad.Trans.Control
|
2021-09-24 01:56:37 +03:00
|
|
|
import Data.Aeson
|
2021-10-01 15:52:19 +03:00
|
|
|
import Data.Aeson qualified as J
|
2021-09-24 01:56:37 +03:00
|
|
|
import Data.Aeson.TH
|
|
|
|
import Data.Environment qualified as Env
|
|
|
|
import Data.Text (pack, unpack)
|
2022-01-14 17:08:17 +03:00
|
|
|
import Database.MSSQL.Pool qualified as MSPool
|
|
|
|
import Database.MSSQL.Transaction qualified as MSTx
|
2021-09-24 01:56:37 +03:00
|
|
|
import Database.ODBC.SQLServer qualified as ODBC
|
2022-02-07 17:11:49 +03:00
|
|
|
import Hasura.Backends.MSSQL.SQL.Error
|
2021-09-24 01:56:37 +03:00
|
|
|
import Hasura.Base.Error
|
|
|
|
import Hasura.Incremental (Cacheable (..))
|
|
|
|
import Hasura.Prelude
|
2021-09-09 13:37:50 +03:00
|
|
|
|
2022-02-24 11:13:19 +03:00
|
|
|
class MonadError QErr m => MonadMSSQLTx m where
|
|
|
|
liftMSSQLTx :: MSTx.TxE QErr a -> m a
|
|
|
|
|
|
|
|
instance MonadMSSQLTx m => MonadMSSQLTx (ReaderT s m) where
|
|
|
|
liftMSSQLTx = lift . liftMSSQLTx
|
|
|
|
|
|
|
|
instance MonadMSSQLTx m => MonadMSSQLTx (StateT s m) where
|
|
|
|
liftMSSQLTx = lift . liftMSSQLTx
|
|
|
|
|
|
|
|
instance (Monoid w, MonadMSSQLTx m) => MonadMSSQLTx (WriterT w m) where
|
|
|
|
liftMSSQLTx = lift . liftMSSQLTx
|
|
|
|
|
|
|
|
instance MonadIO m => MonadMSSQLTx (MSTx.TxET QErr m) where
|
|
|
|
liftMSSQLTx = hoist liftIO
|
|
|
|
|
|
|
|
-- | ODBC connection string for MSSQL server
|
|
|
|
newtype MSSQLConnectionString = MSSQLConnectionString {unMSSQLConnectionString :: Text}
|
|
|
|
deriving (Show, Eq, ToJSON, FromJSON, Cacheable, Hashable, NFData)
|
|
|
|
|
2022-01-14 17:08:17 +03:00
|
|
|
-- * Orphan instances
|
|
|
|
|
|
|
|
instance Cacheable MSPool.ConnectionString
|
|
|
|
|
|
|
|
instance Hashable MSPool.ConnectionString
|
|
|
|
|
|
|
|
instance NFData MSPool.ConnectionString
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
data InputConnectionString
|
2022-07-29 17:05:03 +03:00
|
|
|
= RawString MSPool.ConnectionString
|
|
|
|
| FromEnvironment Text
|
2021-03-18 21:32:47 +03:00
|
|
|
deriving stock (Show, Eq, Generic)
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
instance Cacheable InputConnectionString
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
instance Hashable InputConnectionString
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
instance NFData InputConnectionString
|
|
|
|
|
|
|
|
instance ToJSON InputConnectionString where
|
|
|
|
toJSON =
|
|
|
|
\case
|
2021-09-24 01:56:37 +03:00
|
|
|
(RawString m) -> toJSON m
|
2021-03-18 21:32:47 +03:00
|
|
|
(FromEnvironment wEnv) -> object ["from_env" .= wEnv]
|
|
|
|
|
|
|
|
instance FromJSON InputConnectionString where
|
|
|
|
parseJSON =
|
|
|
|
\case
|
2021-09-24 01:56:37 +03:00
|
|
|
(Object o) -> FromEnvironment <$> o .: "from_env"
|
2021-03-18 21:32:47 +03:00
|
|
|
s@(String _) -> RawString <$> parseJSON s
|
2021-09-24 01:56:37 +03:00
|
|
|
_ -> fail "one of string or object must be provided"
|
|
|
|
|
|
|
|
data MSSQLPoolSettings = MSSQLPoolSettings
|
2022-07-29 17:05:03 +03:00
|
|
|
{ _mpsMaxConnections :: Int,
|
|
|
|
_mpsIdleTimeout :: Int
|
2021-09-24 01:56:37 +03:00
|
|
|
}
|
|
|
|
deriving (Show, Eq, Generic)
|
2021-03-18 21:32:47 +03:00
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
instance Cacheable MSSQLPoolSettings
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
instance Hashable MSSQLPoolSettings
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
instance NFData MSSQLPoolSettings
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
$(deriveToJSON hasuraJSON ''MSSQLPoolSettings)
|
|
|
|
|
|
|
|
instance FromJSON MSSQLPoolSettings where
|
|
|
|
parseJSON = withObject "MSSQL pool settings" $ \o ->
|
|
|
|
MSSQLPoolSettings
|
|
|
|
<$> o .:? "max_connections" .!= _mpsMaxConnections defaultMSSQLPoolSettings
|
2021-09-24 01:56:37 +03:00
|
|
|
<*> o .:? "idle_timeout" .!= _mpsIdleTimeout defaultMSSQLPoolSettings
|
2021-02-25 21:15:55 +03:00
|
|
|
|
|
|
|
defaultMSSQLPoolSettings :: MSSQLPoolSettings
|
|
|
|
defaultMSSQLPoolSettings =
|
|
|
|
MSSQLPoolSettings
|
2021-09-24 01:56:37 +03:00
|
|
|
{ _mpsMaxConnections = 50,
|
|
|
|
_mpsIdleTimeout = 5
|
|
|
|
}
|
|
|
|
|
|
|
|
data MSSQLConnectionInfo = MSSQLConnectionInfo
|
2022-07-29 17:05:03 +03:00
|
|
|
{ _mciConnectionString :: InputConnectionString,
|
|
|
|
_mciPoolSettings :: MSSQLPoolSettings
|
2021-02-25 21:15:55 +03:00
|
|
|
}
|
2021-09-24 01:56:37 +03:00
|
|
|
deriving (Show, Eq, Generic)
|
2021-02-25 21:15:55 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance Cacheable MSSQLConnectionInfo
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance Hashable MSSQLConnectionInfo
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance NFData MSSQLConnectionInfo
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
$(deriveToJSON hasuraJSON ''MSSQLConnectionInfo)
|
|
|
|
|
|
|
|
instance FromJSON MSSQLConnectionInfo where
|
|
|
|
parseJSON = withObject "Object" $ \o ->
|
|
|
|
MSSQLConnectionInfo
|
|
|
|
<$> ((o .: "database_url") <|> (o .: "connection_string"))
|
|
|
|
<*> o .:? "pool_settings" .!= defaultMSSQLPoolSettings
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
data MSSQLConnConfiguration = MSSQLConnConfiguration
|
2022-07-29 17:05:03 +03:00
|
|
|
{ _mccConnectionInfo :: MSSQLConnectionInfo,
|
|
|
|
_mccReadReplicas :: Maybe (NonEmpty MSSQLConnectionInfo)
|
2021-09-24 01:56:37 +03:00
|
|
|
}
|
|
|
|
deriving (Show, Eq, Generic)
|
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance Cacheable MSSQLConnConfiguration
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance Hashable MSSQLConnConfiguration
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
instance NFData MSSQLConnConfiguration
|
2021-09-24 01:56:37 +03:00
|
|
|
|
2022-01-11 12:51:05 +03:00
|
|
|
$(deriveJSON hasuraJSON {omitNothingFields = True} ''MSSQLConnConfiguration)
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
createMSSQLPool ::
|
|
|
|
MonadIO m =>
|
|
|
|
QErrM m =>
|
|
|
|
MSSQLConnectionInfo ->
|
|
|
|
Env.Environment ->
|
2022-01-14 17:08:17 +03:00
|
|
|
m (MSPool.ConnectionString, MSPool.MSSQLPool)
|
2021-09-24 01:56:37 +03:00
|
|
|
createMSSQLPool (MSSQLConnectionInfo iConnString MSSQLPoolSettings {..}) env = do
|
2021-03-18 21:32:47 +03:00
|
|
|
connString <- resolveInputConnectionString env iConnString
|
2022-01-14 17:08:17 +03:00
|
|
|
let connOptions =
|
|
|
|
MSPool.ConnectionOptions
|
|
|
|
{ _coConnections = _mpsMaxConnections,
|
|
|
|
_coStripes = 1,
|
|
|
|
_coIdleTime = fromIntegral _mpsIdleTimeout
|
|
|
|
}
|
|
|
|
pool <- liftIO $ MSPool.initMSSQLPool connString connOptions
|
2021-03-18 21:32:47 +03:00
|
|
|
pure (connString, pool)
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
resolveInputConnectionString ::
|
|
|
|
QErrM m =>
|
|
|
|
Env.Environment ->
|
|
|
|
InputConnectionString ->
|
2022-01-14 17:08:17 +03:00
|
|
|
m MSPool.ConnectionString
|
2021-03-18 21:32:47 +03:00
|
|
|
resolveInputConnectionString env =
|
|
|
|
\case
|
2021-09-24 01:56:37 +03:00
|
|
|
(RawString cs) -> pure cs
|
2022-01-14 17:08:17 +03:00
|
|
|
(FromEnvironment envVar) -> MSPool.ConnectionString <$> getEnv env envVar
|
2021-03-18 21:32:47 +03:00
|
|
|
|
|
|
|
getEnv :: QErrM m => Env.Environment -> Text -> m Text
|
|
|
|
getEnv env k = do
|
|
|
|
let mEnv = Env.lookupEnv env (unpack k)
|
|
|
|
case mEnv of
|
2021-09-24 01:56:37 +03:00
|
|
|
Nothing -> throw400 NotFound $ "environment variable '" <> k <> "' not set"
|
2021-03-18 21:32:47 +03:00
|
|
|
Just envVal -> return (pack envVal)
|
2021-02-25 21:15:55 +03:00
|
|
|
|
2022-01-04 14:53:50 +03:00
|
|
|
type MSSQLRunTx =
|
2022-01-14 17:08:17 +03:00
|
|
|
forall m a. (MonadIO m, MonadBaseControl IO m) => MSTx.TxET QErr m a -> ExceptT QErr m a
|
2022-01-04 14:53:50 +03:00
|
|
|
|
|
|
|
-- | Execution Context required to execute MSSQL transactions
|
|
|
|
data MSSQLExecCtx = MSSQLExecCtx
|
|
|
|
{ -- | A function that runs read-only queries
|
2022-01-14 17:08:17 +03:00
|
|
|
mssqlRunReadOnly :: MSSQLRunTx,
|
|
|
|
-- | A function that runs read-write queries; run in a transaction
|
|
|
|
mssqlRunReadWrite :: MSSQLRunTx,
|
2022-01-04 14:53:50 +03:00
|
|
|
-- | Destroys connection pools
|
|
|
|
mssqlDestroyConn :: IO ()
|
|
|
|
}
|
|
|
|
|
|
|
|
-- | Creates a MSSQL execution context for a single primary pool
|
2022-01-14 17:08:17 +03:00
|
|
|
mkMSSQLExecCtx :: MSPool.MSSQLPool -> MSSQLExecCtx
|
2022-01-04 14:53:50 +03:00
|
|
|
mkMSSQLExecCtx pool =
|
|
|
|
MSSQLExecCtx
|
2022-02-07 17:11:49 +03:00
|
|
|
{ mssqlRunReadOnly = \tx -> MSTx.runTxE defaultMSSQLTxErrorHandler tx pool,
|
|
|
|
mssqlRunReadWrite = \tx -> MSTx.runTxE defaultMSSQLTxErrorHandler tx pool,
|
2022-01-14 17:08:17 +03:00
|
|
|
mssqlDestroyConn = MSPool.drainMSSQLPool pool
|
2022-01-04 14:53:50 +03:00
|
|
|
}
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
data MSSQLSourceConfig = MSSQLSourceConfig
|
2022-07-29 17:05:03 +03:00
|
|
|
{ _mscConnectionString :: MSPool.ConnectionString,
|
|
|
|
_mscExecCtx :: MSSQLExecCtx
|
2021-09-24 01:56:37 +03:00
|
|
|
}
|
|
|
|
deriving (Generic)
|
2021-02-25 21:15:55 +03:00
|
|
|
|
|
|
|
instance Show MSSQLSourceConfig where
|
|
|
|
show = show . _mscConnectionString
|
|
|
|
|
|
|
|
instance Eq MSSQLSourceConfig where
|
|
|
|
MSSQLSourceConfig connStr1 _ == MSSQLSourceConfig connStr2 _ =
|
|
|
|
connStr1 == connStr2
|
|
|
|
|
|
|
|
instance Cacheable MSSQLSourceConfig where
|
|
|
|
unchanged _ = (==)
|
|
|
|
|
|
|
|
instance ToJSON MSSQLSourceConfig where
|
|
|
|
toJSON = toJSON . _mscConnectionString
|
2021-09-09 10:59:04 +03:00
|
|
|
|
2021-10-01 15:52:19 +03:00
|
|
|
odbcValueToJValue :: ODBC.Value -> J.Value
|
|
|
|
odbcValueToJValue = \case
|
|
|
|
ODBC.TextValue t -> J.String t
|
|
|
|
ODBC.ByteStringValue b -> J.String $ bsToTxt b
|
|
|
|
ODBC.BinaryValue b -> J.String $ bsToTxt $ ODBC.unBinary b
|
|
|
|
ODBC.BoolValue b -> J.Bool b
|
|
|
|
ODBC.DoubleValue d -> J.toJSON d
|
|
|
|
ODBC.FloatValue f -> J.toJSON f
|
|
|
|
ODBC.IntValue i -> J.toJSON i
|
|
|
|
ODBC.ByteValue b -> J.toJSON b
|
|
|
|
ODBC.DayValue d -> J.toJSON d
|
|
|
|
ODBC.TimeOfDayValue td -> J.toJSON td
|
|
|
|
ODBC.LocalTimeValue l -> J.toJSON l
|
|
|
|
ODBC.NullValue -> J.Null
|
2022-04-21 10:19:37 +03:00
|
|
|
|
|
|
|
runMSSQLSourceReadTx ::
|
|
|
|
(MonadIO m, MonadBaseControl IO m) =>
|
|
|
|
MSSQLSourceConfig ->
|
|
|
|
MSTx.TxET QErr m a ->
|
|
|
|
m (Either QErr a)
|
|
|
|
runMSSQLSourceReadTx msc =
|
|
|
|
runExceptT . mssqlRunReadOnly (_mscExecCtx msc)
|
|
|
|
|
|
|
|
runMSSQLSourceWriteTx ::
|
|
|
|
(MonadIO m, MonadBaseControl IO m) =>
|
|
|
|
MSSQLSourceConfig ->
|
|
|
|
MSTx.TxET QErr m a ->
|
|
|
|
m (Either QErr a)
|
|
|
|
runMSSQLSourceWriteTx msc =
|
|
|
|
runExceptT . mssqlRunReadWrite (_mscExecCtx msc)
|