1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-23 15:32:27 +03:00
graphql-engine/server/src-lib/Autodocodec/Extended.hs
Jesse Hallett 4d6604ba08 server: event trigger codecs
Codecs for event triggers, including webhook transforms. These are not hooked into the higher-up table metadata codec yet because some backend implementations implement event triggers with `error` which causes an error when codecs are evaluated. I plan to follow up with another PR to resolve that.

Ticket: https://hasurahq.atlassian.net/browse/GDC-585

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7237
GitOrigin-RevId: 8ce40fe6fedcf8b109d6ca50a505333df855a8ce
2022-12-15 20:38:21 +00:00

211 lines
8.8 KiB
Haskell

module Autodocodec.Extended
( caseInsensitiveHashMapCodec,
caseInsensitiveTextCodec,
graphQLFieldNameCodec,
graphQLValueCodec,
graphQLSchemaDocumentCodec,
hashSetCodec,
hashSetCodecWith,
integerCodec,
optionalFieldOrIncludedNull,
optionalFieldOrIncludedNull',
optionalFieldOrIncludedNullWith,
optionalFieldOrIncludedNullWith',
)
where
import Autodocodec
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.CaseInsensitive qualified as CI
import Data.HashMap.Strict qualified as M
import Data.HashSet qualified as HashSet
import Data.Scientific (Scientific (base10Exponent), floatingOrInteger)
import Data.Text qualified as T
import Data.Typeable (Typeable)
import Hasura.Metadata.DTO.Utils (typeableName)
import Hasura.Prelude
import Language.GraphQL.Draft.Parser qualified as GParser
import Language.GraphQL.Draft.Printer qualified as GPrinter
import Language.GraphQL.Draft.Syntax qualified as G
import Text.Builder qualified as TB
-- | Like 'hashMapCodec', but with case-insensitive keys.
caseInsensitiveHashMapCodec ::
forall k a.
(CI.FoldCase k, Hashable k, FromJSONKey k, ToJSONKey k) =>
JSONCodec a ->
JSONCodec (M.HashMap (CI.CI k) a)
caseInsensitiveHashMapCodec elemCodec =
dimapCodec
(mapKeys CI.mk)
(mapKeys CI.original)
$ hashMapCodec elemCodec
-- | Codec for case-insensitive strings / text. The underlying value may be
-- @Text@ or another type that implements @FoldCase@ and @HasCodec@.
caseInsensitiveTextCodec :: forall a. (CI.FoldCase a, HasCodec a) => JSONCodec (CI.CI a)
caseInsensitiveTextCodec = dimapCodec CI.mk CI.original codec
-- | Codec for a GraphQL field name
graphQLFieldNameCodec :: JSONCodec G.Name
graphQLFieldNameCodec = named "GraphQLName" $ bimapCodec dec enc codec
where
dec text =
maybeToEither ("invalid GraphQL field name '" <> T.unpack text <> "'") $
G.mkName text
enc = G.unName
graphQLValueCodec :: forall var. Typeable var => JSONCodec var -> JSONCodec (G.Value var)
graphQLValueCodec varCodec =
named ("GraphQLValue_" <> typeableName @var) $
matchChoicesCodec
[ (isVVariable, dimapCodec G.VVariable fromVVariable varCodec), -- The VVariable case must be first in case its codec overlaps with other cases
(isVNull, dimapCodec (const G.VNull) (const ()) nullCodec),
(isVInt, dimapCodec (G.VInt . toInteger) fromVInt integerCodec), -- It's important to try VInt first because the Scientific codec will match integers
(isVFloat, dimapCodec G.VFloat fromVFloat codec),
(isVString, dimapCodec G.VString fromVString codec),
(isVBoolean, dimapCodec G.VBoolean fromVBoolean codec),
(isVEnum, dimapCodec G.VEnum fromVEnum $ dimapCodec G.EnumValue G.unEnumValue graphQLFieldNameCodec),
(isVList, dimapCodec G.VList fromVList $ listCodec (graphQLValueCodec varCodec)),
(isVObject, dimapCodec G.VObject fromVObject $ hashMapCodec (graphQLValueCodec varCodec))
]
unhandledCase
where
isVVariable = \case v@(G.VVariable _) -> Just v; _ -> Nothing
isVNull = \case v@G.VNull -> Just v; _ -> Nothing
isVInt = \case v@(G.VInt _) -> Just v; _ -> Nothing
isVFloat = \case v@(G.VFloat _) -> Just v; _ -> Nothing
isVString = \case v@(G.VString _) -> Just v; _ -> Nothing
isVBoolean = \case v@(G.VBoolean _) -> Just v; _ -> Nothing
isVEnum = \case v@(G.VEnum _) -> Just v; _ -> Nothing
isVList = \case v@(G.VList _) -> Just v; _ -> Nothing
isVObject = \case v@(G.VObject _) -> Just v; _ -> Nothing
fromVVariable = \case (G.VVariable var) -> var; _ -> error "expected a VVariable"
fromVInt = \case (G.VInt i) -> i; _ -> error "expected a VInt"
fromVFloat = \case (G.VFloat f) -> f; _ -> error "expected a VFloat"
fromVString = \case (G.VString s) -> s; _ -> error "expected a VString"
fromVBoolean = \case (G.VBoolean b) -> b; _ -> error "expected a VBoolean"
fromVEnum = \case (G.VEnum s) -> s; _ -> error "expected a VEnum"
fromVList = \case (G.VList list) -> list; _ -> error "expected a VList"
fromVObject = \case (G.VObject obj) -> obj; _ -> error "expected a VObject"
unhandledCase =
let msg = "no codec for value type"
dec _ = Left msg -- handle failure without exception when decoding
enc _ = error msg -- encoding is supposed to be total so we need an exception here
in bimapCodec dec enc nullCodec
graphQLSchemaDocumentCodec :: JSONCodec G.SchemaDocument
graphQLSchemaDocumentCodec = named "GraphQLSchema" $ bimapCodec dec enc $ codec @Text
where
dec = mapLeft T.unpack . GParser.parseSchemaDocument
enc = TB.run . GPrinter.schemaDocument
-- | Serializes a hash set by converting it to a list. This matches the FromJSON
-- and ToJSON instances in aeson.
hashSetCodec :: (Hashable a, HasCodec a) => JSONCodec (HashSet a)
hashSetCodec = hashSetCodecWith codec
-- | Serializes a hash set by converting it to a list. This matches the FromJSON
-- and ToJSON instances in aeson. This version accepts a codec for individual
-- set values as an argument.
hashSetCodecWith :: Hashable a => JSONCodec a -> JSONCodec (HashSet a)
hashSetCodecWith elemCodec =
dimapCodec HashSet.fromList HashSet.toList $
listCodec elemCodec
-- | Codec for integer with a generous bounds check that matches the behavior of
-- aeson integer deserialization.
integerCodec :: JSONCodec Integer
integerCodec = bimapCodec dec enc $ codec @Scientific
where
dec scientific =
if exp10 > 1024
then Left msg
else parseIntegralFromScientific scientific
where
exp10 = base10Exponent scientific
msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
enc = fromInteger
parseIntegralFromScientific :: (Integral a) => Scientific -> Either String a
parseIntegralFromScientific s = case floatingOrInteger @Float s of
Right x -> Right x
Left _ -> Left $ "unexpected floating number " <> show s
-- | An optional field that might be @null@ where a @Nothing@ value should be
-- represented as @null@ on serialization instead of omitting the field.
--
-- This differs from Autodocodec's stock 'optionalFieldOrNull' in that that
-- function omits the field during serialization if the Haskell value is
-- @Nothing@. This version includes the field with a serialized value of @null@.
optionalFieldOrIncludedNull ::
HasCodec output =>
-- | Key
Text ->
-- | Documentation
Text ->
ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrIncludedNull key doc = optionalFieldOrIncludedNullWith key codec doc
-- | An optional field that might be @null@ where a @Nothing@ value should be
-- represented as @null@ on serialization instead of omitting the field.
--
-- This differs from Autodocodec's stock 'optionalFieldOrNull'' in that that
-- function omits the field during serialization if the Haskell value is
-- @Nothing@. This version includes the field with a serialized value of @null@.
optionalFieldOrIncludedNull' ::
HasCodec output =>
-- | Key
Text ->
ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrIncludedNull' key = optionalFieldOrIncludedNullWith' key codec
-- | An optional field that might be @null@ where a @Nothing@ value should be
-- represented as @null@ on serialization instead of omitting the field.
--
-- This differs from Autodocodec's stock 'optionalFieldOrNullWith' in that that
-- function omits the field during serialization if the Haskell value is
-- @Nothing@. This version includes the field with a serialized value of @null@.
optionalFieldOrIncludedNullWith ::
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Documentation
Text ->
ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrIncludedNullWith key c doc =
orIncludedNullHelper $
OptionalKeyCodec key (maybeCodec c) (Just doc)
-- | An optional field that might be @null@ where a @Nothing@ value should be
-- represented as @null@ on serialization instead of omitting the field.
--
-- This differs from Autodocodec's stock 'optionalFieldOrNullWith'' in that that
-- function omits the field during serialization if the Haskell value is
-- @Nothing@. This version includes the field with a serialized value of @null@.
optionalFieldOrIncludedNullWith' ::
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrIncludedNullWith' key c =
orIncludedNullHelper $
OptionalKeyCodec key (maybeCodec c) Nothing
orIncludedNullHelper :: ObjectCodec (Maybe (Maybe input)) (Maybe (Maybe output)) -> ObjectCodec (Maybe input) (Maybe output)
orIncludedNullHelper = dimapCodec dec enc
where
dec :: Maybe (Maybe input) -> Maybe input
dec = \case
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just a) -> Just a
enc :: Maybe output -> Maybe (Maybe output)
enc = \case
Nothing -> Just Nothing -- This is the case that differs from the stock `orNullHelper`
Just a -> Just (Just a)