server/mssql: support transactions

https://github.com/hasura/graphql-engine-mono/pull/2268

GitOrigin-RevId: b1bc2812cd403688228b3ecf143aa36b3a6af707

CHANGELOG.md

@@ -3,6 +3,7 @@
 ## Next release
 
 (Add entries below in the order of server, console, cli, docs, others)
+- server: support MSSQL transactions
 
 ## v2.0.9
 

scripts/containers/mssql.sh

@@ -1,3 +1,4 @@
+#!/usr/bin/env bash
 ### This file is not meant to be run directly, but to be sourced from
 ### the dev script. It defines all the functions required to run an
 ### MSSQL docker container.
@@ -15,7 +16,7 @@ fi
 
 MSSQL_PASSWORD=hasuraMSSQL1
 MSSQL_CONTAINER_NAME="hasura-dev-mssql-$MSSQL_PORT"
-MSSQL_DB_URL="DRIVER={ODBC Driver 17 for SQL Server};SERVER=127.0.0.1,$MSSQL_PORT;Uid=sa;Pwd=$MSSQL_PASSWORD;"
+MSSQL_CONN_STR="DRIVER={ODBC Driver 17 for SQL Server};SERVER=127.0.0.1,$MSSQL_PORT;Uid=sa;Pwd=$MSSQL_PASSWORD;"
 MSSQL_DOCKER="docker exec -it $MSSQL_CONTAINER_NAME sqlcmd -S localhost -U sa -P $MSSQL_PASSWORD"
 
 
@@ -40,7 +41,7 @@ function mssql_wait {
 function mssql_cleanup(){
   echo_pretty "Removing $MSSQL_CONTAINER_NAME and its volumes in 5 seconds!"
   echo_pretty "  PRESS CTRL-C TO ABORT removal of all containers, or ENTER to clean up right away"
-  read -t5 || true
+  read -rt5 || true
   docker stop "$MSSQL_CONTAINER_NAME"
   docker rm -v "$MSSQL_CONTAINER_NAME"
 }

scripts/data-sources-util.sh

@@ -11,10 +11,10 @@ function add_sources() {
             add_citus_source "$hasura_graphql_server_port" "$CITUS_DB_URL"
         ;;
         mssql)
-            add_mssql_source "$hasura_graphql_server_port" "$MSSQL_DB_URL"
+            add_mssql_source "$hasura_graphql_server_port" "$MSSQL_CONN_STR"
         ;;
         mysql)
-            add_mysql_source "$hasura_graphql_server_port" "$MSSQL_DB_URL"
+            add_mysql_source "$hasura_graphql_server_port" "$MSSQL_CONN_STR"
         ;;
         # bigquery deliberately omitted as its test setup is atypical. See:
         # https://github.com/hasura/graphql-engine/blob/master/server/CONTRIBUTING.md#running-the-python-test-suite-on-bigquery

scripts/dev.sh

@@ -165,7 +165,7 @@ fi
 ####################################
 
 source scripts/containers/postgres
-source scripts/containers/mssql
+source scripts/containers/mssql.sh
 source scripts/containers/citus
 source scripts/containers/mysql.sh
 source scripts/data-sources-util.sh
@@ -385,7 +385,7 @@ elif [ "$MODE" = "mssql" ]; then
   echo_pretty "    $ $MSSQL_DOCKER -i <import_file>"
   echo_pretty ""
   echo_pretty "Here is the database URL:"
-  echo_pretty "    $MSSQL_DB_URL"
+  echo_pretty "    $MSSQL_CONN_STR"
   echo_pretty ""
   docker logs -f --tail=0 "$MSSQL_CONTAINER_NAME"
 
@@ -453,14 +453,18 @@ elif [ "$MODE" = "test" ]; then
     cabal new-run --project-file=cabal.project.dev-sh -- exe:graphql-engine \
         --metadata-database-url="$PG_DB_URL" version
     start_dbs
-  else
-    # unit tests just need access to a postgres instance:
-    pg_start
   fi
 
   if [ "$RUN_UNIT_TESTS" = true ]; then
     echo_pretty "Running Haskell test suite"
-    HASURA_GRAPHQL_DATABASE_URL="$PG_DB_URL" cabal new-run --project-file=cabal.project.dev-sh -- test:graphql-engine-tests
+
+    # unit tests need access to postgres and mssql instances:
+    mssql_start
+    pg_start
+
+    HASURA_GRAPHQL_DATABASE_URL="$PG_DB_URL" \
+      HASURA_MSSQL_CONN_STR="$MSSQL_CONN_STR" \
+      cabal new-run --project-file=cabal.project.dev-sh -- test:graphql-engine-tests
   fi
 
   if [ "$RUN_HLINT" = true ]; then

server/graphql-engine.cabal

@@ -313,6 +313,7 @@ library
                      , Data.Text.NonEmpty
                      , Data.Time.Clock.Units
                      , Data.URL.Template
+                     , Database.MSSQL.Transaction
                      , GHC.Stats.Extended
                      , Hasura.App
                      , Hasura.Metadata.Class
@@ -702,6 +703,9 @@ test-suite graphql-engine-tests
     , transformers-base
     , unordered-containers
     , vector
+    -- mssql support
+    , odbc
+    , resource-pool
   hs-source-dirs: src-test
   main-is: Main.hs
   other-modules:
@@ -711,18 +715,19 @@ test-suite graphql-engine-tests
     Data.Parser.URLTemplate
     Data.Text.RawString
     Data.TimeSpec
+    Database.MSSQL.TransactionSpec
     Hasura.EventingSpec
     Hasura.Generator
     Hasura.GraphQL.Parser.DirectivesTest
     Hasura.GraphQL.Parser.TestUtils
+    Hasura.GraphQL.RemoteServerSpec
     Hasura.GraphQL.Schema.RemoteTest
     Hasura.IncrementalSpec
-    Hasura.SessionSpec
-    Hasura.GraphQL.RemoteServerSpec
     Hasura.RQL.PermissionSpec
-    Hasura.RQL.Types.EndpointSpec
     Hasura.RQL.Types.CommonSpec
-    Hasura.SQL.WKTSpec
+    Hasura.RQL.Types.EndpointSpec
     Hasura.Server.AuthSpec
     Hasura.Server.MigrateSpec
     Hasura.Server.TelemetrySpec
+    Hasura.SessionSpec
+    Hasura.SQL.WKTSpec

server/src-lib/Database/MSSQL/Transaction.hs

@@ -0,0 +1,99 @@
+module Database.MSSQL.Transaction
+  ( runTx
+  , unitQ
+  , withQ
+  , TxT
+  , TxET(..)
+  , MSSQLTxError(..)
+  , ResultOk(..)
+  ) where
+
+import           Hasura.Prelude          (hoistEither)
+import           Prelude
+
+import qualified Database.ODBC.SQLServer as ODBC
+
+import           Control.Exception       (try)
+import           Control.Monad           (void)
+import           Control.Monad.Except    (ExceptT (..), MonadError, catchError, throwError,
+                                          withExceptT)
+import           Control.Monad.IO.Class  (MonadIO (..))
+import           Control.Monad.Morph     (hoist)
+import           Control.Monad.Reader    (MonadFix, MonadReader, ReaderT (..))
+
+
+data MSSQLTxError
+  = MSSQLTxError !ODBC.Query !ODBC.ODBCException
+  deriving (Eq, Show)
+
+newtype ResultOk = ResultOk [[ODBC.Value]]
+  deriving (Eq, Show)
+
+-- | The transaction command to run, parameterised over:
+-- e - the exception type
+-- m - some Monad
+-- a - the successful result type
+newtype TxET e m a
+  = TxET { txHandler :: ReaderT ODBC.Connection (ExceptT e m) a }
+  deriving (Functor, Applicative, Monad, MonadError e, MonadIO, MonadReader ODBC.Connection, MonadFix)
+
+-- | The transaction command to run,
+-- returning an MSSQLTxError or the result
+type TxT m a = TxET MSSQLTxError m a
+
+beginTx :: MonadIO m => TxT m ()
+beginTx =
+  unitQ "BEGIN TRANSACTION"
+
+commitTx :: MonadIO m => TxT m ()
+commitTx =
+  unitQ "COMMIT TRANSACTION"
+
+rollbackTx :: MonadIO m => TxT m ()
+rollbackTx =
+  unitQ "ROLLBACK TRANSACTION"
+
+unitQ :: MonadIO m => ODBC.Query -> TxT m ()
+unitQ = void <$> withQ
+
+withQ :: MonadIO m => ODBC.Query -> TxT m ResultOk
+withQ q = TxET $ ReaderT $ \conn ->
+  hoist liftIO $ execQuery conn q
+
+execQuery
+  :: MonadIO m
+  => ODBC.Connection
+  -> ODBC.Query
+  -> ExceptT MSSQLTxError m ResultOk
+execQuery conn query = do
+  result :: Either ODBC.ODBCException [[ODBC.Value]] <- liftIO $ try $ ODBC.query conn query
+  withExceptT (MSSQLTxError query) $ hoistEither $ ResultOk <$> result
+
+-- | Run a command on the given connection wrapped in a transaction.
+runTx :: MonadIO m
+      => TxT m ResultOk
+      -> ODBC.Connection
+      -> ExceptT MSSQLTxError m ResultOk
+runTx tx =
+  asTransaction (\connRsrc -> execTx connRsrc tx)
+
+{-# INLINE execTx #-}
+execTx :: ODBC.Connection -> TxET e m a -> ExceptT e m a
+execTx conn tx = runReaderT (txHandler tx) conn
+
+asTransaction :: MonadIO m
+              => (ODBC.Connection -> ExceptT MSSQLTxError m ResultOk)
+              -> ODBC.Connection
+              -> ExceptT MSSQLTxError m ResultOk
+asTransaction f conn = do
+  -- Begin the transaction. If there is an err, do not rollback
+  _ <- execTx conn beginTx
+  -- Run the transaction and commit. If there is an err, rollback
+  flip catchError rollback $ do
+    result <- f conn
+    _ <- execTx conn commitTx
+    return result
+  where
+    rollback err = do
+      _ <- execTx conn rollbackTx
+      throwError err

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

@@ -4,6 +4,7 @@ import           Hasura.Prelude
 
 import qualified Data.Environment        as Env
 import qualified Data.Pool               as Pool
+import qualified Data.Text               as T
 import qualified Database.ODBC.SQLServer as ODBC
 
 import           Control.Exception
@@ -15,7 +16,6 @@ import           Data.Text               (pack, unpack)
 import           Hasura.Base.Error
 import           Hasura.Incremental      (Cacheable (..))
 
-
 -- | ODBC connection string for MSSQL server
 newtype MSSQLConnectionString
   = MSSQLConnectionString {unMSSQLConnectionString :: Text}
@@ -167,3 +167,6 @@ instance Cacheable MSSQLSourceConfig where
 
 instance ToJSON MSSQLSourceConfig where
   toJSON = toJSON . _mscConnectionString
+
+newtype MSSQLConnErr = MSSQLConnErr { getConnErr :: T.Text }
+  deriving (Show, Eq, ToJSON)

server/src-test/Database/MSSQL/TransactionSpec.hs

@@ -0,0 +1,79 @@
+module Database.MSSQL.TransactionSpec (spec) where
+
+import           Hasura.Prelude
+
+import           Control.Exception.Base     (bracket)
+import           Database.MSSQL.Transaction
+import           Database.ODBC.SQLServer    as ODBC (ODBCException (UnsuccessfulReturnCode),
+                                                     Value (ByteStringValue, IntValue), close,
+                                                     connect)
+import           Test.Hspec
+
+
+spec :: Text -> Spec
+spec connString = do
+  describe "runTx" $ do
+    it "runs command in a transaction" $ do
+      result <- runInConn connString selectQuery
+      result `shouldBe` Right (ResultOk [[IntValue 1]])
+
+    it "commits a successful transaction, returning a single field" $ do
+      _ <- runInConn connString insertIdQuery
+      result <- runInConn connString selectIdQuery
+      result `shouldBe` Right (ResultOk [[IntValue 2]])
+
+    it "commits a successful transaction, returning multiple fields" $ do
+      _ <- runInConn connString insertNameQuery
+      result <- runInConn connString selectIdNameQuery
+      result `shouldBe` Right (ResultOk [[IntValue 2,ByteStringValue "A"]])
+
+    it "displays the SQL Server error on an unsuccessful transaction" $ do
+      result <- runInConn connString badQuery
+      either
+        (\(MSSQLTxError _ err) -> err `shouldBe`
+          UnsuccessfulReturnCode "odbc_SQLExecDirectW" (-1) invalidSyntaxError)
+        (\(ResultOk resultOk) -> expectationFailure $ "expected Left, returned " <> show resultOk)
+        result
+
+    it "rolls back an unsuccessful transaction" $ do
+      _ <- runInConn connString badQuery
+      result <- runInConn connString selectIdQuery
+      either
+        (\err -> expectationFailure $ "expected Right, returned " <> show err)
+        (\(ResultOk resultOk) -> resultOk `shouldNotContain` [[IntValue 3]])
+        result
+
+selectQuery :: TxT IO ResultOk
+selectQuery = withQ "SELECT 1"
+
+insertIdQuery :: TxT IO ResultOk
+insertIdQuery = withQ
+  "CREATE TABLE SingleCol (ID INT);INSERT INTO SingleCol VALUES (2);"
+
+selectIdQuery :: TxT IO ResultOk
+selectIdQuery = withQ
+  "SELECT ID FROM SingleCol;"
+
+insertNameQuery :: TxT IO ResultOk
+insertNameQuery = withQ
+  "CREATE TABLE MultiCol (ID INT, NAME VARCHAR(1));INSERT INTO MultiCol VALUES (2, 'A');"
+
+selectIdNameQuery :: TxT IO ResultOk
+selectIdNameQuery = withQ
+  "SELECT ID, NAME FROM MultiCol;"
+
+badQuery :: TxT IO ResultOk
+badQuery = withQ
+  "CREATE TABLE BadQuery (ID INT, INVALID_SYNTAX);INSERT INTO BadQuery VALUES (3);"
+
+-- | spec helper functions
+runInConn :: Text -> TxT IO ResultOk -> IO (Either MSSQLTxError ResultOk)
+runInConn connString query =
+  bracket
+    (connect connString)
+    close
+    (runExceptT . runTx query)
+
+invalidSyntaxError :: String
+invalidSyntaxError =
+  "[Microsoft][ODBC Driver 17 for SQL Server][SQL Server]The definition for column 'INVALID_SYNTAX' must include a data type.[Microsoft][ODBC Driver 17 for SQL Server][SQL Server]The definition for column 'INVALID_SYNTAX' must include a data type."

server/src-test/Main.hs

@@ -24,6 +24,7 @@ import           System.Environment                   (getEnvironment)
 import           System.Exit                          (exitFailure)
 import           Test.Hspec
 
+import qualified Database.MSSQL.TransactionSpec       as TransactionSpec
 import qualified Hasura.EventingSpec                  as EventingSpec
 import qualified Hasura.GraphQL.Parser.DirectivesTest as GraphQLDirectivesSpec
 import qualified Hasura.GraphQL.RemoteServerSpec      as RemoteServerSpec
@@ -51,24 +52,30 @@ import           Hasura.Server.Version.TH
 
 
 data TestSuites
-  = AllSuites !(Maybe URLTemplate)
-  -- ^ Run all test suites. It probably doesn't make sense to be able to specify additional
-  -- hspec args here.
-  | SingleSuite ![String] !TestSuite
-  -- ^ Args to pass through to hspec (as if from 'getArgs'), and the specific suite to run.
+  = -- | Run all test suites. It probably doesn't make sense to be able to specify additional
+    -- hspec args here.
+    AllSuites !(Maybe URLTemplate) !(Maybe URLTemplate)
+  | -- | Args to pass through to hspec (as if from 'getArgs'), and the specific suite to run.
+    SingleSuite ![String] !TestSuite
 
 data TestSuite
   = UnitSuite
   | PostgresSuite !(Maybe URLTemplate)
+  | MSSQLSuite !(Maybe URLTemplate)
 
 main :: IO ()
-main = withVersion $$(getVersionFromEnvironment) $ parseArgs >>= \case
-  AllSuites pgConnOptions -> do
-    postgresSpecs <- buildPostgresSpecs pgConnOptions
-    runHspec [] (unitSpecs *> postgresSpecs)
-  SingleSuite hspecArgs suite -> runHspec hspecArgs =<< case suite of
-    UnitSuite                   -> pure unitSpecs
-    PostgresSuite pgConnOptions -> buildPostgresSpecs pgConnOptions
+main =
+  withVersion $$(getVersionFromEnvironment) $
+    parseArgs >>= \case
+      AllSuites pgConnOptions mssqlConnOptions -> do
+        postgresSpecs <- buildPostgresSpecs pgConnOptions
+        mssqlSpecs <- buildMSSQLSpecs mssqlConnOptions
+        runHspec [] (unitSpecs *> postgresSpecs *> mssqlSpecs)
+      SingleSuite hspecArgs suite ->
+        runHspec hspecArgs =<< case suite of
+          UnitSuite                   -> pure unitSpecs
+          PostgresSuite pgConnOptions -> buildPostgresSpecs pgConnOptions
+          MSSQLSuite mssqlConnOptions -> buildMSSQLSpecs mssqlConnOptions
 
 unitSpecs :: Spec
 unitSpecs = do
@@ -88,6 +95,27 @@ unitSpecs = do
   describe "Hasura.Server.Telemetry" TelemetrySpec.spec
   describe "Hasura.RQL.PermissionSpec" PermSpec.spec
 
+buildMSSQLSpecs :: Maybe URLTemplate -> IO Spec
+buildMSSQLSpecs maybeUrlTemplate = do
+  env <- liftIO getEnvironment
+  let envMap = Env.mkEnvironment env
+
+  urlTemplate <- flip onLeft printErrExit $
+    runWithEnv env $ do
+      let envVar = fst mssqlConnectionString
+      maybeV <- withEnv maybeUrlTemplate envVar
+      onNothing maybeV $
+        throwError $
+          "Expected: " <> envVar
+  connStr <- flip onLeft printErrExit $ renderURLTemplate envMap urlTemplate
+  pure $ describe "Database.MSSQL.TransactionSpec" $ TransactionSpec.spec connStr
+
+mssqlConnectionString :: (String, String)
+mssqlConnectionString =
+  ( "HASURA_MSSQL_CONN_STR",
+    "SQL Server database connection string. Example DRIVER={ODBC Driver 17 for SQL Server};SERVER=$IP_ADDRESS,$PORT;Uid=$USER;Pwd=$PASSWORD;"
+  )
+
 buildPostgresSpecs :: HasVersion => Maybe URLTemplate -> IO Spec
 buildPostgresSpecs maybeUrlTemplate = do
   env <- getEnvironment
@@ -145,15 +173,22 @@ parseArgs = execParser $ info (helper <*> (parseNoCommand <|> parseSubCommand))
   where
     parseDbUrlTemplate =
       parseDatabaseUrl <|> (fmap rawConnDetailsToUrl <$> parseRawConnDetails)
-    parseNoCommand = AllSuites <$> parseDbUrlTemplate
+    parseNoCommand = AllSuites <$> parseDbUrlTemplate <*> parseDbUrlTemplate
     parseSubCommand = SingleSuite <$> parseHspecPassThroughArgs <*> subCmd
       where
-        subCmd = subparser $ mconcat
-          [ command "unit" $ info (pure UnitSuite) $
-              progDesc "Only run unit tests"
-          , command "postgres" $ info (helper <*> (PostgresSuite <$> parseDbUrlTemplate)) $
-              progDesc "Only run Postgres integration tests"
-          ]
+        subCmd =
+          subparser $
+            mconcat
+              [ command "unit" $
+                  info (pure UnitSuite) $
+                    progDesc "Only run unit tests",
+                command "postgres" $
+                  info (helper <*> (PostgresSuite <$> parseDbUrlTemplate)) $
+                    progDesc "Only run Postgres integration tests",
+                command "mssql" $
+                  info (helper <*> (MSSQLSuite <$> parseDbUrlTemplate)) $
+                    progDesc "Only run SQL Server unit tests"
+              ]
         -- Add additional arguments and tweak as needed:
         hspecArgs = ["match", "skip"]
         -- parse to a list of arguments as they'd appear from 'getArgs':