1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-19 05:21:47 +03:00
graphql-engine/server/src-lib/Hasura/SQL/BackendMap.hs
Brandon Simmons 6e8da71ece server: migrate to aeson-2 in preparation for ghc 9.2 upgrade
(Work here originally done by awjchen, rebased and fixed up for merge by
jberryman)

This is part of a merge train towards GHC 9.2 compatibility. The main
issue is the use of the new abstract `KeyMap` in 2.0. See:
https://hackage.haskell.org/package/aeson-2.0.3.0/changelog

Alex's original work is here:


BEHAVIOR CHANGE NOTE: This change causes a different arbitrary ordering
of serialized Json, for example during metadata export. CLI users care
about this in particular, and so we need to call it out as a _behavior
change_ as we did in v2.5.0. The good news though is that after this
change ordering should be more stable (alphabetical key order).

See: https://hasurahq.slack.com/archives/C01M20G1YRW/p1654012632634389

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4611
Co-authored-by: awjchen <13142944+awjchen@users.noreply.github.com>
GitOrigin-RevId: 700265162c782739b2bb88300ee3cda3819b2e87
2022-06-08 15:32:27 +00:00

69 lines
2.7 KiB
Haskell

{-# LANGUAGE UndecidableInstances #-}
module Hasura.SQL.BackendMap
( BackendMap,
singleton,
lookup,
elems,
)
where
import Data.Aeson (FromJSON, ToJSON, Value, object, withObject)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Kind (Type)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text.Extended (toTxt)
import Hasura.Prelude hiding (empty, lookup)
import Hasura.SQL.AnyBackend (AnyBackend, SatisfiesForAllBackends, dispatchAnyBackend'', mkAnyBackend, parseAnyBackendFromJSON, unpackAnyBackend)
import Hasura.SQL.Backend (BackendType, parseBackendTypeFromText)
import Hasura.SQL.Tag (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)
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
instance i `SatisfiesForAllBackends` FromJSON => FromJSON (BackendMap i) where
parseJSON =
withObject "BackendMap" $ \obj -> do
BackendMap . Map.fromList
<$> traverse
( \(backendTypeStr, val) -> do
backendType <- parseBackendTypeFromText $ K.toText backendTypeStr
(backendType,) <$> parseAnyBackendFromJSON backendType val
)
(KM.toList obj)
instance i `SatisfiesForAllBackends` ToJSON => ToJSON (BackendMap i) where
toJSON (BackendMap backendMap) =
object $ valueToPair <$> Map.elems backendMap
where
valueToPair :: AnyBackend i -> (K.Key, Value)
valueToPair value = dispatchAnyBackend'' @ToJSON @HasTag value $ \(v :: i b) ->
let backendTypeText = K.fromText . toTxt . reify $ backendTag @b
in (backendTypeText, J.toJSON v)