{-# LANGUAGE TemplateHaskell #-}

module Hasura.GraphQL.Schema.Common
  ( SchemaContext (..),
    SchemaKind (..),
    RemoteRelationshipParserBuilder (..),
    NodeInterfaceParserBuilder (..),
    MonadBuildSchemaBase,
    retrieve,
    MonadBuildSourceSchema,
    MonadBuildRemoteSchema,
    runSourceSchema,
    runRemoteSchema,
    ignoreRemoteRelationship,
    isHasuraSchema,
    AggSelectExp,
    AnnotatedField,
    AnnotatedFields,
    ConnectionFields,
    ConnectionSelectExp,
    AnnotatedActionField,
    AnnotatedActionFields,
    EdgeFields,
    Scenario (..),
    SelectArgs,
    SelectStreamArgs,
    SelectExp,
    StreamSelectExp,
    TablePerms,
    getTableRoles,
    askTableInfo,
    comparisonAggOperators,
    mapField,
    mkDescriptionWith,
    numericAggOperators,
    optionalFieldParser,
    parsedSelectionsToFields,
    partialSQLExpToUnpreparedValue,
    requiredFieldParser,
    takeValidFunctions,
    takeValidTables,
    textToName,
    RemoteSchemaParser (..),
    mkEnumTypeName,
    addEnumSuffix,
    peelWithOrigin,
  )
where

import Data.Either (isRight)
import Data.Has
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Text qualified as T
import Data.Text.Casing (GQLNameIdentifier)
import Data.Text.Extended
import Hasura.Backends.Postgres.SQL.Types qualified as PG
import Hasura.Base.Error
import Hasura.GraphQL.Namespace (NamespacedField)
import Hasura.GraphQL.Parser.Internal.TypeChecking qualified as P
import Hasura.GraphQL.Schema.NamingCase
import Hasura.GraphQL.Schema.Node
import Hasura.GraphQL.Schema.Options (SchemaOptions)
import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.GraphQL.Schema.Typename
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.IR qualified as IR
import Hasura.RQL.IR.BoolExp
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Function
import Hasura.RQL.Types.Relationships.Remote
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.SchemaCache hiding (askTableInfo)
import Hasura.RQL.Types.Source
import Hasura.RQL.Types.SourceCustomization
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.Session (RoleName)
import Language.GraphQL.Draft.Syntax qualified as G

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

-- | Aggregation of contextual information required to build the schema.
data SchemaContext = SchemaContext
  { -- | the kind of schema being built
    SchemaContext -> SchemaKind
scSchemaKind :: SchemaKind,
    -- | how to process remote relationships
    SchemaContext -> RemoteRelationshipParserBuilder
scRemoteRelationshipParserBuilder :: RemoteRelationshipParserBuilder,
    -- | the role for which the schema is being built
    SchemaContext -> RoleName
scRole :: RoleName
  }

-- | The kind of schema we're building, and its associated options.
data SchemaKind
  = HasuraSchema
  | RelaySchema NodeInterfaceParserBuilder

isHasuraSchema :: SchemaKind -> Bool
isHasuraSchema :: SchemaKind -> Bool
isHasuraSchema = \case
  SchemaKind
HasuraSchema -> Bool
True
  RelaySchema NodeInterfaceParserBuilder
_ -> Bool
False

-- | The set of common constraints required to build the schema.
type MonadBuildSchemaBase r m n =
  ( MonadError QErr m,
    MonadReader r m,
    P.MonadMemoize m,
    P.MonadParse n,
    Has SchemaOptions r,
    Has SchemaContext r,
    -- TODO: make all `Has x r` explicit fields of 'SchemaContext'
    Has MkTypename r,
    Has CustomizeRemoteFieldName r,
    Has NamingCase r
  )

-- | How a remote relationship field should be processed when building a
-- schema. Injecting this function from the top level avoids having to know how
-- to do top-level dispatch from deep within the schema code.
--
-- Note: the inner function type uses an existential qualifier: it is expected
-- that the given function will work for _any_ monad @m@ that has the relevant
-- constraints. This prevents us from passing a function that is specfic to the
-- monad in which the schema construction will run, but avoids having to
-- propagate type annotations to each call site.
newtype RemoteRelationshipParserBuilder
  = RemoteRelationshipParserBuilder
      ( forall lhsJoinField r n m.
        MonadBuildSchemaBase r m n =>
        RemoteFieldInfo lhsJoinField ->
        m (Maybe [P.FieldParser n (IR.RemoteRelationshipField IR.UnpreparedValue)])
      )

-- | A 'RemoteRelationshipParserBuilder' that ignores the field altogether, that can
-- be used in tests or to build a source or remote schema in isolation.
ignoreRemoteRelationship :: RemoteRelationshipParserBuilder
ignoreRemoteRelationship :: RemoteRelationshipParserBuilder
ignoreRemoteRelationship = (forall lhsJoinField r (n :: * -> *) (m :: * -> *).
 MonadBuildSchemaBase r m n =>
 RemoteFieldInfo lhsJoinField
 -> m (Maybe
         [FieldParser n (RemoteRelationshipField UnpreparedValue)]))
-> RemoteRelationshipParserBuilder
RemoteRelationshipParserBuilder ((forall lhsJoinField r (n :: * -> *) (m :: * -> *).
  MonadBuildSchemaBase r m n =>
  RemoteFieldInfo lhsJoinField
  -> m (Maybe
          [FieldParser n (RemoteRelationshipField UnpreparedValue)]))
 -> RemoteRelationshipParserBuilder)
-> (forall lhsJoinField r (n :: * -> *) (m :: * -> *).
    MonadBuildSchemaBase r m n =>
    RemoteFieldInfo lhsJoinField
    -> m (Maybe
            [FieldParser n (RemoteRelationshipField UnpreparedValue)]))
-> RemoteRelationshipParserBuilder
forall a b. (a -> b) -> a -> b
$ m (Maybe [FieldParser n (RemoteRelationshipField UnpreparedValue)])
-> RemoteFieldInfo lhsJoinField
-> m (Maybe
        [FieldParser n (RemoteRelationshipField UnpreparedValue)])
forall a b. a -> b -> a
const (m (Maybe
      [FieldParser n (RemoteRelationshipField UnpreparedValue)])
 -> RemoteFieldInfo lhsJoinField
 -> m (Maybe
         [FieldParser n (RemoteRelationshipField UnpreparedValue)]))
-> m (Maybe
        [FieldParser n (RemoteRelationshipField UnpreparedValue)])
-> RemoteFieldInfo lhsJoinField
-> m (Maybe
        [FieldParser n (RemoteRelationshipField UnpreparedValue)])
forall a b. (a -> b) -> a -> b
$ Maybe [FieldParser n (RemoteRelationshipField UnpreparedValue)]
-> m (Maybe
        [FieldParser n (RemoteRelationshipField UnpreparedValue)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [FieldParser n (RemoteRelationshipField UnpreparedValue)]
forall a. Maybe a
Nothing

-- | How to build the 'Relay' node.
--
-- Similarly to what we do for remote relationships, we pass in the context the
-- builder function required to build the 'Node' interface, in order to avoid
-- the cross-sources cycles it creates otherwise.
newtype NodeInterfaceParserBuilder = NodeInterfaceParserBuilder
  { NodeInterfaceParserBuilder
-> forall r (n :: * -> *) (m :: * -> *).
   MonadBuildSchemaBase r m n =>
   m (Parser 'Output n NodeMap)
runNodeBuilder ::
      ( forall r n m.
        MonadBuildSchemaBase r m n =>
        m (P.Parser 'P.Output n NodeMap)
      )
  }

-- TODO: move this to Prelude?
retrieve ::
  (MonadReader r m, Has a r) =>
  (a -> b) ->
  m b
retrieve :: (a -> b) -> m b
retrieve a -> b
f = (r -> b) -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((r -> b) -> m b) -> (r -> b) -> m b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> (r -> a) -> r -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
forall a t. Has a t => t -> a
getter

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

type MonadBuildSourceSchema r m n = MonadBuildSchemaBase r m n

runSourceSchema ::
  SchemaContext ->
  SchemaOptions ->
  ReaderT
    ( SchemaContext,
      SchemaOptions,
      MkTypename,
      CustomizeRemoteFieldName,
      NamingCase
    )
    m
    a ->
  m a
runSourceSchema :: SchemaContext
-> SchemaOptions
-> ReaderT
     (SchemaContext, SchemaOptions, MkTypename,
      CustomizeRemoteFieldName, NamingCase)
     m
     a
-> m a
runSourceSchema SchemaContext
context SchemaOptions
options = (ReaderT
   (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
   m
   a
 -> (SchemaContext, SchemaOptions, MkTypename,
     CustomizeRemoteFieldName, NamingCase)
 -> m a)
-> (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
-> ReaderT
     (SchemaContext, SchemaOptions, MkTypename,
      CustomizeRemoteFieldName, NamingCase)
     m
     a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (SchemaContext, SchemaOptions, MkTypename,
   CustomizeRemoteFieldName, NamingCase)
  m
  a
-> (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
-> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SchemaContext
context, SchemaOptions
options, MkTypename
forall a. Monoid a => a
mempty, CustomizeRemoteFieldName
forall a. Monoid a => a
mempty, NamingCase
HasuraCase)

type MonadBuildRemoteSchema r m n = MonadBuildSchemaBase r m n

runRemoteSchema ::
  SchemaContext ->
  SchemaOptions ->
  ReaderT
    ( SchemaContext,
      SchemaOptions,
      MkTypename,
      CustomizeRemoteFieldName,
      NamingCase
    )
    m
    a ->
  m a
runRemoteSchema :: SchemaContext
-> SchemaOptions
-> ReaderT
     (SchemaContext, SchemaOptions, MkTypename,
      CustomizeRemoteFieldName, NamingCase)
     m
     a
-> m a
runRemoteSchema SchemaContext
context SchemaOptions
options = (ReaderT
   (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
   m
   a
 -> (SchemaContext, SchemaOptions, MkTypename,
     CustomizeRemoteFieldName, NamingCase)
 -> m a)
-> (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
-> ReaderT
     (SchemaContext, SchemaOptions, MkTypename,
      CustomizeRemoteFieldName, NamingCase)
     m
     a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (SchemaContext, SchemaOptions, MkTypename,
   CustomizeRemoteFieldName, NamingCase)
  m
  a
-> (SchemaContext, SchemaOptions, MkTypename,
    CustomizeRemoteFieldName, NamingCase)
-> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SchemaContext
context, SchemaOptions
options, MkTypename
forall a. Monoid a => a
mempty, CustomizeRemoteFieldName
forall a. Monoid a => a
mempty, NamingCase
HasuraCase)

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

type SelectExp b = IR.AnnSimpleSelectG b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type StreamSelectExp b = IR.AnnSimpleStreamSelectG b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type AggSelectExp b = IR.AnnAggregateSelectG b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type ConnectionSelectExp b = IR.ConnectionSelect b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type SelectArgs b = IR.SelectArgsG b (IR.UnpreparedValue b)

type SelectStreamArgs b = IR.SelectStreamArgsG b (IR.UnpreparedValue b)

type TablePerms b = IR.TablePermG b (IR.UnpreparedValue b)

type AnnotatedFields b = IR.AnnFieldsG b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type AnnotatedField b = IR.AnnFieldG b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type ConnectionFields b = IR.ConnectionFields b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type EdgeFields b = IR.EdgeFields b (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue b)

type AnnotatedActionFields = IR.ActionFieldsG (IR.RemoteRelationshipField IR.UnpreparedValue)

type AnnotatedActionField = IR.ActionFieldG (IR.RemoteRelationshipField IR.UnpreparedValue)

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

data RemoteSchemaParser n = RemoteSchemaParser
  { RemoteSchemaParser n
-> [FieldParser
      n
      (NamespacedField
         (RemoteSchemaRootField
            (RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable))]
piQuery :: [P.FieldParser n (NamespacedField (IR.RemoteSchemaRootField (IR.RemoteRelationshipField IR.UnpreparedValue) RemoteSchemaVariable))],
    RemoteSchemaParser n
-> Maybe
     [FieldParser
        n
        (NamespacedField
           (RemoteSchemaRootField
              (RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable))]
piMutation :: Maybe [P.FieldParser n (NamespacedField (IR.RemoteSchemaRootField (IR.RemoteRelationshipField IR.UnpreparedValue) RemoteSchemaVariable))],
    RemoteSchemaParser n
-> Maybe
     [FieldParser
        n
        (NamespacedField
           (RemoteSchemaRootField
              (RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable))]
piSubscription :: Maybe [P.FieldParser n (NamespacedField (IR.RemoteSchemaRootField (IR.RemoteRelationshipField IR.UnpreparedValue) RemoteSchemaVariable))]
  }

getTableRoles :: BackendSourceInfo -> [RoleName]
getTableRoles :: BackendSourceInfo -> [RoleName]
getTableRoles BackendSourceInfo
bsi = BackendSourceInfo
-> (forall (b :: BackendType).
    Backend b =>
    SourceInfo b -> [RoleName])
-> [RoleName]
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @Backend BackendSourceInfo
bsi forall (b :: BackendType). Backend b => SourceInfo b -> [RoleName]
forall (b :: BackendType). SourceInfo b -> [RoleName]
go
  where
    go :: SourceInfo b -> [RoleName]
go SourceInfo b
si = HashMap RoleName (RolePermInfo b) -> [RoleName]
forall k v. HashMap k v -> [k]
Map.keys (HashMap RoleName (RolePermInfo b) -> [RoleName])
-> (TableInfo b -> HashMap RoleName (RolePermInfo b))
-> TableInfo b
-> [RoleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableInfo b -> HashMap RoleName (RolePermInfo b)
forall (b :: BackendType). TableInfo b -> RolePermInfoMap b
_tiRolePermInfoMap (TableInfo b -> [RoleName]) -> [TableInfo b] -> [RoleName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HashMap (TableName b) (TableInfo b) -> [TableInfo b]
forall k v. HashMap k v -> [v]
Map.elems (SourceInfo b -> HashMap (TableName b) (TableInfo b)
forall (b :: BackendType). SourceInfo b -> TableCache b
_siTables SourceInfo b
si)

-- | Looks up table information for the given table name. This function
-- should never fail, since the schema cache construction process is
-- supposed to ensure all dependencies are resolved.
-- TODO: deduplicate this with `CacheRM`.
askTableInfo ::
  forall b m.
  (Backend b, MonadError QErr m) =>
  SourceInfo b ->
  TableName b ->
  m (TableInfo b)
askTableInfo :: SourceInfo b -> TableName b -> m (TableInfo b)
askTableInfo SourceInfo {Maybe QueryTagsConfig
TableCache b
FunctionCache b
SourceName
SourceConfig b
SourceCustomization
_siCustomization :: forall (b :: BackendType). SourceInfo b -> SourceCustomization
_siQueryTagsConfig :: forall (b :: BackendType). SourceInfo b -> Maybe QueryTagsConfig
_siConfiguration :: forall (b :: BackendType). SourceInfo b -> SourceConfig b
_siFunctions :: forall (b :: BackendType). SourceInfo b -> FunctionCache b
_siName :: forall (b :: BackendType). SourceInfo b -> SourceName
_siCustomization :: SourceCustomization
_siQueryTagsConfig :: Maybe QueryTagsConfig
_siConfiguration :: SourceConfig b
_siFunctions :: FunctionCache b
_siTables :: TableCache b
_siName :: SourceName
_siTables :: forall (b :: BackendType). SourceInfo b -> TableCache b
..} TableName b
tableName =
  TableName b -> TableCache b -> Maybe (TableInfo b)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TableName b
tableName TableCache b
_siTables
    Maybe (TableInfo b) -> m (TableInfo b) -> m (TableInfo b)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Text -> m (TableInfo b)
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 (Text
"askTableInfo: no info for table " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TableName b -> Text
forall t. ToTxt t => t -> Text
dquote TableName b
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in source " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceName -> Text
forall t. ToTxt t => t -> Text
dquote SourceName
_siName)

-- | Whether the request is sent with `x-hasura-use-backend-only-permissions` set to `true`.
data Scenario = Backend | Frontend deriving (Int -> Scenario
Scenario -> Int
Scenario -> [Scenario]
Scenario -> Scenario
Scenario -> Scenario -> [Scenario]
Scenario -> Scenario -> Scenario -> [Scenario]
(Scenario -> Scenario)
-> (Scenario -> Scenario)
-> (Int -> Scenario)
-> (Scenario -> Int)
-> (Scenario -> [Scenario])
-> (Scenario -> Scenario -> [Scenario])
-> (Scenario -> Scenario -> [Scenario])
-> (Scenario -> Scenario -> Scenario -> [Scenario])
-> Enum Scenario
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Scenario -> Scenario -> Scenario -> [Scenario]
$cenumFromThenTo :: Scenario -> Scenario -> Scenario -> [Scenario]
enumFromTo :: Scenario -> Scenario -> [Scenario]
$cenumFromTo :: Scenario -> Scenario -> [Scenario]
enumFromThen :: Scenario -> Scenario -> [Scenario]
$cenumFromThen :: Scenario -> Scenario -> [Scenario]
enumFrom :: Scenario -> [Scenario]
$cenumFrom :: Scenario -> [Scenario]
fromEnum :: Scenario -> Int
$cfromEnum :: Scenario -> Int
toEnum :: Int -> Scenario
$ctoEnum :: Int -> Scenario
pred :: Scenario -> Scenario
$cpred :: Scenario -> Scenario
succ :: Scenario -> Scenario
$csucc :: Scenario -> Scenario
Enum, Int -> Scenario -> ShowS
[Scenario] -> ShowS
Scenario -> String
(Int -> Scenario -> ShowS)
-> (Scenario -> String) -> ([Scenario] -> ShowS) -> Show Scenario
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scenario] -> ShowS
$cshowList :: [Scenario] -> ShowS
show :: Scenario -> String
$cshow :: Scenario -> String
showsPrec :: Int -> Scenario -> ShowS
$cshowsPrec :: Int -> Scenario -> ShowS
Show, Scenario -> Scenario -> Bool
(Scenario -> Scenario -> Bool)
-> (Scenario -> Scenario -> Bool) -> Eq Scenario
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scenario -> Scenario -> Bool
$c/= :: Scenario -> Scenario -> Bool
== :: Scenario -> Scenario -> Bool
$c== :: Scenario -> Scenario -> Bool
Eq)

textToName :: MonadError QErr m => Text -> m G.Name
textToName :: Text -> m Name
textToName Text
textName =
  Text -> Maybe Name
G.mkName Text
textName
    Maybe Name -> m Name -> m Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Code -> Text -> m Name
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400
      Code
ValidationFailed
      ( Text
"cannot include " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
textName Text -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" in the GraphQL schema because "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" it is not a valid GraphQL identifier"
      )

partialSQLExpToUnpreparedValue :: PartialSQLExp b -> IR.UnpreparedValue b
partialSQLExpToUnpreparedValue :: PartialSQLExp b -> UnpreparedValue b
partialSQLExpToUnpreparedValue (PSESessVar SessionVarType b
pftype SessionVariable
var) = SessionVarType b -> SessionVariable -> UnpreparedValue b
forall (b :: BackendType).
SessionVarType b -> SessionVariable -> UnpreparedValue b
IR.UVSessionVar SessionVarType b
pftype SessionVariable
var
partialSQLExpToUnpreparedValue PartialSQLExp b
PSESession = UnpreparedValue b
forall (b :: BackendType). UnpreparedValue b
IR.UVSession
partialSQLExpToUnpreparedValue (PSESQLExp SQLExpression b
sqlExp) = SQLExpression b -> UnpreparedValue b
forall (b :: BackendType). SQLExpression b -> UnpreparedValue b
IR.UVLiteral SQLExpression b
sqlExp

mapField ::
  Functor m =>
  P.InputFieldsParser m (Maybe a) ->
  (a -> b) ->
  P.InputFieldsParser m (Maybe b)
mapField :: InputFieldsParser m (Maybe a)
-> (a -> b) -> InputFieldsParser m (Maybe b)
mapField InputFieldsParser m (Maybe a)
fp a -> b
f = (Maybe a -> Maybe b)
-> InputFieldsParser m (Maybe a) -> InputFieldsParser m (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) InputFieldsParser m (Maybe a)
fp

parsedSelectionsToFields ::
  -- | how to handle @__typename@ fields
  (Text -> a) ->
  OMap.InsOrdHashMap G.Name (P.ParsedSelection a) ->
  Fields a
parsedSelectionsToFields :: (Text -> a) -> InsOrdHashMap Name (ParsedSelection a) -> Fields a
parsedSelectionsToFields Text -> a
mkTypenameFromText =
  InsOrdHashMap Name (ParsedSelection a)
-> [(Name, ParsedSelection a)]
forall k v. InsOrdHashMap k v -> [(k, v)]
OMap.toList
    (InsOrdHashMap Name (ParsedSelection a)
 -> [(Name, ParsedSelection a)])
-> ([(Name, ParsedSelection a)] -> Fields a)
-> InsOrdHashMap Name (ParsedSelection a)
-> Fields a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Name, ParsedSelection a) -> (FieldName, a))
-> [(Name, ParsedSelection a)] -> Fields a
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldName
FieldName (Text -> FieldName) -> (Name -> Text) -> Name -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
G.unName (Name -> FieldName)
-> (ParsedSelection a -> a)
-> (Name, ParsedSelection a)
-> (FieldName, a)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Name -> a) -> ParsedSelection a -> a
forall a. (Name -> a) -> ParsedSelection a -> a
P.handleTypename (Text -> a
mkTypenameFromText (Text -> a) -> (Name -> Text) -> Name -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
G.unName))

numericAggOperators :: [G.Name]
numericAggOperators :: [Name]
numericAggOperators =
  [ Name
Name._sum,
    Name
Name._avg,
    Name
Name._stddev,
    Name
Name._stddev_samp,
    Name
Name._stddev_pop,
    Name
Name._variance,
    Name
Name._var_samp,
    Name
Name._var_pop
  ]

comparisonAggOperators :: [G.Name]
comparisonAggOperators :: [Name]
comparisonAggOperators = [$$(G.litName "max"), $$(G.litName "min")]

mkDescriptionWith :: Maybe PG.PGDescription -> Text -> G.Description
mkDescriptionWith :: Maybe PGDescription -> Text -> Description
mkDescriptionWith Maybe PGDescription
descM Text
defaultTxt = Text -> Description
G.Description (Text -> Description) -> Text -> Description
forall a b. (a -> b) -> a -> b
$ case Maybe PGDescription
descM of
  Maybe PGDescription
Nothing -> Text
defaultTxt
  Just (PG.PGDescription Text
descTxt) -> [Text] -> Text
T.unlines [Text
descTxt, Text
"\n", Text
defaultTxt]

-- TODO why do we do these validations at this point? What does it mean to track
--      a function but not add it to the schema...?
--      Auke:
--        I believe the intention is simply to allow the console to do postgres data management
--      Karthikeyan: Yes, this is correct. We allowed this pre PDV but somehow
--        got removed in PDV. OTOH, I’m not sure how prevalent this feature
--        actually is
takeValidTables :: forall b. Backend b => TableCache b -> TableCache b
takeValidTables :: TableCache b -> TableCache b
takeValidTables = (TableName b -> TableInfo b -> Bool)
-> TableCache b -> TableCache b
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey TableName b -> TableInfo b -> Bool
graphQLTableFilter
  where
    graphQLTableFilter :: TableName b -> TableInfo b -> Bool
graphQLTableFilter TableName b
tableName TableInfo b
tableInfo =
      -- either the table name should be GraphQL compliant
      -- or it should have a GraphQL custom name set with it
      Either QErr Name -> Bool
forall a b. Either a b -> Bool
isRight (TableName b -> Either QErr Name
forall (b :: BackendType).
Backend b =>
TableName b -> Either QErr Name
tableGraphQLName @b TableName b
tableName)
        Bool -> Bool -> Bool
|| Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (TableConfig b -> Maybe Name
forall (b :: BackendType). TableConfig b -> Maybe Name
_tcCustomName (TableConfig b -> Maybe Name) -> TableConfig b -> Maybe Name
forall a b. (a -> b) -> a -> b
$ TableCoreInfoG b (FieldInfo b) (ColumnInfo b) -> TableConfig b
forall (b :: BackendType) field primaryKeyColumn.
TableCoreInfoG b field primaryKeyColumn -> TableConfig b
_tciCustomConfig (TableCoreInfoG b (FieldInfo b) (ColumnInfo b) -> TableConfig b)
-> TableCoreInfoG b (FieldInfo b) (ColumnInfo b) -> TableConfig b
forall a b. (a -> b) -> a -> b
$ TableInfo b -> TableCoreInfoG b (FieldInfo b) (ColumnInfo b)
forall (b :: BackendType). TableInfo b -> TableCoreInfo b
_tiCoreInfo TableInfo b
tableInfo)

-- TODO and what about graphql-compliant function names here too?
takeValidFunctions :: forall b. FunctionCache b -> FunctionCache b
takeValidFunctions :: FunctionCache b -> FunctionCache b
takeValidFunctions = (FunctionInfo b -> Bool) -> FunctionCache b -> FunctionCache b
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter FunctionInfo b -> Bool
forall (b :: BackendType). FunctionInfo b -> Bool
functionFilter
  where
    functionFilter :: FunctionInfo b -> Bool
functionFilter = Bool -> Bool
not (Bool -> Bool)
-> (FunctionInfo b -> Bool) -> FunctionInfo b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemDefined -> Bool
isSystemDefined (SystemDefined -> Bool)
-> (FunctionInfo b -> SystemDefined) -> FunctionInfo b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctionInfo b -> SystemDefined
forall (b :: BackendType). FunctionInfo b -> SystemDefined
_fiSystemDefined

-- root field builder helpers

requiredFieldParser ::
  (Functor n, Functor m) =>
  (a -> b) ->
  m (P.FieldParser n a) ->
  m (Maybe (P.FieldParser n b))
requiredFieldParser :: (a -> b) -> m (FieldParser n a) -> m (Maybe (FieldParser n b))
requiredFieldParser a -> b
f = (FieldParser n a -> Maybe (FieldParser n b))
-> m (FieldParser n a) -> m (Maybe (FieldParser n b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FieldParser n a -> Maybe (FieldParser n b))
 -> m (FieldParser n a) -> m (Maybe (FieldParser n b)))
-> (FieldParser n a -> Maybe (FieldParser n b))
-> m (FieldParser n a)
-> m (Maybe (FieldParser n b))
forall a b. (a -> b) -> a -> b
$ FieldParser n b -> Maybe (FieldParser n b)
forall a. a -> Maybe a
Just (FieldParser n b -> Maybe (FieldParser n b))
-> (FieldParser n a -> FieldParser n b)
-> FieldParser n a
-> Maybe (FieldParser n b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> FieldParser n a -> FieldParser n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f

optionalFieldParser ::
  (Functor n, Functor m) =>
  (a -> b) ->
  m (Maybe (P.FieldParser n a)) ->
  m (Maybe (P.FieldParser n b))
optionalFieldParser :: (a -> b)
-> m (Maybe (FieldParser n a)) -> m (Maybe (FieldParser n b))
optionalFieldParser = (Maybe (FieldParser n a) -> Maybe (FieldParser n b))
-> m (Maybe (FieldParser n a)) -> m (Maybe (FieldParser n b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (FieldParser n a) -> Maybe (FieldParser n b))
 -> m (Maybe (FieldParser n a)) -> m (Maybe (FieldParser n b)))
-> ((a -> b) -> Maybe (FieldParser n a) -> Maybe (FieldParser n b))
-> (a -> b)
-> m (Maybe (FieldParser n a))
-> m (Maybe (FieldParser n b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldParser n a -> FieldParser n b)
-> Maybe (FieldParser n a) -> Maybe (FieldParser n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FieldParser n a -> FieldParser n b)
 -> Maybe (FieldParser n a) -> Maybe (FieldParser n b))
-> ((a -> b) -> FieldParser n a -> FieldParser n b)
-> (a -> b)
-> Maybe (FieldParser n a)
-> Maybe (FieldParser n b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> FieldParser n a -> FieldParser n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | Builds the type name for referenced enum tables.
mkEnumTypeName :: forall b m r. (Backend b, MonadReader r m, Has MkTypename r, MonadError QErr m, Has NamingCase r) => EnumReference b -> m G.Name
mkEnumTypeName :: EnumReference b -> m Name
mkEnumTypeName (EnumReference TableName b
enumTableName EnumValues
_ Maybe Name
enumTableCustomName) = do
  NamingCase
tCase <- (r -> NamingCase) -> m NamingCase
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> NamingCase
forall a t. Has a t => t -> a
getter
  GQLNameIdentifier
enumTableGQLName <- TableName b -> Either QErr GQLNameIdentifier
forall (b :: BackendType).
Backend b =>
TableName b -> Either QErr GQLNameIdentifier
getTableIdentifier @b TableName b
enumTableName Either QErr GQLNameIdentifier
-> (QErr -> m GQLNameIdentifier) -> m GQLNameIdentifier
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` QErr -> m GQLNameIdentifier
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  GQLNameIdentifier -> Maybe Name -> NamingCase -> m Name
forall r (m :: * -> *).
(MonadReader r m, Has MkTypename r) =>
GQLNameIdentifier -> Maybe Name -> NamingCase -> m Name
addEnumSuffix GQLNameIdentifier
enumTableGQLName Maybe Name
enumTableCustomName NamingCase
tCase

addEnumSuffix :: (MonadReader r m, Has MkTypename r) => GQLNameIdentifier -> Maybe G.Name -> NamingCase -> m G.Name
addEnumSuffix :: GQLNameIdentifier -> Maybe Name -> NamingCase -> m Name
addEnumSuffix GQLNameIdentifier
enumTableGQLName Maybe Name
enumTableCustomName NamingCase
tCase = Name -> m Name
forall r (m :: * -> *).
(MonadReader r m, Has MkTypename r) =>
Name -> m Name
mkTypename (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ NamingCase -> GQLNameIdentifier -> Name
applyTypeNameCaseIdentifier NamingCase
tCase (GQLNameIdentifier -> Name) -> GQLNameIdentifier -> Name
forall a b. (a -> b) -> a -> b
$ GQLNameIdentifier -> Maybe Name -> GQLNameIdentifier
mkEnumTableTypeName GQLNameIdentifier
enumTableGQLName Maybe Name
enumTableCustomName

-- TODO: figure out what the purpose of this method is.
peelWithOrigin :: P.MonadParse m => P.Parser 'P.Both m a -> P.Parser 'P.Both m (IR.ValueWithOrigin a)
peelWithOrigin :: Parser 'Both m a -> Parser 'Both m (ValueWithOrigin a)
peelWithOrigin Parser 'Both m a
parser =
  Parser 'Both m a
parser
    { pParser :: ParserInput 'Both -> m (ValueWithOrigin a)
P.pParser = \case
        P.GraphQLValue (G.VVariable var@P.Variable {vInfo, vValue}) -> do
          -- Check types c.f. 5.8.5 of the June 2018 GraphQL spec
          Bool -> GType -> Variable -> m ()
forall (m :: * -> *).
MonadParse m =>
Bool -> GType -> Variable -> m ()
P.typeCheck Bool
False (Type MetadataObjId 'Both -> GType
forall origin (k :: Kind). Type origin k -> GType
P.toGraphQLType (Type MetadataObjId 'Both -> GType)
-> Type MetadataObjId 'Both -> GType
forall a b. (a -> b) -> a -> b
$ Parser 'Both m a -> Type MetadataObjId 'Both
forall origin (k :: Kind) (m :: * -> *) a.
Parser origin k m a -> Type origin k
P.pType Parser 'Both m a
parser) Variable
var
          VariableInfo -> a -> ValueWithOrigin a
forall a. VariableInfo -> a -> ValueWithOrigin a
IR.ValueWithOrigin VariableInfo
vInfo (a -> ValueWithOrigin a) -> m a -> m (ValueWithOrigin a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser 'Both m a -> ParserInput 'Both -> m a
forall origin (k :: Kind) (m :: * -> *) a.
Parser origin k m a -> ParserInput k -> m a
P.pParser Parser 'Both m a
parser (Void -> Variable
forall a. Void -> a
absurd (Void -> Variable) -> InputValue Void -> InputValue Variable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputValue Void
vValue)
        ParserInput 'Both
value -> a -> ValueWithOrigin a
forall a. a -> ValueWithOrigin a
IR.ValueNoOrigin (a -> ValueWithOrigin a) -> m a -> m (ValueWithOrigin a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser 'Both m a -> ParserInput 'Both -> m a
forall origin (k :: Kind) (m :: * -> *) a.
Parser origin k m a -> ParserInput k -> m a
P.pParser Parser 'Both m a
parser ParserInput 'Both
value
    }