1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-23 07:22:53 +03:00
graphql-engine/server/src-lib/Hasura/RQL/DDL/Action.hs
Auke Booij 05b3a64e8f Clean up Hasura.Prelude a bit
- Remove `onJust` in favor of the more general `for_`
- Remove `withJust` which was used only once
- Remove `hashNub` in favor of `Ord`-based `uniques`
- Simplify some of the implementations in `Hasura.Prelude`
- Add `hlint` hint from `maybe True` to `all`, and `maybe False` to `any`

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6173
GitOrigin-RevId: 2c6ebbe2d04f60071d2a53a2d43c6d62dbc4b84e
2022-10-03 21:50:53 +00:00

341 lines
12 KiB
Haskell

{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.DDL.Action
( CreateAction (..),
runCreateAction,
resolveAction,
UpdateAction,
runUpdateAction,
DropAction,
runDropAction,
dropActionInMetadata,
CreateActionPermission (..),
runCreateActionPermission,
DropActionPermission,
runDropActionPermission,
dropActionPermissionInMetadata,
caName,
caDefinition,
caComment,
uaName,
uaDefinition,
uaComment,
)
where
import Control.Lens (makeLenses, (.~), (^.))
import Data.Aeson qualified as J
import Data.Aeson.TH qualified as J
import Data.Environment qualified as Env
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.List.NonEmpty qualified as NEList
import Data.Text.Extended
import Data.URL.Template (printURLTemplate)
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.Metadata.Class
import Hasura.Prelude
import Hasura.RQL.DDL.CustomTypes (lookupBackendScalar)
import Hasura.RQL.Types.Action
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.CustomTypes
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.Metadata.Object
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.RQL.Types.Source
import Hasura.SQL.BackendMap (BackendMap)
import Hasura.Session
import Language.GraphQL.Draft.Syntax qualified as G
getActionInfo ::
(QErrM m, CacheRM m) =>
ActionName ->
m ActionInfo
getActionInfo actionName = do
actionMap <- scActions <$> askSchemaCache
onNothing (Map.lookup actionName actionMap) $
throw400 NotExists $ "action with name " <> actionName <<> " does not exist"
data CreateAction = CreateAction
{ _caName :: ActionName,
_caDefinition :: ActionDefinitionInput,
_caComment :: Maybe Text
}
$(makeLenses ''CreateAction)
$(J.deriveJSON hasuraJSON ''CreateAction)
runCreateAction ::
(QErrM m, CacheRWM m, MetadataM m) =>
CreateAction ->
m EncJSON
runCreateAction createAction = do
-- check if action with same name exists already
actionMap <- scActions <$> askSchemaCache
for_ (Map.lookup actionName actionMap) $
const $
throw400 AlreadyExists $
"action with name " <> actionName <<> " already exists"
let metadata =
ActionMetadata
actionName
(_caComment createAction)
(_caDefinition createAction)
[]
buildSchemaCacheFor (MOAction actionName) $
MetadataModifier $
metaActions %~ OMap.insert actionName metadata
pure successMsg
where
actionName = _caName createAction
{- Note [Postgres scalars in action input arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very comfortable to be able to reference Postgres scalars in actions
input arguments. For example, see the following action mutation:
extend type mutation_root {
create_user (
name: String!
created_at: timestamptz
): User
}
The timestamptz is a Postgres scalar. We need to validate the presence of
timestamptz type in the Postgres database. So, the 'resolveAction' function
takes all Postgres scalar types as one of the inputs and returns the set of
referred scalars.
-}
resolveAction ::
QErrM m =>
Env.Environment ->
AnnotatedCustomTypes ->
ActionDefinitionInput ->
BackendMap ScalarMap -> -- See Note [Postgres scalars in custom types]
m
( ResolvedActionDefinition,
AnnotatedOutputType
)
resolveAction env AnnotatedCustomTypes {..} ActionDefinition {..} allScalars = do
resolvedArguments <- forM _adArguments $ \argumentDefinition -> do
forM argumentDefinition $ \argumentType -> do
let gType = unGraphQLType argumentType
argumentBaseType = G.getBaseType gType
(gType,)
<$> if
| Just noCTScalar <- lookupBackendScalar allScalars argumentBaseType ->
pure $ NOCTScalar noCTScalar
| Just nonObjectType <- Map.lookup argumentBaseType _actInputTypes ->
pure nonObjectType
| otherwise ->
throw400 InvalidParams $
"the type: " <> dquote argumentBaseType
<> " is not defined in custom types or it is not a scalar/enum/input_object"
-- Check if the response type is an object
let outputType = unGraphQLType _adOutputType
outputBaseType = G.getBaseType outputType
outputObject <- do
aot <-
if
| Just aoTScalar <- lookupBackendScalar allScalars outputBaseType ->
pure $ AOTScalar aoTScalar
| Just objectType <- Map.lookup outputBaseType _actObjectTypes ->
pure $ AOTObject objectType
| Just (NOCTScalar s) <- Map.lookup outputBaseType _actInputTypes ->
pure (AOTScalar s)
| otherwise ->
throw400 NotExists ("the type: " <> dquote outputBaseType <> " is not an object or scalar type defined in custom types")
-- If the Action is sync:
-- 1. Check if the output type has only top level relations (if any)
-- If the Action is async:
-- 1. Check that the output type has no relations if the output type contains nested objects
-- These checks ensure that the SQL we generate for the join does not have to extract nested fields
-- from the action webhook response.
let (nestedObjects, scalarOrEnumFields) = case aot of
AOTObject aot' ->
NEList.partition
( \ObjectFieldDefinition {..} ->
case snd _ofdType of
AOFTScalar _ -> False
AOFTEnum _ -> False
AOFTObject _ -> True
)
(_aotFields aot')
AOTScalar _ -> ([], [])
scalarOrEnumFieldNames = fmap (\ObjectFieldDefinition {..} -> unObjectFieldName _ofdName) scalarOrEnumFields
validateSyncAction = case aot of
AOTObject aot' -> do
let relationshipsWithNonTopLevelFields =
filter
( \AnnotatedTypeRelationship {..} ->
let objsInRel = unObjectFieldName <$> Map.keys _atrFieldMapping
in not $ all (`elem` scalarOrEnumFieldNames) objsInRel
)
(_aotRelationships aot')
unless (null relationshipsWithNonTopLevelFields) $
throw400 ConstraintError $
"Relationships cannot be defined with nested object fields: "
<> commaSeparated (dquote . _atrName <$> relationshipsWithNonTopLevelFields)
AOTScalar _ -> pure ()
case _adType of
ActionQuery -> validateSyncAction
ActionMutation ActionSynchronous -> validateSyncAction
ActionMutation ActionAsynchronous -> case aot of
AOTScalar _ -> pure ()
AOTObject aot' ->
unless (null (_aotRelationships aot') || null nestedObjects) $
throw400 ConstraintError $ "Async action relations cannot be used with object fields: " <> commaSeparated (dquote . _ofdName <$> nestedObjects)
pure aot
resolvedWebhook <- resolveWebhook env _adHandler
let webhookEnvRecord = EnvRecord (printURLTemplate $ unInputWebhook _adHandler) resolvedWebhook
pure
( ActionDefinition
resolvedArguments
_adOutputType
_adType
_adHeaders
_adForwardClientHeaders
_adTimeout
webhookEnvRecord
_adRequestTransform
_adResponseTransform,
outputObject
)
data UpdateAction = UpdateAction
{ _uaName :: ActionName,
_uaDefinition :: ActionDefinitionInput,
_uaComment :: Maybe Text
}
$(makeLenses ''UpdateAction)
$(J.deriveFromJSON hasuraJSON ''UpdateAction)
runUpdateAction ::
forall m.
(QErrM m, CacheRWM m, MetadataM m) =>
UpdateAction ->
m EncJSON
runUpdateAction (UpdateAction actionName actionDefinition actionComment) = do
sc <- askSchemaCache
let actionsMap = scActions sc
void $
onNothing (Map.lookup actionName actionsMap) $
throw400 NotExists $ "action with name " <> actionName <<> " does not exist"
buildSchemaCacheFor (MOAction actionName) $ updateActionMetadataModifier actionDefinition actionComment
pure successMsg
where
updateActionMetadataModifier :: ActionDefinitionInput -> Maybe Text -> MetadataModifier
updateActionMetadataModifier def comment =
MetadataModifier $
(metaActions . ix actionName . amDefinition .~ def)
. (metaActions . ix actionName . amComment .~ comment)
newtype ClearActionData = ClearActionData {unClearActionData :: Bool}
deriving (Show, Eq, J.FromJSON, J.ToJSON)
shouldClearActionData :: ClearActionData -> Bool
shouldClearActionData = unClearActionData
defaultClearActionData :: ClearActionData
defaultClearActionData = ClearActionData True
data DropAction = DropAction
{ _daName :: ActionName,
_daClearData :: Maybe ClearActionData
}
deriving (Show, Eq)
$(J.deriveJSON hasuraJSON ''DropAction)
runDropAction ::
( CacheRWM m,
MetadataM m,
MonadMetadataStorageQueryAPI m
) =>
DropAction ->
m EncJSON
runDropAction (DropAction actionName clearDataM) = do
void $ getActionInfo actionName
withNewInconsistentObjsCheck $
buildSchemaCache $
dropActionInMetadata actionName
when (shouldClearActionData clearData) $ deleteActionData actionName
return successMsg
where
-- When clearData is not present we assume that
-- the data needs to be retained
clearData = fromMaybe defaultClearActionData clearDataM
dropActionInMetadata :: ActionName -> MetadataModifier
dropActionInMetadata name =
MetadataModifier $ metaActions %~ OMap.delete name
newtype ActionMetadataField = ActionMetadataField {unActionMetadataField :: Text}
deriving (Show, Eq, J.FromJSON, J.ToJSON)
doesActionPermissionExist :: Metadata -> ActionName -> RoleName -> Bool
doesActionPermissionExist metadata actionName roleName =
any ((== roleName) . _apmRole) $ metadata ^. (metaActions . ix actionName . amPermissions)
data CreateActionPermission = CreateActionPermission
{ _capAction :: ActionName,
_capRole :: RoleName,
_capDefinition :: Maybe J.Value,
_capComment :: Maybe Text
}
$(J.deriveFromJSON hasuraJSON ''CreateActionPermission)
runCreateActionPermission ::
(QErrM m, CacheRWM m, MetadataM m) =>
CreateActionPermission ->
m EncJSON
runCreateActionPermission createActionPermission = do
metadata <- getMetadata
when (doesActionPermissionExist metadata actionName roleName) $
throw400 AlreadyExists $
"permission for role " <> roleName
<<> " is already defined on " <>> actionName
buildSchemaCacheFor (MOActionPermission actionName roleName) $
MetadataModifier $
metaActions . ix actionName . amPermissions
%~ (:) (ActionPermissionMetadata roleName comment)
pure successMsg
where
CreateActionPermission actionName roleName _ comment = createActionPermission
data DropActionPermission = DropActionPermission
{ _dapAction :: ActionName,
_dapRole :: RoleName
}
deriving (Show, Eq)
$(J.deriveJSON hasuraJSON ''DropActionPermission)
runDropActionPermission ::
(QErrM m, CacheRWM m, MetadataM m) =>
DropActionPermission ->
m EncJSON
runDropActionPermission dropActionPermission = do
metadata <- getMetadata
unless (doesActionPermissionExist metadata actionName roleName) $
throw400 NotExists $
"permission for role: " <> roleName <<> " is not defined on " <>> actionName
buildSchemaCacheFor (MOActionPermission actionName roleName) $
dropActionPermissionInMetadata actionName roleName
return successMsg
where
actionName = _dapAction dropActionPermission
roleName = _dapRole dropActionPermission
dropActionPermissionInMetadata :: ActionName -> RoleName -> MetadataModifier
dropActionPermissionInMetadata name role =
MetadataModifier $
metaActions . ix name . amPermissions %~ filter ((/=) role . _apmRole)