mssql: connection pooling

GitOrigin-RevId: c1a6509f19a903724ce2b770ae23cbd925b537f8

CHANGELOG.md

@@ -6,6 +6,7 @@
 
 - server/mssql: fix malformed JSON answer on empty tables
 - server/mssql: fix runtime errors when selecting geography/geometry columns
+- server/mssql: supports connection pooling to sql server
 
 ## v1.4.0-alpha.2
 ### MSSQL support

server/graphql-engine.cabal

@@ -269,6 +269,7 @@ library
 
                      -- mssql support
                      , odbc
+                     , resource-pool
 
   if !flag(profiling)
     build-depends:
@@ -344,7 +345,6 @@ library
                      , Hasura.Backends.MSSQL.Instances.Types
                      , Hasura.Backends.MSSQL.Meta
                      , Hasura.Backends.MSSQL.Plan
-                     , Hasura.Backends.MSSQL.Result
                      , Hasura.Backends.MSSQL.ToQuery
                      , Hasura.Backends.MSSQL.Types
                      , Hasura.Backends.MSSQL.Types.Instances

server/src-lib/Hasura/Backends/MSSQL/Connection.hs

@@ -2,26 +2,67 @@ module Hasura.Backends.MSSQL.Connection where
 
 import           Hasura.Prelude
 
+import qualified Data.Pool               as Pool
+import qualified Database.ODBC.SQLServer as ODBC
+
+import           Control.Exception
 import           Data.Aeson
+import           Data.Aeson.Casing
 import           Data.Aeson.TH
 
-import           Hasura.Incremental (Cacheable (..))
+import           Hasura.Incremental      (Cacheable (..))
+import           Hasura.RQL.Types.Error
 
 -- | ODBC connection string for MSSQL server
 newtype MSSQLConnectionString
   = MSSQLConnectionString {unMSSQLConnectionString :: Text}
   deriving (Show, Eq, ToJSON, FromJSON, Cacheable, Hashable, NFData, Arbitrary)
 
+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
+
+instance Arbitrary MSSQLPoolSettings where
+  arbitrary = genericArbitrary
+
+defaultMSSQLPoolSettings :: MSSQLPoolSettings
+defaultMSSQLPoolSettings =
+  MSSQLPoolSettings
+  { _mpsMaxConnections = 50
+  , _mpsIdleTimeout    = 5
+  }
+
 data MSSQLConnectionInfo
   = MSSQLConnectionInfo
   { _mciConnectionString :: !MSSQLConnectionString
+  , _mciPoolSettings     :: !MSSQLPoolSettings
   } deriving (Show, Eq, Generic)
 instance Cacheable MSSQLConnectionInfo
 instance Hashable MSSQLConnectionInfo
 instance NFData MSSQLConnectionInfo
+$(deriveToJSON hasuraJSON ''MSSQLConnectionInfo)
+
 instance Arbitrary MSSQLConnectionInfo where
   arbitrary = genericArbitrary
-$(deriveJSON hasuraJSON ''MSSQLConnectionInfo)
+
+
+instance FromJSON MSSQLConnectionInfo where
+  parseJSON = withObject "Object" $ \o ->
+    MSSQLConnectionInfo
+      <$> ((o .: "database_url") <|> (o .: "connection_string"))
+      <*> o .:? "pool_settings" .!= defaultMSSQLPoolSettings
 
 data MSSQLConnConfiguration
   = MSSQLConnConfiguration
@@ -34,3 +75,53 @@ $(deriveJSON hasuraJSON ''MSSQLConnConfiguration)
 
 instance Arbitrary MSSQLConnConfiguration where
   arbitrary = genericArbitrary
+
+newtype MSSQLPool
+  = MSSQLPool { unMSSQLPool :: Pool.Pool ODBC.Connection }
+
+createMSSQLPool :: MSSQLConnectionInfo -> IO MSSQLPool
+createMSSQLPool (MSSQLConnectionInfo connString MSSQLPoolSettings{..}) =
+  MSSQLPool <$>
+    Pool.createPool (ODBC.connect $ unMSSQLConnectionString connString)
+    ODBC.close 1 (fromIntegral _mpsIdleTimeout) _mpsMaxConnections
+
+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
+runJSONPathQuery pool query = do
+  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

server/src-lib/Hasura/Backends/MSSQL/DDL/RunSQL.hs

@@ -1,32 +1,53 @@
 module Hasura.Backends.MSSQL.DDL.RunSQL
-  (runSQL)
+  ( runSQL
+  , MSSQLRunSQL
+  )
 where
 
 import           Hasura.Prelude
 
-import           Control.Exception
-import           Data.String                  (fromString)
+import qualified Data.Aeson                       as J
+import qualified Data.Text                        as T
+import qualified Database.ODBC.Internal           as ODBC
 
-import qualified Data.Aeson                   as J
-import qualified Data.Text                    as T
-import qualified Database.ODBC.Internal       as ODBC
+import           Data.Aeson.TH
+import           Data.String                      (fromString)
 
-import           Hasura.Backends.MSSQL.Result
-import           Hasura.Backends.MSSQL.Types
+import           Hasura.Backends.MSSQL.Connection
 import           Hasura.EncJSON
-import           Hasura.RQL.DDL.Schema        (RunSQLRes (..))
+import           Hasura.RQL.DDL.Schema            (RunSQLRes (..))
 import           Hasura.RQL.Types
 
 
+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
+
+data MSSQLRunSQL
+  = MSSQLRunSQL
+  { _mrsSql    :: Text
+  , _mrsSource :: !SourceName
+  } deriving (Show, Eq)
+$(deriveJSON hasuraJSON ''MSSQLRunSQL)
+
 runSQL
   :: (MonadIO m, CacheRWM m, MonadError QErr m)
   => MSSQLRunSQL -> m EncJSON
 runSQL (MSSQLRunSQL sqlText source) = do
-  connection    <- _mscConnection <$> askSourceConfig source
-  resultsEither <- liftIO $ try $ ODBC.query connection $ fromString $ T.unpack sqlText
-  case resultsEither of
-    Left (e :: SomeException) -> throw400 Unexpected $ "unexpected exception while executing query: " <> tshow e
-    Right results -> pure $ encJFromJValue $ toResult results
+  pool <- _mscConnectionPool <$> askSourceConfig source
+  results <- withMSSQLPool pool $ \conn -> ODBC.query conn $ fromString $ T.unpack sqlText
+  pure $ encJFromJValue $ toResult results
 
 toResult :: [[(ODBC.Column, ODBC.Value)]] -> RunSQLRes
 toResult result = case result of

server/src-lib/Hasura/Backends/MSSQL/DDL/Source.hs

@@ -7,13 +7,8 @@ where
 
 import           Hasura.Prelude
 
-import           Control.Exception
-
-import qualified Database.ODBC.SQLServer          as ODBC
-
 import           Hasura.Backends.MSSQL.Connection
 import           Hasura.Backends.MSSQL.Meta
-import           Hasura.Backends.MSSQL.Types
 import           Hasura.RQL.Types.Common
 import           Hasura.RQL.Types.Error
 import           Hasura.RQL.Types.Source
@@ -24,35 +19,25 @@ resolveSourceConfig
   => SourceName
   -> MSSQLConnConfiguration
   -> m (Either QErr MSSQLSourceConfig)
-resolveSourceConfig _name config = runExceptT do
-  eitherResult <- liftIO $ try $ ODBC.connect connStringText
-  case eitherResult of
-    Left (e :: SomeException) ->
-      throw400 Unexpected $ "unexpected exception while connecting to database: " <> tshow e
-    Right conn ->
-      pure $ MSSQLSourceConfig connString conn
+resolveSourceConfig _name (MSSQLConnConfiguration connInfo) = do
+  mssqlPool <- liftIO $ createMSSQLPool connInfo
+  pure $ Right $ MSSQLSourceConfig connString mssqlPool
   where
-    MSSQLConnConfiguration connInfo = config
     connString = _mciConnectionString connInfo
-    connStringText = unMSSQLConnectionString connString
 
 resolveDatabaseMetadata
   :: (MonadIO m)
   => MSSQLSourceConfig
   -> m (Either QErr (ResolvedSource 'MSSQL))
 resolveDatabaseMetadata config = runExceptT do
-  eitherResult <- liftIO $ try $ loadDBMetadata conn
-  case eitherResult of
-    Left (e :: SomeException) ->
-      throw400 Unexpected $ "unexpected exception while connecting to database: " <> tshow e
-    Right dbTablesMetadata -> do
-      pure $ ResolvedSource config dbTablesMetadata mempty mempty
+  dbTablesMetadata <- loadDBMetadata pool
+  pure $ ResolvedSource config dbTablesMetadata mempty mempty
   where
-    MSSQLSourceConfig _connString conn = config
+    MSSQLSourceConfig _connString pool = config
 
 postDropSourceHook
   :: (MonadIO m)
   => MSSQLSourceConfig -> m ()
-postDropSourceHook (MSSQLSourceConfig _ conn) =
+postDropSourceHook (MSSQLSourceConfig _ pool) =
   -- Close the connection
-  ODBC.close conn
+  liftIO $ drainMSSQLPool pool

server/src-lib/Hasura/Backends/MSSQL/Instances/Execute.hs

@@ -13,9 +13,9 @@ import qualified Network.HTTP.Types                    as HTTP
 
 import           Data.Text.Extended
 
+import           Hasura.Backends.MSSQL.Connection
 import           Hasura.Backends.MSSQL.Plan
 import           Hasura.Backends.MSSQL.ToQuery
-import           Hasura.Backends.MSSQL.Types
 import           Hasura.EncJSON
 import           Hasura.GraphQL.Context
 import           Hasura.GraphQL.Execute.Backend
@@ -28,7 +28,7 @@ import           Hasura.Session
 instance BackendExecute 'MSSQL where
   type PreparedQuery    'MSSQL = Text
   type MultiplexedQuery 'MSSQL = NoMultiplex
-  type ExecutionMonad   'MSSQL = IO
+  type ExecutionMonad   'MSSQL = ExceptT QErr IO
   getRemoteJoins = const []
 
   mkDBQueryPlan = msDBQueryPlan
@@ -62,12 +62,9 @@ msDBQueryPlan
 msDBQueryPlan _env _manager _reqHeaders userInfo _directives sourceConfig qrf = do
   select <- fromSelect <$> planNoPlan userInfo qrf
   let queryString = ODBC.renderQuery $ toQueryPretty select
-      connection  = _mscConnection sourceConfig
-      odbcQuery   = ODBC.query connection (toQueryFlat select) <&> toResultJSON
+      pool  = _mscConnectionPool sourceConfig
+      odbcQuery = encJFromText <$> runJSONPathQuery pool (toQueryFlat select)
   pure $ ExecStepDB sourceConfig (Just queryString) [] odbcQuery
-  where
-    toResultJSON :: [Text] -> EncJSON
-    toResultJSON = encJFromText . mconcat
 
 -- mutation
 

server/src-lib/Hasura/Backends/MSSQL/Instances/Transport.hs

@@ -4,9 +4,7 @@ module Hasura.Backends.MSSQL.Instances.Transport () where
 
 import           Hasura.Prelude
 
-import qualified Control.Exception                       as E
 import qualified Data.ByteString                         as B
-import qualified Database.ODBC.SQLServer                 as ODBC
 import qualified Language.GraphQL.Draft.Syntax           as G
 
 import           Data.Text.Encoding                      (encodeUtf8)
@@ -15,8 +13,8 @@ import           Hasura.RQL.Types.Error                  as HE
 
 import qualified Hasura.Logging                          as L
 
+import           Hasura.Backends.MSSQL.Connection
 import           Hasura.Backends.MSSQL.Instances.Execute
-import           Hasura.Backends.MSSQL.Types
 import           Hasura.EncJSON
 import           Hasura.GraphQL.Execute.Backend
 import           Hasura.GraphQL.Execute.LiveQuery.Plan
@@ -46,7 +44,7 @@ runQuery
   -> UserInfo
   -> L.Logger L.Hasura
   -> SourceConfig 'MSSQL
-  -> IO EncJSON
+  -> ExceptT QErr IO EncJSON
   -> Maybe Text
   -> m (DiffTime, EncJSON)
   -- ^ Also return the time spent in the PG query; for telemetry.
@@ -70,7 +68,7 @@ runMutation
   -> UserInfo
   -> L.Logger L.Hasura
   -> SourceConfig 'MSSQL
-  -> IO EncJSON
+  -> ExceptT QErr IO EncJSON
   -> Maybe Text
   -> m (DiffTime, EncJSON)
   -- ^ Also return 'Mutation' when the operation was a mutation, and the time
@@ -90,19 +88,19 @@ runSubscription
   -> [(CohortId, CohortVariables)]
   -> m (DiffTime, Either QErr [(CohortId, B.ByteString)])
 runSubscription sourceConfig (NoMultiplex (name, query)) variables = do
-  let connection = _mscConnection sourceConfig
+  let pool = _mscConnectionPool sourceConfig
   withElapsedTime $ runExceptT $ for variables $ traverse $ const $
-    fmap toResult $ run $ ODBC.query connection query
+    fmap toResult $ run $ runJSONPathQuery pool query
   where
-    toResult :: [Text] -> B.ByteString
-    toResult = encodeUtf8 . addFieldName . mconcat
+    toResult :: Text -> B.ByteString
+    toResult = encodeUtf8 . addFieldName
 
     -- TODO: This should probably be generated from the database or should
     -- probably return encjson so that encJFromAssocList can be used
     addFieldName result =
       "{\"" <> G.unName name <> "\":" <> result <> "}"
 
-run :: (MonadIO m, MonadError QErr m) => IO a -> m a
+run :: (MonadIO m, MonadError QErr m) => ExceptT QErr IO a -> m a
 run action = do
-  result <- liftIO $ E.try @ODBC.ODBCException action
-  result `onLeft` (throw400 HE.MSSQLError . tshow)
+  result <- liftIO $ runExceptT action
+  result `onLeft` throwError

server/src-lib/Hasura/Backends/MSSQL/Meta.hs

@@ -8,21 +8,20 @@ module Hasura.Backends.MSSQL.Meta
 
 import           Hasura.Prelude
 
+import           Data.Aeson                            as Aeson
 import qualified Data.HashMap.Strict                   as HM
 import qualified Data.HashSet                          as HS
+import           Data.String
+import qualified Data.Text                             as T
 import qualified Data.Text.Encoding                    as T
 import qualified Database.PG.Query                     as Q (sqlFromFile)
 
-import           Data.Aeson                            as Aeson
-import           Data.Aeson.Types                      (parseEither)
-import           Data.Attoparsec.ByteString
-import           Data.String
-import           Database.ODBC.SQLServer
-
+import           Hasura.Backends.MSSQL.Connection
 import           Hasura.Backends.MSSQL.Instances.Types ()
 import           Hasura.Backends.MSSQL.Types
 import           Hasura.RQL.Types.Column
 import           Hasura.RQL.Types.Common               (OID (..))
+import           Hasura.RQL.Types.Error
 import           Hasura.RQL.Types.Table
 import           Hasura.SQL.Backend
 
@@ -30,12 +29,15 @@ import           Hasura.SQL.Backend
 --------------------------------------------------------------------------------
 -- Loader
 
-loadDBMetadata :: Connection -> IO (DBTablesMetadata 'MSSQL)
-loadDBMetadata conn = do
+loadDBMetadata
+  :: (MonadError QErr m, MonadIO m)
+  => MSSQLPool -> m (DBTablesMetadata 'MSSQL)
+loadDBMetadata pool = do
   let sql = $(Q.sqlFromFile "src-rsr/mssql_table_metadata.sql")
-  sysTables <- queryJson conn (fromString sql)
-  let tables = map transformTable sysTables
-  pure $ HM.fromList tables
+  sysTablesText <- runJSONPathQuery pool (fromString sql)
+  case Aeson.eitherDecodeStrict (T.encodeUtf8 sysTablesText) of
+    Left e          -> throw500 $ T.pack $ "error loading sql server database schema: " <> e
+    Right sysTables -> pure $ HM.fromList $ map transformTable sysTables
 
 --------------------------------------------------------------------------------
 -- Local types
@@ -178,24 +180,3 @@ parseScalarType = \case
   "geometry"         -> GeometryType
   t                  -> UnknownType t
 
-
---------------------------------------------------------------------------------
--- Quick catalog queries
-
-queryJson :: FromJSON a => Connection -> Query -> IO [a]
-queryJson conn query' = do
-  (steps, iresult) <-
-    stream
-      conn
-      query'
-      (\(!steps, parser) input ->
-         pure (Continue (steps + 1, feed parser (T.encodeUtf8 input))))
-      (0 :: Int, parse json mempty)
-  case steps of
-    0 -> pure []
-    _ ->
-      case iresult of
-        Done _ jvalue ->
-          parseEither parseJSON jvalue `onLeft` error -- FIXME
-        Partial {} -> error "Incomplete output from SQL Server."
-        Fail _ _ctx err -> error ("JSON parser error: " <> err)

server/src-lib/Hasura/Backends/MSSQL/Result.hs

@@ -1,22 +0,0 @@
-module Hasura.Backends.MSSQL.Result where
-
-import           Hasura.Prelude
-
-import qualified Data.Aeson             as J
-import qualified Database.ODBC.Internal as ODBC
-
-
-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

server/src-lib/Hasura/Backends/MSSQL/Types.hs

@@ -1,46 +1,8 @@
 -- | Types for Transact-SQL aka T-SQL; the language of SQL Server.
 
 module Hasura.Backends.MSSQL.Types
-  ( MSSQLSourceConfig(..)
-  , MSSQLRunSQL(..)
-  , module Hasura.Backends.MSSQL.Types.Internal
+  ( module Hasura.Backends.MSSQL.Types.Internal
   ) where
 
-import           Hasura.Prelude
-
-import           Data.Aeson
-import           Data.Aeson.TH
-
-import qualified Database.ODBC.SQLServer               as ODBC
-
-import           Hasura.Backends.MSSQL.Connection
 import           Hasura.Backends.MSSQL.Types.Instances ()
 import           Hasura.Backends.MSSQL.Types.Internal
-import           Hasura.Incremental                    (Cacheable (..))
-import           Hasura.RQL.Types.Common
-
-data MSSQLSourceConfig
-  = MSSQLSourceConfig
-  { _mscConnectionString :: !MSSQLConnectionString
-  , _mscConnection       :: !ODBC.Connection
-  } 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
-
-data MSSQLRunSQL
-  = MSSQLRunSQL
-  { _mrsSql    :: Text
-  , _mrsSource :: !SourceName
-  } deriving (Show, Eq)
-$(deriveJSON hasuraJSON ''MSSQLRunSQL)

server/src-lib/Hasura/Server/API/V2Query.hs

@@ -27,7 +27,6 @@ import           Hasura.Server.Version            (HasVersion)
 import           Hasura.Session
 
 import qualified Hasura.Backends.MSSQL.DDL.RunSQL as MSSQL
-import qualified Hasura.Backends.MSSQL.Types      as MSSQL
 import qualified Hasura.Tracing                   as Tracing
 
 data RQLQuery