{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | MSSQL Instances Transport
--
-- Defines the MSSQL instance of 'BackendTransport' and how to
-- interact with the database for running queries, mutations, subscriptions,
-- and so on.
module Hasura.Backends.MSSQL.Instances.Transport () where

import Control.Exception.Safe (throwIO)
import Data.Aeson qualified as J
import Data.ByteString qualified as B
import Data.String (fromString)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Extended
import Database.MSSQL.Transaction (forJsonQueryE)
import Database.ODBC.SQLServer qualified as ODBC
import Hasura.Backends.MSSQL.Connection
import Hasura.Backends.MSSQL.Execute.QueryTags (withQueryTags)
import Hasura.Backends.MSSQL.Instances.Execute
import Hasura.Backends.MSSQL.SQL.Error
import Hasura.Backends.MSSQL.ToQuery
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.GraphQL.Execute.Backend
import Hasura.GraphQL.Execute.Subscription.Plan
import Hasura.GraphQL.Logging
import Hasura.GraphQL.Namespace (RootFieldAlias)
import Hasura.GraphQL.Transport.Backend
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.Logging qualified as L
import Hasura.Prelude
import Hasura.RQL.Types.Backend
import Hasura.SQL.Backend
import Hasura.Server.Types (RequestId)
import Hasura.Session
import Hasura.Tracing

instance BackendTransport 'MSSQL where
  runDBQuery :: RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExecutionMonad 'MSSQL EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runDBQuery = RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExecutionMonad 'MSSQL EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadQueryLog m, MonadTrace m, MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExceptT QErr IO EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runQuery
  runDBQueryExplain :: DBStepInfo 'MSSQL -> m EncJSON
runDBQueryExplain = DBStepInfo 'MSSQL -> m EncJSON
forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
DBStepInfo 'MSSQL -> m EncJSON
runQueryExplain
  runDBMutation :: RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExecutionMonad 'MSSQL EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runDBMutation = RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExecutionMonad 'MSSQL EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadQueryLog m, MonadTrace m, MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExceptT QErr IO EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runMutation
  runDBSubscription :: SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runDBSubscription = SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
forall (m :: * -> *).
MonadIO m =>
SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runSubscription
  runDBStreamingSubscription :: SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
runDBStreamingSubscription SourceConfig 'MSSQL
_ MultiplexedQuery 'MSSQL
_ [(CohortId, CohortVariables)]
_ =
    IO
  (DiffTime,
   Either QErr [(CohortId, ByteString, CursorVariableValues)])
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (DiffTime,
    Either QErr [(CohortId, ByteString, CursorVariableValues)])
 -> m (DiffTime,
       Either QErr [(CohortId, ByteString, CursorVariableValues)]))
-> (IOError
    -> IO
         (DiffTime,
          Either QErr [(CohortId, ByteString, CursorVariableValues)]))
-> IOError
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError
-> IO
     (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError
 -> m (DiffTime,
       Either QErr [(CohortId, ByteString, CursorVariableValues)]))
-> IOError
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"runDBSubscription: not implemented for MS-SQL sources."

newtype CohortResult = CohortResult (CohortId, Text)

instance J.FromJSON CohortResult where
  parseJSON :: Value -> Parser CohortResult
parseJSON = String
-> (Object -> Parser CohortResult) -> Value -> Parser CohortResult
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"CohortResult" \Object
o -> do
    CohortId
cohortId <- Object
o Object -> Key -> Parser CohortId
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"result_id"
    Text
cohortData <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"result"
    CohortResult -> Parser CohortResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CohortResult -> Parser CohortResult)
-> CohortResult -> Parser CohortResult
forall a b. (a -> b) -> a -> b
$ (CohortId, Text) -> CohortResult
CohortResult (CohortId
cohortId, Text
cohortData)

runQuery ::
  ( MonadIO m,
    MonadQueryLog m,
    MonadTrace m,
    MonadError QErr m
  ) =>
  RequestId ->
  GQLReqUnparsed ->
  RootFieldAlias ->
  UserInfo ->
  L.Logger L.Hasura ->
  SourceConfig 'MSSQL ->
  ExceptT QErr IO EncJSON ->
  Maybe (PreparedQuery 'MSSQL) ->
  -- | Also return the time spent in the PG query; for telemetry.
  m (DiffTime, EncJSON)
runQuery :: RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExceptT QErr IO EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runQuery RequestId
reqId GQLReqUnparsed
query RootFieldAlias
fieldName UserInfo
_userInfo Logger Hasura
logger SourceConfig 'MSSQL
_sourceConfig ExceptT QErr IO EncJSON
tx Maybe (PreparedQuery 'MSSQL)
genSql = do
  Logger Hasura -> QueryLog -> m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> m ()) -> QueryLog -> m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> RootFieldAlias
-> Maybe (PreparedQuery 'MSSQL)
-> RequestId
-> QueryLog
mkQueryLog GQLReqUnparsed
query RootFieldAlias
fieldName Maybe (PreparedQuery 'MSSQL)
genSql RequestId
reqId
  m EncJSON -> m (DiffTime, EncJSON)
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (m EncJSON -> m (DiffTime, EncJSON))
-> m EncJSON -> m (DiffTime, EncJSON)
forall a b. (a -> b) -> a -> b
$
    Text -> m EncJSON -> m EncJSON
forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
trace (Text
"MSSQL Query for root field " Text -> RootFieldAlias -> Text
forall t. ToTxt t => Text -> t -> Text
<>> RootFieldAlias
fieldName) (m EncJSON -> m EncJSON) -> m EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$
      ExceptT QErr IO EncJSON -> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadError QErr m) =>
ExceptT QErr IO a -> m a
run ExceptT QErr IO EncJSON
tx

runQueryExplain ::
  ( MonadIO m,
    MonadError QErr m
  ) =>
  DBStepInfo 'MSSQL ->
  m EncJSON
runQueryExplain :: DBStepInfo 'MSSQL -> m EncJSON
runQueryExplain (DBStepInfo SourceName
_ SourceConfig 'MSSQL
_ Maybe (PreparedQuery 'MSSQL)
_ ExecutionMonad 'MSSQL EncJSON
action) = ExceptT QErr IO EncJSON -> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadError QErr m) =>
ExceptT QErr IO a -> m a
run ExceptT QErr IO EncJSON
ExecutionMonad 'MSSQL EncJSON
action

runMutation ::
  ( MonadIO m,
    MonadQueryLog m,
    MonadTrace m,
    MonadError QErr m
  ) =>
  RequestId ->
  GQLReqUnparsed ->
  RootFieldAlias ->
  UserInfo ->
  L.Logger L.Hasura ->
  SourceConfig 'MSSQL ->
  ExceptT QErr IO EncJSON ->
  Maybe (PreparedQuery 'MSSQL) ->
  -- | Also return 'Mutation' when the operation was a mutation, and the time
  -- spent in the PG query; for telemetry.
  m (DiffTime, EncJSON)
runMutation :: RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig 'MSSQL
-> ExceptT QErr IO EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> m (DiffTime, EncJSON)
runMutation RequestId
reqId GQLReqUnparsed
query RootFieldAlias
fieldName UserInfo
_userInfo Logger Hasura
logger SourceConfig 'MSSQL
_sourceConfig ExceptT QErr IO EncJSON
tx Maybe (PreparedQuery 'MSSQL)
_genSql = do
  Logger Hasura -> QueryLog -> m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> m ()) -> QueryLog -> m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> RootFieldAlias
-> Maybe (PreparedQuery 'MSSQL)
-> RequestId
-> QueryLog
mkQueryLog GQLReqUnparsed
query RootFieldAlias
fieldName Maybe (PreparedQuery 'MSSQL)
forall a. Maybe a
Nothing RequestId
reqId
  m EncJSON -> m (DiffTime, EncJSON)
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (m EncJSON -> m (DiffTime, EncJSON))
-> m EncJSON -> m (DiffTime, EncJSON)
forall a b. (a -> b) -> a -> b
$
    Text -> m EncJSON -> m EncJSON
forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
trace (Text
"MSSQL Mutation for root field " Text -> RootFieldAlias -> Text
forall t. ToTxt t => Text -> t -> Text
<>> RootFieldAlias
fieldName) (m EncJSON -> m EncJSON) -> m EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$
      ExceptT QErr IO EncJSON -> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadError QErr m) =>
ExceptT QErr IO a -> m a
run ExceptT QErr IO EncJSON
tx

runSubscription ::
  MonadIO m =>
  SourceConfig 'MSSQL ->
  MultiplexedQuery 'MSSQL ->
  [(CohortId, CohortVariables)] ->
  m (DiffTime, Either QErr [(CohortId, B.ByteString)])
runSubscription :: SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runSubscription SourceConfig 'MSSQL
sourceConfig (MultiplexedQuery' reselect queryTags) [(CohortId, CohortVariables)]
variables = do
  let mssqlExecCtx :: MSSQLExecCtx
mssqlExecCtx = MSSQLSourceConfig -> MSSQLExecCtx
_mscExecCtx MSSQLSourceConfig
SourceConfig 'MSSQL
sourceConfig
      multiplexed :: Select
multiplexed = [(CohortId, CohortVariables)] -> Reselect -> Select
multiplexRootReselect [(CohortId, CohortVariables)]
variables Reselect
reselect
      query :: Query
query = Printer -> Query
toQueryFlat (Select -> Printer
fromSelect Select
multiplexed)
      -- Append query tags comment to the query. We cannot use 'toSQL' to convert
      -- QueryTagsComment to Query, because it escapes the query tags comment which
      -- will create a badly formatted query. Hence we use the 'rawUnescapedText' to
      -- append the comment without any escaping.
      queryWithQueryTags :: Query
queryWithQueryTags = Query
query Query -> QueryTagsComment -> Query
`withQueryTags` QueryTagsComment
queryTags
  m (Either QErr [(CohortId, ByteString)])
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (m (Either QErr [(CohortId, ByteString)])
 -> m (DiffTime, Either QErr [(CohortId, ByteString)]))
-> m (Either QErr [(CohortId, ByteString)])
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
forall a b. (a -> b) -> a -> b
$ ExceptT QErr m [(CohortId, ByteString)]
-> m (Either QErr [(CohortId, ByteString)])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m [(CohortId, ByteString)]
 -> m (Either QErr [(CohortId, ByteString)]))
-> ExceptT QErr m [(CohortId, ByteString)]
-> m (Either QErr [(CohortId, ByteString)])
forall a b. (a -> b) -> a -> b
$ MSSQLExecCtx -> Query -> ExceptT QErr m [(CohortId, ByteString)]
forall (m :: * -> *).
MonadIO m =>
MSSQLExecCtx -> Query -> ExceptT QErr m [(CohortId, ByteString)]
executeMultiplexedQuery MSSQLExecCtx
mssqlExecCtx Query
queryWithQueryTags

executeMultiplexedQuery ::
  MonadIO m =>
  MSSQLExecCtx ->
  ODBC.Query ->
  ExceptT QErr m [(CohortId, B.ByteString)]
executeMultiplexedQuery :: MSSQLExecCtx -> Query -> ExceptT QErr m [(CohortId, ByteString)]
executeMultiplexedQuery MSSQLExecCtx
mssqlExecCtx Query
query = do
  let parseResult :: Text -> m a
parseResult Text
r = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecodeStrict (Text -> ByteString
encodeUtf8 Text
r) Either String a -> (String -> m a) -> m a
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \String
s -> Code -> Text -> m a
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ParseFailed (String -> Text
forall a. IsString a => String -> a
fromString String
s)
      convertFromJSON :: [CohortResult] -> [(CohortId, B.ByteString)]
      convertFromJSON :: [CohortResult] -> [(CohortId, ByteString)]
convertFromJSON = (CohortResult -> (CohortId, ByteString))
-> [CohortResult] -> [(CohortId, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map \(CohortResult (CohortId
cid, Text
cresult)) -> (CohortId
cid, Text -> ByteString
encodeUtf8 Text
cresult)
  -- Because the 'query' will have a @FOR JSON@ clause at the toplevel it will
  -- be split across multiple rows, hence use of 'forJsonQueryE' which takes
  -- care of concatenating the results.
  Text
textResult <- ExceptT QErr IO Text -> ExceptT QErr m Text
forall (m :: * -> *) a.
(MonadIO m, MonadError QErr m) =>
ExceptT QErr IO a -> m a
run (ExceptT QErr IO Text -> ExceptT QErr m Text)
-> ExceptT QErr IO Text -> ExceptT QErr m Text
forall a b. (a -> b) -> a -> b
$ MSSQLExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
mssqlRunReadOnly MSSQLExecCtx
mssqlExecCtx (TxET QErr IO Text -> ExceptT QErr IO Text)
-> TxET QErr IO Text -> ExceptT QErr IO Text
forall a b. (a -> b) -> a -> b
$ (MSSQLTxError -> QErr) -> Query -> TxET QErr IO Text
forall (m :: * -> *) e.
MonadIO m =>
(MSSQLTxError -> e) -> Query -> TxET e m Text
forJsonQueryE MSSQLTxError -> QErr
defaultMSSQLTxErrorHandler Query
query
  [CohortResult]
parsedResult <- Text -> ExceptT QErr m [CohortResult]
forall (m :: * -> *) a.
(FromJSON a, MonadError QErr m) =>
Text -> m a
parseResult Text
textResult
  [(CohortId, ByteString)] -> ExceptT QErr m [(CohortId, ByteString)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(CohortId, ByteString)]
 -> ExceptT QErr m [(CohortId, ByteString)])
-> [(CohortId, ByteString)]
-> ExceptT QErr m [(CohortId, ByteString)]
forall a b. (a -> b) -> a -> b
$ [CohortResult] -> [(CohortId, ByteString)]
convertFromJSON [CohortResult]
parsedResult

run :: (MonadIO m, MonadError QErr m) => ExceptT QErr IO a -> m a
run :: ExceptT QErr IO a -> m a
run ExceptT QErr IO a
action = do
  Either QErr a
result <- IO (Either QErr a) -> m (Either QErr a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr a) -> m (Either QErr a))
-> IO (Either QErr a) -> m (Either QErr a)
forall a b. (a -> b) -> a -> b
$ ExceptT QErr IO a -> IO (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT QErr IO a
action
  Either QErr a
result Either QErr a -> (QErr -> m a) -> m a
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

mkQueryLog ::
  GQLReqUnparsed ->
  RootFieldAlias ->
  Maybe (PreparedQuery 'MSSQL) ->
  RequestId ->
  QueryLog
mkQueryLog :: GQLReqUnparsed
-> RootFieldAlias
-> Maybe (PreparedQuery 'MSSQL)
-> RequestId
-> QueryLog
mkQueryLog GQLReqUnparsed
gqlQuery RootFieldAlias
fieldName Maybe (PreparedQuery 'MSSQL)
preparedSql RequestId
requestId =
  GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
gqlQuery ((RootFieldAlias
fieldName,) (GeneratedQuery -> (RootFieldAlias, GeneratedQuery))
-> Maybe GeneratedQuery -> Maybe (RootFieldAlias, GeneratedQuery)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GeneratedQuery
generatedQuery) RequestId
requestId QueryLogKind
QueryLogKindDatabase
  where
    generatedQuery :: Maybe GeneratedQuery
generatedQuery =
      Maybe Text
Maybe (PreparedQuery 'MSSQL)
preparedSql Maybe Text -> (Text -> GeneratedQuery) -> Maybe GeneratedQuery
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
queryString ->
        Text -> Value -> GeneratedQuery
GeneratedQuery Text
queryString Value
J.Null