module Hasura.Backends.DataConnector.Adapter.RunSQL
  ( DataConnectorRunSQL (..),
    runSQL,
  )
where

import Data.Aeson qualified as J
import Data.HashMap.Strict qualified as HashMap
import Data.Text.Extended (ToTxt (..))
import Hasura.Backends.DataConnector.API (RawRequest (..))
import Hasura.Backends.DataConnector.API qualified as API
import Hasura.Backends.DataConnector.Adapter.Types (DataConnectorName (), SourceConfig (..))
import Hasura.Base.Error (Code (DataConnectorError), QErr (qeInternal), QErrExtra (ExtraInternal), err400)
import Hasura.EncJSON (EncJSON, encJFromJValue)
import Hasura.Prelude
import Hasura.RQL.DDL.Schema (RunSQLRes (..))
import Hasura.RQL.Types.BackendType (BackendType (DataConnector))
import Hasura.RQL.Types.Common (SourceName (), sourceNameToText)
import Hasura.RQL.Types.SchemaCache (askSourceConfig)
import Hasura.RQL.Types.SchemaCache.Build (CacheRWM, MetadataM)
import Servant.Client (mkClientEnv, runClientM, (//))
import Servant.Client.Generic (genericClient)
import Witch qualified

data DataConnectorRunSQL = DataConnectorRunSQL
  { DataConnectorRunSQL -> SourceName
_dcSource :: SourceName,
    DataConnectorRunSQL -> Text
_dcSql :: Text
  }
  deriving (Int -> DataConnectorRunSQL -> ShowS
[DataConnectorRunSQL] -> ShowS
DataConnectorRunSQL -> String
(Int -> DataConnectorRunSQL -> ShowS)
-> (DataConnectorRunSQL -> String)
-> ([DataConnectorRunSQL] -> ShowS)
-> Show DataConnectorRunSQL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DataConnectorRunSQL -> ShowS
showsPrec :: Int -> DataConnectorRunSQL -> ShowS
$cshow :: DataConnectorRunSQL -> String
show :: DataConnectorRunSQL -> String
$cshowList :: [DataConnectorRunSQL] -> ShowS
showList :: [DataConnectorRunSQL] -> ShowS
Show, DataConnectorRunSQL -> DataConnectorRunSQL -> Bool
(DataConnectorRunSQL -> DataConnectorRunSQL -> Bool)
-> (DataConnectorRunSQL -> DataConnectorRunSQL -> Bool)
-> Eq DataConnectorRunSQL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DataConnectorRunSQL -> DataConnectorRunSQL -> Bool
== :: DataConnectorRunSQL -> DataConnectorRunSQL -> Bool
$c/= :: DataConnectorRunSQL -> DataConnectorRunSQL -> Bool
/= :: DataConnectorRunSQL -> DataConnectorRunSQL -> Bool
Eq)

instance J.FromJSON DataConnectorRunSQL where
  parseJSON :: Value -> Parser DataConnectorRunSQL
parseJSON = String
-> (Object -> Parser DataConnectorRunSQL)
-> Value
-> Parser DataConnectorRunSQL
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"DataConnectorRunSQL" ((Object -> Parser DataConnectorRunSQL)
 -> Value -> Parser DataConnectorRunSQL)
-> (Object -> Parser DataConnectorRunSQL)
-> Value
-> Parser DataConnectorRunSQL
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
_dcSql <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"sql"
    SourceName
_dcSource <- Object
o Object -> Key -> Parser SourceName
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"source"
    do
      -- Throw errors on unsupported operations
      Maybe Bool
cascade <- Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"cascade"
      Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
cascade Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) do
        String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cascade not supported for raw data connector queries"
      Maybe Bool
readOnly <- Object
o Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"read_only"
      Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
readOnly Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) do
        String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Read-only not supported for raw data connector queries"
    DataConnectorRunSQL -> Parser DataConnectorRunSQL
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataConnectorRunSQL {Text
SourceName
_dcSource :: SourceName
_dcSql :: Text
_dcSql :: Text
_dcSource :: SourceName
..}

instance J.ToJSON DataConnectorRunSQL where
  toJSON :: DataConnectorRunSQL -> Value
toJSON DataConnectorRunSQL {Text
SourceName
_dcSource :: DataConnectorRunSQL -> SourceName
_dcSql :: DataConnectorRunSQL -> Text
_dcSource :: SourceName
_dcSql :: Text
..} =
    [Pair] -> Value
J.object
      [ Key
"sql" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Text
_dcSql
      ]

-- TODO:
--
-- This is defined in the same manner as runSQL variants for other existing backends.
--
-- The pattern used here should be improved since:

-- * It is brittle: Not as type-safe as it could be

-- * It is slow: Doesn't reuse schema-cache

-- * It is verbose: Code duplication i.e. templates

-- * It is incorrect: Uses runClientM directly without tracing capabilities

--
-- The intent is to refactor all usage of raw sql queries rather than try to fix everything
-- in this PR.
--
runSQL ::
  forall m.
  (MonadIO m, CacheRWM m, MonadError QErr m, MetadataM m) =>
  DataConnectorName ->
  DataConnectorRunSQL ->
  m EncJSON
runSQL :: forall (m :: * -> *).
(MonadIO m, CacheRWM m, MonadError QErr m, MetadataM m) =>
DataConnectorName -> DataConnectorRunSQL -> m EncJSON
runSQL DataConnectorName
methodConnectorName DataConnectorRunSQL {Text
SourceName
_dcSource :: DataConnectorRunSQL -> SourceName
_dcSql :: DataConnectorRunSQL -> Text
_dcSource :: SourceName
_dcSql :: Text
..} = do
  SourceConfig {Maybe Int
Maybe Text
Config
Capabilities
Environment
Manager
BaseUrl
DataConnectorName
_scEndpoint :: BaseUrl
_scConfig :: Config
_scTemplate :: Maybe Text
_scCapabilities :: Capabilities
_scManager :: Manager
_scTimeoutMicroseconds :: Maybe Int
_scDataConnectorName :: DataConnectorName
_scEnvironment :: Environment
_scEndpoint :: SourceConfig -> BaseUrl
_scConfig :: SourceConfig -> Config
_scTemplate :: SourceConfig -> Maybe Text
_scCapabilities :: SourceConfig -> Capabilities
_scManager :: SourceConfig -> Manager
_scTimeoutMicroseconds :: SourceConfig -> Maybe Int
_scDataConnectorName :: SourceConfig -> DataConnectorName
_scEnvironment :: SourceConfig -> Environment
..} <- forall (b :: BackendType) (m :: * -> *).
(CacheRM m, MonadError QErr m, Backend b, MetadataM m) =>
SourceName -> m (SourceConfig b)
askSourceConfig @'DataConnector SourceName
_dcSource

  -- There is no way to know if the source prefix matches the backend type until we have `SourceConfig` available.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DataConnectorName
_scDataConnectorName DataConnectorName -> DataConnectorName -> Bool
forall a. Eq a => a -> a -> Bool
== DataConnectorName
methodConnectorName) do
    QErr -> m ()
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ( Code -> Text -> QErr
err400
          Code
DataConnectorError
          ( Text
"run_sql query referencing connector type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DataConnectorName -> Text
forall source target. From source target => source -> target
Witch.from DataConnectorName
methodConnectorName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not supported on source "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceName -> Text
sourceNameToText SourceName
_dcSource
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for data connector of type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DataConnectorName -> Text
forall source target. From source target => source -> target
Witch.from DataConnectorName
_scDataConnectorName
          )
      )

  let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
_scManager BaseUrl
_scEndpoint
  let client :: ClientM RawResponse
client = (RoutesG Config (AsClientT ClientM)
forall (routes :: * -> *) (m :: * -> *).
(HasClient m (ToServantApi routes),
 GenericServant routes (AsClientT m),
 Client m (ToServantApi routes) ~ ToServant routes (AsClientT m)) =>
routes (AsClientT m)
genericClient RoutesG Config (AsClientT ClientM)
-> (RoutesG Config (AsClientT ClientM)
    -> Text -> Config -> RawRequest -> ClientM RawResponse)
-> Text
-> Config
-> RawRequest
-> ClientM RawResponse
forall a b. a -> (a -> b) -> b
// RoutesG Config (AsClientT ClientM)
-> AsClientT ClientM
   :- ("raw"
       :> (SourceNameHeader Required
           :> (ConfigHeader Config Required
               :> (ReqBody '[JSON] RawRequest :> Post '[JSON] RawResponse))))
RoutesG Config (AsClientT ClientM)
-> Text -> Config -> RawRequest -> ClientM RawResponse
forall config mode. RoutesG config mode -> mode :- RawApi config
API._raw) (SourceName -> Text
forall a. ToTxt a => a -> Text
toTxt SourceName
_dcSource) Config
_scConfig (Text -> RawRequest
RawRequest Text
_dcSql)

  Either ClientError RawResponse
resultsE <- IO (Either ClientError RawResponse)
-> m (Either ClientError RawResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError RawResponse)
 -> m (Either ClientError RawResponse))
-> IO (Either ClientError RawResponse)
-> m (Either ClientError RawResponse)
forall a b. (a -> b) -> a -> b
$ ClientM RawResponse
-> ClientEnv -> IO (Either ClientError RawResponse)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM RawResponse
client ClientEnv
clientEnv

  case RawResponse -> [[(Text, Value)]]
tupleRows (RawResponse -> [[(Text, Value)]])
-> Either ClientError RawResponse
-> Either ClientError [[(Text, Value)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ClientError RawResponse
resultsE of
    Left ClientError
e ->
      QErr -> m EncJSON
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (Code -> Text -> QErr
err400 Code
DataConnectorError Text
"Error performing raw query to data connector")
          { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (Value -> QErrExtra
ExtraInternal (Text -> Value
J.String (ClientError -> Text
forall a. Show a => a -> Text
tshow ClientError
e)))
          }
    Right [] -> EncJSON -> m EncJSON
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> m EncJSON) -> EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ RunSQLRes -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (RunSQLRes -> EncJSON) -> RunSQLRes -> EncJSON
forall a b. (a -> b) -> a -> b
$ Text -> Value -> RunSQLRes
RunSQLRes Text
"CommandOk" Value
J.Null
    Right results :: [[(Text, Value)]]
results@([(Text, Value)]
firstRow : [[(Text, Value)]]
_) ->
      let toRow :: [(a, b)] -> [b]
toRow = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd
          toHeader :: [(Text, b)] -> [Value]
toHeader = ((Text, b) -> Value) -> [(Text, b)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (((Text, b) -> Value) -> [(Text, b)] -> [Value])
-> ((Text, b) -> Value) -> [(Text, b)] -> [Value]
forall a b. (a -> b) -> a -> b
$ Text -> Value
J.String (Text -> Value) -> ((Text, b) -> Text) -> (Text, b) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, b) -> Text
forall a b. (a, b) -> a
fst
       in EncJSON -> m EncJSON
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> m EncJSON) -> EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ RunSQLRes -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (RunSQLRes -> EncJSON) -> RunSQLRes -> EncJSON
forall a b. (a -> b) -> a -> b
$ Text -> Value -> RunSQLRes
RunSQLRes Text
"TuplesOk" (Value -> RunSQLRes) -> Value -> RunSQLRes
forall a b. (a -> b) -> a -> b
$ [[Value]] -> Value
forall a. ToJSON a => a -> Value
J.toJSON ([[Value]] -> Value) -> [[Value]] -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> [Value]
forall {b}. [(Text, b)] -> [Value]
toHeader [(Text, Value)]
firstRow [Value] -> [[Value]] -> [[Value]]
forall a. a -> [a] -> [a]
: ([(Text, Value)] -> [Value]) -> [[(Text, Value)]] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map [(Text, Value)] -> [Value]
forall {a} {b}. [(a, b)] -> [b]
toRow [[(Text, Value)]]
results

tupleRows :: API.RawResponse -> [[(Text, J.Value)]]
tupleRows :: RawResponse -> [[(Text, Value)]]
tupleRows (API.RawResponse [HashMap Text Value]
rs) = case [HashMap Text Value]
rs of
  [] -> []
  xs :: [HashMap Text Value]
xs@(HashMap Text Value
x : [HashMap Text Value]
_) ->
    let ks :: [Text]
ks = HashMap Text Value -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Text Value
x
        lookupKeys :: HashMap Text Value -> [(Text, Value)]
lookupKeys HashMap Text Value
m = (\Text
k -> [(Text, Value)]
-> (Value -> [(Text, Value)]) -> Maybe Value -> [(Text, Value)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text, Value) -> [(Text, Value)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Value) -> [(Text, Value)])
-> (Value -> (Text, Value)) -> Value -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
k,)) (Maybe Value -> [(Text, Value)]) -> Maybe Value -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
k HashMap Text Value
m) (Text -> [(Text, Value)]) -> [Text] -> [(Text, Value)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text]
ks
     in (HashMap Text Value -> [(Text, Value)])
-> [HashMap Text Value] -> [[(Text, Value)]]
forall a b. (a -> b) -> [a] -> [b]
map HashMap Text Value -> [(Text, Value)]
lookupKeys [HashMap Text Value]
xs