{-# 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 Control.Monad.Trans.Control
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.DataConnector.Agent.Client (AgentLicenseKey)
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.CredentialCache
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.RQL.Types.BackendType
import Hasura.SQL.AnyBackend (AnyBackend)
import Hasura.Server.Types (RequestId)
import Hasura.Session
import Hasura.Tracing

instance BackendTransport 'MSSQL where
  runDBQuery :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadQueryLog m, MonadExecutionLog m, MonadTrace m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad
     (ExecutionMonad 'MSSQL)
     (Maybe (AnyBackend ExecutionStats), EncJSON)
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runDBQuery = RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad
     (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad
     (ExecutionMonad 'MSSQL)
     (Maybe (AnyBackend ExecutionStats), EncJSON)
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadQueryLog m, MonadTrace m,
 MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad
     (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runQuery
  runDBQueryExplain :: forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadBaseControl IO m,
 MonadTrace m) =>
Maybe (CredentialCache AgentLicenseKey)
-> DBStepInfo 'MSSQL -> m EncJSON
runDBQueryExplain = Maybe (CredentialCache AgentLicenseKey)
-> DBStepInfo 'MSSQL -> m EncJSON
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
Maybe (CredentialCache AgentLicenseKey)
-> DBStepInfo 'MSSQL -> m EncJSON
runQueryExplain
  runDBMutation :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadQueryLog m, MonadTrace m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad (ExecutionMonad 'MSSQL) EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runDBMutation = RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad (ExceptT QErr) EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad (ExecutionMonad 'MSSQL) EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadQueryLog m, MonadTrace m,
 MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad (ExceptT QErr) EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runMutation
  runDBSubscription :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runDBSubscription = SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runSubscription
  runDBStreamingSubscription :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
runDBStreamingSubscription SourceConfig 'MSSQL
_ MultiplexedQuery 'MSSQL
_ [(CohortId, CohortVariables)]
_ ResolvedConnectionTemplate 'MSSQL
_ =
    IO
  (DiffTime,
   Either QErr [(CohortId, ByteString, CursorVariableValues)])
-> m (DiffTime,
      Either QErr [(CohortId, ByteString, CursorVariableValues)])
forall a. IO a -> m a
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 a. a -> Parser a
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,
    MonadBaseControl IO m,
    MonadQueryLog m,
    MonadTrace m,
    MonadError QErr m
  ) =>
  RequestId ->
  GQLReqUnparsed ->
  RootFieldAlias ->
  UserInfo ->
  L.Logger L.Hasura ->
  Maybe (CredentialCache AgentLicenseKey) ->
  SourceConfig 'MSSQL ->
  OnBaseMonad (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON) ->
  Maybe (PreparedQuery 'MSSQL) ->
  ResolvedConnectionTemplate 'MSSQL ->
  -- | Also return the time spent in the PG query; for telemetry.
  m (DiffTime, EncJSON)
runQuery :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadQueryLog m, MonadTrace m,
 MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad
     (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runQuery RequestId
reqId GQLReqUnparsed
query RootFieldAlias
fieldName UserInfo
_userInfo Logger Hasura
logger Maybe (CredentialCache AgentLicenseKey)
_ SourceConfig 'MSSQL
sourceConfig OnBaseMonad
  (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
tx Maybe (PreparedQuery 'MSSQL)
genSql ResolvedConnectionTemplate 'MSSQL
_ = 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.
(MonadIO m, MonadTrace m) =>
Text -> m a -> m a
newSpan (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
$ (m EncJSON -> m () -> m EncJSON
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (b :: BackendType) (m :: * -> *).
(HasSourceConfiguration b, MonadTrace m) =>
SourceConfig b -> m ()
attachSourceConfigAttributes @'MSSQL SourceConfig 'MSSQL
sourceConfig)
    (m EncJSON -> m EncJSON) -> m EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ ((Maybe (AnyBackend ExecutionStats), EncJSON) -> EncJSON)
-> m (Maybe (AnyBackend ExecutionStats), EncJSON) -> m EncJSON
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (AnyBackend ExecutionStats), EncJSON) -> EncJSON
forall a b. (a, b) -> b
snd (OnBaseMonad
  (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
-> m (Maybe (AnyBackend ExecutionStats), EncJSON)
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
OnBaseMonad (ExceptT QErr) a -> m a
run OnBaseMonad
  (ExceptT QErr) (Maybe (AnyBackend ExecutionStats), EncJSON)
tx)

runQueryExplain ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m,
    MonadTrace m
  ) =>
  Maybe (CredentialCache AgentLicenseKey) ->
  DBStepInfo 'MSSQL ->
  m EncJSON
runQueryExplain :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
Maybe (CredentialCache AgentLicenseKey)
-> DBStepInfo 'MSSQL -> m EncJSON
runQueryExplain Maybe (CredentialCache AgentLicenseKey)
_ (DBStepInfo SourceName
_ SourceConfig 'MSSQL
_ Maybe (PreparedQuery 'MSSQL)
_ OnBaseMonad (ExecutionMonad 'MSSQL) (ActionResult 'MSSQL)
action ResolvedConnectionTemplate 'MSSQL
_) = (ActionResult 'MSSQL -> EncJSON)
-> m (ActionResult 'MSSQL) -> m EncJSON
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActionResult 'MSSQL -> EncJSON
forall (b :: BackendType). ActionResult b -> EncJSON
arResult (OnBaseMonad (ExceptT QErr) (ActionResult 'MSSQL)
-> m (ActionResult 'MSSQL)
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
OnBaseMonad (ExceptT QErr) a -> m a
run OnBaseMonad (ExceptT QErr) (ActionResult 'MSSQL)
OnBaseMonad (ExecutionMonad 'MSSQL) (ActionResult 'MSSQL)
action)

runMutation ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadQueryLog m,
    MonadTrace m,
    MonadError QErr m
  ) =>
  RequestId ->
  GQLReqUnparsed ->
  RootFieldAlias ->
  UserInfo ->
  L.Logger L.Hasura ->
  Maybe (CredentialCache AgentLicenseKey) ->
  SourceConfig 'MSSQL ->
  OnBaseMonad (ExceptT QErr) EncJSON ->
  Maybe (PreparedQuery 'MSSQL) ->
  ResolvedConnectionTemplate 'MSSQL ->
  -- | Also return 'Mutation' when the operation was a mutation, and the time
  -- spent in the PG query; for telemetry.
  m (DiffTime, EncJSON)
runMutation :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadQueryLog m, MonadTrace m,
 MonadError QErr m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> Maybe (CredentialCache AgentLicenseKey)
-> SourceConfig 'MSSQL
-> OnBaseMonad (ExceptT QErr) EncJSON
-> Maybe (PreparedQuery 'MSSQL)
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, EncJSON)
runMutation RequestId
reqId GQLReqUnparsed
query RootFieldAlias
fieldName UserInfo
_userInfo Logger Hasura
logger Maybe (CredentialCache AgentLicenseKey)
_ SourceConfig 'MSSQL
sourceConfig OnBaseMonad (ExceptT QErr) EncJSON
tx Maybe (PreparedQuery 'MSSQL)
_genSql ResolvedConnectionTemplate 'MSSQL
_ = 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 Text
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.
(MonadIO m, MonadTrace m) =>
Text -> m a -> m a
newSpan (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
$ (m EncJSON -> m () -> m EncJSON
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (b :: BackendType) (m :: * -> *).
(HasSourceConfiguration b, MonadTrace m) =>
SourceConfig b -> m ()
attachSourceConfigAttributes @'MSSQL SourceConfig 'MSSQL
sourceConfig)
    (m EncJSON -> m EncJSON) -> m EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ OnBaseMonad (ExceptT QErr) EncJSON -> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
OnBaseMonad (ExceptT QErr) a -> m a
run OnBaseMonad (ExceptT QErr) EncJSON
tx

runSubscription ::
  (MonadIO m, MonadBaseControl IO m) =>
  SourceConfig 'MSSQL ->
  MultiplexedQuery 'MSSQL ->
  [(CohortId, CohortVariables)] ->
  ResolvedConnectionTemplate 'MSSQL ->
  m (DiffTime, Either QErr [(CohortId, B.ByteString)])
runSubscription :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig 'MSSQL
-> MultiplexedQuery 'MSSQL
-> [(CohortId, CohortVariables)]
-> ResolvedConnectionTemplate 'MSSQL
-> m (DiffTime, Either QErr [(CohortId, ByteString)])
runSubscription SourceConfig 'MSSQL
sourceConfig (MultiplexedQuery' Reselect
reselect QueryTagsComment
queryTags) [(CohortId, CohortVariables)]
variables ResolvedConnectionTemplate 'MSSQL
_ = 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, MonadBaseControl IO m) =>
MSSQLExecCtx -> Query -> ExceptT QErr m [(CohortId, ByteString)]
executeMultiplexedQuery MSSQLExecCtx
mssqlExecCtx Query
queryWithQueryTags

executeMultiplexedQuery ::
  (MonadIO m, MonadBaseControl IO m) =>
  MSSQLExecCtx ->
  ODBC.Query ->
  ExceptT QErr m [(CohortId, B.ByteString)]
executeMultiplexedQuery :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
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 m (Either QErr Text) -> ExceptT QErr m Text
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (ExceptT QErr m (Either QErr Text) -> ExceptT QErr m Text)
-> ExceptT QErr m (Either QErr Text) -> ExceptT QErr m Text
forall a b. (a -> b) -> a -> b
$ ExceptT QErr (ExceptT QErr m) Text
-> ExceptT QErr m (Either QErr Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr (ExceptT QErr m) Text
 -> ExceptT QErr m (Either QErr Text))
-> ExceptT QErr (ExceptT QErr m) Text
-> ExceptT QErr m (Either QErr Text)
forall a b. (a -> b) -> a -> b
$ MSSQLExecCtx -> MSSQLRunTx
mssqlRunReadOnly MSSQLExecCtx
mssqlExecCtx (TxET QErr (ExceptT QErr m) Text
 -> ExceptT QErr (ExceptT QErr m) Text)
-> TxET QErr (ExceptT QErr m) Text
-> ExceptT QErr (ExceptT QErr m) Text
forall a b. (a -> b) -> a -> b
$ (MSSQLTxError -> QErr) -> Query -> TxET QErr (ExceptT QErr m) 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 a. a -> ExceptT QErr m a
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, MonadBaseControl IO m, MonadError QErr m, MonadTrace m) => OnBaseMonad (ExceptT QErr) a -> m a
run :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
OnBaseMonad (ExceptT QErr) a -> m a
run = m (Either QErr a) -> m a
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr a) -> m a)
-> (OnBaseMonad (ExceptT QErr) a -> m (Either QErr a))
-> OnBaseMonad (ExceptT QErr) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT QErr m a -> m (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m a -> m (Either QErr a))
-> (OnBaseMonad (ExceptT QErr) a -> ExceptT QErr m a)
-> OnBaseMonad (ExceptT QErr) a
-> m (Either QErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnBaseMonad (ExceptT QErr) a -> ExceptT QErr m a
OnBaseMonad (ExceptT QErr) a
-> forall (m :: * -> *).
   (Functor (ExceptT QErr m), MonadIO m, MonadBaseControl IO m,
    MonadTrace m, MonadError QErr m) =>
   ExceptT QErr m a
forall (t :: (* -> *) -> * -> *) a.
OnBaseMonad t a
-> forall (m :: * -> *).
   (Functor (t m), MonadIO m, MonadBaseControl IO m, MonadTrace m,
    MonadError QErr m) =>
   t m a
runOnBaseMonad

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 =
  -- @QueryLogKindDatabase Nothing@ means that the backend doesn't support connection templates
  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 (Maybe BackendResolvedConnectionTemplate -> QueryLogKind
QueryLogKindDatabase Maybe BackendResolvedConnectionTemplate
forall a. Maybe a
Nothing)
  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