mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 12:31:52 +03:00
311 lines
9.5 KiB
Haskell
311 lines
9.5 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Hasura.GraphQL.Context where
|
|
|
|
import Data.Aeson
|
|
import Data.Has
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.HashSet as Set
|
|
import qualified Data.Text as T
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
|
|
import Hasura.GraphQL.Resolve.ContextTypes
|
|
import Hasura.GraphQL.Validate.Types
|
|
import Hasura.RQL.Types.BoolExp
|
|
import Hasura.RQL.Types.Common
|
|
import Hasura.RQL.Types.Permission
|
|
import Hasura.SQL.Types
|
|
|
|
|
|
type OpCtxMap = Map.HashMap G.Name OpCtx
|
|
|
|
data OpCtx
|
|
-- table, req hdrs
|
|
= OCInsert QualifiedTable [T.Text]
|
|
-- tn, filter exp, limit, req hdrs
|
|
| OCSelect QualifiedTable AnnBoolExpSQL (Maybe Int) [T.Text]
|
|
-- tn, filter exp, reqt hdrs
|
|
| OCSelectPkey QualifiedTable AnnBoolExpSQL [T.Text]
|
|
-- tn, filter exp, limit, req hdrs
|
|
| OCSelectAgg QualifiedTable AnnBoolExpSQL (Maybe Int) [T.Text]
|
|
-- tn, filter exp, req hdrs
|
|
| OCUpdate QualifiedTable AnnBoolExpSQL [T.Text]
|
|
-- tn, filter exp, req hdrs
|
|
| OCDelete QualifiedTable AnnBoolExpSQL [T.Text]
|
|
deriving (Show, Eq)
|
|
|
|
data GCtx
|
|
= GCtx
|
|
{ _gTypes :: !TypeMap
|
|
, _gFields :: !FieldMap
|
|
, _gOrdByCtx :: !OrdByCtx
|
|
, _gQueryRoot :: !ObjTyInfo
|
|
, _gMutRoot :: !(Maybe ObjTyInfo)
|
|
, _gSubRoot :: !(Maybe ObjTyInfo)
|
|
, _gOpCtxMap :: !OpCtxMap
|
|
, _gInsCtxMap :: !InsCtxMap
|
|
} deriving (Show, Eq)
|
|
|
|
instance Has TypeMap GCtx where
|
|
getter = _gTypes
|
|
modifier f ctx = ctx { _gTypes = f $ _gTypes ctx }
|
|
|
|
-- data OpCtx
|
|
-- -- table, req hdrs
|
|
-- = OCInsert QualifiedTable [T.Text]
|
|
-- -- tn, filter exp, limit, req hdrs
|
|
-- | OCSelect QualifiedTable S.BoolExp (Maybe Int) [T.Text]
|
|
-- -- tn, filter exp, reqt hdrs
|
|
-- | OCSelectPkey QualifiedTable S.BoolExp [T.Text]
|
|
-- -- tn, filter exp, limit, req hdrs
|
|
-- | OCSelectAgg QualifiedTable S.BoolExp (Maybe Int) [T.Text]
|
|
-- -- tn, filter exp, req hdrs
|
|
-- | OCUpdate QualifiedTable S.BoolExp [T.Text]
|
|
-- -- tn, filter exp, req hdrs
|
|
-- | OCDelete QualifiedTable S.BoolExp [T.Text]
|
|
-- deriving (Show, Eq)
|
|
|
|
-- data GCtx
|
|
-- = GCtx
|
|
-- { _gTypes :: !TypeMap
|
|
-- , _gFields :: !FieldMap
|
|
-- , _gOrdByCtx :: !OrdByCtx
|
|
-- , _gQueryRoot :: !ObjTyInfo
|
|
-- , _gMutRoot :: !(Maybe ObjTyInfo)
|
|
-- , _gSubRoot :: !(Maybe ObjTyInfo)
|
|
-- , _gOpCtxMap :: !OpCtxMap
|
|
-- , _gInsCtxMap :: !InsCtxMap
|
|
-- } deriving (Show, Eq)
|
|
|
|
-- instance Has TypeMap GCtx where
|
|
-- getter = _gTypes
|
|
-- modifier f ctx = ctx { _gTypes = f $ _gTypes ctx }
|
|
|
|
instance ToJSON GCtx where
|
|
toJSON _ = String "GCtx"
|
|
|
|
type GCtxMap = Map.HashMap RoleName GCtx
|
|
|
|
data TyAgg
|
|
= TyAgg
|
|
{ _taTypes :: !TypeMap
|
|
, _taFields :: !FieldMap
|
|
, _taOrdBy :: !OrdByCtx
|
|
} deriving (Show, Eq)
|
|
|
|
instance Semigroup TyAgg where
|
|
(TyAgg t1 f1 o1) <> (TyAgg t2 f2 o2) =
|
|
TyAgg (Map.union t1 t2) (Map.union f1 f2) (Map.union o1 o2)
|
|
|
|
instance Monoid TyAgg where
|
|
mempty = TyAgg Map.empty Map.empty Map.empty
|
|
mappend = (<>)
|
|
|
|
newtype RootFlds
|
|
= RootFlds
|
|
{ _taMutation :: Map.HashMap G.Name (OpCtx, Either ObjFldInfo ObjFldInfo)
|
|
} deriving (Show, Eq)
|
|
|
|
instance Semigroup RootFlds where
|
|
(RootFlds m1) <> (RootFlds m2)
|
|
= RootFlds (Map.union m1 m2)
|
|
|
|
instance Monoid RootFlds where
|
|
mempty = RootFlds Map.empty
|
|
mappend = (<>)
|
|
|
|
mkHsraObjFldInfo
|
|
:: Maybe G.Description
|
|
-> G.Name
|
|
-> ParamMap
|
|
-> G.GType
|
|
-> ObjFldInfo
|
|
mkHsraObjFldInfo descM name params ty =
|
|
ObjFldInfo descM name params ty HasuraType
|
|
|
|
mkHsraObjTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> ObjFieldMap
|
|
-> ObjTyInfo
|
|
mkHsraObjTyInfo descM ty flds =
|
|
mkObjTyInfo descM ty flds HasuraType
|
|
|
|
mkHsraInpTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> InpObjFldMap
|
|
-> InpObjTyInfo
|
|
mkHsraInpTyInfo descM ty flds =
|
|
InpObjTyInfo descM ty flds HasuraType
|
|
|
|
mkHsraEnumTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> Map.HashMap G.EnumValue EnumValInfo
|
|
-> EnumTyInfo
|
|
mkHsraEnumTyInfo descM ty enumVals =
|
|
EnumTyInfo descM ty enumVals HasuraType
|
|
|
|
mkHsraScalarTyInfo :: PGColType -> ScalarTyInfo
|
|
mkHsraScalarTyInfo ty = ScalarTyInfo Nothing ty HasuraType
|
|
|
|
fromInpValL :: [InpValInfo] -> Map.HashMap G.Name InpValInfo
|
|
fromInpValL = mapFromL _iviName
|
|
|
|
mkCompExpName :: PGColType -> G.Name
|
|
mkCompExpName pgColTy =
|
|
G.Name $ T.pack (show pgColTy) <> "_comparison_exp"
|
|
|
|
mkCompExpTy :: PGColType -> G.NamedType
|
|
mkCompExpTy =
|
|
G.NamedType . mkCompExpName
|
|
|
|
--- | make compare expression input type
|
|
mkCompExpInp :: PGColType -> InpObjTyInfo
|
|
mkCompExpInp colTy =
|
|
InpObjTyInfo (Just tyDesc) (mkCompExpTy colTy) (fromInpValL $ concat
|
|
[ map (mk colScalarTy) typedOps
|
|
, map (mk $ G.toLT colScalarTy) listOps
|
|
, bool [] (map (mk $ mkScalarTy PGText) stringOps) isStringTy
|
|
, bool [] (map jsonbOpToInpVal jsonbOps) isJsonbTy
|
|
, [InpValInfo Nothing "_is_null" $ G.TypeNamed (G.Nullability True) $ G.NamedType "Boolean"]
|
|
]) HasuraType
|
|
where
|
|
tyDesc = mconcat
|
|
[ "expression to compare columns of type "
|
|
, G.Description (T.pack $ show colTy)
|
|
, ". All fields are combined with logical 'AND'."
|
|
]
|
|
isStringTy = case colTy of
|
|
PGVarchar -> True
|
|
PGText -> True
|
|
_ -> False
|
|
mk t n = InpValInfo Nothing n $ G.toGT t
|
|
colScalarTy = mkScalarTy colTy
|
|
-- colScalarListTy = GA.GTList colGTy
|
|
typedOps =
|
|
["_eq", "_neq", "_gt", "_lt", "_gte", "_lte"]
|
|
listOps =
|
|
[ "_in", "_nin" ]
|
|
-- TODO
|
|
-- columnOps =
|
|
-- [ "_ceq", "_cneq", "_cgt", "_clt", "_cgte", "_clte"]
|
|
stringOps =
|
|
[ "_like", "_nlike", "_ilike", "_nilike"
|
|
, "_similar", "_nsimilar"
|
|
]
|
|
isJsonbTy = case colTy of
|
|
PGJSONB -> True
|
|
_ -> False
|
|
jsonbOpToInpVal (op, ty, desc) = InpValInfo (Just desc) op ty
|
|
jsonbOps =
|
|
[ ( "_contains"
|
|
, G.toGT $ mkScalarTy PGJSONB
|
|
, "does the column contain the given json value at the top level"
|
|
)
|
|
, ( "_contained_in"
|
|
, G.toGT $ mkScalarTy PGJSONB
|
|
, "is the column contained in the given json value"
|
|
)
|
|
, ( "_has_key"
|
|
, G.toGT $ mkScalarTy PGText
|
|
, "does the string exist as a top-level key in the column"
|
|
)
|
|
, ( "_has_keys_any"
|
|
, G.toGT $ G.toLT $ G.toNT $ mkScalarTy PGText
|
|
, "do any of these strings exist as top-level keys in the column"
|
|
)
|
|
, ( "_has_keys_all"
|
|
, G.toGT $ G.toLT $ G.toNT $ mkScalarTy PGText
|
|
, "do all of these strings exist as top-level keys in the column"
|
|
)
|
|
]
|
|
|
|
ordByTy :: G.NamedType
|
|
ordByTy = G.NamedType "order_by"
|
|
|
|
ordByEnumTy :: EnumTyInfo
|
|
ordByEnumTy =
|
|
mkHsraEnumTyInfo (Just desc) ordByTy $ mapFromL _eviVal $
|
|
map mkEnumVal enumVals
|
|
where
|
|
desc = G.Description "column ordering options"
|
|
mkEnumVal (n, d) =
|
|
EnumValInfo (Just d) (G.EnumValue n) False
|
|
enumVals =
|
|
[ ( "asc"
|
|
, "in the ascending order, nulls last"
|
|
),
|
|
( "asc_nulls_last"
|
|
, "in the ascending order, nulls last"
|
|
),
|
|
( "asc_nulls_first"
|
|
, "in the ascending order, nulls first"
|
|
),
|
|
( "desc"
|
|
, "in the descending order, nulls first"
|
|
),
|
|
( "desc_nulls_first"
|
|
, "in the descending order, nulls first"
|
|
),
|
|
( "desc_nulls_last"
|
|
, "in the descending order, nulls last"
|
|
)
|
|
]
|
|
|
|
defaultTypes :: [TypeInfo]
|
|
defaultTypes = $(fromSchemaDocQ defaultSchema HasuraType)
|
|
|
|
|
|
mkGCtx :: TyAgg -> RootFlds -> InsCtxMap -> GCtx
|
|
mkGCtx (TyAgg tyInfos fldInfos ordByEnums) (RootFlds flds) insCtxMap =
|
|
let queryRoot = mkHsraObjTyInfo (Just "query root")
|
|
(G.NamedType "query_root") $
|
|
mapFromL _fiName (schemaFld:typeFld:qFlds)
|
|
colTys = Set.toList $ Set.fromList $ map pgiType $
|
|
lefts $ Map.elems fldInfos
|
|
scalarTys = map (TIScalar . mkHsraScalarTyInfo) colTys
|
|
compTys = map (TIInpObj . mkCompExpInp) colTys
|
|
ordByEnumTyM = bool (Just ordByEnumTy) Nothing $ null qFlds
|
|
allTys = Map.union tyInfos $ mkTyInfoMap $
|
|
catMaybes [ Just $ TIObj queryRoot
|
|
, TIObj <$> mutRootM
|
|
, TIObj <$> subRootM
|
|
, TIEnum <$> ordByEnumTyM
|
|
] <>
|
|
scalarTys <> compTys <> defaultTypes
|
|
-- for now subscription root is query root
|
|
in GCtx allTys fldInfos ordByEnums queryRoot mutRootM (Just queryRoot)
|
|
(Map.map fst flds) insCtxMap
|
|
where
|
|
mkMutRoot =
|
|
mkHsraObjTyInfo (Just "mutation root") (G.NamedType "mutation_root") .
|
|
mapFromL _fiName
|
|
mutRootM = bool (Just $ mkMutRoot mFlds) Nothing $ null mFlds
|
|
mkSubRoot =
|
|
mkHsraObjTyInfo (Just "subscription root")
|
|
(G.NamedType "subscription_root") . mapFromL _fiName
|
|
subRootM = bool (Just $ mkSubRoot qFlds) Nothing $ null qFlds
|
|
(qFlds, mFlds) = partitionEithers $ map snd $ Map.elems flds
|
|
schemaFld = mkHsraObjFldInfo Nothing "__schema" Map.empty $
|
|
G.toGT $ G.toNT $ G.NamedType "__Schema"
|
|
typeFld = mkHsraObjFldInfo Nothing "__type" typeFldArgs $
|
|
G.toGT $ G.NamedType "__Type"
|
|
where
|
|
typeFldArgs = mapFromL _iviName [
|
|
InpValInfo (Just "name of the type") "name"
|
|
$ G.toGT $ G.toNT $ G.NamedType "String"
|
|
]
|
|
|
|
emptyGCtx :: GCtx
|
|
emptyGCtx = mkGCtx mempty mempty mempty
|