mirror of
https://github.com/hasura/graphql-engine.git
synced 2025-01-05 14:27:59 +03:00
server: GHC 9.2 changes compatible with 8.10 (#3550)
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4841 Co-authored-by: awjchen <13142944+awjchen@users.noreply.github.com> GitOrigin-RevId: ce47b1290fefb07f3f800c6c62120437c02086e5
This commit is contained in:
Brandon Simmons
hasura-bot
parent
baf196daa6
commit
b704192268
@ -95,6 +95,12 @@
|
||||
- ignore: {name: Use <$>, within: [Hasura.RQL.DDL.Metadata, Hasura.Backends.MSSQL.Types.Instances]}
|
||||
- ignore: {name: Functor law, within: Hasura.Server.AuthSpec}
|
||||
- ignore: {name: Use underscore} # suggests to format port numbers
|
||||
# These three need to be disabled under 'simplified subsumption' unfortunately.
|
||||
# If we want to use -XDeepSubsumption these can be reenabled and lints fixed
|
||||
# See: https://github.com/mpickering/ghc-proposals/blob/deep-subsumption/proposals/0000-deep-subsumption.rst
|
||||
- ignore: {name: Avoid lambda}
|
||||
- ignore: {name: Redundant lambda}
|
||||
- ignore: {name: Avoid lambda using `infix`}
|
||||
|
||||
# Define some custom infix operators
|
||||
# - fixity: infixr 3 ~^#^~
|
||||
|
||||
@ -65,6 +65,7 @@ source-repository-package
|
||||
location: https://github.com/hasura/pool.git
|
||||
tag: 427c8f47b5a0de858780b0a9522ad953197b1658
|
||||
|
||||
-- This is an unrelesaed version of "odbc"
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/fpco/odbc.git
|
||||
@ -81,7 +82,7 @@ package odbc
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/hasura/ekg-core.git
|
||||
tag: ac51c3834e242833e9735394295cbcaa583233f8
|
||||
tag: b0cdc337ca2a52e392d427916ba3e28246b396c0
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@ -5,8 +5,6 @@
|
||||
-- You can temporarily override values here rather than modifying 'dev.sh'
|
||||
-- during development (although that might break certain things).
|
||||
|
||||
with-compiler: ghc-8.10.7
|
||||
|
||||
package *
|
||||
documentation: true
|
||||
-- build with DWARF support. This may not be very useful yet, but we want
|
||||
|
||||
@ -7,8 +7,6 @@
|
||||
-- ...or, it can be copied if you would like to customize any settings:
|
||||
-- $ cp cabal/cabal.project.dev cabal.project.local
|
||||
|
||||
with-compiler: ghc-8.10.7
|
||||
|
||||
package *
|
||||
documentation: true
|
||||
|
||||
|
||||
@ -102,6 +102,7 @@ common common-all
|
||||
NamedFieldPuns
|
||||
NoImplicitPrelude
|
||||
OverloadedStrings
|
||||
PackageImports
|
||||
RankNTypes
|
||||
RecordWildCards
|
||||
RoleAnnotations
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
@ -1065,10 +1065,10 @@ instance (MonadIO m, MonadBaseControl IO m) => MonadConfigApiHandler (PGMetadata
|
||||
runConfigApiHandler = configApiGetHandler
|
||||
|
||||
instance (MonadIO m) => MonadQueryLog (PGMetadataStorageAppT m) where
|
||||
logQueryLog = unLogger
|
||||
logQueryLog logger = unLogger logger
|
||||
|
||||
instance (MonadIO m) => WS.MonadWSLog (PGMetadataStorageAppT m) where
|
||||
logWSLog = unLogger
|
||||
logWSLog logger = unLogger logger
|
||||
|
||||
instance (Monad m) => MonadResolveSource (PGMetadataStorageAppT m) where
|
||||
getPGSourceResolver = mkPgSourceResolver <$> asks snd
|
||||
|
||||
@ -1,5 +1,10 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{- ORMOLU_DISABLE -}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- NOTE: This module previously used Template Haskell to generate its instances,
|
||||
-- but additional restrictions on Template Haskell splices introduced in GHC 9.0 impose an ordering
|
||||
-- on the generated instances that is difficult to satisfy (see ../MySQL/Types/Instances.hs).
|
||||
-- To avoid these difficulties, we now use CPP.
|
||||
|
||||
-- | MSSQL Types Instances
|
||||
--
|
||||
@ -13,141 +18,102 @@ import Database.ODBC.SQLServer qualified as ODBC
|
||||
import Hasura.Backends.MSSQL.Types.Internal
|
||||
import Hasura.Incremental.Internal.Dependency
|
||||
import Hasura.Prelude
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
$( fmap concat $ for
|
||||
[''Aliased]
|
||||
\name ->
|
||||
[d|
|
||||
deriving instance Generic ($(conT name) a)
|
||||
deriving instance Generic (Aliased a)
|
||||
instance Hashable a => Hashable (Aliased a)
|
||||
instance Cacheable a => Cacheable (Aliased a)
|
||||
deriving instance Eq a => Eq (Aliased a)
|
||||
instance NFData a => NFData (Aliased a)
|
||||
deriving instance Show a => Show (Aliased a)
|
||||
deriving instance Functor Aliased
|
||||
deriving instance Data a => Data (Aliased a)
|
||||
|
||||
instance Hashable a => Hashable ($(conT name) a)
|
||||
|
||||
instance Cacheable a => Cacheable ($(conT name) a)
|
||||
#define INSTANCE_CLUMP_1(name) \
|
||||
deriving instance Generic name ;\
|
||||
instance Hashable name ;\
|
||||
instance Cacheable name ;\
|
||||
deriving instance Eq name ;\
|
||||
deriving instance Show name ;\
|
||||
deriving instance Data name ;\
|
||||
instance NFData name ;\
|
||||
instance FromJSON name ;\
|
||||
deriving instance Ord name
|
||||
INSTANCE_CLUMP_1(UnifiedTableName)
|
||||
INSTANCE_CLUMP_1(UnifiedObjectRelationship)
|
||||
INSTANCE_CLUMP_1(UnifiedArrayRelationship)
|
||||
INSTANCE_CLUMP_1(UnifiedUsing)
|
||||
INSTANCE_CLUMP_1(UnifiedOn)
|
||||
INSTANCE_CLUMP_1(UnifiedColumn)
|
||||
INSTANCE_CLUMP_1(TempTableName)
|
||||
INSTANCE_CLUMP_1(SomeTableName)
|
||||
|
||||
deriving instance Eq a => Eq ($(conT name) a)
|
||||
|
||||
instance NFData a => NFData ($(conT name) a)
|
||||
#define INSTANCE_CLUMP_2(name) \
|
||||
deriving instance Generic name ;\
|
||||
instance Hashable name ;\
|
||||
instance Cacheable name ;\
|
||||
deriving instance Eq name ;\
|
||||
deriving instance Show name ;\
|
||||
deriving instance Data name ;\
|
||||
instance NFData name
|
||||
INSTANCE_CLUMP_2(Where)
|
||||
INSTANCE_CLUMP_2(For)
|
||||
INSTANCE_CLUMP_2(Aggregate)
|
||||
INSTANCE_CLUMP_2(EntityAlias)
|
||||
INSTANCE_CLUMP_2(ForJson)
|
||||
INSTANCE_CLUMP_2(JsonCardinality)
|
||||
INSTANCE_CLUMP_2(Root)
|
||||
INSTANCE_CLUMP_2(OrderBy)
|
||||
INSTANCE_CLUMP_2(JoinAlias)
|
||||
INSTANCE_CLUMP_2(Reselect)
|
||||
INSTANCE_CLUMP_2(ColumnName)
|
||||
INSTANCE_CLUMP_2(DataLength)
|
||||
INSTANCE_CLUMP_2(Expression)
|
||||
INSTANCE_CLUMP_2(FunctionApplicationExpression)
|
||||
INSTANCE_CLUMP_2(MethodApplicationExpression)
|
||||
INSTANCE_CLUMP_2(NullsOrder)
|
||||
INSTANCE_CLUMP_2(Order)
|
||||
INSTANCE_CLUMP_2(ScalarType)
|
||||
INSTANCE_CLUMP_2(TableName)
|
||||
INSTANCE_CLUMP_2(Select)
|
||||
INSTANCE_CLUMP_2(With)
|
||||
INSTANCE_CLUMP_2(Top)
|
||||
INSTANCE_CLUMP_2(FieldName)
|
||||
INSTANCE_CLUMP_2(JsonPath)
|
||||
INSTANCE_CLUMP_2(Op)
|
||||
INSTANCE_CLUMP_2(SpatialOp)
|
||||
INSTANCE_CLUMP_2(Projection)
|
||||
INSTANCE_CLUMP_2(From)
|
||||
INSTANCE_CLUMP_2(OpenJson)
|
||||
INSTANCE_CLUMP_2(JsonFieldSpec)
|
||||
INSTANCE_CLUMP_2(Join)
|
||||
INSTANCE_CLUMP_2(JoinSource)
|
||||
INSTANCE_CLUMP_2(SelectIntoTempTable)
|
||||
INSTANCE_CLUMP_2(SITTConstraints)
|
||||
INSTANCE_CLUMP_2(InsertValuesIntoTempTable)
|
||||
INSTANCE_CLUMP_2(InsertOutput)
|
||||
INSTANCE_CLUMP_2(Inserted)
|
||||
INSTANCE_CLUMP_2(OutputColumn)
|
||||
INSTANCE_CLUMP_2(TempTable)
|
||||
INSTANCE_CLUMP_2(Deleted)
|
||||
INSTANCE_CLUMP_2(DeleteOutput)
|
||||
INSTANCE_CLUMP_2(Values)
|
||||
INSTANCE_CLUMP_2(Delete)
|
||||
INSTANCE_CLUMP_2(Insert)
|
||||
INSTANCE_CLUMP_2(Merge)
|
||||
INSTANCE_CLUMP_2(MergeUsing)
|
||||
INSTANCE_CLUMP_2(MergeOn)
|
||||
INSTANCE_CLUMP_2(MergeWhenMatched)
|
||||
INSTANCE_CLUMP_2(MergeWhenNotMatched)
|
||||
|
||||
deriving instance Show a => Show ($(conT name) a)
|
||||
deriving instance Ord TableName
|
||||
deriving instance Ord ScalarType
|
||||
|
||||
deriving instance Functor $(conT name)
|
||||
|
||||
deriving instance Data a => Data ($(conT name) a)
|
||||
|]
|
||||
)
|
||||
|
||||
$( fmap concat $ for
|
||||
[ ''UnifiedTableName,
|
||||
''UnifiedObjectRelationship,
|
||||
''UnifiedArrayRelationship,
|
||||
''UnifiedUsing,
|
||||
''UnifiedOn,
|
||||
''UnifiedColumn,
|
||||
''TempTableName,
|
||||
''SomeTableName
|
||||
]
|
||||
\name ->
|
||||
[d|
|
||||
deriving instance Generic $(conT name)
|
||||
|
||||
instance Hashable $(conT name)
|
||||
|
||||
instance Cacheable $(conT name)
|
||||
|
||||
deriving instance Eq $(conT name)
|
||||
|
||||
deriving instance Show $(conT name)
|
||||
|
||||
deriving instance Data $(conT name)
|
||||
|
||||
instance NFData $(conT name)
|
||||
|
||||
instance FromJSON $(conT name)
|
||||
|
||||
deriving instance Ord $(conT name)
|
||||
|]
|
||||
)
|
||||
|
||||
$( fmap concat $ for
|
||||
[ ''Where,
|
||||
''For,
|
||||
''Aggregate,
|
||||
''EntityAlias,
|
||||
''ForJson,
|
||||
''JsonCardinality,
|
||||
''Root,
|
||||
''OrderBy,
|
||||
''JoinAlias,
|
||||
''Reselect,
|
||||
''ColumnName,
|
||||
''DataLength,
|
||||
''Expression,
|
||||
''FunctionApplicationExpression,
|
||||
''MethodApplicationExpression,
|
||||
''NullsOrder,
|
||||
''Order,
|
||||
''ScalarType,
|
||||
''TableName,
|
||||
''Select,
|
||||
''With,
|
||||
''Top,
|
||||
''FieldName,
|
||||
''JsonPath,
|
||||
''Op,
|
||||
''SpatialOp,
|
||||
''Projection,
|
||||
''From,
|
||||
''OpenJson,
|
||||
''JsonFieldSpec,
|
||||
''Join,
|
||||
''JoinSource,
|
||||
''SelectIntoTempTable,
|
||||
''SITTConstraints,
|
||||
''InsertValuesIntoTempTable,
|
||||
''InsertOutput,
|
||||
''Inserted,
|
||||
''OutputColumn,
|
||||
''TempTable,
|
||||
''Deleted,
|
||||
''DeleteOutput,
|
||||
''Values,
|
||||
''Delete,
|
||||
''Insert,
|
||||
''Merge,
|
||||
''MergeUsing,
|
||||
''MergeOn,
|
||||
''MergeWhenMatched,
|
||||
''MergeWhenNotMatched
|
||||
]
|
||||
\name ->
|
||||
[d|
|
||||
deriving instance Generic $(conT name)
|
||||
|
||||
instance Hashable $(conT name)
|
||||
|
||||
instance Cacheable $(conT name)
|
||||
|
||||
deriving instance Eq $(conT name)
|
||||
|
||||
deriving instance Show $(conT name)
|
||||
|
||||
deriving instance Data $(conT name)
|
||||
|
||||
instance NFData $(conT name)
|
||||
|]
|
||||
)
|
||||
|
||||
$( fmap concat $ for
|
||||
[''TableName, ''ScalarType]
|
||||
\name -> [d|deriving instance Ord $(conT name)|]
|
||||
)
|
||||
|
||||
$( fmap concat $ for
|
||||
[''TableName, ''NullsOrder, ''Order]
|
||||
\name -> [d|deriving instance Lift $(conT name)|]
|
||||
)
|
||||
deriving instance Lift TableName
|
||||
deriving instance Lift NullsOrder
|
||||
deriving instance Lift Order
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Third-party types
|
||||
@ -171,17 +137,15 @@ instance ToTxt TableName where
|
||||
instance ToTxt ColumnName where
|
||||
toTxt = columnNameText
|
||||
|
||||
$( fmap concat $ for
|
||||
[''Order, ''NullsOrder, ''ScalarType, ''FieldName]
|
||||
\name ->
|
||||
[d|
|
||||
instance ToJSON $(conT name) where
|
||||
toJSON = genericToJSON hasuraJSON
|
||||
|
||||
instance FromJSON $(conT name) where
|
||||
parseJSON = genericParseJSON hasuraJSON
|
||||
|]
|
||||
)
|
||||
#define INSTANCE_CLUMP_3(name) \
|
||||
instance ToJSON name where \
|
||||
{ toJSON = genericToJSON hasuraJSON } ;\
|
||||
instance FromJSON name where \
|
||||
{ parseJSON = genericParseJSON hasuraJSON }
|
||||
INSTANCE_CLUMP_3(Order)
|
||||
INSTANCE_CLUMP_3(NullsOrder)
|
||||
INSTANCE_CLUMP_3(ScalarType)
|
||||
INSTANCE_CLUMP_3(FieldName)
|
||||
|
||||
deriving instance FromJSON ColumnName
|
||||
|
||||
|
||||
@ -169,19 +169,16 @@ fromOffsetAndLimit (Top val) (Just offset) =
|
||||
fromOrderBys ::
|
||||
Maybe (NonEmpty OrderBy) -> Printer
|
||||
fromOrderBys Nothing = ""
|
||||
fromOrderBys morderBys =
|
||||
fromOrderBys (Just orderBys) =
|
||||
SeqPrinter
|
||||
[ "ORDER BY ",
|
||||
IndentPrinter
|
||||
9
|
||||
( SepByPrinter
|
||||
NewlinePrinter
|
||||
[ case morderBys of
|
||||
Nothing -> ""
|
||||
Just orderBys ->
|
||||
SepByPrinter
|
||||
("," <+> NewlinePrinter)
|
||||
(concatMap fromOrderBy (toList orderBys))
|
||||
[ SepByPrinter
|
||||
("," <+> NewlinePrinter)
|
||||
(concatMap fromOrderBy (toList orderBys))
|
||||
]
|
||||
)
|
||||
]
|
||||
|
||||
@ -21,7 +21,50 @@ import Hasura.Prelude
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
----
|
||||
---- Countable instances
|
||||
|
||||
-- These instances must be defined before the TH-defined instances below.
|
||||
|
||||
deriving instance Generic (Countable n)
|
||||
|
||||
instance Hashable n => Hashable (Countable n)
|
||||
|
||||
instance Cacheable n => Cacheable (Countable n)
|
||||
|
||||
deriving instance Eq n => Eq (Countable n)
|
||||
|
||||
deriving instance Show n => Show (Countable n)
|
||||
|
||||
deriving instance Data n => Data (Countable n)
|
||||
|
||||
instance NFData n => NFData (Countable n)
|
||||
|
||||
instance ToJSON n => ToJSON (Countable n)
|
||||
|
||||
instance FromJSON n => FromJSON (Countable n)
|
||||
|
||||
----
|
||||
---- TH-defined instances
|
||||
|
||||
$( concat <$> for
|
||||
[ ''ScalarType
|
||||
]
|
||||
\name ->
|
||||
[d|
|
||||
deriving instance Generic $(conT name)
|
||||
|
||||
instance Hashable $(conT name)
|
||||
|
||||
instance Cacheable $(conT name)
|
||||
|
||||
deriving instance Data $(conT name)
|
||||
|
||||
instance NFData $(conT name)
|
||||
|]
|
||||
)
|
||||
|
||||
$( fmap concat $ for
|
||||
[''Aliased]
|
||||
\name ->
|
||||
[d|
|
||||
@ -82,23 +125,6 @@ $( concat <$> for
|
||||
|]
|
||||
)
|
||||
|
||||
$( concat <$> for
|
||||
[ ''ScalarType
|
||||
]
|
||||
\name ->
|
||||
[d|
|
||||
deriving instance Generic $(conT name)
|
||||
|
||||
instance Hashable $(conT name)
|
||||
|
||||
instance Cacheable $(conT name)
|
||||
|
||||
deriving instance Data $(conT name)
|
||||
|
||||
instance NFData $(conT name)
|
||||
|]
|
||||
)
|
||||
|
||||
$( concat <$> for
|
||||
[''TableName, ''ScalarType]
|
||||
\name -> [d|deriving instance Ord $(conT name)|]
|
||||
@ -122,29 +148,11 @@ $( concat <$> for
|
||||
)
|
||||
|
||||
----
|
||||
---- Manual instances
|
||||
---- Manually-defined instances
|
||||
|
||||
instance ToTxt TableName where
|
||||
toTxt TableName {..} = name
|
||||
|
||||
deriving instance Generic (Countable n)
|
||||
|
||||
instance Hashable n => Hashable (Countable n)
|
||||
|
||||
instance Cacheable n => Cacheable (Countable n)
|
||||
|
||||
deriving instance Eq n => Eq (Countable n)
|
||||
|
||||
deriving instance Show n => Show (Countable n)
|
||||
|
||||
deriving instance Data n => Data (Countable n)
|
||||
|
||||
instance NFData n => NFData (Countable n)
|
||||
|
||||
instance ToJSON n => ToJSON (Countable n)
|
||||
|
||||
instance FromJSON n => FromJSON (Countable n)
|
||||
|
||||
instance FromJSON TableName where
|
||||
parseJSON v@(String _) =
|
||||
TableName <$> parseJSON v <*> pure Nothing
|
||||
|
||||
@ -398,4 +398,4 @@ type SubscriptionPostPollHook = PollDetails -> IO ()
|
||||
|
||||
-- the default SubscriptionPostPollHook
|
||||
defaultSubscriptionPostPollHook :: L.Logger L.Hasura -> SubscriptionPostPollHook
|
||||
defaultSubscriptionPostPollHook = L.unLogger
|
||||
defaultSubscriptionPostPollHook = \x -> L.unLogger x
|
||||
|
||||
@ -186,7 +186,7 @@ forceConnReconnect wsConn bs = liftIO $ closeConnWithCode wsConn 1012 bs
|
||||
|
||||
closeConnWithCode :: WSConn a -> Word16 -> BL.ByteString -> IO ()
|
||||
closeConnWithCode wsConn code bs = do
|
||||
(L.unLogger . _wcLogger) wsConn $
|
||||
((\x -> L.unLogger x) . _wcLogger) wsConn $
|
||||
WSLog (_wcConnId wsConn) (ECloseSent $ SB.fromLBS bs) Nothing
|
||||
WS.sendCloseCode (_wcConnRaw wsConn) code bs
|
||||
|
||||
|
||||
@ -94,14 +94,6 @@ instance NFData ActionMetadata
|
||||
|
||||
instance Cacheable ActionMetadata
|
||||
|
||||
instance J.FromJSON ActionMetadata where
|
||||
parseJSON = J.withObject "ActionMetadata" $ \o ->
|
||||
ActionMetadata
|
||||
<$> o .: "name"
|
||||
<*> o .:? "comment"
|
||||
<*> o .: "definition"
|
||||
<*> o .:? "permissions" .!= []
|
||||
|
||||
data ActionPermissionMetadata = ActionPermissionMetadata
|
||||
{ _apmRole :: !RoleName,
|
||||
_apmComment :: !(Maybe Text)
|
||||
@ -158,45 +150,6 @@ instance (NFData a, NFData w) => NFData (ActionDefinition a w)
|
||||
|
||||
instance (Cacheable a, Cacheable w) => Cacheable (ActionDefinition a w)
|
||||
|
||||
instance (J.FromJSON a, J.FromJSON b) => J.FromJSON (ActionDefinition a b) where
|
||||
parseJSON = J.withObject "ActionDefinition" $ \o -> do
|
||||
_adArguments <- o .:? "arguments" .!= []
|
||||
_adOutputType <- o .: "output_type"
|
||||
_adHeaders <- o .:? "headers" .!= []
|
||||
_adForwardClientHeaders <- o .:? "forward_client_headers" .!= False
|
||||
_adHandler <- o .: "handler"
|
||||
_adTimeout <- o .:? "timeout" .!= defaultActionTimeoutSecs
|
||||
actionType <- o .:? "type" .!= "mutation"
|
||||
_adType <- case actionType of
|
||||
"mutation" -> ActionMutation <$> o .:? "kind" .!= ActionSynchronous
|
||||
"query" -> pure ActionQuery
|
||||
t -> fail $ "expected mutation or query, but found " <> t
|
||||
_adRequestTransform <- o .:? "request_transform"
|
||||
_adResponseTransform <- o .:? "response_transform"
|
||||
pure ActionDefinition {..}
|
||||
|
||||
instance (J.ToJSON a, J.ToJSON b) => J.ToJSON (ActionDefinition a b) where
|
||||
toJSON (ActionDefinition {..}) =
|
||||
let typeAndKind = case _adType of
|
||||
ActionQuery -> ["type" .= ("query" :: String)]
|
||||
ActionMutation kind ->
|
||||
[ "type" .= ("mutation" :: String),
|
||||
"kind" .= kind
|
||||
]
|
||||
in J.object $
|
||||
[ "arguments" .= _adArguments,
|
||||
"output_type" .= _adOutputType,
|
||||
"headers" .= _adHeaders,
|
||||
"forward_client_headers" .= _adForwardClientHeaders,
|
||||
"handler" .= _adHandler,
|
||||
"timeout" .= _adTimeout
|
||||
]
|
||||
<> catMaybes
|
||||
[ ("request_transform" .=) <$> _adRequestTransform,
|
||||
("response_transform" .=) <$> _adResponseTransform
|
||||
]
|
||||
<> typeAndKind
|
||||
|
||||
data ActionType
|
||||
= ActionQuery
|
||||
| ActionMutation !ActionMutationKind
|
||||
@ -312,11 +265,61 @@ instance Q.ToPrepArg LockedActionIdArray where
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Template haskell derivation
|
||||
-- ...and other instances that need to live here in a particular order, due to
|
||||
-- GHC 9.0 TH changes...
|
||||
|
||||
$(J.deriveJSON hasuraJSON {J.omitNothingFields = True} ''ActionPermissionMetadata)
|
||||
|
||||
$(J.deriveJSON hasuraJSON ''ArgumentDefinition)
|
||||
$(J.deriveJSON J.defaultOptions {J.constructorTagModifier = J.snakeCase . drop 6} ''ActionMutationKind)
|
||||
|
||||
instance (J.FromJSON a, J.FromJSON b) => J.FromJSON (ActionDefinition a b) where
|
||||
parseJSON = J.withObject "ActionDefinition" $ \o -> do
|
||||
_adArguments <- o .:? "arguments" .!= []
|
||||
_adOutputType <- o .: "output_type"
|
||||
_adHeaders <- o .:? "headers" .!= []
|
||||
_adForwardClientHeaders <- o .:? "forward_client_headers" .!= False
|
||||
_adHandler <- o .: "handler"
|
||||
_adTimeout <- o .:? "timeout" .!= defaultActionTimeoutSecs
|
||||
actionType <- o .:? "type" .!= "mutation"
|
||||
_adType <- case actionType of
|
||||
"mutation" -> ActionMutation <$> o .:? "kind" .!= ActionSynchronous
|
||||
"query" -> pure ActionQuery
|
||||
t -> fail $ "expected mutation or query, but found " <> t
|
||||
_adRequestTransform <- o .:? "request_transform"
|
||||
_adResponseTransform <- o .:? "response_transform"
|
||||
pure ActionDefinition {..}
|
||||
|
||||
instance J.FromJSON ActionMetadata where
|
||||
parseJSON = J.withObject "ActionMetadata" $ \o ->
|
||||
ActionMetadata
|
||||
<$> o .: "name"
|
||||
<*> o .:? "comment"
|
||||
<*> o .: "definition"
|
||||
<*> o .:? "permissions" .!= []
|
||||
|
||||
instance (J.ToJSON a, J.ToJSON b) => J.ToJSON (ActionDefinition a b) where
|
||||
toJSON (ActionDefinition {..}) =
|
||||
let typeAndKind = case _adType of
|
||||
ActionQuery -> ["type" .= ("query" :: String)]
|
||||
ActionMutation kind ->
|
||||
[ "type" .= ("mutation" :: String),
|
||||
"kind" .= kind
|
||||
]
|
||||
in J.object $
|
||||
[ "arguments" .= _adArguments,
|
||||
"output_type" .= _adOutputType,
|
||||
"headers" .= _adHeaders,
|
||||
"forward_client_headers" .= _adForwardClientHeaders,
|
||||
"handler" .= _adHandler,
|
||||
"timeout" .= _adTimeout
|
||||
]
|
||||
<> catMaybes
|
||||
[ ("request_transform" .=) <$> _adRequestTransform,
|
||||
("response_transform" .=) <$> _adResponseTransform
|
||||
]
|
||||
<> typeAndKind
|
||||
|
||||
$(J.deriveToJSON hasuraJSON ''ActionLogResponse)
|
||||
$(J.deriveToJSON hasuraJSON ''ActionMetadata)
|
||||
$(J.deriveToJSON hasuraJSON ''ActionInfo)
|
||||
|
||||
@ -117,14 +117,6 @@ instance NFData CustomTypes
|
||||
|
||||
instance Cacheable CustomTypes
|
||||
|
||||
instance J.FromJSON CustomTypes where
|
||||
parseJSON = J.withObject "CustomTypes" \o ->
|
||||
CustomTypes
|
||||
<$> (o .:? "input_objects" .!= [])
|
||||
<*> (o .:? "objects" .!= [])
|
||||
<*> (o .:? "scalars" .!= [])
|
||||
<*> (o .:? "enums" .!= [])
|
||||
|
||||
emptyCustomTypes :: CustomTypes
|
||||
emptyCustomTypes = CustomTypes [] [] [] []
|
||||
|
||||
@ -175,14 +167,6 @@ instance NFData ObjectTypeDefinition
|
||||
|
||||
instance Cacheable ObjectTypeDefinition
|
||||
|
||||
instance J.FromJSON ObjectTypeDefinition where
|
||||
parseJSON = J.withObject "ObjectTypeDefinition" \o ->
|
||||
ObjectTypeDefinition
|
||||
<$> (o .: "name")
|
||||
<*> (o .:? "description")
|
||||
<*> (o .: "fields")
|
||||
<*> (o .:? "relationships" .!= [])
|
||||
|
||||
newtype ObjectTypeName = ObjectTypeName {unObjectTypeName :: G.Name}
|
||||
deriving (Show, Eq, Ord, Hashable, J.FromJSON, J.ToJSON, ToTxt, Generic, NFData, Cacheable)
|
||||
|
||||
@ -315,15 +299,6 @@ data AnnotatedScalarType
|
||||
| ASTReusedScalar G.Name (AnyBackend ScalarWrapper)
|
||||
deriving (Eq, Generic)
|
||||
|
||||
instance J.ToJSON AnnotatedScalarType where
|
||||
toJSON = \case
|
||||
ASTCustom std ->
|
||||
J.object ["tag" .= J.String "ASTCustom", "contents" .= J.toJSON std]
|
||||
-- warning: can't be parsed back, as it does not include the
|
||||
-- backend-specific scalar information.
|
||||
ASTReusedScalar name _scalar ->
|
||||
J.object ["tag" .= J.String "ASTReusedScalar", "contents" .= J.toJSON name]
|
||||
|
||||
newtype ScalarWrapper b = ScalarWrapper {unwrapScalar :: (ScalarType b)}
|
||||
|
||||
deriving instance (Backend b) => Eq (ScalarWrapper b)
|
||||
@ -362,21 +337,51 @@ data AnnotatedTypeRelationship = AnnotatedTypeRelationship
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Template haskell derivation
|
||||
-- ...and other instances that need to live here in a particular order, due to
|
||||
-- GHC 9.0 TH changes...
|
||||
|
||||
$(J.deriveJSON hasuraJSON ''InputObjectFieldDefinition)
|
||||
$(J.deriveJSON hasuraJSON ''InputObjectTypeDefinition)
|
||||
$(J.deriveJSON hasuraJSON ''ObjectFieldDefinition)
|
||||
$(J.deriveJSON hasuraJSON ''ScalarTypeDefinition)
|
||||
$(J.deriveJSON hasuraJSON ''EnumTypeDefinition)
|
||||
|
||||
$(J.deriveJSON hasuraJSON ''EnumValueDefinition)
|
||||
|
||||
$(J.deriveToJSON hasuraJSON ''CustomTypes)
|
||||
$(J.deriveToJSON hasuraJSON ''ObjectTypeDefinition)
|
||||
$(J.deriveToJSON hasuraJSON ''TypeRelationshipDefinition)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedInputType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedOutputType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedObjectType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedObjectFieldType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedTypeRelationship)
|
||||
|
||||
instance J.ToJSON AnnotatedScalarType where
|
||||
toJSON = \case
|
||||
ASTCustom std ->
|
||||
J.object ["tag" .= J.String "ASTCustom", "contents" .= J.toJSON std]
|
||||
-- warning: can't be parsed back, as it does not include the
|
||||
-- backend-specific scalar information.
|
||||
ASTReusedScalar name _scalar ->
|
||||
J.object ["tag" .= J.String "ASTReusedScalar", "contents" .= J.toJSON name]
|
||||
|
||||
$(makeLenses ''TypeRelationshipDefinition)
|
||||
|
||||
$(J.deriveJSON hasuraJSON ''EnumTypeDefinition)
|
||||
|
||||
instance J.FromJSON CustomTypes where
|
||||
parseJSON = J.withObject "CustomTypes" \o ->
|
||||
CustomTypes
|
||||
<$> (o .:? "input_objects" .!= [])
|
||||
<*> (o .:? "objects" .!= [])
|
||||
<*> (o .:? "scalars" .!= [])
|
||||
<*> (o .:? "enums" .!= [])
|
||||
|
||||
instance J.FromJSON ObjectTypeDefinition where
|
||||
parseJSON = J.withObject "ObjectTypeDefinition" \o ->
|
||||
ObjectTypeDefinition
|
||||
<$> (o .: "name")
|
||||
<*> (o .:? "description")
|
||||
<*> (o .: "fields")
|
||||
<*> (o .:? "relationships" .!= [])
|
||||
|
||||
$(J.deriveToJSON hasuraJSON ''ObjectTypeDefinition)
|
||||
$(J.deriveToJSON hasuraJSON ''CustomTypes)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedInputType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedObjectFieldType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedTypeRelationship)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedObjectType)
|
||||
$(J.deriveToJSON hasuraJSON ''AnnotatedOutputType)
|
||||
|
||||
@ -23,6 +23,8 @@ import Data.Aeson.Types qualified as J
|
||||
import Data.Vector qualified as V
|
||||
import Hasura.Prelude
|
||||
|
||||
-- Positions
|
||||
|
||||
data Position
|
||||
= Position !Double !Double !(Maybe Double)
|
||||
deriving (Show, Eq)
|
||||
@ -52,12 +54,16 @@ instance J.ToJSON Position where
|
||||
toJSON (Position a b c) =
|
||||
J.toJSON $ a : b : maybeToList c
|
||||
|
||||
-- Point, Multipoint
|
||||
|
||||
newtype Point = Point {unPoint :: Position}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
|
||||
newtype MultiPoint = MultiPoint {unMultiPoint :: [Position]}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
|
||||
-- LineString, MultiLineString
|
||||
|
||||
data LineString = LineString
|
||||
{ _lsFirst :: !Position,
|
||||
_lsSecond :: !Position,
|
||||
@ -83,8 +89,7 @@ instance J.FromJSON LineString where
|
||||
newtype MultiLineString = MultiLineString {unMultiLineString :: [LineString]}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
|
||||
newtype GeometryCollection = GeometryCollection {unGeometryCollection :: [GeometryWithCRS]}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
-- Polygon, MultiPolygon
|
||||
|
||||
data LinearRing = LinearRing
|
||||
{ _pFirst :: !Position,
|
||||
@ -119,16 +124,34 @@ newtype Polygon = Polygon {unPolygon :: [LinearRing]}
|
||||
newtype MultiPolygon = MultiPolygon {unMultiPolygon :: [Polygon]}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
|
||||
data Geometry
|
||||
= GPoint !Point
|
||||
| GMultiPoint !MultiPoint
|
||||
| GLineString !LineString
|
||||
| GMultiLineString !MultiLineString
|
||||
| GPolygon !Polygon
|
||||
| GMultiPolygon !MultiPolygon
|
||||
| GGeometryCollection !GeometryCollection
|
||||
-- GeometryCollection
|
||||
|
||||
data CRSNameProps = CRSNameProps
|
||||
{ _cnpName :: !Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data CRSLinkProps = CRSLinkProps
|
||||
{ _clpHref :: !Text,
|
||||
_clpType :: !(Maybe Text)
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data CRS
|
||||
= CRSName !CRSNameProps
|
||||
| CRSLink !CRSLinkProps
|
||||
deriving (Show, Eq)
|
||||
|
||||
$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSNameProps)
|
||||
$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSLinkProps)
|
||||
$( J.deriveJSON
|
||||
J.defaultOptions
|
||||
{ J.constructorTagModifier = J.camelCase . drop 3,
|
||||
J.sumEncoding = J.TaggedObject "type" "properties"
|
||||
}
|
||||
''CRS
|
||||
)
|
||||
|
||||
data GeometryWithCRS = GeometryWithCRS
|
||||
{ _gwcGeom :: !Geometry,
|
||||
_gwcCrs :: !(Maybe CRS)
|
||||
@ -170,28 +193,17 @@ instance J.FromJSON GeometryWithCRS where
|
||||
crsM <- o J..:? "crs"
|
||||
return $ GeometryWithCRS geom crsM
|
||||
|
||||
data CRSNameProps = CRSNameProps
|
||||
{ _cnpName :: !Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
newtype GeometryCollection = GeometryCollection {unGeometryCollection :: [GeometryWithCRS]}
|
||||
deriving (Show, Eq, J.ToJSON, J.FromJSON)
|
||||
|
||||
data CRSLinkProps = CRSLinkProps
|
||||
{ _clpHref :: !Text,
|
||||
_clpType :: !(Maybe Text)
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
-- Geometry
|
||||
|
||||
data CRS
|
||||
= CRSName !CRSNameProps
|
||||
| CRSLink !CRSLinkProps
|
||||
data Geometry
|
||||
= GPoint !Point
|
||||
| GMultiPoint !MultiPoint
|
||||
| GLineString !LineString
|
||||
| GMultiLineString !MultiLineString
|
||||
| GPolygon !Polygon
|
||||
| GMultiPolygon !MultiPolygon
|
||||
| GGeometryCollection !GeometryCollection
|
||||
deriving (Show, Eq)
|
||||
|
||||
$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSNameProps)
|
||||
$(J.deriveJSON (J.aesonPrefix J.camelCase) ''CRSLinkProps)
|
||||
$( J.deriveJSON
|
||||
J.defaultOptions
|
||||
{ J.constructorTagModifier = J.camelCase . drop 3,
|
||||
J.sumEncoding = J.TaggedObject "type" "properties"
|
||||
}
|
||||
''CRS
|
||||
)
|
||||
|
||||
@ -144,30 +144,34 @@ data RQLQuery
|
||||
= RQV1 !RQLQueryV1
|
||||
| RQV2 !RQLQueryV2
|
||||
|
||||
instance FromJSON RQLQuery where
|
||||
parseJSON = withObject "Object" $ \o -> do
|
||||
mVersion <- o .:? "version"
|
||||
let version = fromMaybe VIVersion1 mVersion
|
||||
val = Object o
|
||||
case version of
|
||||
VIVersion1 -> RQV1 <$> parseJSON val
|
||||
VIVersion2 -> RQV2 <$> parseJSON val
|
||||
|
||||
$( deriveFromJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = snakeCase . drop 2,
|
||||
sumEncoding = TaggedObject "type" "args"
|
||||
}
|
||||
''RQLQueryV1
|
||||
)
|
||||
|
||||
$( deriveFromJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = snakeCase . drop 4,
|
||||
sumEncoding = TaggedObject "type" "args",
|
||||
tagSingleConstructors = True
|
||||
}
|
||||
''RQLQueryV2
|
||||
-- Since at least one of the following mutually recursive instances is defined
|
||||
-- via TH, after 9.0 they must all be defined within the same TH splice.
|
||||
$( concat
|
||||
<$> sequence
|
||||
[ [d|
|
||||
instance FromJSON RQLQuery where
|
||||
parseJSON = withObject "Object" $ \o -> do
|
||||
mVersion <- o .:? "version"
|
||||
let version = fromMaybe VIVersion1 mVersion
|
||||
val = Object o
|
||||
case version of
|
||||
VIVersion1 -> RQV1 <$> parseJSON val
|
||||
VIVersion2 -> RQV2 <$> parseJSON val
|
||||
|],
|
||||
deriveFromJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = snakeCase . drop 2,
|
||||
sumEncoding = TaggedObject "type" "args"
|
||||
}
|
||||
''RQLQueryV1,
|
||||
deriveFromJSON
|
||||
defaultOptions
|
||||
{ constructorTagModifier = snakeCase . drop 4,
|
||||
sumEncoding = TaggedObject "type" "args",
|
||||
tagSingleConstructors = True
|
||||
}
|
||||
''RQLQueryV2
|
||||
]
|
||||
)
|
||||
|
||||
runQuery ::
|
||||
|
||||
@ -85,7 +85,7 @@ instance
|
||||
|
||||
instance Example (MetadataT (CacheRefT m) ()) where
|
||||
type Arg (MetadataT (CacheRefT m) ()) = MetadataT (CacheRefT m) :~> IO
|
||||
evaluateExample m params action = evaluateExample (action ($$ m)) params ($ ())
|
||||
evaluateExample m params action = evaluateExample (action (\x -> x $$ m)) params ($ ())
|
||||
|
||||
type SpecWithCache m = SpecWith (MetadataT (CacheRefT m) :~> IO)
|
||||
|
||||
|
||||
@ -74,7 +74,7 @@ import System.Metrics qualified as EKG
|
||||
--
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
post :: HasCallStack => TestEnvironment -> String -> Value -> IO Value
|
||||
post testEnvironment path = withFrozenCallStack . postWithHeaders testEnvironment path mempty
|
||||
post testEnvironment path v = withFrozenCallStack $ postWithHeaders testEnvironment path mempty v
|
||||
|
||||
-- | Same as 'post', but ignores the value.
|
||||
--
|
||||
@ -82,7 +82,7 @@ post testEnvironment path = withFrozenCallStack . postWithHeaders testEnvironmen
|
||||
--
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
post_ :: HasCallStack => TestEnvironment -> String -> Value -> IO ()
|
||||
post_ testEnvironment path = void . withFrozenCallStack . postWithHeaders_ testEnvironment path mempty
|
||||
post_ testEnvironment path v = void $ withFrozenCallStack $ postWithHeaders_ testEnvironment path mempty v
|
||||
|
||||
-- | Post some JSON to graphql-engine, getting back more JSON.
|
||||
--
|
||||
@ -92,7 +92,7 @@ post_ testEnvironment path = void . withFrozenCallStack . postWithHeaders_ testE
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
postWithHeaders ::
|
||||
HasCallStack => TestEnvironment -> String -> Http.RequestHeaders -> Value -> IO Value
|
||||
postWithHeaders = withFrozenCallStack . postWithHeadersStatus 200
|
||||
postWithHeaders v = withFrozenCallStack $ postWithHeadersStatus 200 v
|
||||
|
||||
-- | Post some JSON to graphql-engine, getting back more JSON.
|
||||
--
|
||||
@ -102,8 +102,8 @@ postWithHeaders = withFrozenCallStack . postWithHeadersStatus 200
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
postWithHeadersStatus ::
|
||||
HasCallStack => Int -> TestEnvironment -> String -> Http.RequestHeaders -> Value -> IO Value
|
||||
postWithHeadersStatus statusCode (getServer -> Server {urlPrefix, port}) path headers =
|
||||
withFrozenCallStack . Http.postValueWithStatus statusCode (urlPrefix ++ ":" ++ show port ++ path) headers
|
||||
postWithHeadersStatus statusCode (getServer -> Server {urlPrefix, port}) path headers v =
|
||||
withFrozenCallStack $ Http.postValueWithStatus statusCode (urlPrefix ++ ":" ++ show port ++ path) headers v
|
||||
|
||||
-- | Post some JSON to graphql-engine, getting back more JSON.
|
||||
--
|
||||
@ -113,15 +113,15 @@ postWithHeadersStatus statusCode (getServer -> Server {urlPrefix, port}) path he
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
postWithHeaders_ ::
|
||||
HasCallStack => TestEnvironment -> String -> Http.RequestHeaders -> Value -> IO ()
|
||||
postWithHeaders_ testEnvironment path headers =
|
||||
void . withFrozenCallStack . postWithHeaders testEnvironment path headers
|
||||
postWithHeaders_ testEnvironment path headers v =
|
||||
void $ withFrozenCallStack $ postWithHeaders testEnvironment path headers v
|
||||
|
||||
-- | Same as 'post', but defaults to the graphql end-point.
|
||||
--
|
||||
-- Note: We add 'withFrozenCallStack' to reduce stack trace clutter.
|
||||
postGraphqlYaml ::
|
||||
HasCallStack => TestEnvironment -> Value -> IO Value
|
||||
postGraphqlYaml testEnvironment = withFrozenCallStack . postGraphqlYamlWithHeaders testEnvironment mempty
|
||||
postGraphqlYaml testEnvironment v = withFrozenCallStack $ postGraphqlYamlWithHeaders testEnvironment mempty v
|
||||
|
||||
-- | Same as 'postWithHeaders', but defaults to the graphql end-point.
|
||||
--
|
||||
@ -164,8 +164,8 @@ postMetadata :: HasCallStack => TestEnvironment -> Value -> IO Value
|
||||
postMetadata testEnvironment = withFrozenCallStack $ post testEnvironment "/v1/metadata"
|
||||
|
||||
postMetadataWithStatus :: HasCallStack => Int -> TestEnvironment -> Value -> IO Value
|
||||
postMetadataWithStatus statusCode testEnvironment =
|
||||
withFrozenCallStack . postWithHeadersStatus statusCode testEnvironment "/v1/metadata" mempty
|
||||
postMetadataWithStatus statusCode testEnvironment v =
|
||||
withFrozenCallStack $ postWithHeadersStatus statusCode testEnvironment "/v1/metadata" mempty v
|
||||
|
||||
-- | Resets metadata, removing all sources or remote schemas.
|
||||
--
|
||||
|
||||
Loading…
Reference in New Issue
Block a user