|
| 1 | +module Hasura.GraphQL.Schema.Select where |
| 2 | + |
| 3 | +import Hasura.Prelude |
| 4 | + |
| 5 | +import qualified Data.HashMap.Strict as Map |
| 6 | +import qualified Language.GraphQL.Draft.Syntax as G |
| 7 | + |
| 8 | +import qualified Hasura.GraphQL.Parser as P |
| 9 | +import qualified Hasura.RQL.DML.Select as RQL |
| 10 | + |
| 11 | +import Hasura.GraphQL.Parser (FieldsParser, Kind (..), Parser, |
| 12 | + UnpreparedValue (..)) |
| 13 | +import Hasura.GraphQL.Parser.Class |
| 14 | +import Hasura.GraphQL.Schema.BoolExp |
| 15 | +import Hasura.GraphQL.Schema.Common (qualifiedObjectToName) |
| 16 | +import Hasura.RQL.Types |
| 17 | +import Hasura.SQL.Types |
| 18 | +import Hasura.SQL.Value |
| 19 | + |
| 20 | + |
| 21 | + |
| 22 | +type SelectExp = RQL.AnnSimpleSelG UnpreparedValue |
| 23 | +type TableArgs = RQL.TableArgsG UnpreparedValue |
| 24 | +type TablePerms = RQL.TablePermG UnpreparedValue |
| 25 | + |
| 26 | + |
| 27 | +selectExp |
| 28 | + :: forall m n. (MonadSchema n m, MonadError QErr m) |
| 29 | + => QualifiedTable |
| 30 | + -> TablePerms |
| 31 | + -> Bool |
| 32 | + -> m (FieldsParser 'Output n (Maybe (G.Name, SelectExp))) |
| 33 | +selectExp table tablePermissions stringifyNum = do |
| 34 | + name <- qualifiedObjectToName table |
| 35 | + tableArgsParser <- tableArgs table |
| 36 | + selectionSetParser <- tableSelectionSet table |
| 37 | + return $ P.selection name Nothing tableArgsParser selectionSetParser <&> fmap |
| 38 | + \(aliasName, tableArgs, tableFields) -> (aliasName, RQL.AnnSelG |
| 39 | + { RQL._asnFields = tableFields |
| 40 | + , RQL._asnFrom = RQL.FromTable table |
| 41 | + , RQL._asnPerm = tablePermissions |
| 42 | + , RQL._asnArgs = tableArgs |
| 43 | + , RQL._asnStrfyNum = stringifyNum |
| 44 | + }) |
| 45 | + |
| 46 | + |
| 47 | +tablePerms |
| 48 | + :: forall m n. (MonadSchema n m) |
| 49 | + => QualifiedTable |
| 50 | + -> m (Maybe TablePerms) |
| 51 | +tablePerms table = do |
| 52 | + roleName <- askRoleName |
| 53 | + tableInfo <- _tiRolePermInfoMap <$> askTableInfo table |
| 54 | + return $ do |
| 55 | + rolePermissions <- Map.lookup roleName tableInfo |
| 56 | + selectPermissions <- _permSel rolePermissions |
| 57 | + return $ RQL.TablePerm |
| 58 | + { RQL._tpFilter = fmapAnnBoolExp toUnpreparedValue $ spiFilter selectPermissions |
| 59 | + , RQL._tpLimit = spiLimit selectPermissions |
| 60 | + } |
| 61 | + where |
| 62 | + toUnpreparedValue (PSESessVar pftype var) = P.UVSessionVar pftype var |
| 63 | + toUnpreparedValue (PSESQLExp exp) = P.UVLiteral exp |
| 64 | + |
| 65 | + |
| 66 | +tableArgs |
| 67 | + :: forall m n. (MonadSchema n m, MonadError QErr m) |
| 68 | + => QualifiedTable |
| 69 | + -> m (FieldsParser 'Input n TableArgs) |
| 70 | +tableArgs table = do |
| 71 | + boolExpParser <- boolExp table |
| 72 | + return $ do |
| 73 | + limit <- P.fieldOptional limitName Nothing P.int |
| 74 | + offset <- P.fieldOptional offsetName Nothing P.int |
| 75 | + whereF <- P.fieldOptional whereName Nothing boolExpParser |
| 76 | + return $ RQL.TableArgs |
| 77 | + { RQL._taWhere = whereF |
| 78 | + , RQL._taOrderBy = Nothing -- TODO |
| 79 | + , RQL._taLimit = fromIntegral <$> limit |
| 80 | + , RQL._taOffset = txtEncoder . PGValInteger <$> offset |
| 81 | + , RQL._taDistCols = Nothing |
| 82 | + } |
| 83 | + where limitName = $$(G.litName "limit") |
| 84 | + offsetName = $$(G.litName "offset") |
| 85 | + whereName = $$(G.litName "where") |
| 86 | + |
| 87 | +-- SELit . Text.pack . show <$> |
| 88 | +{- |
| 89 | +distinct_on: [card_types_select_column!] |
| 90 | +limit: Intoffset: Int |
| 91 | +order_by: [card_types_order_by!] |
| 92 | +where: card_types_bool_exp |
| 93 | +-} |
| 94 | + |
| 95 | + |
| 96 | +type AnnotatedFields = RQL.AnnFldsG UnpreparedValue |
| 97 | +type AnnotatedField = RQL.AnnFldG UnpreparedValue |
| 98 | + |
| 99 | + |
| 100 | + |
| 101 | +-- | Corresponds to an object type for a table: |
| 102 | +-- |
| 103 | +-- > type table { |
| 104 | +-- > col1: colty1 |
| 105 | +-- > ... |
| 106 | +-- > rel1: relty1 |
| 107 | +-- > } |
| 108 | +tableSelectionSet |
| 109 | + :: (MonadSchema n m, MonadError QErr m) |
| 110 | + => QualifiedTable |
| 111 | + -> m (Parser 'Output n AnnotatedFields) |
| 112 | +tableSelectionSet = P.memoize 'tableSelectionSet \tableName -> do |
| 113 | + tableInfo <- _tiCoreInfo <$> askTableInfo tableName |
| 114 | + name <- qualifiedObjectToName $ _tciName tableInfo |
| 115 | + -- FIXME: permissions! |
| 116 | + fields <- catMaybes <$> traverse fieldSelection (Map.elems $ _tciFieldInfoMap tableInfo) |
| 117 | + pure $ P.selectionSet name (_tciDescription tableInfo) $ catMaybes <$> sequenceA fields |
| 118 | + |
| 119 | +-- | A field for a table. Returns 'Nothing' if the field’s name is not a valid |
| 120 | +-- GraphQL 'Name'. |
| 121 | +-- |
| 122 | +-- > field_name(arg_name: arg_type, ...): field_type |
| 123 | +fieldSelection |
| 124 | + :: (MonadSchema n m, MonadError QErr m) |
| 125 | + => FieldInfo |
| 126 | + -> m (Maybe (FieldsParser 'Output n (Maybe (FieldName, AnnotatedField)))) |
| 127 | +fieldSelection fieldInfo = for (fieldInfoGraphQLName fieldInfo) \fieldName -> |
| 128 | + aliasToFieldName <$> case fieldInfo of |
| 129 | + FIColumn columnInfo -> do |
| 130 | + let annotated = RQL.mkAnnColField columnInfo Nothing -- FIXME: support ColOp |
| 131 | + field <- P.column (pgiType columnInfo) (G.Nullability $ pgiIsNullable columnInfo) |
| 132 | + pure $ fmap (, annotated) <$> P.selection_ fieldName fieldDescription field |
| 133 | + FIRelationship relationshipInfo -> undefined -- TODO: implement |
| 134 | + FIComputedField computedFieldInfo -> undefined -- TODO: implement |
| 135 | + where |
| 136 | + aliasToFieldName = fmap $ fmap $ first $ FieldName . G.unName |
| 137 | + |
| 138 | + fieldDescription = case fieldInfo of |
| 139 | + FIColumn info -> pgiDescription info |
| 140 | + FIRelationship _ -> Nothing |
| 141 | + FIComputedField info -> _cffDescription $ _cfiFunction info |
0 commit comments