mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
8f9a41ff88
* server: Bump dependencies to allow Haddock to run successfully * Support casting between PostGIS geometry and geography types in filters
468 lines
14 KiB
Haskell
468 lines
14 KiB
Haskell
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 InsOpCtx
|
|
= InsOpCtx
|
|
{ _iocTable :: !QualifiedTable
|
|
, _iocHeaders :: ![T.Text]
|
|
} deriving (Show, Eq)
|
|
|
|
data SelOpCtx
|
|
= SelOpCtx
|
|
{ _socTable :: !QualifiedTable
|
|
, _socHeaders :: ![T.Text]
|
|
, _socFilter :: !AnnBoolExpPartialSQL
|
|
, _socLimit :: !(Maybe Int)
|
|
} deriving (Show, Eq)
|
|
|
|
data SelPkOpCtx
|
|
= SelPkOpCtx
|
|
{ _spocTable :: !QualifiedTable
|
|
, _spocHeaders :: ![T.Text]
|
|
, _spocFilter :: !AnnBoolExpPartialSQL
|
|
, _spocArgMap :: !PGColArgMap
|
|
} deriving (Show, Eq)
|
|
|
|
data FuncQOpCtx
|
|
= FuncQOpCtx
|
|
{ _fqocTable :: !QualifiedTable
|
|
, _fqocHeaders :: ![T.Text]
|
|
, _fqocFilter :: !AnnBoolExpPartialSQL
|
|
, _fqocLimit :: !(Maybe Int)
|
|
, _fqocFunction :: !QualifiedFunction
|
|
, _fqocArgs :: !FuncArgSeq
|
|
} deriving (Show, Eq)
|
|
|
|
data UpdOpCtx
|
|
= UpdOpCtx
|
|
{ _uocTable :: !QualifiedTable
|
|
, _uocHeaders :: ![T.Text]
|
|
, _uocFilter :: !AnnBoolExpPartialSQL
|
|
, _uocPresetCols :: !PreSetColsPartial
|
|
, _uocAllCols :: ![PGColInfo]
|
|
} deriving (Show, Eq)
|
|
|
|
data DelOpCtx
|
|
= DelOpCtx
|
|
{ _docTable :: !QualifiedTable
|
|
, _docHeaders :: ![T.Text]
|
|
, _docFilter :: !AnnBoolExpPartialSQL
|
|
, _docAllCols :: ![PGColInfo]
|
|
} deriving (Show, Eq)
|
|
|
|
data OpCtx
|
|
= OCSelect !SelOpCtx
|
|
| OCSelectPkey !SelPkOpCtx
|
|
| OCSelectAgg !SelOpCtx
|
|
| OCFuncQuery !FuncQOpCtx
|
|
| OCFuncAggQuery !FuncQOpCtx
|
|
| OCInsert !InsOpCtx
|
|
| OCUpdate !UpdOpCtx
|
|
| OCDelete !DelOpCtx
|
|
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
|
|
, _taScalars :: !(Set.HashSet PGColType)
|
|
, _taOrdBy :: !OrdByCtx
|
|
} deriving (Show, Eq)
|
|
|
|
instance Semigroup TyAgg where
|
|
(TyAgg t1 f1 s1 o1) <> (TyAgg t2 f2 s2 o2) =
|
|
TyAgg (Map.union t1 t2) (Map.union f1 f2)
|
|
(Set.union s1 s2) (Map.union o1 o2)
|
|
|
|
instance Monoid TyAgg where
|
|
mempty = TyAgg Map.empty Map.empty Set.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 TLHasuraType
|
|
|
|
mkHsraObjTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> IFacesSet
|
|
-> ObjFieldMap
|
|
-> ObjTyInfo
|
|
mkHsraObjTyInfo descM ty implIFaces flds =
|
|
mkObjTyInfo descM ty implIFaces flds TLHasuraType
|
|
|
|
mkHsraInpTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> InpObjFldMap
|
|
-> InpObjTyInfo
|
|
mkHsraInpTyInfo descM ty flds =
|
|
InpObjTyInfo descM ty flds TLHasuraType
|
|
|
|
mkHsraEnumTyInfo
|
|
:: Maybe G.Description
|
|
-> G.NamedType
|
|
-> Map.HashMap G.EnumValue EnumValInfo
|
|
-> EnumTyInfo
|
|
mkHsraEnumTyInfo descM ty enumVals =
|
|
EnumTyInfo descM ty enumVals TLHasuraType
|
|
|
|
mkHsraScalarTyInfo :: PGColType -> ScalarTyInfo
|
|
mkHsraScalarTyInfo ty = ScalarTyInfo Nothing ty TLHasuraType
|
|
|
|
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
|
|
|
|
mkCastExpName :: PGColType -> G.Name
|
|
mkCastExpName pgColTy = G.Name $ T.pack (show pgColTy) <> "_cast_exp"
|
|
|
|
mkCastExpTy :: PGColType -> G.NamedType
|
|
mkCastExpTy = G.NamedType . mkCastExpName
|
|
|
|
-- TODO(shahidhk) this should ideally be st_d_within_geometry
|
|
{-
|
|
input st_d_within_input {
|
|
distance: Float!
|
|
from: geometry!
|
|
}
|
|
-}
|
|
stDWithinGeometryInpTy :: G.NamedType
|
|
stDWithinGeometryInpTy = G.NamedType "st_d_within_input"
|
|
|
|
{-
|
|
input st_d_within_geography_input {
|
|
distance: Float!
|
|
from: geography!
|
|
use_spheroid: Bool!
|
|
}
|
|
-}
|
|
stDWithinGeographyInpTy :: G.NamedType
|
|
stDWithinGeographyInpTy = G.NamedType "st_d_within_geography_input"
|
|
|
|
|
|
--- | 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 $ G.toNT colScalarTy) listOps
|
|
, bool [] (map (mk $ mkScalarTy PGText) stringOps) isStringTy
|
|
, bool [] (map jsonbOpToInpVal jsonbOps) isJsonbTy
|
|
, bool [] (stDWithinGeoOpInpVal stDWithinGeometryInpTy :
|
|
map geoOpToInpVal (geoOps ++ geomOps)) isGeometryType
|
|
, bool [] (stDWithinGeoOpInpVal stDWithinGeographyInpTy :
|
|
map geoOpToInpVal geoOps) isGeographyType
|
|
, [InpValInfo Nothing "_is_null" Nothing $ G.TypeNamed (G.Nullability True) $ G.NamedType "Boolean"]
|
|
, maybeToList castOpInputValue
|
|
]) TLHasuraType
|
|
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 Nothing $ 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 Nothing 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"
|
|
)
|
|
]
|
|
|
|
castOpInputValue =
|
|
-- currently, only geometry/geography types support casting
|
|
guard (isGeoType colTy) $>
|
|
InpValInfo Nothing "_cast" Nothing (G.toGT $ mkCastExpTy colTy)
|
|
|
|
stDWithinGeoOpInpVal ty =
|
|
InpValInfo (Just stDWithinGeoDesc) "_st_d_within" Nothing $ G.toGT ty
|
|
stDWithinGeoDesc =
|
|
"is the column within a distance from a " <> colTyDesc <> " value"
|
|
|
|
-- Geometry related ops
|
|
isGeometryType = case colTy of
|
|
PGGeometry -> True
|
|
_ -> False
|
|
|
|
-- Geography related ops
|
|
isGeographyType = case colTy of
|
|
PGGeography -> True
|
|
_ -> False
|
|
|
|
geoOpToInpVal (op, desc) =
|
|
InpValInfo (Just desc) op Nothing $ G.toGT $ mkScalarTy colTy
|
|
|
|
colTyDesc = G.Description $ T.pack $ show colTy
|
|
|
|
-- operators applicable only to geometry types
|
|
geomOps :: [(G.Name, G.Description)]
|
|
geomOps =
|
|
[
|
|
( "_st_contains"
|
|
, "does the column contain the given geometry value"
|
|
)
|
|
, ( "_st_crosses"
|
|
, "does the column crosses the given geometry value"
|
|
)
|
|
, ( "_st_equals"
|
|
, "is the column equal to given geometry value. Directionality is ignored"
|
|
)
|
|
, ( "_st_overlaps"
|
|
, "does the column 'spatially overlap' (intersect but not completely contain) the given geometry value"
|
|
)
|
|
, ( "_st_touches"
|
|
, "does the column have atleast one point in common with the given geometry value"
|
|
)
|
|
, ( "_st_within"
|
|
, "is the column contained in the given geometry value"
|
|
)
|
|
]
|
|
|
|
-- operators applicable to geometry and geography types
|
|
geoOps =
|
|
[
|
|
( "_st_intersects"
|
|
, "does the column spatially intersect the given " <> colTyDesc <> " value"
|
|
)
|
|
]
|
|
|
|
-- | Makes an input type declaration for the @_cast@ field of a comparison expression.
|
|
-- (Currently only used for casting between geometry and geography types.)
|
|
mkCastExpressionInputType :: PGColType -> [PGColType] -> InpObjTyInfo
|
|
mkCastExpressionInputType sourceType targetTypes =
|
|
mkHsraInpTyInfo (Just description) (mkCastExpTy sourceType) (fromInpValL targetFields)
|
|
where
|
|
description = mconcat
|
|
[ "Expression to compare the result of casting a column of type "
|
|
, G.Description (T.pack $ show sourceType)
|
|
, ". Multiple cast targets are combined with logical 'AND'."
|
|
]
|
|
targetFields = map targetField targetTypes
|
|
targetField targetType = InpValInfo
|
|
Nothing
|
|
(G.Name . T.pack $ show targetType)
|
|
Nothing
|
|
(G.toGT $ mkCompExpTy targetType)
|
|
|
|
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 TLHasuraType)
|
|
|
|
|
|
mkGCtx :: TyAgg -> RootFlds -> InsCtxMap -> GCtx
|
|
mkGCtx tyAgg (RootFlds flds) insCtxMap =
|
|
let queryRoot = mkHsraObjTyInfo (Just "query root")
|
|
(G.NamedType "query_root") Set.empty $
|
|
mapFromL _fiName (schemaFld:typeFld:qFlds)
|
|
scalarTys = map (TIScalar . mkHsraScalarTyInfo) (Set.toList allScalarTypes)
|
|
compTys = map (TIInpObj . mkCompExpInp) (Set.toList allComparableTypes)
|
|
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 <> wiredInGeoInputTypes
|
|
-- for now subscription root is query root
|
|
in GCtx allTys fldInfos ordByEnums queryRoot mutRootM subRootM
|
|
(Map.map fst flds) insCtxMap
|
|
where
|
|
TyAgg tyInfos fldInfos scalars ordByEnums = tyAgg
|
|
colTys = Set.fromList $ map pgiType $ lefts $ Map.elems fldInfos
|
|
mkMutRoot =
|
|
mkHsraObjTyInfo (Just "mutation root") (G.NamedType "mutation_root") Set.empty .
|
|
mapFromL _fiName
|
|
mutRootM = bool (Just $ mkMutRoot mFlds) Nothing $ null mFlds
|
|
mkSubRoot =
|
|
mkHsraObjTyInfo (Just "subscription root")
|
|
(G.NamedType "subscription_root") Set.empty . 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" Nothing
|
|
$ G.toGT $ G.toNT $ G.NamedType "String"
|
|
]
|
|
|
|
anyGeoTypes = any isGeoType colTys
|
|
allComparableTypes =
|
|
if anyGeoTypes
|
|
-- due to casting, we need to generate both geometry and geography
|
|
-- operations even if just one of the two appears in the schema
|
|
then Set.union (Set.fromList [PGGeometry, PGGeography]) colTys
|
|
else colTys
|
|
allScalarTypes = allComparableTypes <> scalars
|
|
|
|
wiredInGeoInputTypes =
|
|
guard anyGeoTypes *> map TIInpObj
|
|
[ stDWithinGeometryInputType
|
|
, stDWithinGeographyInputType
|
|
, castGeometryInputType
|
|
, castGeographyInputType
|
|
]
|
|
|
|
stDWithinGeometryInputType =
|
|
mkHsraInpTyInfo Nothing stDWithinGeometryInpTy $ fromInpValL
|
|
[ InpValInfo Nothing "from" Nothing $ G.toGT $ G.toNT $ mkScalarTy PGGeometry
|
|
, InpValInfo Nothing "distance" Nothing $ G.toNT $ mkScalarTy PGFloat
|
|
]
|
|
stDWithinGeographyInputType =
|
|
mkHsraInpTyInfo Nothing stDWithinGeographyInpTy $ fromInpValL
|
|
[ InpValInfo Nothing "from" Nothing $ G.toGT $ G.toNT $ mkScalarTy PGGeography
|
|
, InpValInfo Nothing "distance" Nothing $ G.toNT $ mkScalarTy PGFloat
|
|
, InpValInfo
|
|
Nothing "use_spheroid" (Just $ G.VCBoolean True) $ G.toGT $ mkScalarTy PGBoolean
|
|
]
|
|
|
|
castGeometryInputType = mkCastExpressionInputType PGGeometry [PGGeography]
|
|
castGeographyInputType = mkCastExpressionInputType PGGeography [PGGeometry]
|
|
|
|
emptyGCtx :: GCtx
|
|
emptyGCtx = mkGCtx mempty mempty mempty
|
|
|
|
data RemoteGCtx
|
|
= RemoteGCtx
|
|
{ _rgTypes :: !TypeMap
|
|
, _rgQueryRoot :: !ObjTyInfo
|
|
, _rgMutationRoot :: !(Maybe ObjTyInfo)
|
|
, _rgSubscriptionRoot :: !(Maybe ObjTyInfo)
|
|
} deriving (Show, Eq)
|