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

module Hasura.Backends.MySQL.Instances.Execute () where

import Data.Aeson as J
import Data.Bifunctor
import Data.Coerce
import Data.Environment qualified as Env
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Tree
import Database.MySQL.Base (fetchFields, query, storeResult)
import Hasura.Backends.MySQL.Connection
import Hasura.Backends.MySQL.DataLoader.Execute (OutputValue (..), RecordSet (..))
import Hasura.Backends.MySQL.DataLoader.Execute qualified as DataLoader
import Hasura.Backends.MySQL.DataLoader.Plan qualified as DataLoader
import Hasura.Backends.MySQL.Plan
import Hasura.Backends.MySQL.ToQuery as ToQuery
import Hasura.Backends.MySQL.Types qualified as MySQL
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.GraphQL.Execute.Backend
import Hasura.GraphQL.Namespace
import Hasura.Prelude hiding (first, second)
import Hasura.RQL.IR
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Common
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.SQL.Backend
import Hasura.Session
import Hasura.Tracing qualified as Tracing

instance BackendExecute 'MySQL where
  type PreparedQuery 'MySQL = Text
  type MultiplexedQuery 'MySQL = Void
  type ExecutionMonad 'MySQL = Tracing.TraceT (ExceptT QErr IO)

  mkDBQueryPlan :: UserInfo
-> Environment
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
mkDBQueryPlan = UserInfo
-> Environment
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
forall (m :: * -> *).
MonadError QErr m =>
UserInfo
-> Environment
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
mysqlDBQueryPlan
  mkDBMutationPlan :: UserInfo
-> StringifyNumbers
-> SourceName
-> SourceConfig 'MySQL
-> MutationDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
mkDBMutationPlan = [Char]
-> UserInfo
-> StringifyNumbers
-> SourceName
-> SourceConfig
-> MutationDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
forall a. HasCallStack => [Char] -> a
error [Char]
"mkDBMutationPlan: MySQL backend does not support this operation yet."
  mkLiveQuerySubscriptionPlan :: UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> Maybe Name
-> RootFieldMap (QueryDB 'MySQL Void (UnpreparedValue 'MySQL))
-> m (SubscriptionQueryPlan 'MySQL (MultiplexedQuery 'MySQL))
mkLiveQuerySubscriptionPlan UserInfo
_ SourceName
_ SourceConfig 'MySQL
_ Maybe Name
_ = [Char]
-> RootFieldMap (QueryDB 'MySQL Void (UnpreparedValue 'MySQL))
-> m (SubscriptionQueryPlan 'MySQL Void)
forall a. HasCallStack => [Char] -> a
error [Char]
"mkLiveQuerySubscriptionPlan: MySQL backend does not support this operation yet."
  mkDBStreamingSubscriptionPlan :: UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> (RootFieldAlias, QueryDB 'MySQL Void (UnpreparedValue 'MySQL))
-> m (SubscriptionQueryPlan 'MySQL (MultiplexedQuery 'MySQL))
mkDBStreamingSubscriptionPlan UserInfo
_ SourceName
_ SourceConfig 'MySQL
_ (RootFieldAlias, QueryDB 'MySQL Void (UnpreparedValue 'MySQL))
_ = [Char] -> m (SubscriptionQueryPlan 'MySQL Void)
forall a. HasCallStack => [Char] -> a
error [Char]
"mkDBStreamingSubscriptionPlan: MySQL backend does not support this operation yet."
  mkDBQueryExplain :: RootFieldAlias
-> UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (AnyBackend DBStepInfo)
mkDBQueryExplain = RootFieldAlias
-> UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (AnyBackend DBStepInfo)
forall (m :: * -> *).
MonadError QErr m =>
RootFieldAlias
-> UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (AnyBackend DBStepInfo)
mysqlDBQueryExplain
  mkSubscriptionExplain :: SubscriptionQueryPlan 'MySQL (MultiplexedQuery 'MySQL)
-> m SubscriptionQueryPlanExplanation
mkSubscriptionExplain SubscriptionQueryPlan 'MySQL (MultiplexedQuery 'MySQL)
_ = [Char] -> m SubscriptionQueryPlanExplanation
forall a. HasCallStack => [Char] -> a
error [Char]
"mkSubscriptionExplain: MySQL backend does not support this operation yet."
  mkDBRemoteRelationshipPlan :: UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> NonEmpty Object
-> HashMap FieldName (Column 'MySQL, ScalarType 'MySQL)
-> FieldName
-> (FieldName,
    SourceRelationshipSelection 'MySQL Void UnpreparedValue)
-> m (DBStepInfo 'MySQL)
mkDBRemoteRelationshipPlan = [Char]
-> UserInfo
-> SourceName
-> SourceConfig
-> NonEmpty Object
-> HashMap FieldName (Column, ScalarType)
-> FieldName
-> (FieldName,
    SourceRelationshipSelection 'MySQL Void UnpreparedValue)
-> m (DBStepInfo 'MySQL)
forall a. HasCallStack => [Char] -> a
error [Char]
"mkDBRemoteRelationshipPlan: MySQL does not support this operation yet."

mysqlDBQueryPlan ::
  forall m.
  ( MonadError QErr m
  ) =>
  UserInfo ->
  Env.Environment ->
  SourceName ->
  SourceConfig 'MySQL ->
  QueryDB 'MySQL Void (UnpreparedValue 'MySQL) ->
  m (DBStepInfo 'MySQL)
mysqlDBQueryPlan :: UserInfo
-> Environment
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (DBStepInfo 'MySQL)
mysqlDBQueryPlan UserInfo
userInfo Environment
_env SourceName
sourceName SourceConfig 'MySQL
sourceConfig QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
qrf = do
  (HeadAndTail
headAndTail, Forest PlannedAction
actionsForest) <- UserInfo
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (HeadAndTail, Forest PlannedAction)
forall (m :: * -> *).
MonadError QErr m =>
UserInfo
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (HeadAndTail, Forest PlannedAction)
queryToActionForest UserInfo
userInfo QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
qrf
  DBStepInfo 'MySQL -> m (DBStepInfo 'MySQL)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( SourceName
-> SourceConfig 'MySQL
-> Maybe (PreparedQuery 'MySQL)
-> ExecutionMonad 'MySQL EncJSON
-> DBStepInfo 'MySQL
forall (b :: BackendType).
SourceName
-> SourceConfig b
-> Maybe (PreparedQuery b)
-> ExecutionMonad b EncJSON
-> DBStepInfo b
DBStepInfo
        @'MySQL
        SourceName
sourceName
        SourceConfig 'MySQL
sourceConfig
        (Text -> Maybe Text
forall a. a -> Maybe a
Just ([Char] -> Text
T.pack ([Tree [Char]] -> [Char]
drawForest ((Tree PlannedAction -> Tree [Char])
-> Forest PlannedAction -> [Tree [Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PlannedAction -> [Char]) -> Tree PlannedAction -> Tree [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PlannedAction -> [Char]
forall a. Show a => a -> [Char]
show) Forest PlannedAction
actionsForest))))
        ( do
            Either ExecuteProblem RecordSet
result <-
              SourceConfig
-> HeadAndTail
-> Execute ()
-> TraceT (ExceptT QErr IO) (Either ExecuteProblem RecordSet)
forall (m :: * -> *) a.
MonadIO m =>
SourceConfig
-> HeadAndTail -> Execute a -> m (Either ExecuteProblem RecordSet)
DataLoader.runExecute
                SourceConfig 'MySQL
SourceConfig
sourceConfig
                HeadAndTail
headAndTail
                (Forest PlannedAction -> Execute ()
DataLoader.execute Forest PlannedAction
actionsForest)
            (ExecuteProblem -> TraceT (ExceptT QErr IO) EncJSON)
-> (RecordSet -> TraceT (ExceptT QErr IO) EncJSON)
-> Either ExecuteProblem RecordSet
-> TraceT (ExceptT QErr IO) EncJSON
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
              (Text -> Value -> TraceT (ExceptT QErr IO) EncJSON
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"MySQL DataLoader Error" (Value -> TraceT (ExceptT QErr IO) EncJSON)
-> (ExecuteProblem -> Value)
-> ExecuteProblem
-> TraceT (ExceptT QErr IO) EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Char] -> Value)
-> (ExecuteProblem -> [Char]) -> ExecuteProblem -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecuteProblem -> [Char]
forall a. Show a => a -> [Char]
show)
              (EncJSON -> TraceT (ExceptT QErr IO) EncJSON
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> TraceT (ExceptT QErr IO) EncJSON)
-> (RecordSet -> EncJSON)
-> RecordSet
-> TraceT (ExceptT QErr IO) EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordSet -> EncJSON
encJFromRecordSet)
              Either ExecuteProblem RecordSet
result
        )
    )

--------------------------------------------------------------------------------
-- Encoding for Hasura's GraphQL JSON representation

mysqlDBQueryExplain ::
  MonadError QErr m =>
  RootFieldAlias ->
  UserInfo ->
  SourceName ->
  SourceConfig 'MySQL ->
  QueryDB 'MySQL Void (UnpreparedValue 'MySQL) ->
  m (AB.AnyBackend DBStepInfo)
mysqlDBQueryExplain :: RootFieldAlias
-> UserInfo
-> SourceName
-> SourceConfig 'MySQL
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
-> m (AnyBackend DBStepInfo)
mysqlDBQueryExplain RootFieldAlias
fieldName UserInfo
userInfo SourceName
sourceName SourceConfig 'MySQL
sourceConfig QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
qrf = do
  Select
select :: MySQL.Select <- SessionVariables
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL) -> m Select
forall (m :: * -> *).
MonadError QErr m =>
SessionVariables
-> QueryDB 'MySQL Void (UnpreparedValue 'MySQL) -> m Select
planQuery (UserInfo -> SessionVariables
_uiSession UserInfo
userInfo) QueryDB 'MySQL Void (UnpreparedValue 'MySQL)
qrf
  let sqlQuery :: Query
sqlQuery = Select -> Query
selectSQLTextForQuery Select
select
      sqlQueryText :: Text
sqlQueryText = (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Printer -> ByteString) -> Printer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> ByteString
unQuery (Query -> ByteString)
-> (Printer -> Query) -> Printer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printer -> Query
toQueryPretty) (Select -> Printer
ToQuery.fromSelect Select
select)
      explainResult :: TraceT (ExceptT QErr IO) EncJSON
explainResult =
        Pool Connection
-> (Connection -> IO EncJSON) -> TraceT (ExceptT QErr IO) EncJSON
forall (m :: * -> *) a.
MonadIO m =>
Pool Connection -> (Connection -> IO a) -> m a
withMySQLPool
          (SourceConfig -> Pool Connection
MySQL.scConnectionPool SourceConfig 'MySQL
SourceConfig
sourceConfig)
          ( \Connection
conn -> do
              Connection -> ByteString -> IO ()
query Connection
conn (ByteString
"EXPLAIN FORMAT=JSON " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Query -> ByteString
unQuery Query
sqlQuery))
              Result
result <- Connection -> IO Result
storeResult Connection
conn
              [Field]
fields <- Result -> IO [Field]
fetchFields Result
result
              [[Maybe ByteString]]
rows <- Result -> IO [[Maybe ByteString]]
fetchAllRows Result
result
              let texts :: [Text]
texts = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Field] -> [[Maybe ByteString]] -> [[Text]]
parseTextRows [Field]
fields [[Maybe ByteString]]
rows
              EncJSON -> IO EncJSON
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> IO EncJSON) -> EncJSON -> IO EncJSON
forall a b. (a -> b) -> a -> b
$ ExplainPlan -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (ExplainPlan -> EncJSON) -> ExplainPlan -> EncJSON
forall a b. (a -> b) -> a -> b
$ RootFieldAlias -> Maybe Text -> Maybe [Text] -> ExplainPlan
ExplainPlan RootFieldAlias
fieldName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sqlQueryText) ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
texts)
          )
  AnyBackend DBStepInfo -> m (AnyBackend DBStepInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyBackend DBStepInfo -> m (AnyBackend DBStepInfo))
-> AnyBackend DBStepInfo -> m (AnyBackend DBStepInfo)
forall a b. (a -> b) -> a -> b
$
    DBStepInfo 'MySQL -> AnyBackend DBStepInfo
forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
i b -> AnyBackend i
AB.mkAnyBackend (DBStepInfo 'MySQL -> AnyBackend DBStepInfo)
-> DBStepInfo 'MySQL -> AnyBackend DBStepInfo
forall a b. (a -> b) -> a -> b
$
      SourceName
-> SourceConfig 'MySQL
-> Maybe (PreparedQuery 'MySQL)
-> ExecutionMonad 'MySQL EncJSON
-> DBStepInfo 'MySQL
forall (b :: BackendType).
SourceName
-> SourceConfig b
-> Maybe (PreparedQuery b)
-> ExecutionMonad b EncJSON
-> DBStepInfo b
DBStepInfo @'MySQL SourceName
sourceName SourceConfig 'MySQL
sourceConfig Maybe (PreparedQuery 'MySQL)
forall a. Maybe a
Nothing TraceT (ExceptT QErr IO) EncJSON
ExecutionMonad 'MySQL EncJSON
explainResult

selectSQLTextForQuery :: MySQL.Select -> ToQuery.Query
selectSQLTextForQuery :: Select -> Query
selectSQLTextForQuery Select
select = Printer -> Query
toQueryFlat (Printer -> Query) -> Printer -> Query
forall a b. (a -> b) -> a -> b
$ Select -> Printer
ToQuery.fromSelect Select
select

encJFromRecordSet :: RecordSet -> EncJSON
encJFromRecordSet :: RecordSet -> EncJSON
encJFromRecordSet RecordSet {Vector (InsOrdHashMap FieldName OutputValue)
rows :: RecordSet -> Vector (InsOrdHashMap FieldName OutputValue)
rows :: Vector (InsOrdHashMap FieldName OutputValue)
rows} =
  [EncJSON] -> EncJSON
encJFromList
    ( (InsOrdHashMap FieldName OutputValue -> EncJSON)
-> [InsOrdHashMap FieldName OutputValue] -> [EncJSON]
forall a b. (a -> b) -> [a] -> [b]
map
        ( [(Text, EncJSON)] -> EncJSON
encJFromAssocList
            ([(Text, EncJSON)] -> EncJSON)
-> (InsOrdHashMap FieldName OutputValue -> [(Text, EncJSON)])
-> InsOrdHashMap FieldName OutputValue
-> EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, OutputValue) -> (Text, EncJSON))
-> [(FieldName, OutputValue)] -> [(Text, EncJSON)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldName -> Text) -> (FieldName, EncJSON) -> (Text, EncJSON)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FieldName -> Text
coerce ((FieldName, EncJSON) -> (Text, EncJSON))
-> ((FieldName, OutputValue) -> (FieldName, EncJSON))
-> (FieldName, OutputValue)
-> (Text, EncJSON)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputValue -> EncJSON)
-> (FieldName, OutputValue) -> (FieldName, EncJSON)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second OutputValue -> EncJSON
encJFromOutputValue)
            ([(FieldName, OutputValue)] -> [(Text, EncJSON)])
-> (InsOrdHashMap FieldName OutputValue
    -> [(FieldName, OutputValue)])
-> InsOrdHashMap FieldName OutputValue
-> [(Text, EncJSON)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap FieldName OutputValue -> [(FieldName, OutputValue)]
forall k v. InsOrdHashMap k v -> [(k, v)]
OMap.toList
        )
        (Vector (InsOrdHashMap FieldName OutputValue)
-> [InsOrdHashMap FieldName OutputValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector (InsOrdHashMap FieldName OutputValue)
rows)
    )

encJFromOutputValue :: DataLoader.OutputValue -> EncJSON
encJFromOutputValue :: OutputValue -> EncJSON
encJFromOutputValue =
  \case
    ArrayOutputValue Vector OutputValue
array -> [EncJSON] -> EncJSON
encJFromList ((OutputValue -> EncJSON) -> [OutputValue] -> [EncJSON]
forall a b. (a -> b) -> [a] -> [b]
map OutputValue -> EncJSON
encJFromOutputValue (Vector OutputValue -> [OutputValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector OutputValue
array))
    RecordOutputValue InsOrdHashMap FieldName OutputValue
m ->
      [(Text, EncJSON)] -> EncJSON
encJFromAssocList
        ([(Text, EncJSON)] -> EncJSON)
-> (InsOrdHashMap FieldName OutputValue -> [(Text, EncJSON)])
-> InsOrdHashMap FieldName OutputValue
-> EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, OutputValue) -> (Text, EncJSON))
-> [(FieldName, OutputValue)] -> [(Text, EncJSON)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldName -> Text) -> (FieldName, EncJSON) -> (Text, EncJSON)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FieldName -> Text
coerce ((FieldName, EncJSON) -> (Text, EncJSON))
-> ((FieldName, OutputValue) -> (FieldName, EncJSON))
-> (FieldName, OutputValue)
-> (Text, EncJSON)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputValue -> EncJSON)
-> (FieldName, OutputValue) -> (FieldName, EncJSON)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second OutputValue -> EncJSON
encJFromOutputValue)
        ([(FieldName, OutputValue)] -> [(Text, EncJSON)])
-> (InsOrdHashMap FieldName OutputValue
    -> [(FieldName, OutputValue)])
-> InsOrdHashMap FieldName OutputValue
-> [(Text, EncJSON)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap FieldName OutputValue -> [(FieldName, OutputValue)]
forall k v. InsOrdHashMap k v -> [(k, v)]
OMap.toList
        (InsOrdHashMap FieldName OutputValue -> EncJSON)
-> InsOrdHashMap FieldName OutputValue -> EncJSON
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap FieldName OutputValue
m
    ScalarOutputValue Value
value -> Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue Value
value
    NullOutputValue {} -> Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue Value
J.Null