1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-22 23:11:41 +03:00
graphql-engine/server/src-lib/Hasura/GraphQL/Namespace.hs
Auke Booij 29158900d8 Refactor type name customization
Source typename customization (hasura/graphql-engine@aac64f2c81) introduced a mechanism to change certain names in the GraphQL schema that is exposed. In particular it allows last-minute modification of:
1. the names of some types, and
2. the names of some root fields.

The above two items are assigned distinct customization algorithms, and at times both algorithms are in scope. So a need to distinguish them is needed.

In the original design, this was addressed by introducing a newtype wrapper `Typename` around GraphQL `Name`s, dedicated to the names of types. However, in the majority of the codebase, type names are also represented by `Name`. For this reason, it was unavoidable to allow for easy conversion. This was supported by a `HasName Typename` instance, as well as by publishing the constructors of `Typename`.

This means that the type safety that newtypes can add is lost. In particular, it is now very easy to confuse type name customization with root field name customization.

This refactors the above design by instead introducing newtypes around the customization operations:
```haskell
newtype MkTypename = MkTypename {runMkTypename :: Name -> Name}
  deriving (Semigroup, Monoid) via (Endo Name)

newtype MkRootFieldName = MkRootFieldName {runMkRootFieldName :: Name -> Name}
  deriving (Semigroup, Monoid) via (Endo Name)
```
The `Monoid` instance allows easy composition of customization operations, piggybacking off of the type of `Endo`maps.

This design allows safe co-existence of the two customization algorithms, while avoiding the syntactic overhead of packing and unpacking newtypes.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/2989
GitOrigin-RevId: da3a353a9b003ee40c8d0a1e02872e99d2edd3ca
2021-11-30 09:52:53 +00:00

104 lines
3.6 KiB
Haskell

module Hasura.GraphQL.Namespace
( RootFieldAlias (..),
mkUnNamespacedRootFieldAlias,
mkNamespacedRootFieldAlias,
RootFieldMap,
NamespacedField (..),
namespacedField,
NamespacedFieldMap,
flattenNamespaces,
unflattenNamespaces,
customizeNamespace,
)
where
import Data.Aeson qualified as J
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Text.Extended
import Hasura.GraphQL.Parser
import Hasura.GraphQL.Parser qualified as P
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax qualified as G
data RootFieldAlias = RootFieldAlias
{ _rfaNamespace :: !(Maybe G.Name),
_rfaAlias :: !G.Name
}
deriving (Show, Eq, Generic)
instance Hashable RootFieldAlias
instance ToTxt RootFieldAlias where
toTxt RootFieldAlias {..} = case _rfaNamespace of
Nothing -> G.unName _rfaAlias
Just ns -> G.unName ns <> "." <> G.unName _rfaAlias
-- | This ToJSON instance is used in responses to the explain API
-- (via the ToJSON instance for ExplainPlan).
-- It will use dot separator for namespaces fields, i.e. "namespace.fieldname"
-- TODO: We need to decide if this dotted notation is what we want to use for explain responses.
instance J.ToJSON RootFieldAlias where
toJSON = J.toJSON . toTxt
mkUnNamespacedRootFieldAlias :: G.Name -> RootFieldAlias
mkUnNamespacedRootFieldAlias = RootFieldAlias Nothing
mkNamespacedRootFieldAlias :: G.Name -> G.Name -> RootFieldAlias
mkNamespacedRootFieldAlias = RootFieldAlias . Just
type RootFieldMap = InsOrdHashMap RootFieldAlias
data NamespacedField a
= -- | Normal field
NotNamespaced a
| -- | Namespace field with other fields nested within
Namespaced (InsOrdHashMap G.Name a)
deriving (Eq, Show, Functor)
namespacedField :: (a -> b) -> (InsOrdHashMap G.Name a -> b) -> NamespacedField a -> b
namespacedField f g = \case
NotNamespaced a -> f a
Namespaced m -> g m
type NamespacedFieldMap a = InsOrdHashMap G.Name (NamespacedField a)
flattenNamespaces :: forall a. NamespacedFieldMap a -> RootFieldMap a
flattenNamespaces = OMap.foldMapWithKey flattenNamespace
where
flattenNamespace :: G.Name -> NamespacedField a -> RootFieldMap a
flattenNamespace fieldName =
namespacedField
(OMap.singleton $ mkUnNamespacedRootFieldAlias fieldName)
(OMap.mapKeys $ mkNamespacedRootFieldAlias fieldName)
unflattenNamespaces :: RootFieldMap a -> NamespacedFieldMap a
unflattenNamespaces = OMap.foldlWithKey' insert mempty
where
insert m RootFieldAlias {..} v = case _rfaNamespace of
Nothing -> OMap.insert _rfaAlias (NotNamespaced v) m
Just ns -> OMap.insertWith merge ns (Namespaced $ (OMap.singleton _rfaAlias v)) m
merge (Namespaced m) (Namespaced m') = Namespaced (OMap.union m' m) -- Note: order of arguments to OMap.union to preserve ordering
merge v _ = v
-- | Wrap the field parser results in @NamespacedField@
customizeNamespace ::
forall n a.
(MonadParse n) =>
Maybe G.Name ->
(G.Name -> P.ParsedSelection a -> a) ->
P.MkTypename ->
[FieldParser n a] ->
[FieldParser n (NamespacedField a)]
customizeNamespace (Just namespace) fromParsedSelection mkNamespaceTypename fieldParsers =
-- Source or remote schema has a namespace field so wrap the parsers
-- in a new namespace field parser.
[P.subselection_ namespace Nothing parser]
where
parser :: Parser 'Output n (NamespacedField a)
parser =
Namespaced . OMap.mapWithKey fromParsedSelection
<$> P.selectionSet (runMkTypename mkNamespaceTypename namespace) Nothing fieldParsers
customizeNamespace Nothing _ _ fieldParsers =
-- No namespace so just wrap the field parser results in @NotNamespaced@.
fmap NotNamespaced <$> fieldParsers