1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-20 22:11:45 +03:00
graphql-engine/server/src-lib/Hasura/SQL/BackendMap.hs
Auke Booij 83ea4a254d server: plumb StoredIntrospection while building the Schema Cache
We'd like to be able to build a Schema Cache from only serializable data. We already have Metadata. The data that's missing to build a Schema Cache is referred to as "stored introspection", and this includes:
- DB introspection
- User-defined enum values (i.e. contents of specific DB tables)
- Remote schema introspection

This PR introduces a new `StoredIntrospection` container that holds that data, and plumbs it through to the right parts of the schema cache building process, so that stored introspection can be used as a substitute for fresh introspection requests against live data sources.

The serialization of `StoredIntrospection` is intended to be straightforward: just take the serialized source introspection results, and put them in an appropriate JSON object. Though I don't think that this PR achieves that entirely.

In order for `StoredIntrospection` to be deserializable (through `aeson` instances), while keeping the required code changes low, this piggy-backs off of the `ResolvedSource` data type. `ResolvedSource` is _almost_ exactly what we want, and _almost_ deserializable, so this PR brings it across the finish line by moving a few things out of that type, and adding a `FromJSON (RawFunctionInfo b)` context to the `Backend` type class.

[PLAT-270]: https://hasurahq.atlassian.net/browse/PLAT-270?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ
[PLAT-270]: https://hasurahq.atlassian.net/browse/PLAT-270?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ
[PLAT-276]: https://hasurahq.atlassian.net/browse/PLAT-276?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ
[PLAT-276]: https://hasurahq.atlassian.net/browse/PLAT-276?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7053
GitOrigin-RevId: 5001b4ea086195cb5e65886747eac2a0a657b64c
2023-01-20 14:52:36 +00:00

138 lines
5.1 KiB
Haskell

{-# LANGUAGE UndecidableInstances #-}
module Hasura.SQL.BackendMap
( BackendMap,
singleton,
lookup,
lookupD,
elems,
alter,
modify,
overridesDeeply,
)
where
--------------------------------------------------------------------------------
import Data.Aeson qualified as Aeson
import Data.Aeson.Extended
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Data
import Data.Kind (Type)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text.Extended (toTxt)
import Hasura.Incremental.Internal.Dependency (Dependency (..), selectD)
import Hasura.Incremental.Select
import Hasura.Prelude hiding (empty, lookup, modify)
import Hasura.SQL.AnyBackend
import Hasura.SQL.Backend (BackendType)
import Hasura.SQL.Tag (BackendTag, HasTag, backendTag, reify)
--------------------------------------------------------------------------------
-- | A BackendMap is a data structure that can contain at most one value of an 'i' per 'BackendType'
-- The 'i' type must be one that is parameterized by a BackendType-kinded type parameter
newtype BackendMap (i :: BackendType -> Type) = BackendMap (Map BackendType (AnyBackend i))
deriving stock (Generic)
deriving newtype (Semigroup, Monoid)
deriving newtype instance i `SatisfiesForAllBackends` Show => Show (BackendMap i)
deriving newtype instance i `SatisfiesForAllBackends` Eq => Eq (BackendMap i)
instance i `SatisfiesForAllBackends` FromJSON => FromJSON (BackendMap i) where
parseJSON =
Aeson.withObject "BackendMap" $ \obj -> do
BackendMap . Map.fromList
<$> traverse
( \keyValue -> do
out <- parseJSONKeyValue keyValue
pure $ (lowerTag out, out)
)
(KeyMap.toList obj)
instance i `SatisfiesForAllBackends` ToJSON => ToJSON (BackendMap i) where
toJSON (BackendMap backendMap) =
Aeson.object $ valueToPair <$> Map.elems backendMap
where
valueToPair :: AnyBackend i -> (Key, Aeson.Value)
valueToPair value = dispatchAnyBackend'' @ToJSON @HasTag value $ \(v :: i b) ->
let backendTypeText = Key.fromText . toTxt . reify $ backendTag @b
in (backendTypeText, Aeson.toJSON v)
instance Select (BackendMap i) where
type Selector (BackendMap i) = BackendMapS i
select (BackendMapS (_ :: BackendTag b)) = lookup @b
data BackendMapS i a where
BackendMapS :: forall (b :: BackendType) (i :: BackendType -> Type). HasTag b => BackendTag b -> BackendMapS i (Maybe (i b))
instance GEq (BackendMapS i) where
BackendMapS a `geq` BackendMapS b = case a `geq` b of
Just Refl -> Just Refl
Nothing -> Nothing
instance GCompare (BackendMapS i) where
BackendMapS a `gcompare` BackendMapS b = case a `gcompare` b of
GLT -> GLT
GEQ -> GEQ
GGT -> GGT
lookupD ::
forall (b :: BackendType) (i :: BackendType -> Type).
HasTag b =>
Dependency (BackendMap i) ->
Dependency (Maybe (i b))
lookupD = selectD (BackendMapS (backendTag @b))
--------------------------------------------------------------------------------
singleton :: forall b i. HasTag b => i b -> BackendMap i
singleton value = BackendMap $ Map.singleton (reify $ backendTag @b) (mkAnyBackend value)
-- | Get a value from the map for the particular 'BackendType' 'b'. This function
-- is usually used with a type application.
-- @
-- lookup @('Postgres 'Vanilla) backendMap
-- @
lookup :: forall (b :: BackendType) i. HasTag b => BackendMap i -> Maybe (i b)
lookup (BackendMap backendMap) =
Map.lookup (reify $ backendTag @b) backendMap >>= unpackAnyBackend @b
-- | Get all values in the map
elems :: forall i. BackendMap i -> [AnyBackend i]
elems (BackendMap backendMap) = Map.elems backendMap
-- | The expression @modify f bmap@ alters the value @x@ at
-- @b@. @modify@ is a restricted version of 'alter' which cannot
-- delete entries and if there is no @b@ key present in the map, it
-- will apply the modification function to the @i b@ unit value and
-- insert the result at @b@.
modify :: forall b i. (HasTag b, Monoid (i b)) => (i b -> i b) -> BackendMap i -> BackendMap i
modify f = alter \case
Nothing -> Just $ f mempty
Just ab -> Just $ f ab
-- | The expression @alter f bmap@ alters the value @x@ at @b@, or
-- absence thereof. alter can be used to insert, delete, or update a
-- value in a Map.
--
-- In short : @lookup k (alter f k m) = f (lookup k m)@.
alter :: forall b i. HasTag b => (Maybe (i b) -> Maybe (i b)) -> BackendMap i -> BackendMap i
alter f (BackendMap bmap) = BackendMap $ Map.alter (wrap . f . unwrap) (reify @b backendTag) bmap
where
wrap :: Maybe (i b) -> Maybe (AnyBackend i)
wrap = fmap mkAnyBackend
unwrap :: Maybe (AnyBackend i) -> Maybe (i b)
unwrap x = x >>= unpackAnyBackend @b
-- | The expression @a `overridesDeeply b@ applies the values from @a@ on top of the defaults @b@.
-- In practice this should union the maps for each backend type.
overridesDeeply :: i `SatisfiesForAllBackends` Semigroup => BackendMap i -> BackendMap i -> BackendMap i
overridesDeeply (BackendMap a) (BackendMap b) = BackendMap (Map.unionWith override a b)
where
override a' b' = mergeAnyBackend @Semigroup (<>) a' b' a'