2021-02-23 20:37:27 +03:00
|
|
|
module Hasura.Backends.MSSQL.Connection where
|
|
|
|
|
|
|
|
import Hasura.Prelude
|
|
|
|
|
2021-07-23 15:25:16 +03:00
|
|
|
import qualified Data.Environment as Env
|
2021-02-25 21:15:55 +03:00
|
|
|
import qualified Data.Pool as Pool
|
|
|
|
import qualified Database.ODBC.SQLServer as ODBC
|
|
|
|
|
|
|
|
import Control.Exception
|
2021-02-23 20:37:27 +03:00
|
|
|
import Data.Aeson
|
2021-02-25 21:15:55 +03:00
|
|
|
import Data.Aeson.Casing
|
2021-02-23 20:37:27 +03:00
|
|
|
import Data.Aeson.TH
|
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
import Data.Text (pack, unpack)
|
2021-05-11 18:18:31 +03:00
|
|
|
import Hasura.Base.Error
|
2021-02-25 21:15:55 +03:00
|
|
|
import Hasura.Incremental (Cacheable (..))
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2021-09-09 13:37:50 +03:00
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
-- | ODBC connection string for MSSQL server
|
|
|
|
newtype MSSQLConnectionString
|
|
|
|
= MSSQLConnectionString {unMSSQLConnectionString :: Text}
|
2021-07-30 10:54:50 +03:00
|
|
|
deriving (Show, Eq, ToJSON, FromJSON, Cacheable, Hashable, NFData)
|
2021-02-23 20:37:27 +03:00
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
data InputConnectionString
|
|
|
|
= RawString !MSSQLConnectionString
|
|
|
|
| FromEnvironment !Text
|
|
|
|
deriving stock (Show, Eq, Generic)
|
|
|
|
instance Cacheable InputConnectionString
|
|
|
|
instance Hashable InputConnectionString
|
|
|
|
instance NFData InputConnectionString
|
|
|
|
|
|
|
|
instance ToJSON InputConnectionString where
|
|
|
|
toJSON =
|
|
|
|
\case
|
|
|
|
(RawString m) -> toJSON m
|
|
|
|
(FromEnvironment wEnv) -> object ["from_env" .= wEnv]
|
|
|
|
|
|
|
|
instance FromJSON InputConnectionString where
|
|
|
|
parseJSON =
|
|
|
|
\case
|
|
|
|
(Object o) -> FromEnvironment <$> o .: "from_env"
|
|
|
|
s@(String _) -> RawString <$> parseJSON s
|
|
|
|
_ -> fail "one of string or object must be provided"
|
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
data MSSQLPoolSettings
|
|
|
|
= MSSQLPoolSettings
|
|
|
|
{ _mpsMaxConnections :: !Int
|
|
|
|
, _mpsIdleTimeout :: !Int
|
|
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance Cacheable MSSQLPoolSettings
|
|
|
|
instance Hashable MSSQLPoolSettings
|
|
|
|
instance NFData MSSQLPoolSettings
|
|
|
|
$(deriveToJSON hasuraJSON ''MSSQLPoolSettings)
|
|
|
|
|
|
|
|
instance FromJSON MSSQLPoolSettings where
|
|
|
|
parseJSON = withObject "MSSQL pool settings" $ \o ->
|
|
|
|
MSSQLPoolSettings
|
|
|
|
<$> o .:? "max_connections" .!= _mpsMaxConnections defaultMSSQLPoolSettings
|
|
|
|
<*> o .:? "idle_timeout" .!= _mpsIdleTimeout defaultMSSQLPoolSettings
|
|
|
|
|
|
|
|
defaultMSSQLPoolSettings :: MSSQLPoolSettings
|
|
|
|
defaultMSSQLPoolSettings =
|
|
|
|
MSSQLPoolSettings
|
|
|
|
{ _mpsMaxConnections = 50
|
|
|
|
, _mpsIdleTimeout = 5
|
|
|
|
}
|
|
|
|
|
2021-02-23 20:37:27 +03:00
|
|
|
data MSSQLConnectionInfo
|
|
|
|
= MSSQLConnectionInfo
|
2021-03-18 21:32:47 +03:00
|
|
|
{ _mciConnectionString :: !InputConnectionString
|
2021-02-25 21:15:55 +03:00
|
|
|
, _mciPoolSettings :: !MSSQLPoolSettings
|
2021-02-23 20:37:27 +03:00
|
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance Cacheable MSSQLConnectionInfo
|
|
|
|
instance Hashable MSSQLConnectionInfo
|
|
|
|
instance NFData MSSQLConnectionInfo
|
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
|
|
|
|
|
|
|
data MSSQLConnConfiguration
|
|
|
|
= MSSQLConnConfiguration
|
|
|
|
{ _mccConnectionInfo :: !MSSQLConnectionInfo
|
|
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance Cacheable MSSQLConnConfiguration
|
|
|
|
instance Hashable MSSQLConnConfiguration
|
|
|
|
instance NFData MSSQLConnConfiguration
|
|
|
|
$(deriveJSON hasuraJSON ''MSSQLConnConfiguration)
|
|
|
|
|
2021-02-25 21:15:55 +03:00
|
|
|
newtype MSSQLPool
|
|
|
|
= MSSQLPool { unMSSQLPool :: Pool.Pool ODBC.Connection }
|
|
|
|
|
2021-03-18 21:32:47 +03:00
|
|
|
createMSSQLPool
|
|
|
|
:: MonadIO m
|
|
|
|
=> QErrM m
|
|
|
|
=> MSSQLConnectionInfo
|
2021-07-23 15:25:16 +03:00
|
|
|
-> Env.Environment
|
2021-03-18 21:32:47 +03:00
|
|
|
-> m (MSSQLConnectionString, MSSQLPool)
|
2021-07-23 15:25:16 +03:00
|
|
|
createMSSQLPool (MSSQLConnectionInfo iConnString MSSQLPoolSettings{..}) env = do
|
2021-03-18 21:32:47 +03:00
|
|
|
connString <- resolveInputConnectionString env iConnString
|
|
|
|
pool <- liftIO
|
|
|
|
$ MSSQLPool
|
|
|
|
<$> Pool.createPool
|
|
|
|
(ODBC.connect $ unMSSQLConnectionString connString)
|
|
|
|
ODBC.close
|
|
|
|
1
|
|
|
|
(fromIntegral _mpsIdleTimeout) _mpsMaxConnections
|
|
|
|
pure (connString, pool)
|
|
|
|
|
|
|
|
resolveInputConnectionString
|
|
|
|
:: QErrM m
|
|
|
|
=> Env.Environment
|
|
|
|
-> InputConnectionString
|
|
|
|
-> m MSSQLConnectionString
|
|
|
|
resolveInputConnectionString env =
|
|
|
|
\case
|
|
|
|
(RawString cs) -> pure cs
|
|
|
|
(FromEnvironment envVar) -> MSSQLConnectionString <$> getEnv env envVar
|
|
|
|
|
|
|
|
getEnv :: QErrM m => Env.Environment -> Text -> m Text
|
|
|
|
getEnv env k = do
|
|
|
|
let mEnv = Env.lookupEnv env (unpack k)
|
|
|
|
case mEnv of
|
|
|
|
Nothing -> throw400 NotFound $ "environment variable '" <> k <> "' not set"
|
|
|
|
Just envVal -> return (pack envVal)
|
2021-02-25 21:15:55 +03:00
|
|
|
|
|
|
|
drainMSSQLPool :: MSSQLPool -> IO ()
|
|
|
|
drainMSSQLPool (MSSQLPool pool) =
|
|
|
|
Pool.destroyAllResources pool
|
|
|
|
|
|
|
|
odbcExceptionToJSONValue :: ODBC.ODBCException -> Value
|
|
|
|
odbcExceptionToJSONValue =
|
|
|
|
$(mkToJSON defaultOptions{constructorTagModifier = snakeCase} ''ODBC.ODBCException)
|
|
|
|
|
|
|
|
runJSONPathQuery
|
|
|
|
:: (MonadError QErr m, MonadIO m)
|
|
|
|
=> MSSQLPool -> ODBC.Query -> m Text
|
2021-05-27 18:06:13 +03:00
|
|
|
runJSONPathQuery pool query =
|
2021-02-25 21:15:55 +03:00
|
|
|
mconcat <$> withMSSQLPool pool (`ODBC.query` query)
|
|
|
|
|
|
|
|
withMSSQLPool
|
|
|
|
:: (MonadError QErr m, MonadIO m)
|
|
|
|
=> MSSQLPool -> (ODBC.Connection -> IO a) -> m a
|
|
|
|
withMSSQLPool (MSSQLPool pool) f = do
|
|
|
|
res <- liftIO $ try $ Pool.withResource pool f
|
|
|
|
onLeft res $ \e ->
|
|
|
|
throw500WithDetail "sql server exception" $ odbcExceptionToJSONValue e
|
|
|
|
|
|
|
|
data MSSQLSourceConfig
|
|
|
|
= MSSQLSourceConfig
|
|
|
|
{ _mscConnectionString :: !MSSQLConnectionString
|
|
|
|
, _mscConnectionPool :: !MSSQLPool
|
|
|
|
} deriving (Generic)
|
|
|
|
|
|
|
|
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-09-09 13:37:50 +03:00
|
|
|
newtype MSSQLConnErr = MSSQLConnErr { getConnErr :: Text }
|
2021-09-09 10:59:04 +03:00
|
|
|
deriving (Show, Eq, ToJSON)
|