-- | Validate native queries against postgres-like flavors.
module Hasura.Backends.Postgres.Instances.NativeQueries
  ( validateNativeQuery,
    nativeQueryToPreparedStatement,
  )
where

import Data.Aeson (toJSON)
import Data.Bifunctor
import Data.ByteString qualified as BS
import Data.Environment qualified as Env
import Data.HashMap.Strict qualified as HashMap
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Extended (commaSeparated, dquoteList, toTxt)
import Data.Tuple (swap)
import Database.PG.Query qualified as PG
import Database.PostgreSQL.LibPQ qualified as PQ
import Hasura.Backends.Postgres.Connection qualified as PG
import Hasura.Backends.Postgres.Connection.Connect (withPostgresDB)
import Hasura.Backends.Postgres.Instances.Types ()
import Hasura.Backends.Postgres.SQL.Types (PGScalarType (..), pgScalarTypeToText)
import Hasura.Base.Error
import Hasura.LogicalModel.Cache (LogicalModelInfo (..))
import Hasura.LogicalModel.Common (columnsFromFields)
import Hasura.NativeQuery.InterpolatedQuery (trimQueryEnd)
import Hasura.NativeQuery.Metadata
  ( ArgumentName,
    InterpolatedItem (..),
    InterpolatedQuery (..),
    NativeQueryMetadata (..),
  )
import Hasura.NativeQuery.Types (NullableScalarType (nstType))
import Hasura.NativeQuery.Validation (validateArgumentDeclaration)
import Hasura.Prelude
import Hasura.RQL.Types.BackendType

-- | Prepare a native query query against a postgres-like database to validate it.
validateNativeQuery ::
  forall m pgKind.
  (MonadIO m, MonadError QErr m) =>
  InsOrdHashMap.InsOrdHashMap PGScalarType PQ.Oid ->
  Env.Environment ->
  PG.PostgresConnConfiguration ->
  LogicalModelInfo ('Postgres pgKind) ->
  NativeQueryMetadata ('Postgres pgKind) ->
  m (InterpolatedQuery ArgumentName)
validateNativeQuery :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadIO m, MonadError QErr m) =>
InsOrdHashMap PGScalarType Oid
-> Environment
-> PostgresConnConfiguration
-> LogicalModelInfo ('Postgres pgKind)
-> NativeQueryMetadata ('Postgres pgKind)
-> m (InterpolatedQuery ArgumentName)
validateNativeQuery InsOrdHashMap PGScalarType Oid
pgTypeOidMapping Environment
env PostgresConnConfiguration
connConf LogicalModelInfo ('Postgres pgKind)
logicalModel NativeQueryMetadata ('Postgres pgKind)
nq = do
  NativeQueryMetadata ('Postgres pgKind) -> m ()
forall (m :: * -> *) (b :: BackendType).
(MonadIO m, MonadError QErr m) =>
NativeQueryMetadata b -> m ()
validateArgumentDeclaration NativeQueryMetadata ('Postgres pgKind)
nq
  let nqmCode :: InterpolatedQuery ArgumentName
nqmCode = InterpolatedQuery ArgumentName -> InterpolatedQuery ArgumentName
forall var. InterpolatedQuery var -> InterpolatedQuery var
trimQueryEnd (NativeQueryMetadata ('Postgres pgKind)
-> InterpolatedQuery ArgumentName
forall (b :: BackendType).
NativeQueryMetadata b -> InterpolatedQuery ArgumentName
_nqmCode NativeQueryMetadata ('Postgres pgKind)
nq)
      model :: NativeQueryMetadata ('Postgres pgKind)
model = NativeQueryMetadata ('Postgres pgKind)
nq {_nqmCode :: InterpolatedQuery ArgumentName
_nqmCode = InterpolatedQuery ArgumentName
nqmCode}
  (ByteString
prepname, Text
preparedQuery) <- LogicalModelInfo ('Postgres pgKind)
-> NativeQueryMetadata ('Postgres pgKind) -> m (ByteString, Text)
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadError QErr m =>
LogicalModelInfo ('Postgres pgKind)
-> NativeQueryMetadata ('Postgres pgKind) -> m (ByteString, Text)
nativeQueryToPreparedStatement LogicalModelInfo ('Postgres pgKind)
logicalModel NativeQueryMetadata ('Postgres pgKind)
model
  PreparedDescription Oid
description <- ByteString -> Query -> m (PreparedDescription Oid)
runCheck ByteString
prepname (Text -> Query
PG.fromText Text
preparedQuery)
  let returnColumns :: [(Text, PGScalarType)]
returnColumns = (PGCol -> Text)
-> (NullableScalarType ('Postgres pgKind) -> PGScalarType)
-> (PGCol, NullableScalarType ('Postgres pgKind))
-> (Text, PGScalarType)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PGCol -> Text
forall a. ToTxt a => a -> Text
toTxt NullableScalarType ('Postgres pgKind)
-> ScalarType ('Postgres pgKind)
NullableScalarType ('Postgres pgKind) -> PGScalarType
forall (b :: BackendType). NullableScalarType b -> ScalarType b
nstType ((PGCol, NullableScalarType ('Postgres pgKind))
 -> (Text, PGScalarType))
-> [(PGCol, NullableScalarType ('Postgres pgKind))]
-> [(Text, PGScalarType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
-> [(PGCol, NullableScalarType ('Postgres pgKind))]
forall k v. InsOrdHashMap k v -> [(k, v)]
InsOrdHashMap.toList (InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
-> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
forall k (b :: BackendType).
InsOrdHashMap k (LogicalModelField b)
-> InsOrdHashMap k (NullableScalarType b)
columnsFromFields (InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
 -> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind)))
-> InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
-> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ LogicalModelInfo ('Postgres pgKind)
-> InsOrdHashMap
     (Column ('Postgres pgKind)) (LogicalModelField ('Postgres pgKind))
forall (b :: BackendType).
LogicalModelInfo b
-> InsOrdHashMap (Column b) (LogicalModelField b)
_lmiFields LogicalModelInfo ('Postgres pgKind)
logicalModel)

  [(Text, PGScalarType)] -> ((Text, PGScalarType) -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([(Text, PGScalarType)] -> [(Text, PGScalarType)]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [(Text, PGScalarType)]
returnColumns) (PreparedDescription Oid -> (Text, PGScalarType) -> m ()
matchTypes PreparedDescription Oid
description)
  InterpolatedQuery ArgumentName
-> m (InterpolatedQuery ArgumentName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InterpolatedQuery ArgumentName
nqmCode
  where
    -- Run stuff against the database.
    --
    -- We don't need to deallocate the prepared statement because 'withPostgresDB'
    -- opens a new connection, runs a statement, and then closes the connection.
    -- Since a prepared statement only lasts for the duration of the session, once
    -- the session closes, the prepared statement is deallocated as well.
    runCheck :: BS.ByteString -> PG.Query -> m (PG.PreparedDescription PQ.Oid)
    runCheck :: ByteString -> Query -> m (PreparedDescription Oid)
runCheck ByteString
prepname Query
stmt =
      Either QErr (PreparedDescription Oid)
-> m (PreparedDescription Oid)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        (Either QErr (PreparedDescription Oid)
 -> m (PreparedDescription Oid))
-> m (Either QErr (PreparedDescription Oid))
-> m (PreparedDescription Oid)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either QErr (PreparedDescription Oid))
-> m (Either QErr (PreparedDescription Oid))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          ( Environment
-> PostgresConnConfiguration
-> TxET QErr IO (PreparedDescription Oid)
-> IO (Either QErr (PreparedDescription Oid))
forall a.
Environment
-> PostgresConnConfiguration
-> TxET QErr IO a
-> IO (Either QErr a)
withPostgresDB
              Environment
env
              PostgresConnConfiguration
connConf
              ( do
                  -- prepare statement
                  forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> [PrepArg] -> Bool -> TxET e m a
PG.rawQE @_ @()
                    ( \PGTxErr
e ->
                        (Code -> Text -> QErr
err400 Code
ValidationFailed Text
"Failed to validate query")
                          { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGTxErr -> Value
forall a. ToJSON a => a -> Value
toJSON PGTxErr
e
                          }
                    )
                    Query
stmt
                    []
                    Bool
False
                  -- extract description
                  (PGTxErr -> QErr)
-> ByteString -> TxET QErr IO (PreparedDescription Oid)
forall (m :: * -> *) e.
MonadIO m =>
(PGTxErr -> e) -> ByteString -> TxET e m (PreparedDescription Oid)
PG.describePreparedStatement
                    ( \PGTxErr
e ->
                        (Code -> Text -> QErr
err400 Code
ValidationFailed Text
"Failed to validate query")
                          { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGTxErr -> Value
forall a. ToJSON a => a -> Value
toJSON PGTxErr
e
                          }
                    )
                    ByteString
prepname
              )
          )

    -- Look for the type for a particular column in the prepared statement description
    --   and compare them.
    --   fail if not found, try to provide a good error message if you can.
    matchTypes :: PG.PreparedDescription PQ.Oid -> (Text, PGScalarType) -> m ()
    matchTypes :: PreparedDescription Oid -> (Text, PGScalarType) -> m ()
matchTypes PreparedDescription Oid
description (Text
name, PGScalarType
expectedType) =
      case Maybe ByteString -> [(Maybe ByteString, Oid)] -> Maybe Oid
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
Text.encodeUtf8 Text
name)) (PreparedDescription Oid -> [(Maybe ByteString, Oid)]
forall typ. PreparedDescription typ -> [(Maybe ByteString, typ)]
PG.pd_fname_ftype PreparedDescription Oid
description) of
        Maybe Oid
Nothing ->
          QErr -> m ()
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
            (Code -> Text -> QErr
err400 Code
ValidationFailed Text
"Failed to validate query")
              { qeInternal :: Maybe QErrExtra
qeInternal =
                  QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just
                    (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal
                    (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON @Text
                    (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
"Column named '"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. ToTxt a => a -> Text
toTxt Text
name
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not returned from the query."
              }
        Just Oid
actualOid
          | Just Oid
expectedOid <- PGScalarType -> InsOrdHashMap PGScalarType Oid -> Maybe Oid
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup PGScalarType
expectedType InsOrdHashMap PGScalarType Oid
pgTypeOidMapping,
            Oid
expectedOid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= Oid
actualOid ->
              QErr -> m ()
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                (Code -> Text -> QErr
err400 Code
ValidationFailed Text
"Failed to validate query")
                  { qeInternal :: Maybe QErrExtra
qeInternal =
                      QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just
                        (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal
                        (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON @Text
                        (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
                        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [ Text
"Return column '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' has a type mismatch.",
                            Text
"The expected type is '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PGScalarType -> Text
forall a. ToTxt a => a -> Text
toTxt PGScalarType
expectedType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"',"
                          ]
                        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> case Oid -> Map Oid PGScalarType -> Maybe PGScalarType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Oid
actualOid (InsOrdHashMap PGScalarType Oid -> Map Oid PGScalarType
invertPgTypeOidMap InsOrdHashMap PGScalarType Oid
pgTypeOidMapping) of
                          Just PGScalarType
t ->
                            [Text
"but the actual type is '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PGScalarType -> Text
forall a. ToTxt a => a -> Text
toTxt PGScalarType
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."]
                          Maybe PGScalarType
Nothing ->
                            [ Text
"and has the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Oid -> Text
forall a. Show a => a -> Text
tshow Oid
expectedOid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
",",
                              Text
"but the actual type has the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Oid -> Text
forall a. Show a => a -> Text
tshow Oid
actualOid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                            ]
                  }
        Just {} -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Invert the type/oid mapping.
invertPgTypeOidMap :: InsOrdHashMap PGScalarType PQ.Oid -> Map PQ.Oid PGScalarType
invertPgTypeOidMap :: InsOrdHashMap PGScalarType Oid -> Map Oid PGScalarType
invertPgTypeOidMap = [(Oid, PGScalarType)] -> Map Oid PGScalarType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Oid, PGScalarType)] -> Map Oid PGScalarType)
-> (InsOrdHashMap PGScalarType Oid -> [(Oid, PGScalarType)])
-> InsOrdHashMap PGScalarType Oid
-> Map Oid PGScalarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PGScalarType, Oid) -> (Oid, PGScalarType))
-> [(PGScalarType, Oid)] -> [(Oid, PGScalarType)]
forall a b. (a -> b) -> [a] -> [b]
map (PGScalarType, Oid) -> (Oid, PGScalarType)
forall a b. (a, b) -> (b, a)
swap ([(PGScalarType, Oid)] -> [(Oid, PGScalarType)])
-> (InsOrdHashMap PGScalarType Oid -> [(PGScalarType, Oid)])
-> InsOrdHashMap PGScalarType Oid
-> [(Oid, PGScalarType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap PGScalarType Oid -> [(PGScalarType, Oid)]
forall k v. InsOrdHashMap k v -> [(k, v)]
InsOrdHashMap.toList

---------------------------------------

-- | The environment and fresh-name generator used by 'renameIQ'.
data RenamingState = RenamingState
  { RenamingState -> Int
rsNextFree :: Int,
    RenamingState -> Map ArgumentName Int
rsBoundVars :: Map ArgumentName Int
  }

-- | 'Rename' an 'InterpolatedQuery' expression with 'ArgumentName' variables
-- into one which uses ordinal arguments instead of named arguments, suitable
-- for a prepared query.
renameIQ ::
  InterpolatedQuery ArgumentName ->
  ( InterpolatedQuery Int,
    Map Int ArgumentName
  )
renameIQ :: InterpolatedQuery ArgumentName
-> (InterpolatedQuery Int, Map Int ArgumentName)
renameIQ = State RenamingState (InterpolatedQuery Int)
-> (InterpolatedQuery Int, Map Int ArgumentName)
forall a. State RenamingState a -> (a, Map Int ArgumentName)
runRenaming (State RenamingState (InterpolatedQuery Int)
 -> (InterpolatedQuery Int, Map Int ArgumentName))
-> (InterpolatedQuery ArgumentName
    -> State RenamingState (InterpolatedQuery Int))
-> InterpolatedQuery ArgumentName
-> (InterpolatedQuery Int, Map Int ArgumentName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([InterpolatedItem Int] -> InterpolatedQuery Int)
-> StateT RenamingState Identity [InterpolatedItem Int]
-> State RenamingState (InterpolatedQuery Int)
forall a b.
(a -> b)
-> StateT RenamingState Identity a
-> StateT RenamingState Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [InterpolatedItem Int] -> InterpolatedQuery Int
forall variable.
[InterpolatedItem variable] -> InterpolatedQuery variable
InterpolatedQuery (StateT RenamingState Identity [InterpolatedItem Int]
 -> State RenamingState (InterpolatedQuery Int))
-> (InterpolatedQuery ArgumentName
    -> StateT RenamingState Identity [InterpolatedItem Int])
-> InterpolatedQuery ArgumentName
-> State RenamingState (InterpolatedQuery Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InterpolatedItem ArgumentName
 -> StateT RenamingState Identity (InterpolatedItem Int))
-> [InterpolatedItem ArgumentName]
-> StateT RenamingState Identity [InterpolatedItem Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM InterpolatedItem ArgumentName
-> StateT RenamingState Identity (InterpolatedItem Int)
renameII ([InterpolatedItem ArgumentName]
 -> StateT RenamingState Identity [InterpolatedItem Int])
-> (InterpolatedQuery ArgumentName
    -> [InterpolatedItem ArgumentName])
-> InterpolatedQuery ArgumentName
-> StateT RenamingState Identity [InterpolatedItem Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpolatedQuery ArgumentName -> [InterpolatedItem ArgumentName]
forall variable.
InterpolatedQuery variable -> [InterpolatedItem variable]
getInterpolatedQuery
  where
    runRenaming :: forall a. State RenamingState a -> (a, Map Int ArgumentName)
    runRenaming :: forall a. State RenamingState a -> (a, Map Int ArgumentName)
runRenaming State RenamingState a
action =
      let (a
res, RenamingState
st) = State RenamingState a -> RenamingState -> (a, RenamingState)
forall s a. State s a -> s -> (a, s)
runState State RenamingState a
action (Int -> Map ArgumentName Int -> RenamingState
RenamingState Int
1 Map ArgumentName Int
forall a. Monoid a => a
mempty)
       in (a
res, Map ArgumentName Int -> Map Int ArgumentName
forall b a. Ord b => Map a b -> Map b a
inverseMap (Map ArgumentName Int -> Map Int ArgumentName)
-> Map ArgumentName Int -> Map Int ArgumentName
forall a b. (a -> b) -> a -> b
$ RenamingState -> Map ArgumentName Int
rsBoundVars RenamingState
st)

    drawFree :: State RenamingState Int
    drawFree :: State RenamingState Int
drawFree = do
      Int
i <- (RenamingState -> Int) -> State RenamingState Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenamingState -> Int
rsNextFree
      (RenamingState -> RenamingState)
-> StateT RenamingState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RenamingState
s -> RenamingState
s {rsNextFree :: Int
rsNextFree = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1})
      Int -> State RenamingState Int
forall a. a -> StateT RenamingState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

    -- Rename a variable, assigning a fresh argument index when encounting new
    -- variables and reusing the previously assigned indices when encountering a
    -- previously treated variable accordingly.
    renameII ::
      InterpolatedItem ArgumentName ->
      State RenamingState (InterpolatedItem Int)
    renameII :: InterpolatedItem ArgumentName
-> StateT RenamingState Identity (InterpolatedItem Int)
renameII = (ArgumentName -> State RenamingState Int)
-> InterpolatedItem ArgumentName
-> StateT RenamingState Identity (InterpolatedItem Int)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InterpolatedItem a -> f (InterpolatedItem b)
traverse \ArgumentName
v -> do
      Map ArgumentName Int
env <- (RenamingState -> Map ArgumentName Int)
-> StateT RenamingState Identity (Map ArgumentName Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RenamingState -> Map ArgumentName Int
rsBoundVars
      (ArgumentName -> Map ArgumentName Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ArgumentName
v Map ArgumentName Int
env)
        Maybe Int -> State RenamingState Int -> State RenamingState Int
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` ( do
                        Int
i <- State RenamingState Int
drawFree
                        (RenamingState -> RenamingState)
-> StateT RenamingState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \RenamingState
s -> RenamingState
s {rsBoundVars :: Map ArgumentName Int
rsBoundVars = ArgumentName -> Int -> Map ArgumentName Int -> Map ArgumentName Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ArgumentName
v Int
i (RenamingState -> Map ArgumentName Int
rsBoundVars RenamingState
s)}
                        Int -> State RenamingState Int
forall a. a -> StateT RenamingState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
                    )

    -- When renaming from the named representation to the ordinal representation
    -- it is convenient for the variable renaming environment to be keyed by the
    -- names.
    -- When subsequently rendering the prepared statement definition however, it
    -- is more convenient to inspect the environment by index.
    -- Therefore we invert the map as part of renaming.
    inverseMap :: (Ord b) => Map a b -> Map b a
    inverseMap :: forall b a. Ord b => Map a b -> Map b a
inverseMap = [(b, a)] -> Map b a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(b, a)] -> Map b a)
-> (Map a b -> [(b, a)]) -> Map a b -> Map b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (b, a)) -> [(a, b)] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> (b, a)
forall a b. (a, b) -> (b, a)
swap ([(a, b)] -> [(b, a)])
-> (Map a b -> [(a, b)]) -> Map a b -> [(b, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Pretty print an interpolated query with numbered parameters.
renderIQ :: InterpolatedQuery Int -> Text
renderIQ :: InterpolatedQuery Int -> Text
renderIQ (InterpolatedQuery [InterpolatedItem Int]
items) = (InterpolatedItem Int -> Text) -> [InterpolatedItem Int] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap InterpolatedItem Int -> Text
printItem [InterpolatedItem Int]
items
  where
    printItem :: InterpolatedItem Int -> Text
    printItem :: InterpolatedItem Int -> Text
printItem (IIText Text
t) = Text
t
    printItem (IIVariable Int
i) = Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
i

-----------------------------------------

-- | Convert a native query to a prepared statement to be validate.
--
-- Used by 'validateNativeQuery'. Exported for testing.
nativeQueryToPreparedStatement ::
  forall m pgKind.
  (MonadError QErr m) =>
  LogicalModelInfo ('Postgres pgKind) ->
  NativeQueryMetadata ('Postgres pgKind) ->
  m (BS.ByteString, Text)
nativeQueryToPreparedStatement :: forall (m :: * -> *) (pgKind :: PostgresKind).
MonadError QErr m =>
LogicalModelInfo ('Postgres pgKind)
-> NativeQueryMetadata ('Postgres pgKind) -> m (ByteString, Text)
nativeQueryToPreparedStatement LogicalModelInfo ('Postgres pgKind)
logicalModel NativeQueryMetadata ('Postgres pgKind)
model = do
  let (InterpolatedQuery Int
preparedIQ, Map Int ArgumentName
argumentMapping) = InterpolatedQuery ArgumentName
-> (InterpolatedQuery Int, Map Int ArgumentName)
renameIQ (InterpolatedQuery ArgumentName
 -> (InterpolatedQuery Int, Map Int ArgumentName))
-> InterpolatedQuery ArgumentName
-> (InterpolatedQuery Int, Map Int ArgumentName)
forall a b. (a -> b) -> a -> b
$ NativeQueryMetadata ('Postgres pgKind)
-> InterpolatedQuery ArgumentName
forall (b :: BackendType).
NativeQueryMetadata b -> InterpolatedQuery ArgumentName
_nqmCode NativeQueryMetadata ('Postgres pgKind)
model
      logimoCode :: Text
      logimoCode :: Text
logimoCode = InterpolatedQuery Int -> Text
renderIQ InterpolatedQuery Int
preparedIQ
      prepname :: Text
prepname = Text
"_logimo_vali_"

      occurringArguments, declaredArguments, undeclaredArguments :: Set ArgumentName
      occurringArguments :: Set ArgumentName
occurringArguments = [ArgumentName] -> Set ArgumentName
forall a. Ord a => [a] -> Set a
Set.fromList (Map Int ArgumentName -> [ArgumentName]
forall k a. Map k a -> [a]
Map.elems Map Int ArgumentName
argumentMapping)
      declaredArguments :: Set ArgumentName
declaredArguments = [ArgumentName] -> Set ArgumentName
forall a. Ord a => [a] -> Set a
Set.fromList ([ArgumentName] -> Set ArgumentName)
-> [ArgumentName] -> Set ArgumentName
forall a b. (a -> b) -> a -> b
$ HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
-> [ArgumentName]
forall k v. HashMap k v -> [k]
HashMap.keys (NativeQueryMetadata ('Postgres pgKind)
-> HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
forall (b :: BackendType).
NativeQueryMetadata b
-> HashMap ArgumentName (NullableScalarType b)
_nqmArguments NativeQueryMetadata ('Postgres pgKind)
model)
      undeclaredArguments :: Set ArgumentName
undeclaredArguments = Set ArgumentName
occurringArguments Set ArgumentName -> Set ArgumentName -> Set ArgumentName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ArgumentName
declaredArguments

      argumentTypes :: Map Int PGScalarType
      argumentTypes :: Map Int PGScalarType
argumentTypes = NullableScalarType ('Postgres pgKind)
-> ScalarType ('Postgres pgKind)
NullableScalarType ('Postgres pgKind) -> PGScalarType
forall (b :: BackendType). NullableScalarType b -> ScalarType b
nstType (NullableScalarType ('Postgres pgKind) -> PGScalarType)
-> Map Int (NullableScalarType ('Postgres pgKind))
-> Map Int PGScalarType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ArgumentName, NullableScalarType ('Postgres pgKind))]
-> Map ArgumentName (NullableScalarType ('Postgres pgKind))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
-> [(ArgumentName, NullableScalarType ('Postgres pgKind))]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
 -> [(ArgumentName, NullableScalarType ('Postgres pgKind))])
-> HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
-> [(ArgumentName, NullableScalarType ('Postgres pgKind))]
forall a b. (a -> b) -> a -> b
$ NativeQueryMetadata ('Postgres pgKind)
-> HashMap ArgumentName (NullableScalarType ('Postgres pgKind))
forall (b :: BackendType).
NativeQueryMetadata b
-> HashMap ArgumentName (NullableScalarType b)
_nqmArguments NativeQueryMetadata ('Postgres pgKind)
model) Map ArgumentName (NullableScalarType ('Postgres pgKind))
-> Map Int ArgumentName
-> Map Int (NullableScalarType ('Postgres pgKind))
forall b c a. Ord b => Map b c -> Map a b -> Map a c
`Map.compose` Map Int ArgumentName
argumentMapping

      argumentSignature :: Text
argumentSignature
        | Map Int PGScalarType
argumentTypes Map Int PGScalarType -> Map Int PGScalarType -> Bool
forall a. Eq a => a -> a -> Bool
/= Map Int PGScalarType
forall a. Monoid a => a
mempty = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
commaSeparated (PGScalarType -> Text
pgScalarTypeToText (PGScalarType -> Text) -> [PGScalarType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Int PGScalarType -> [PGScalarType]
forall k a. Map k a -> [a]
Map.elems Map Int PGScalarType
argumentTypes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        | Bool
otherwise = Text
""

      returnedColumnNames :: Text
      returnedColumnNames :: Text
returnedColumnNames =
        [PGCol] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
dquoteList ([PGCol] -> Text) -> [PGCol] -> Text
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
-> [PGCol]
forall k v. InsOrdHashMap k v -> [k]
InsOrdHashMap.keys (InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
-> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
forall k (b :: BackendType).
InsOrdHashMap k (LogicalModelField b)
-> InsOrdHashMap k (NullableScalarType b)
columnsFromFields (InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
 -> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind)))
-> InsOrdHashMap PGCol (LogicalModelField ('Postgres pgKind))
-> InsOrdHashMap PGCol (NullableScalarType ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ LogicalModelInfo ('Postgres pgKind)
-> InsOrdHashMap
     (Column ('Postgres pgKind)) (LogicalModelField ('Postgres pgKind))
forall (b :: BackendType).
LogicalModelInfo b
-> InsOrdHashMap (Column b) (LogicalModelField b)
_lmiFields LogicalModelInfo ('Postgres pgKind)
logicalModel)

      wrapInCTE :: Text -> Text
      wrapInCTE :: Text -> Text
wrapInCTE Text
query =
        Text -> [Text] -> Text
Text.intercalate
          Text
"\n"
          [ Text
"WITH " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ctename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AS (",
            Text
query,
            Text
")",
            Text
"SELECT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
returnedColumnNames,
            Text
"FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ctename
          ]
        where
          ctename :: Text
ctename = Text
"_cte" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prepname

      preparedQuery :: Text
preparedQuery = Text
"PREPARE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prepname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argumentSignature Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
wrapInCTE Text
logimoCode

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set ArgumentName
forall a. Set a
Set.empty Set ArgumentName -> Set ArgumentName -> Bool
forall a. Eq a => a -> a -> Bool
/= Set ArgumentName
undeclaredArguments)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ QErr -> m ()
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (QErr -> m ()) -> QErr -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err400 Code
ValidationFailed
    (Text -> QErr) -> Text -> QErr
forall a b. (a -> b) -> a -> b
$ Text
"Undeclared arguments: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
commaSeparated ((ArgumentName -> Text) -> [ArgumentName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ArgumentName -> Text
forall a. Show a => a -> Text
tshow ([ArgumentName] -> [Text]) -> [ArgumentName] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set ArgumentName -> [ArgumentName]
forall a. Set a -> [a]
Set.toList Set ArgumentName
undeclaredArguments)

  (ByteString, Text) -> m (ByteString, Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ByteString
Text.encodeUtf8 Text
prepname, Text
preparedQuery)