mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-11-13 09:17:21 +03:00
server: metadata separation: reorganize metadata types (#6103)
https://github.com/hasura/graphql-engine/pull/6103
This commit is contained in:
Auke Booij
GitHub
parent
81e836a12c
commit
3bcde3d4b8
@ -388,6 +388,7 @@ library
|
||||
, Hasura.RQL.Types.Permission
|
||||
, Hasura.RQL.Types.QueryCollection
|
||||
, Hasura.RQL.Types.Action
|
||||
, Hasura.RQL.Types.Relationship
|
||||
, Hasura.RQL.Types.RemoteSchema
|
||||
, Hasura.RQL.Types.RemoteRelationship
|
||||
, Hasura.RQL.Types.ScheduledTrigger
|
||||
@ -405,7 +406,6 @@ library
|
||||
, Hasura.RQL.DDL.QueryCollection
|
||||
, Hasura.RQL.DDL.Relationship
|
||||
, Hasura.RQL.DDL.Relationship.Rename
|
||||
, Hasura.RQL.DDL.Relationship.Types
|
||||
, Hasura.RQL.DDL.RemoteRelationship
|
||||
, Hasura.RQL.DDL.RemoteRelationship.Validate
|
||||
, Hasura.RQL.DDL.RemoteSchema
|
||||
|
||||
@ -10,7 +10,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Hasura.App
|
||||
import Hasura.Logging (Hasura)
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DDL.Metadata (fetchMetadata)
|
||||
import Hasura.RQL.DDL.Metadata (fetchMetadataFromHdbTables)
|
||||
import Hasura.RQL.DDL.Schema
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.Server.Init
|
||||
@ -24,8 +24,8 @@ import qualified Data.Environment as Env
|
||||
import qualified Database.PG.Query as Q
|
||||
import qualified Hasura.Tracing as Tracing
|
||||
import qualified System.Exit as Sys
|
||||
import qualified System.Posix.Signals as Signals
|
||||
import qualified System.Metrics as EKG
|
||||
import qualified System.Posix.Signals as Signals
|
||||
|
||||
|
||||
main :: IO ()
|
||||
@ -44,17 +44,17 @@ runApp env (HGEOptionsG rci hgeCmd) =
|
||||
withVersion $$(getVersionFromEnvironment) $ case hgeCmd of
|
||||
HCServe serveOptions -> do
|
||||
(initCtx, initTime) <- initialiseCtx env hgeCmd rci
|
||||
|
||||
|
||||
ekgStore <- liftIO do
|
||||
s <- EKG.newStore
|
||||
EKG.registerGcMetrics s
|
||||
|
||||
|
||||
let getTimeMs :: IO Int64
|
||||
getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
|
||||
|
||||
EKG.registerCounter "ekg.server_timestamp_ms" getTimeMs s
|
||||
pure s
|
||||
|
||||
|
||||
let shutdownApp = return ()
|
||||
-- Catches the SIGTERM signal and initiates a graceful shutdown.
|
||||
-- Graceful shutdown for regular HTTP requests is already implemented in
|
||||
@ -69,7 +69,7 @@ runApp env (HGEOptionsG rci hgeCmd) =
|
||||
|
||||
HCExport -> do
|
||||
(initCtx, _) <- initialiseCtx env hgeCmd rci
|
||||
res <- runTx' initCtx fetchMetadata Q.ReadCommitted
|
||||
res <- runTx' initCtx fetchMetadataFromHdbTables Q.ReadCommitted
|
||||
either (printErrJExit MetadataExportError) printJSON res
|
||||
|
||||
HCClean -> do
|
||||
|
||||
@ -7,6 +7,8 @@ module Hasura.Incremental.Internal.Dependency where
|
||||
import Hasura.Prelude
|
||||
|
||||
import qualified Data.Dependent.Map as DM
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import qualified Data.HashMap.Strict.InsOrd as OMap
|
||||
import qualified Data.URL.Template as UT
|
||||
import qualified Language.GraphQL.Draft.Syntax as G
|
||||
import qualified Network.URI.Extended as N
|
||||
@ -21,8 +23,8 @@ import Data.Set (Set)
|
||||
import Data.Text.NonEmpty
|
||||
import Data.Time.Clock
|
||||
import Data.Vector (Vector)
|
||||
import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), V1,
|
||||
(:*:) (..), (:+:) (..))
|
||||
import GHC.Generics ((:*:) (..), (:+:) (..), Generic (..), K1 (..),
|
||||
M1 (..), U1 (..), V1)
|
||||
import System.Cron.Types
|
||||
|
||||
import Hasura.Incremental.Select
|
||||
@ -196,6 +198,10 @@ instance (Cacheable a) => Cacheable (CI a) where
|
||||
unchanged _ = (==)
|
||||
instance (Cacheable a) => Cacheable (Set a) where
|
||||
unchanged = liftEq . unchanged
|
||||
instance (Hashable k, Cacheable k, Cacheable v) => Cacheable (InsOrdHashMap k v) where
|
||||
unchanged accesses l r = unchanged accesses (toHashMap l) (toHashMap r)
|
||||
where
|
||||
toHashMap = Map.fromList . OMap.toList
|
||||
|
||||
instance Cacheable ()
|
||||
instance (Cacheable a, Cacheable b) => Cacheable (a, b)
|
||||
|
||||
@ -20,6 +20,7 @@ module Hasura.Prelude
|
||||
, coerceSet
|
||||
, findWithIndex
|
||||
, mapFromL
|
||||
, oMapFromL
|
||||
-- * Measuring and working with moments and durations
|
||||
, withElapsedTime
|
||||
, startTimer
|
||||
@ -46,10 +47,10 @@ import Data.Foldable as M (asum, fold, foldrM, for
|
||||
traverse_)
|
||||
import Data.Function as M (on, (&))
|
||||
import Data.Functor as M (($>), (<&>))
|
||||
import Data.Hashable as M (Hashable)
|
||||
import Data.HashMap.Strict as M (HashMap)
|
||||
import Data.HashMap.Strict.InsOrd as M (InsOrdHashMap)
|
||||
import Data.HashSet as M (HashSet)
|
||||
import Data.Hashable as M (Hashable)
|
||||
import Data.List as M (find, findIndex, foldl', group,
|
||||
intercalate, intersect, lookup, sort,
|
||||
sortBy, sortOn, union, unionBy, (\\))
|
||||
@ -79,6 +80,7 @@ import qualified Data.ByteString.Base64.Lazy as Base64
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Coerce
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import qualified Data.HashMap.Strict.InsOrd as OMap
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
@ -160,6 +162,9 @@ findWithIndex p l = do
|
||||
mapFromL :: (Eq k, Hashable k) => (a -> k) -> [a] -> Map.HashMap k a
|
||||
mapFromL f = Map.fromList . map (\v -> (f v, v))
|
||||
|
||||
oMapFromL :: (Eq k, Hashable k) => (a -> k) -> [a] -> InsOrdHashMap k a
|
||||
oMapFromL f = OMap.fromList . map (\v -> (f v, v))
|
||||
|
||||
-- | Time an IO action, returning the time with microsecond precision. The
|
||||
-- result of the input action will be evaluated to WHNF.
|
||||
--
|
||||
|
||||
@ -31,22 +31,12 @@ import Hasura.EncJSON
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.DDL.Deps
|
||||
import Hasura.RQL.DDL.Permission.Internal
|
||||
import Hasura.RQL.DDL.Schema.Function (RawFunctionInfo (..), mkFunctionArgs)
|
||||
import Hasura.RQL.DDL.Schema.Function (mkFunctionArgs)
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.SQL.Types
|
||||
import Hasura.Server.Utils (makeReasonMessage)
|
||||
|
||||
|
||||
data ComputedFieldDefinition
|
||||
= ComputedFieldDefinition
|
||||
{ _cfdFunction :: !QualifiedFunction
|
||||
, _cfdTableArgument :: !(Maybe FunctionArgName)
|
||||
, _cfdSessionArgument :: !(Maybe FunctionArgName)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance NFData ComputedFieldDefinition
|
||||
instance Cacheable ComputedFieldDefinition
|
||||
$(deriveJSON (aesonDrop 4 snakeCase){omitNothingFields = True} ''ComputedFieldDefinition)
|
||||
|
||||
data AddComputedField
|
||||
= AddComputedField
|
||||
{ _afcTable :: !QualifiedTable
|
||||
|
||||
@ -343,13 +343,6 @@ getWebhookInfoFromConf env wc = case wc of
|
||||
envVal <- getEnv env we
|
||||
return $ WebhookConfInfo wc envVal
|
||||
|
||||
getEnv :: QErrM m => Env.Environment -> Text -> m Text
|
||||
getEnv env k = do
|
||||
let mEnv = Env.lookupEnv env (T.unpack k)
|
||||
case mEnv of
|
||||
Nothing -> throw400 NotFound $ "environment variable '" <> k <> "' not set"
|
||||
Just envVal -> return (T.pack envVal)
|
||||
|
||||
getEventTriggerDef
|
||||
:: TriggerName
|
||||
-> Q.TxE QErr (QualifiedTable, EventTriggerConf)
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
module Hasura.RQL.DDL.Metadata
|
||||
( runReplaceMetadata
|
||||
, runExportMetadata
|
||||
, fetchMetadata
|
||||
, fetchMetadataFromHdbTables
|
||||
, runClearMetadata
|
||||
, runReloadMetadata
|
||||
, runDumpInternalState
|
||||
@ -17,8 +17,8 @@ import Hasura.Prelude
|
||||
import qualified Data.Aeson.Ordered as AO
|
||||
import qualified Data.HashMap.Strict.InsOrd as HMIns
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.HashSet.InsOrd as HSIns
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.PG.Query as Q
|
||||
|
||||
import Control.Lens hiding ((.=))
|
||||
@ -39,7 +39,7 @@ import Hasura.RQL.DDL.ComputedField (dropComputedFieldFromCatalo
|
||||
import Hasura.RQL.DDL.EventTrigger (delEventTriggerFromCatalog, subTableP2)
|
||||
import Hasura.RQL.DDL.Metadata.Types
|
||||
import Hasura.RQL.DDL.Permission.Internal (dropPermFromCatalog)
|
||||
import Hasura.RQL.DDL.RemoteSchema (addRemoteSchemaToCatalog, fetchRemoteSchemas,
|
||||
import Hasura.RQL.DDL.RemoteSchema (addRemoteSchemaToCatalog,
|
||||
removeRemoteSchemaFromCatalog)
|
||||
import Hasura.RQL.DDL.ScheduledTrigger (addCronTriggerToCatalog,
|
||||
deleteCronTriggerFromCatalog)
|
||||
@ -72,86 +72,12 @@ runClearMetadata _ = do
|
||||
buildSchemaCacheStrict
|
||||
return successMsg
|
||||
|
||||
applyQP1
|
||||
:: (QErrM m)
|
||||
=> ReplaceMetadata -> m ()
|
||||
applyQP1 (ReplaceMetadata _ tables functionsMeta schemas
|
||||
collections
|
||||
allowlist _ actions
|
||||
cronTriggers) = do
|
||||
withPathK "tables" $ do
|
||||
|
||||
checkMultipleDecls "tables" $ map _tmTable tables
|
||||
|
||||
-- process each table
|
||||
void $ indexedForM tables $ \table -> withTableName (table ^. tmTable) $ do
|
||||
let allRels = map Relationship.rdName (table ^. tmObjectRelationships) <>
|
||||
map Relationship.rdName (table ^. tmArrayRelationships)
|
||||
|
||||
insPerms = map Permission.pdRole $ table ^. tmInsertPermissions
|
||||
selPerms = map Permission.pdRole $ table ^. tmSelectPermissions
|
||||
updPerms = map Permission.pdRole $ table ^. tmUpdatePermissions
|
||||
delPerms = map Permission.pdRole $ table ^. tmDeletePermissions
|
||||
eventTriggers = map etcName $ table ^. tmEventTriggers
|
||||
computedFields = map _cfmName $ table ^. tmComputedFields
|
||||
remoteRelationships = map _rrmName $ table ^. tmRemoteRelationships
|
||||
|
||||
checkMultipleDecls "relationships" allRels
|
||||
checkMultipleDecls "insert permissions" insPerms
|
||||
checkMultipleDecls "select permissions" selPerms
|
||||
checkMultipleDecls "update permissions" updPerms
|
||||
checkMultipleDecls "delete permissions" delPerms
|
||||
checkMultipleDecls "event triggers" eventTriggers
|
||||
checkMultipleDecls "computed fields" computedFields
|
||||
checkMultipleDecls "remote relationships" remoteRelationships
|
||||
|
||||
withPathK "functions" $
|
||||
case functionsMeta of
|
||||
FMVersion1 qualifiedFunctions ->
|
||||
checkMultipleDecls "functions" qualifiedFunctions
|
||||
FMVersion2 functionsV2 ->
|
||||
checkMultipleDecls "functions" $ map Schema._tfv2Function functionsV2
|
||||
|
||||
withPathK "remote_schemas" $
|
||||
checkMultipleDecls "remote schemas" $ map _arsqName schemas
|
||||
|
||||
withPathK "query_collections" $
|
||||
checkMultipleDecls "query collections" $ map Collection._ccName collections
|
||||
|
||||
withPathK "allowlist" $
|
||||
checkMultipleDecls "allow list" $ map Collection._crCollection allowlist
|
||||
|
||||
withPathK "actions" $
|
||||
checkMultipleDecls "actions" $ map _amName actions
|
||||
|
||||
withPathK "cron_triggers" $
|
||||
checkMultipleDecls "cron triggers" $ map ctName cronTriggers
|
||||
|
||||
where
|
||||
withTableName qt = withPathK (qualifiedObjectToText qt)
|
||||
|
||||
checkMultipleDecls t l = do
|
||||
let dups = getDups l
|
||||
unless (null dups) $
|
||||
throw400 AlreadyExists $ "multiple declarations exist for the following " <> t <> " : "
|
||||
<> T.pack (show dups)
|
||||
|
||||
getDups l =
|
||||
l L.\\ HS.toList (HS.fromList l)
|
||||
|
||||
applyQP2 :: (CacheRWM m, MonadTx m, HasSystemDefined m) => ReplaceMetadata -> m EncJSON
|
||||
applyQP2 replaceMetadata = do
|
||||
clearUserMetadata
|
||||
saveMetadata replaceMetadata
|
||||
buildSchemaCacheStrict
|
||||
pure successMsg
|
||||
|
||||
saveMetadata :: (MonadTx m, HasSystemDefined m) => ReplaceMetadata -> m ()
|
||||
saveMetadata (ReplaceMetadata _ tables functionsMeta
|
||||
saveMetadata :: (MonadTx m, HasSystemDefined m) => Metadata -> m ()
|
||||
saveMetadata (Metadata tables functions
|
||||
schemas collections allowlist customTypes actions cronTriggers) = do
|
||||
|
||||
withPathK "tables" $ do
|
||||
indexedForM_ tables $ \TableMeta{..} -> do
|
||||
indexedForM_ tables $ \TableMetadata{..} -> do
|
||||
-- Save table
|
||||
saveTableToCatalog _tmTable _tmIsEnum _tmConfiguration
|
||||
|
||||
@ -166,14 +92,14 @@ saveMetadata (ReplaceMetadata _ tables functionsMeta
|
||||
-- Computed Fields
|
||||
withPathK "computed_fields" $
|
||||
indexedForM_ _tmComputedFields $
|
||||
\(ComputedFieldMeta name definition comment) ->
|
||||
\(ComputedFieldMetadata name definition comment) ->
|
||||
ComputedField.addComputedFieldToCatalog $
|
||||
ComputedField.AddComputedField _tmTable name definition comment
|
||||
|
||||
-- Remote Relationships
|
||||
withPathK "remote_relationships" $
|
||||
indexedForM_ _tmRemoteRelationships $
|
||||
\(RemoteRelationshipMeta name def) -> do
|
||||
\(RemoteRelationshipMetadata name def) -> do
|
||||
let RemoteRelationshipDef rs hf rf = def
|
||||
liftTx $ RemoteRelationship.persistRemoteRelationship $
|
||||
RemoteRelationship name _tmTable hf rs rf
|
||||
@ -189,11 +115,8 @@ saveMetadata (ReplaceMetadata _ tables functionsMeta
|
||||
indexedForM_ _tmEventTriggers $ \etc -> subTableP2 _tmTable False etc
|
||||
|
||||
-- sql functions
|
||||
withPathK "functions" $ case functionsMeta of
|
||||
FMVersion1 qualifiedFunctions -> indexedForM_ qualifiedFunctions $
|
||||
\qf -> Schema.saveFunctionToCatalog qf Schema.emptyFunctionConfig
|
||||
FMVersion2 functionsV2 -> indexedForM_ functionsV2 $
|
||||
\(Schema.TrackFunctionV2 function config) -> Schema.saveFunctionToCatalog function config
|
||||
withPathK "functions" $ indexedForM_ functions $
|
||||
\(FunctionMetadata function config) -> Schema.saveFunctionToCatalog function config
|
||||
|
||||
-- query collections
|
||||
systemDefined <- askSystemDefined
|
||||
@ -238,13 +161,15 @@ runReplaceMetadata
|
||||
, CacheRWM m
|
||||
, HasSystemDefined m
|
||||
)
|
||||
=> ReplaceMetadata -> m EncJSON
|
||||
runReplaceMetadata q = do
|
||||
applyQP1 q
|
||||
applyQP2 q
|
||||
=> Metadata -> m EncJSON
|
||||
runReplaceMetadata metadata = do
|
||||
clearUserMetadata
|
||||
saveMetadata metadata
|
||||
buildSchemaCacheStrict
|
||||
pure successMsg
|
||||
|
||||
fetchMetadata :: Q.TxE QErr ReplaceMetadata
|
||||
fetchMetadata = do
|
||||
fetchMetadataFromHdbTables :: MonadTx m => m Metadata
|
||||
fetchMetadataFromHdbTables = liftTx do
|
||||
tables <- Q.catchE defaultTxErrorHandler fetchTables
|
||||
let tableMetaMap = HMIns.fromList . flip map tables $
|
||||
\(schema, name, isEnum, maybeConfig) ->
|
||||
@ -277,63 +202,55 @@ fetchMetadata = do
|
||||
-- Fetch all remote relationships
|
||||
remoteRelationships <- Q.catchE defaultTxErrorHandler fetchRemoteRelationships
|
||||
|
||||
let (_, postRelMap) = flip runState tableMetaMap $ do
|
||||
modMetaMap tmObjectRelationships objRelDefs
|
||||
modMetaMap tmArrayRelationships arrRelDefs
|
||||
modMetaMap tmInsertPermissions insPermDefs
|
||||
modMetaMap tmSelectPermissions selPermDefs
|
||||
modMetaMap tmUpdatePermissions updPermDefs
|
||||
modMetaMap tmDeletePermissions delPermDefs
|
||||
modMetaMap tmEventTriggers triggerMetaDefs
|
||||
modMetaMap tmComputedFields computedFields
|
||||
modMetaMap tmRemoteRelationships remoteRelationships
|
||||
let (_, fullTableMetaMap) = flip runState tableMetaMap $ do
|
||||
modMetaMap tmObjectRelationships _rdName objRelDefs
|
||||
modMetaMap tmArrayRelationships _rdName arrRelDefs
|
||||
modMetaMap tmInsertPermissions _pdRole insPermDefs
|
||||
modMetaMap tmSelectPermissions _pdRole selPermDefs
|
||||
modMetaMap tmUpdatePermissions _pdRole updPermDefs
|
||||
modMetaMap tmDeletePermissions _pdRole delPermDefs
|
||||
modMetaMap tmEventTriggers etcName triggerMetaDefs
|
||||
modMetaMap tmComputedFields _cfmName computedFields
|
||||
modMetaMap tmRemoteRelationships _rrmName remoteRelationships
|
||||
|
||||
-- fetch all functions
|
||||
functions <- FMVersion2 <$> Q.catchE defaultTxErrorHandler fetchFunctions
|
||||
functions <- Q.catchE defaultTxErrorHandler fetchFunctions
|
||||
|
||||
-- fetch all remote schemas
|
||||
remoteSchemas <- fetchRemoteSchemas
|
||||
remoteSchemas <- oMapFromL _arsqName <$> fetchRemoteSchemas
|
||||
|
||||
-- fetch all collections
|
||||
collections <- fetchCollections
|
||||
collections <- oMapFromL _ccName <$> fetchCollections
|
||||
|
||||
-- fetch allow list
|
||||
allowlist <- map Collection.CollectionReq <$> fetchAllowlists
|
||||
allowlist <- HSIns.fromList . map CollectionReq <$> fetchAllowlists
|
||||
|
||||
customTypes <- fetchCustomTypes
|
||||
|
||||
-- -- fetch actions
|
||||
actions <- fetchActions
|
||||
-- fetch actions
|
||||
actions <- oMapFromL _amName <$> fetchActions
|
||||
|
||||
cronTriggers <- fetchCronTriggers
|
||||
|
||||
return $ ReplaceMetadata currentMetadataVersion
|
||||
(HMIns.elems postRelMap)
|
||||
functions
|
||||
remoteSchemas
|
||||
collections
|
||||
allowlist
|
||||
customTypes
|
||||
actions
|
||||
cronTriggers
|
||||
pure $ Metadata fullTableMetaMap functions remoteSchemas collections
|
||||
allowlist customTypes actions cronTriggers
|
||||
|
||||
where
|
||||
|
||||
modMetaMap l xs = do
|
||||
modMetaMap l f xs = do
|
||||
st <- get
|
||||
put $ foldr (\(qt, dfn) b -> b & at qt._Just.l %~ (:) dfn) st xs
|
||||
put $ foldl' (\b (qt, dfn) -> b & at qt._Just.l %~ HMIns.insert (f dfn) dfn) st xs
|
||||
|
||||
mkPermDefs pt = mapM permRowToDef . filter (\pr -> pr ^. _4 == pt)
|
||||
|
||||
permRowToDef (sn, tn, rn, _, Q.AltJ pDef, mComment) = do
|
||||
perm <- decodeValue pDef
|
||||
return (QualifiedObject sn tn, Permission.PermDef rn perm mComment)
|
||||
return (QualifiedObject sn tn, PermDef rn perm mComment)
|
||||
|
||||
mkRelDefs rt = mapM relRowToDef . filter (\rr -> rr ^. _4 == rt)
|
||||
|
||||
relRowToDef (sn, tn, rn, _, Q.AltJ rDef, mComment) = do
|
||||
using <- decodeValue rDef
|
||||
return (QualifiedObject sn tn, Relationship.RelDef rn using mComment)
|
||||
return (QualifiedObject sn tn, RelDef rn using mComment)
|
||||
|
||||
mkTriggerMetaDefs = mapM trigRowToDef
|
||||
|
||||
@ -379,8 +296,21 @@ fetchMetadata = do
|
||||
WHERE is_system_defined = 'false'
|
||||
ORDER BY function_schema ASC, function_name ASC
|
||||
|] () False
|
||||
pure $ flip map l $ \(sn, fn, Q.AltJ config) ->
|
||||
Schema.TrackFunctionV2 (QualifiedObject sn fn) config
|
||||
pure $ oMapFromL _fmFunction $
|
||||
flip map l $ \(sn, fn, Q.AltJ config) ->
|
||||
FunctionMetadata (QualifiedObject sn fn) config
|
||||
|
||||
fetchRemoteSchemas =
|
||||
map fromRow <$> Q.listQE defaultTxErrorHandler
|
||||
[Q.sql|
|
||||
SELECT name, definition, comment
|
||||
FROM hdb_catalog.remote_schemas
|
||||
ORDER BY name ASC
|
||||
|] () True
|
||||
where
|
||||
fromRow (name, Q.AltJ def, comment) =
|
||||
AddRemoteSchemaQuery name def comment
|
||||
|
||||
|
||||
fetchCollections =
|
||||
map fromRow <$> Q.listQE defaultTxErrorHandler [Q.sql|
|
||||
@ -391,7 +321,7 @@ fetchMetadata = do
|
||||
|] () False
|
||||
where
|
||||
fromRow (name, Q.AltJ defn, mComment) =
|
||||
Collection.CreateCollection name defn mComment
|
||||
CreateCollection name defn mComment
|
||||
|
||||
fetchAllowlists = map runIdentity <$>
|
||||
Q.listQE defaultTxErrorHandler [Q.sql|
|
||||
@ -408,11 +338,11 @@ fetchMetadata = do
|
||||
|] () False
|
||||
pure $ flip map r $ \(schema, table, name, Q.AltJ definition, comment) ->
|
||||
( QualifiedObject schema table
|
||||
, ComputedFieldMeta name definition comment
|
||||
, ComputedFieldMetadata name definition comment
|
||||
)
|
||||
|
||||
fetchCronTriggers =
|
||||
map uncurryCronTrigger
|
||||
(oMapFromL ctName . map uncurryCronTrigger)
|
||||
<$> Q.listQE defaultTxErrorHandler
|
||||
[Q.sql|
|
||||
SELECT ct.name, ct.webhook_conf, ct.cron_schedule, ct.payload,
|
||||
@ -440,6 +370,7 @@ fetchMetadata = do
|
||||
Q.rawQE defaultTxErrorHandler [Q.sql|
|
||||
select coalesce((select custom_types::json from hdb_catalog.hdb_custom_types), '{}'::json)
|
||||
|] [] False
|
||||
|
||||
fetchActions =
|
||||
Q.getAltJ . runIdentity . Q.getRow <$> Q.rawQE defaultTxErrorHandler [Q.sql|
|
||||
select
|
||||
@ -482,14 +413,14 @@ fetchMetadata = do
|
||||
|] () False
|
||||
pure $ flip map r $ \(schema, table, name, Q.AltJ definition) ->
|
||||
( QualifiedObject schema table
|
||||
, RemoteRelationshipMeta name definition
|
||||
, RemoteRelationshipMetadata name definition
|
||||
)
|
||||
|
||||
runExportMetadata
|
||||
:: (QErrM m, MonadTx m)
|
||||
=> ExportMetadata -> m EncJSON
|
||||
runExportMetadata _ =
|
||||
AO.toEncJSON . replaceMetadataToOrdJSON <$> liftTx fetchMetadata
|
||||
AO.toEncJSON . metadataToOrdJSON <$> fetchMetadataFromHdbTables
|
||||
|
||||
runReloadMetadata :: (QErrM m, CacheRWM m) => ReloadMetadata -> m EncJSON
|
||||
runReloadMetadata (ReloadMetadata reloadRemoteSchemas) = do
|
||||
|
||||
@ -1,11 +1,19 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- | This module generates a random 'Metadata' object, using a number of
|
||||
-- 'Arbitrary' instances. This is used by the QuickCheck-based testing suite.
|
||||
-- This module is not used by the graphql-engine library itself, and we may wish
|
||||
-- to relocate it, for instance to Hasura.Generator.
|
||||
|
||||
module Hasura.RQL.DDL.Metadata.Generator
|
||||
(genReplaceMetadata)
|
||||
(genMetadata)
|
||||
where
|
||||
|
||||
import Hasura.Prelude
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.HashMap.Strict.InsOrd as OM
|
||||
import qualified Data.HashSet.InsOrd as SetIns
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import qualified Language.GraphQL.Draft.Parser as G
|
||||
@ -22,23 +30,16 @@ import Test.QuickCheck.Instances.Semigroup ()
|
||||
import Test.QuickCheck.Instances.Time ()
|
||||
import Test.QuickCheck.Instances.UnorderedContainers ()
|
||||
|
||||
import qualified Hasura.RQL.DDL.ComputedField as ComputedField
|
||||
import qualified Hasura.RQL.DDL.Permission as Permission
|
||||
import qualified Hasura.RQL.DDL.Permission.Internal as Permission
|
||||
import qualified Hasura.RQL.DDL.QueryCollection as Collection
|
||||
import qualified Hasura.RQL.DDL.Relationship as Relationship
|
||||
import qualified Hasura.RQL.DDL.Schema as Schema
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.GraphQL.Utils (simpleGraphQLQuery)
|
||||
import Hasura.RQL.DDL.Headers
|
||||
import Hasura.RQL.DDL.Metadata.Types
|
||||
import Hasura.RQL.Types
|
||||
|
||||
genReplaceMetadata :: Gen ReplaceMetadata
|
||||
genReplaceMetadata = do
|
||||
genMetadata :: Gen Metadata
|
||||
genMetadata = do
|
||||
version <- arbitrary
|
||||
ReplaceMetadata version
|
||||
Metadata
|
||||
<$> arbitrary
|
||||
<*> genFunctionsMetadata version
|
||||
<*> arbitrary
|
||||
@ -48,10 +49,16 @@ genReplaceMetadata = do
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
where
|
||||
genFunctionsMetadata :: MetadataVersion -> Gen FunctionsMetadata
|
||||
genFunctionsMetadata :: MetadataVersion -> Gen Functions
|
||||
genFunctionsMetadata = \case
|
||||
MVVersion1 -> FMVersion1 <$> arbitrary
|
||||
MVVersion2 -> FMVersion2 <$> arbitrary
|
||||
MVVersion1 -> OM.fromList . map (\qf -> (qf, FunctionMetadata qf emptyFunctionConfig)) <$> arbitrary
|
||||
MVVersion2 -> arbitrary
|
||||
|
||||
instance (Arbitrary k, Eq k, Hashable k, Arbitrary v) => Arbitrary (InsOrdHashMap k v) where
|
||||
arbitrary = OM.fromList <$> arbitrary
|
||||
|
||||
instance (Arbitrary a, Eq a, Hashable a) => Arbitrary (SetIns.InsOrdHashSet a) where
|
||||
arbitrary = SetIns.fromList <$> arbitrary
|
||||
|
||||
instance Arbitrary G.Name where
|
||||
arbitrary = G.unsafeMkName . T.pack <$> listOf1 (elements ['a'..'z'])
|
||||
@ -59,6 +66,9 @@ instance Arbitrary G.Name where
|
||||
instance Arbitrary MetadataVersion where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary FunctionMetadata where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary TableCustomRootFields where
|
||||
arbitrary = uniqueRootFields
|
||||
where
|
||||
@ -71,25 +81,25 @@ instance Arbitrary TableCustomRootFields where
|
||||
instance Arbitrary TableConfig where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance (Arbitrary a) => Arbitrary (Relationship.RelUsing a) where
|
||||
instance (Arbitrary a) => Arbitrary (RelUsing a) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance (Arbitrary a) => Arbitrary (Relationship.RelDef a) where
|
||||
instance (Arbitrary a) => Arbitrary (RelDef a) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Relationship.RelManualConfig where
|
||||
instance Arbitrary RelManualConfig where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Relationship.ArrRelUsingFKeyOn where
|
||||
instance Arbitrary ArrRelUsingFKeyOn where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance (Arbitrary a) => Arbitrary (Permission.PermDef a) where
|
||||
instance (Arbitrary a) => Arbitrary (PermDef a) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary ComputedField.ComputedFieldDefinition where
|
||||
instance Arbitrary ComputedFieldDefinition where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary ComputedFieldMeta where
|
||||
instance Arbitrary ComputedFieldMetadata where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Scientific where
|
||||
@ -121,19 +131,19 @@ instance Arbitrary (GBoolExp b ColExp) where
|
||||
instance Arbitrary (BoolExp b) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Permission.PermColSpec where
|
||||
instance Arbitrary PermColSpec where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary (Permission.InsPerm b) where
|
||||
instance Arbitrary (InsPerm b) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary (Permission.SelPerm b) where
|
||||
instance Arbitrary (SelPerm b) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary (Permission.UpdPerm b) where
|
||||
instance Arbitrary (UpdPerm b) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary (Permission.DelPerm b) where
|
||||
instance Arbitrary (DelPerm b) where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary SubscribeColumns where
|
||||
@ -157,13 +167,13 @@ instance Arbitrary HeaderConf where
|
||||
instance Arbitrary EventTriggerConf where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary TableMeta where
|
||||
instance Arbitrary TableMetadata where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Schema.FunctionConfig where
|
||||
instance Arbitrary FunctionConfig where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Schema.TrackFunctionV2 where
|
||||
instance Arbitrary TrackFunctionV2 where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary QualifiedTable where
|
||||
@ -185,23 +195,23 @@ instance Arbitrary AddRemoteSchemaQuery where
|
||||
|
||||
-- FIXME:- The GraphQL AST has 'Gen' by Hedgehog testing package which lacks the
|
||||
-- 'Arbitrary' class implementation. For time being, a single query is generated every time.
|
||||
instance Arbitrary Collection.GQLQueryWithText where
|
||||
arbitrary = pure $ Collection.GQLQueryWithText ( simpleGraphQLQuery
|
||||
, Collection.GQLQuery simpleQuery
|
||||
)
|
||||
instance Arbitrary GQLQueryWithText where
|
||||
arbitrary = pure $ GQLQueryWithText ( simpleGraphQLQuery
|
||||
, GQLQuery simpleQuery
|
||||
)
|
||||
where
|
||||
simpleQuery = $(either (fail . T.unpack) TH.lift $ G.parseExecutableDoc simpleGraphQLQuery)
|
||||
|
||||
instance Arbitrary Collection.ListedQuery where
|
||||
instance Arbitrary ListedQuery where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Collection.CollectionDef where
|
||||
instance Arbitrary CollectionDef where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Collection.CreateCollection where
|
||||
instance Arbitrary CreateCollection where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary Collection.CollectionReq where
|
||||
instance Arbitrary CollectionReq where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary G.Description where
|
||||
@ -307,13 +317,13 @@ deriving instance Arbitrary RemoteFields
|
||||
instance Arbitrary RemoteRelationshipDef where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary RemoteRelationshipMeta where
|
||||
instance Arbitrary RemoteRelationshipMetadata where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary CronTriggerMetadata where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary WebhookConf where
|
||||
instance Arbitrary UrlConf where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
instance Arbitrary STRetryConf where
|
||||
@ -326,7 +336,7 @@ instance Arbitrary CronSchedule where
|
||||
arbitrary = elements sampleCronSchedules
|
||||
|
||||
sampleCronSchedules :: [CronSchedule]
|
||||
sampleCronSchedules = rights $ map Cr.parseCronSchedule $
|
||||
sampleCronSchedules = rights $ map Cr.parseCronSchedule
|
||||
[ "* * * * *"
|
||||
-- every minute
|
||||
, "5 * * * *"
|
||||
|
||||
@ -4,27 +4,6 @@
|
||||
module Hasura.RQL.DDL.Metadata.Types
|
||||
( currentMetadataVersion
|
||||
, MetadataVersion(..)
|
||||
, TableMeta(..)
|
||||
, tmTable
|
||||
, tmIsEnum
|
||||
, tmConfiguration
|
||||
, tmObjectRelationships
|
||||
, tmArrayRelationships
|
||||
, tmComputedFields
|
||||
, tmRemoteRelationships
|
||||
, tmInsertPermissions
|
||||
, tmSelectPermissions
|
||||
, tmUpdatePermissions
|
||||
, tmDeletePermissions
|
||||
, tmEventTriggers
|
||||
, mkTableMeta
|
||||
, ReplaceMetadata(..)
|
||||
, replaceMetadataToOrdJSON
|
||||
, ActionMetadata(..)
|
||||
, ActionPermissionMetadata(..)
|
||||
, ComputedFieldMeta(..)
|
||||
, RemoteRelationshipMeta(..)
|
||||
, FunctionsMetadata(..)
|
||||
, ExportMetadata(..)
|
||||
, ClearMetadata(..)
|
||||
, ReloadMetadata(..)
|
||||
@ -35,137 +14,13 @@ module Hasura.RQL.DDL.Metadata.Types
|
||||
|
||||
import Hasura.Prelude
|
||||
|
||||
import qualified Data.Aeson.Ordered as AO
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Language.GraphQL.Draft.Syntax as G
|
||||
|
||||
import Control.Lens hiding (set, (.=))
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import qualified Hasura.RQL.DDL.ComputedField as ComputedField
|
||||
import qualified Hasura.RQL.DDL.Permission as Permission
|
||||
import qualified Hasura.RQL.DDL.QueryCollection as Collection
|
||||
import qualified Hasura.RQL.DDL.Relationship as Relationship
|
||||
import qualified Hasura.RQL.DDL.Schema as Schema
|
||||
import qualified Hasura.RQL.Types.RemoteRelationship as RemoteRelationship
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.RQL.Types
|
||||
|
||||
data MetadataVersion
|
||||
= MVVersion1
|
||||
| MVVersion2
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
|
||||
instance ToJSON MetadataVersion where
|
||||
toJSON MVVersion1 = toJSON @Int 1
|
||||
toJSON MVVersion2 = toJSON @Int 2
|
||||
|
||||
instance FromJSON MetadataVersion where
|
||||
parseJSON v = do
|
||||
version :: Int <- parseJSON v
|
||||
case version of
|
||||
1 -> pure MVVersion1
|
||||
2 -> pure MVVersion2
|
||||
i -> fail $ "expected 1 or 2, encountered " ++ show i
|
||||
|
||||
currentMetadataVersion :: MetadataVersion
|
||||
currentMetadataVersion = MVVersion2
|
||||
|
||||
data ComputedFieldMeta
|
||||
= ComputedFieldMeta
|
||||
{ _cfmName :: !ComputedFieldName
|
||||
, _cfmDefinition :: !ComputedField.ComputedFieldDefinition
|
||||
, _cfmComment :: !(Maybe Text)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(deriveJSON (aesonDrop 4 snakeCase) ''ComputedFieldMeta)
|
||||
|
||||
data RemoteRelationshipMeta
|
||||
= RemoteRelationshipMeta
|
||||
{ _rrmName :: !RemoteRelationshipName
|
||||
, _rrmDefinition :: !RemoteRelationship.RemoteRelationshipDef
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(deriveJSON (aesonDrop 4 snakeCase) ''RemoteRelationshipMeta)
|
||||
|
||||
data TableMeta
|
||||
= TableMeta
|
||||
{ _tmTable :: !QualifiedTable
|
||||
, _tmIsEnum :: !Bool
|
||||
, _tmConfiguration :: !TableConfig
|
||||
, _tmObjectRelationships :: ![Relationship.ObjRelDef]
|
||||
, _tmArrayRelationships :: ![Relationship.ArrRelDef]
|
||||
, _tmComputedFields :: ![ComputedFieldMeta]
|
||||
, _tmRemoteRelationships :: ![RemoteRelationshipMeta]
|
||||
, _tmInsertPermissions :: ![Permission.InsPermDef 'Postgres]
|
||||
, _tmSelectPermissions :: ![Permission.SelPermDef 'Postgres]
|
||||
, _tmUpdatePermissions :: ![Permission.UpdPermDef 'Postgres]
|
||||
, _tmDeletePermissions :: ![Permission.DelPermDef 'Postgres]
|
||||
, _tmEventTriggers :: ![EventTriggerConf]
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(makeLenses ''TableMeta)
|
||||
|
||||
mkTableMeta :: QualifiedTable -> Bool -> TableConfig -> TableMeta
|
||||
mkTableMeta qt isEnum config =
|
||||
TableMeta qt isEnum config [] [] [] [] [] [] [] [] []
|
||||
|
||||
instance FromJSON TableMeta where
|
||||
parseJSON (Object o) = do
|
||||
unless (null unexpectedKeys) $
|
||||
fail $ "unexpected keys when parsing TableMetadata : "
|
||||
<> show (HS.toList unexpectedKeys)
|
||||
|
||||
TableMeta
|
||||
<$> o .: tableKey
|
||||
<*> o .:? isEnumKey .!= False
|
||||
<*> o .:? configKey .!= emptyTableConfig
|
||||
<*> o .:? orKey .!= []
|
||||
<*> o .:? arKey .!= []
|
||||
<*> o .:? cfKey .!= []
|
||||
<*> o .:? rrKey .!= []
|
||||
<*> o .:? ipKey .!= []
|
||||
<*> o .:? spKey .!= []
|
||||
<*> o .:? upKey .!= []
|
||||
<*> o .:? dpKey .!= []
|
||||
<*> o .:? etKey .!= []
|
||||
|
||||
where
|
||||
tableKey = "table"
|
||||
isEnumKey = "is_enum"
|
||||
configKey = "configuration"
|
||||
orKey = "object_relationships"
|
||||
arKey = "array_relationships"
|
||||
ipKey = "insert_permissions"
|
||||
spKey = "select_permissions"
|
||||
upKey = "update_permissions"
|
||||
dpKey = "delete_permissions"
|
||||
etKey = "event_triggers"
|
||||
cfKey = "computed_fields"
|
||||
rrKey = "remote_relationships"
|
||||
|
||||
unexpectedKeys =
|
||||
HS.fromList (HM.keys o) `HS.difference` expectedKeySet
|
||||
|
||||
expectedKeySet =
|
||||
HS.fromList [ tableKey, isEnumKey, configKey, orKey
|
||||
, arKey , ipKey, spKey, upKey, dpKey, etKey
|
||||
, cfKey, rrKey
|
||||
]
|
||||
|
||||
parseJSON _ =
|
||||
fail "expecting an Object for TableMetadata"
|
||||
|
||||
data FunctionsMetadata
|
||||
= FMVersion1 ![QualifiedFunction]
|
||||
| FMVersion2 ![Schema.TrackFunctionV2]
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
|
||||
instance ToJSON FunctionsMetadata where
|
||||
toJSON (FMVersion1 qualifiedFunctions) = toJSON qualifiedFunctions
|
||||
toJSON (FMVersion2 functionsV2) = toJSON functionsV2
|
||||
|
||||
data ClearMetadata
|
||||
= ClearMetadata
|
||||
@ -175,37 +30,6 @@ $(deriveToJSON defaultOptions ''ClearMetadata)
|
||||
instance FromJSON ClearMetadata where
|
||||
parseJSON _ = return ClearMetadata
|
||||
|
||||
data ReplaceMetadata
|
||||
= ReplaceMetadata
|
||||
{ aqVersion :: !MetadataVersion
|
||||
, aqTables :: ![TableMeta]
|
||||
, aqFunctions :: !FunctionsMetadata
|
||||
, aqRemoteSchemas :: ![AddRemoteSchemaQuery]
|
||||
, aqQueryCollections :: ![Collection.CreateCollection]
|
||||
, aqAllowlist :: ![Collection.CollectionReq]
|
||||
, aqCustomTypes :: !CustomTypes
|
||||
, aqActions :: ![ActionMetadata]
|
||||
, aqCronTriggers :: ![CronTriggerMetadata]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON ReplaceMetadata where
|
||||
parseJSON = withObject "Object" $ \o -> do
|
||||
version <- o .:? "version" .!= MVVersion1
|
||||
ReplaceMetadata version
|
||||
<$> o .: "tables"
|
||||
<*> (o .:? "functions" >>= parseFunctions version)
|
||||
<*> o .:? "remote_schemas" .!= []
|
||||
<*> o .:? "query_collections" .!= []
|
||||
<*> o .:? "allowlist" .!= []
|
||||
<*> o .:? "custom_types" .!= emptyCustomTypes
|
||||
<*> o .:? "actions" .!= []
|
||||
<*> o .:? "cron_triggers" .!= []
|
||||
where
|
||||
parseFunctions version maybeValue =
|
||||
case version of
|
||||
MVVersion1 -> FMVersion1 <$> maybe (pure []) parseJSON maybeValue
|
||||
MVVersion2 -> FMVersion2 <$> maybe (pure []) parseJSON maybeValue
|
||||
|
||||
data ExportMetadata
|
||||
= ExportMetadata
|
||||
deriving (Show, Eq, Lift)
|
||||
@ -214,15 +38,16 @@ $(deriveToJSON defaultOptions ''ExportMetadata)
|
||||
instance FromJSON ExportMetadata where
|
||||
parseJSON _ = return ExportMetadata
|
||||
|
||||
newtype ReloadMetadata
|
||||
data ReloadMetadata
|
||||
= ReloadMetadata
|
||||
{ _rmReloadRemoteSchemas :: Bool}
|
||||
deriving (Show, Eq, Lift)
|
||||
{ _rmReloadRemoteSchemas :: !Bool
|
||||
} deriving (Show, Eq, Lift)
|
||||
$(deriveToJSON (aesonDrop 3 snakeCase) ''ReloadMetadata)
|
||||
|
||||
instance FromJSON ReloadMetadata where
|
||||
parseJSON = \case
|
||||
Object o -> ReloadMetadata <$> o .:? "reload_remote_schemas" .!= False
|
||||
Object o -> ReloadMetadata
|
||||
<$> o .:? "reload_remote_schemas" .!= False
|
||||
_ -> pure $ ReloadMetadata False
|
||||
|
||||
data DumpInternalState
|
||||
@ -248,332 +73,3 @@ $(deriveToJSON defaultOptions ''DropInconsistentMetadata)
|
||||
|
||||
instance FromJSON DropInconsistentMetadata where
|
||||
parseJSON _ = return DropInconsistentMetadata
|
||||
|
||||
instance ToJSON ReplaceMetadata where
|
||||
toJSON = AO.fromOrdered . replaceMetadataToOrdJSON
|
||||
|
||||
-- | Encode 'ReplaceMetadata' to JSON with deterministic ordering. Ordering of object keys and array
|
||||
-- elements should remain consistent across versions of graphql-engine if possible!
|
||||
--
|
||||
-- Note: While modifying any part of the code below, make sure the encoded JSON of each type is
|
||||
-- parsable via its 'FromJSON' instance.
|
||||
replaceMetadataToOrdJSON :: ReplaceMetadata -> AO.Value
|
||||
replaceMetadataToOrdJSON ( ReplaceMetadata
|
||||
version
|
||||
tables
|
||||
functions
|
||||
remoteSchemas
|
||||
queryCollections
|
||||
allowlist
|
||||
customTypes
|
||||
actions
|
||||
cronTriggers
|
||||
) = AO.object $ [versionPair, tablesPair] <>
|
||||
catMaybes [ functionsPair
|
||||
, remoteSchemasPair
|
||||
, queryCollectionsPair
|
||||
, allowlistPair
|
||||
, actionsPair
|
||||
, customTypesPair
|
||||
, cronTriggersPair
|
||||
]
|
||||
where
|
||||
versionPair = ("version", AO.toOrdered version)
|
||||
tablesPair = ("tables", AO.array $ map tableMetaToOrdJSON tables)
|
||||
functionsPair = ("functions",) <$> functionsMetadataToOrdJSON functions
|
||||
|
||||
remoteSchemasPair = listToMaybeOrdPair "remote_schemas" remoteSchemaQToOrdJSON remoteSchemas
|
||||
|
||||
queryCollectionsPair = listToMaybeOrdPair "query_collections" createCollectionToOrdJSON queryCollections
|
||||
|
||||
allowlistPair = listToMaybeOrdPair "allowlist" AO.toOrdered allowlist
|
||||
customTypesPair = if customTypes == emptyCustomTypes then Nothing
|
||||
else Just ("custom_types", customTypesToOrdJSON customTypes)
|
||||
actionsPair = listToMaybeOrdPair "actions" actionMetadataToOrdJSON actions
|
||||
|
||||
cronTriggersPair = listToMaybeOrdPair "cron_triggers" crontriggerQToOrdJSON cronTriggers
|
||||
|
||||
tableMetaToOrdJSON :: TableMeta -> AO.Value
|
||||
tableMetaToOrdJSON ( TableMeta
|
||||
table
|
||||
isEnum
|
||||
config
|
||||
objectRelationships
|
||||
arrayRelationships
|
||||
computedFields
|
||||
remoteRelationships
|
||||
insertPermissions
|
||||
selectPermissions
|
||||
updatePermissions
|
||||
deletePermissions
|
||||
eventTriggers
|
||||
) = AO.object $ [("table", AO.toOrdered table)]
|
||||
<> catMaybes [ isEnumPair
|
||||
, configPair
|
||||
, objectRelationshipsPair
|
||||
, arrayRelationshipsPair
|
||||
, computedFieldsPair
|
||||
, remoteRelationshipsPair
|
||||
, insertPermissionsPair
|
||||
, selectPermissionsPair
|
||||
, updatePermissionsPair
|
||||
, deletePermissionsPair
|
||||
, eventTriggersPair
|
||||
]
|
||||
where
|
||||
isEnumPair = if isEnum then Just ("is_enum", AO.toOrdered isEnum) else Nothing
|
||||
configPair = if config == emptyTableConfig then Nothing
|
||||
else Just ("configuration" , AO.toOrdered config)
|
||||
objectRelationshipsPair = listToMaybeOrdPair "object_relationships"
|
||||
relDefToOrdJSON objectRelationships
|
||||
arrayRelationshipsPair = listToMaybeOrdPair "array_relationships"
|
||||
relDefToOrdJSON arrayRelationships
|
||||
computedFieldsPair = listToMaybeOrdPair "computed_fields"
|
||||
computedFieldMetaToOrdJSON computedFields
|
||||
remoteRelationshipsPair = listToMaybeOrdPair "remote_relationships"
|
||||
AO.toOrdered remoteRelationships
|
||||
insertPermissionsPair = listToMaybeOrdPair "insert_permissions"
|
||||
insPermDefToOrdJSON insertPermissions
|
||||
selectPermissionsPair = listToMaybeOrdPair "select_permissions"
|
||||
selPermDefToOrdJSON selectPermissions
|
||||
updatePermissionsPair = listToMaybeOrdPair "update_permissions"
|
||||
updPermDefToOrdJSON updatePermissions
|
||||
deletePermissionsPair = listToMaybeOrdPair "delete_permissions"
|
||||
delPermDefToOrdJSON deletePermissions
|
||||
eventTriggersPair = listToMaybeOrdPair "event_triggers"
|
||||
eventTriggerConfToOrdJSON eventTriggers
|
||||
|
||||
relDefToOrdJSON :: (ToJSON a) => Relationship.RelDef a -> AO.Value
|
||||
relDefToOrdJSON (Relationship.RelDef name using comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("using", AO.toOrdered using)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
computedFieldMetaToOrdJSON :: ComputedFieldMeta -> AO.Value
|
||||
computedFieldMetaToOrdJSON (ComputedFieldMeta name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
insPermDefToOrdJSON :: Permission.InsPermDef 'Postgres -> AO.Value
|
||||
insPermDefToOrdJSON = permDefToOrdJSON insPermToOrdJSON
|
||||
where
|
||||
insPermToOrdJSON (Permission.InsPerm check set columns mBackendOnly) =
|
||||
let columnsPair = ("columns",) . AO.toOrdered <$> columns
|
||||
backendOnlyPair = ("backend_only",) . AO.toOrdered <$> mBackendOnly
|
||||
in AO.object $ [("check", AO.toOrdered check)]
|
||||
<> catMaybes [maybeSetToMaybeOrdPair set, columnsPair, backendOnlyPair]
|
||||
|
||||
selPermDefToOrdJSON :: Permission.SelPermDef 'Postgres -> AO.Value
|
||||
selPermDefToOrdJSON = permDefToOrdJSON selPermToOrdJSON
|
||||
where
|
||||
selPermToOrdJSON (Permission.SelPerm columns fltr limit allowAgg computedFieldsPerm) =
|
||||
AO.object $ catMaybes [ columnsPair
|
||||
, computedFieldsPermPair
|
||||
, filterPair
|
||||
, limitPair
|
||||
, allowAggPair
|
||||
]
|
||||
where
|
||||
columnsPair = Just ("columns", AO.toOrdered columns)
|
||||
computedFieldsPermPair = listToMaybeOrdPair "computed_fields" AO.toOrdered computedFieldsPerm
|
||||
filterPair = Just ("filter", AO.toOrdered fltr)
|
||||
limitPair = maybeAnyToMaybeOrdPair "limit" AO.toOrdered limit
|
||||
allowAggPair = if allowAgg
|
||||
then Just ("allow_aggregations", AO.toOrdered allowAgg)
|
||||
else Nothing
|
||||
|
||||
updPermDefToOrdJSON :: Permission.UpdPermDef 'Postgres -> AO.Value
|
||||
updPermDefToOrdJSON = permDefToOrdJSON updPermToOrdJSON
|
||||
where
|
||||
updPermToOrdJSON (Permission.UpdPerm columns set fltr check) =
|
||||
AO.object $ [ ("columns", AO.toOrdered columns)
|
||||
, ("filter", AO.toOrdered fltr)
|
||||
, ("check", AO.toOrdered check)
|
||||
] <> catMaybes [maybeSetToMaybeOrdPair set]
|
||||
|
||||
delPermDefToOrdJSON :: Permission.DelPermDef 'Postgres -> AO.Value
|
||||
delPermDefToOrdJSON = permDefToOrdJSON AO.toOrdered
|
||||
|
||||
permDefToOrdJSON :: (a -> AO.Value) -> Permission.PermDef a -> AO.Value
|
||||
permDefToOrdJSON permToOrdJSON (Permission.PermDef role permission comment) =
|
||||
AO.object $ [ ("role", AO.toOrdered role)
|
||||
, ("permission", permToOrdJSON permission)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
eventTriggerConfToOrdJSON :: EventTriggerConf -> AO.Value
|
||||
eventTriggerConfToOrdJSON (EventTriggerConf name definition webhook webhookFromEnv retryConf headers) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
, ("retry_conf", AO.toOrdered retryConf)
|
||||
] <> catMaybes [ maybeAnyToMaybeOrdPair "webhook" AO.toOrdered webhook
|
||||
, maybeAnyToMaybeOrdPair "webhook_from_env" AO.toOrdered webhookFromEnv
|
||||
, headers >>= listToMaybeOrdPair "headers" AO.toOrdered
|
||||
]
|
||||
|
||||
functionsMetadataToOrdJSON :: FunctionsMetadata -> Maybe AO.Value
|
||||
functionsMetadataToOrdJSON fm =
|
||||
let withList _ [] = Nothing
|
||||
withList f list = Just $ f list
|
||||
functionV2ToOrdJSON (Schema.TrackFunctionV2 function config) =
|
||||
AO.object $ [("function", AO.toOrdered function)]
|
||||
<> if config == Schema.emptyFunctionConfig then []
|
||||
else pure ("configuration", AO.toOrdered config)
|
||||
in case fm of
|
||||
FMVersion1 functionsV1 -> withList AO.toOrdered functionsV1
|
||||
FMVersion2 functionsV2 -> withList (AO.array . map functionV2ToOrdJSON) functionsV2
|
||||
|
||||
remoteSchemaQToOrdJSON :: AddRemoteSchemaQuery -> AO.Value
|
||||
remoteSchemaQToOrdJSON (AddRemoteSchemaQuery name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", remoteSchemaDefToOrdJSON definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
where
|
||||
remoteSchemaDefToOrdJSON :: RemoteSchemaDef -> AO.Value
|
||||
remoteSchemaDefToOrdJSON (RemoteSchemaDef url urlFromEnv headers frwrdClientHdrs timeout) =
|
||||
AO.object $ catMaybes [ maybeToPair "url" url
|
||||
, maybeToPair "url_from_env" urlFromEnv
|
||||
, maybeToPair "timeout_seconds" timeout
|
||||
, headers >>= listToMaybeOrdPair "headers" AO.toOrdered
|
||||
] <> [("forward_client_headers", AO.toOrdered frwrdClientHdrs) | frwrdClientHdrs]
|
||||
where
|
||||
maybeToPair n = maybeAnyToMaybeOrdPair n AO.toOrdered
|
||||
|
||||
createCollectionToOrdJSON :: Collection.CreateCollection -> AO.Value
|
||||
createCollectionToOrdJSON (Collection.CreateCollection name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
crontriggerQToOrdJSON :: CronTriggerMetadata -> AO.Value
|
||||
crontriggerQToOrdJSON
|
||||
(CronTriggerMetadata name webhook schedule payload retryConf headers includeInMetadata comment) =
|
||||
AO.object $
|
||||
[ ("name", AO.toOrdered name)
|
||||
, ("webhook", AO.toOrdered webhook)
|
||||
, ("schedule", AO.toOrdered schedule)
|
||||
, ("include_in_metadata", AO.toOrdered includeInMetadata)
|
||||
]
|
||||
<> catMaybes
|
||||
[ maybeAnyToMaybeOrdPair "payload" AO.toOrdered payload
|
||||
, maybeAnyToMaybeOrdPair "retry_conf" AO.toOrdered (maybeRetryConfiguration retryConf)
|
||||
, maybeAnyToMaybeOrdPair "headers" AO.toOrdered (maybeHeader headers)
|
||||
, maybeAnyToMaybeOrdPair "comment" AO.toOrdered comment]
|
||||
where
|
||||
maybeRetryConfiguration retryConfig
|
||||
| retryConfig == defaultSTRetryConf = Nothing
|
||||
| otherwise = Just retryConfig
|
||||
|
||||
maybeHeader headerConfig
|
||||
| null headerConfig = Nothing
|
||||
| otherwise = Just headerConfig
|
||||
|
||||
customTypesToOrdJSON :: CustomTypes -> AO.Value
|
||||
customTypesToOrdJSON (CustomTypes inpObjs objs scalars enums) =
|
||||
AO.object . catMaybes $ [ listToMaybeOrdPair "input_objects" inputObjectToOrdJSON =<< inpObjs
|
||||
, listToMaybeOrdPair "objects" objectTypeToOrdJSON =<< objs
|
||||
, listToMaybeOrdPair "scalars" scalarTypeToOrdJSON =<< scalars
|
||||
, listToMaybeOrdPair "enums" enumTypeToOrdJSON =<< enums
|
||||
]
|
||||
where
|
||||
inputObjectToOrdJSON :: InputObjectTypeDefinition -> AO.Value
|
||||
inputObjectToOrdJSON (InputObjectTypeDefinition tyName descM fields) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("fields", AO.array $ map fieldDefinitionToOrdJSON $ toList fields)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
where
|
||||
fieldDefinitionToOrdJSON :: InputObjectFieldDefinition -> AO.Value
|
||||
fieldDefinitionToOrdJSON (InputObjectFieldDefinition fieldName fieldDescM ty) =
|
||||
AO.object $ [ ("name", AO.toOrdered fieldName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair fieldDescM]
|
||||
|
||||
objectTypeToOrdJSON :: ObjectType -> AO.Value
|
||||
objectTypeToOrdJSON (ObjectTypeDefinition tyName descM fields rels) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("fields", AO.array $ map fieldDefinitionToOrdJSON $ toList fields)
|
||||
]
|
||||
<> catMaybes [ maybeDescriptionToMaybeOrdPair descM
|
||||
, maybeAnyToMaybeOrdPair "relationships" AO.toOrdered rels
|
||||
]
|
||||
where
|
||||
fieldDefinitionToOrdJSON :: ObjectFieldDefinition GraphQLType -> AO.Value
|
||||
fieldDefinitionToOrdJSON (ObjectFieldDefinition fieldName argsValM fieldDescM ty) =
|
||||
AO.object $ [ ("name", AO.toOrdered fieldName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [ ("arguments", ) . AO.toOrdered <$> argsValM
|
||||
, maybeDescriptionToMaybeOrdPair fieldDescM
|
||||
]
|
||||
|
||||
scalarTypeToOrdJSON :: ScalarTypeDefinition -> AO.Value
|
||||
scalarTypeToOrdJSON (ScalarTypeDefinition tyName descM) =
|
||||
AO.object $ [("name", AO.toOrdered tyName)]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
|
||||
enumTypeToOrdJSON :: EnumTypeDefinition -> AO.Value
|
||||
enumTypeToOrdJSON (EnumTypeDefinition tyName descM values) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("values", AO.toOrdered values)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
|
||||
|
||||
actionMetadataToOrdJSON :: ActionMetadata -> AO.Value
|
||||
actionMetadataToOrdJSON (ActionMetadata name comment definition permissions) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", actionDefinitionToOrdJSON definition)
|
||||
]
|
||||
<> catMaybes [ maybeCommentToMaybeOrdPair comment
|
||||
, listToMaybeOrdPair "permissions" permToOrdJSON permissions
|
||||
]
|
||||
where
|
||||
argDefinitionToOrdJSON :: ArgumentDefinition GraphQLType -> AO.Value
|
||||
argDefinitionToOrdJSON (ArgumentDefinition argName ty descM) =
|
||||
AO.object $ [ ("name", AO.toOrdered argName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [maybeAnyToMaybeOrdPair "description" AO.toOrdered descM]
|
||||
|
||||
actionDefinitionToOrdJSON :: ActionDefinitionInput -> AO.Value
|
||||
actionDefinitionToOrdJSON (ActionDefinition args outputType actionType
|
||||
headers frwrdClientHdrs timeout handler) =
|
||||
let typeAndKind = case actionType of
|
||||
ActionQuery -> [("type", AO.toOrdered ("query" :: String))]
|
||||
ActionMutation kind -> [ ("type", AO.toOrdered ("mutation" :: String))
|
||||
, ("kind", AO.toOrdered kind)]
|
||||
in
|
||||
AO.object $ [ ("handler", AO.toOrdered handler)
|
||||
, ("output_type", AO.toOrdered outputType)
|
||||
]
|
||||
<> [("forward_client_headers", AO.toOrdered frwrdClientHdrs) | frwrdClientHdrs]
|
||||
<> catMaybes [ listToMaybeOrdPair "headers" AO.toOrdered headers
|
||||
, listToMaybeOrdPair "arguments" argDefinitionToOrdJSON args]
|
||||
<> typeAndKind
|
||||
<> bool [("timeout",AO.toOrdered timeout)] mempty (timeout == defaultActionTimeoutSecs)
|
||||
|
||||
permToOrdJSON :: ActionPermissionMetadata -> AO.Value
|
||||
permToOrdJSON (ActionPermissionMetadata role permComment) =
|
||||
AO.object $ [("role", AO.toOrdered role)] <> catMaybes [maybeCommentToMaybeOrdPair permComment]
|
||||
|
||||
-- Utility functions
|
||||
listToMaybeOrdPair :: Text -> (a -> AO.Value) -> [a] -> Maybe (Text, AO.Value)
|
||||
listToMaybeOrdPair name f = \case
|
||||
[] -> Nothing
|
||||
list -> Just $ (name,) $ AO.array $ map f list
|
||||
|
||||
maybeSetToMaybeOrdPair :: Maybe (ColumnValues Value) -> Maybe (Text, AO.Value)
|
||||
maybeSetToMaybeOrdPair set = set >>= \colVals -> if colVals == HM.empty then Nothing
|
||||
else Just ("set", AO.toOrdered colVals)
|
||||
|
||||
|
||||
maybeDescriptionToMaybeOrdPair :: Maybe G.Description -> Maybe (Text, AO.Value)
|
||||
maybeDescriptionToMaybeOrdPair = maybeAnyToMaybeOrdPair "description" AO.toOrdered
|
||||
|
||||
maybeCommentToMaybeOrdPair :: Maybe Text -> Maybe (Text, AO.Value)
|
||||
maybeCommentToMaybeOrdPair = maybeAnyToMaybeOrdPair "comment" AO.toOrdered
|
||||
|
||||
maybeAnyToMaybeOrdPair :: Text -> (a -> AO.Value) -> Maybe a -> Maybe (Text, AO.Value)
|
||||
maybeAnyToMaybeOrdPair name f = fmap ((name,) . f)
|
||||
|
||||
@ -50,7 +50,6 @@ import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.EncJSON
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.DDL.Permission.Internal
|
||||
import Hasura.RQL.DML.Internal hiding (askPermInfo)
|
||||
import Hasura.RQL.Types
|
||||
@ -87,21 +86,6 @@ TRUE TRUE (OR NOT-SET) FALSE
|
||||
TRUE TRUE (OR NOT-SET) TRUE Mutation is shown
|
||||
-}
|
||||
|
||||
-- Insert permission
|
||||
data InsPerm (b :: Backend)
|
||||
= InsPerm
|
||||
{ ipCheck :: !(BoolExp b)
|
||||
, ipSet :: !(Maybe (ColumnValues Value))
|
||||
, ipColumns :: !(Maybe PermColSpec)
|
||||
, ipBackendOnly :: !(Maybe Bool) -- see Note [Backend only permissions]
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (InsPerm 'Postgres)
|
||||
instance FromJSON (InsPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON $ aesonDrop 2 snakeCase
|
||||
instance ToJSON (InsPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
type InsPermDef b = PermDef (InsPerm b)
|
||||
type CreateInsPerm b = CreatePerm (InsPerm b)
|
||||
|
||||
procSetObj
|
||||
@ -126,6 +110,64 @@ procSetObj tn fieldInfoMap mObj = do
|
||||
|
||||
getDepReason = bool DRSessionVariable DROnType . isStaticValue
|
||||
|
||||
class (ToJSON a) => IsPerm a where
|
||||
|
||||
permAccessor
|
||||
:: PermAccessor 'Postgres (PermInfo a)
|
||||
|
||||
buildPermInfo
|
||||
:: (QErrM m, TableCoreInfoRM m)
|
||||
=> QualifiedTable
|
||||
-> FieldInfoMap (FieldInfo 'Postgres)
|
||||
-> PermDef a
|
||||
-> m (WithDeps (PermInfo a))
|
||||
|
||||
getPermAcc1
|
||||
:: PermDef a -> PermAccessor 'Postgres (PermInfo a)
|
||||
getPermAcc1 _ = permAccessor
|
||||
|
||||
getPermAcc2
|
||||
:: DropPerm a -> PermAccessor 'Postgres (PermInfo a)
|
||||
getPermAcc2 _ = permAccessor
|
||||
|
||||
addPermP2 :: (IsPerm a, MonadTx m, HasSystemDefined m) => QualifiedTable -> PermDef a -> m ()
|
||||
addPermP2 tn pd = do
|
||||
let pt = permAccToType $ getPermAcc1 pd
|
||||
systemDefined <- askSystemDefined
|
||||
liftTx $ savePermToCatalog pt tn pd systemDefined
|
||||
|
||||
runCreatePerm
|
||||
:: (UserInfoM m, CacheRWM m, IsPerm a, MonadTx m, HasSystemDefined m)
|
||||
=> CreatePerm a -> m EncJSON
|
||||
runCreatePerm (WithTable tn pd) = do
|
||||
addPermP2 tn pd
|
||||
let pt = permAccToType $ getPermAcc1 pd
|
||||
buildSchemaCacheFor $ MOTableObj tn (MTOPerm (_pdRole pd) pt)
|
||||
pure successMsg
|
||||
|
||||
dropPermP1
|
||||
:: (QErrM m, CacheRM m, IsPerm a)
|
||||
=> DropPerm a -> m (PermInfo a)
|
||||
dropPermP1 dp@(DropPerm tn rn) = do
|
||||
tabInfo <- askTabInfo tn
|
||||
askPermInfo tabInfo rn $ getPermAcc2 dp
|
||||
|
||||
dropPermP2 :: forall a m. (MonadTx m, IsPerm a) => DropPerm a -> m ()
|
||||
dropPermP2 dp@(DropPerm tn rn) =
|
||||
liftTx $ dropPermFromCatalog tn rn pt
|
||||
where
|
||||
pa = getPermAcc2 dp
|
||||
pt = permAccToType pa
|
||||
|
||||
runDropPerm
|
||||
:: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m)
|
||||
=> DropPerm a -> m EncJSON
|
||||
runDropPerm defn = do
|
||||
dropPermP1 defn
|
||||
dropPermP2 defn
|
||||
withNewInconsistentObjsCheck buildSchemaCache
|
||||
return successMsg
|
||||
|
||||
buildInsPermInfo
|
||||
:: (QErrM m, TableCoreInfoRM m)
|
||||
=> QualifiedTable
|
||||
@ -158,28 +200,6 @@ instance IsPerm (InsPerm 'Postgres) where
|
||||
permAccessor = PAInsert
|
||||
buildPermInfo = buildInsPermInfo
|
||||
|
||||
-- Select constraint
|
||||
data SelPerm (b :: Backend)
|
||||
= SelPerm
|
||||
{ spColumns :: !PermColSpec -- ^ Allowed columns
|
||||
, spFilter :: !(BoolExp b) -- ^ Filter expression
|
||||
, spLimit :: !(Maybe Int) -- ^ Limit value
|
||||
, spAllowAggregations :: !Bool -- ^ Allow aggregation
|
||||
, spComputedFields :: ![ComputedFieldName] -- ^ Allowed computed fields
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (SelPerm 'Postgres)
|
||||
instance ToJSON (SelPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
instance FromJSON (SelPerm 'Postgres) where
|
||||
parseJSON = withObject "SelPerm" $ \o ->
|
||||
SelPerm
|
||||
<$> o .: "columns"
|
||||
<*> o .: "filter"
|
||||
<*> o .:? "limit"
|
||||
<*> o .:? "allow_aggregations" .!= False
|
||||
<*> o .:? "computed_fields" .!= []
|
||||
|
||||
buildSelPermInfo
|
||||
:: (QErrM m, TableCoreInfoRM m)
|
||||
=> QualifiedTable
|
||||
@ -223,7 +243,6 @@ buildSelPermInfo tn fieldInfoMap sp = withPathK "permission" $ do
|
||||
computedFields = spComputedFields sp
|
||||
autoInferredErr = "permissions for relationships are automatically inferred"
|
||||
|
||||
type SelPermDef b = PermDef (SelPerm b)
|
||||
type CreateSelPerm b = CreatePerm (SelPerm b)
|
||||
|
||||
-- TODO see TODO for PermInfo above.
|
||||
@ -234,28 +253,8 @@ instance IsPerm (SelPerm 'Postgres) where
|
||||
buildPermInfo tn fieldInfoMap (PermDef _ a _) =
|
||||
buildSelPermInfo tn fieldInfoMap a
|
||||
|
||||
-- Update constraint
|
||||
data UpdPerm b
|
||||
= UpdPerm
|
||||
{ ucColumns :: !PermColSpec -- Allowed columns
|
||||
, ucSet :: !(Maybe (ColumnValues Value)) -- Preset columns
|
||||
, ucFilter :: !(BoolExp b) -- Filter expression (applied before update)
|
||||
, ucCheck :: !(Maybe (BoolExp b))
|
||||
-- ^ Check expression, which must be true after update.
|
||||
-- This is optional because we don't want to break the v1 API
|
||||
-- but Nothing should be equivalent to the expression which always
|
||||
-- returns true.
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (UpdPerm 'Postgres)
|
||||
instance FromJSON (UpdPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON $ aesonDrop 2 snakeCase
|
||||
instance ToJSON (UpdPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
type UpdPermDef b = PermDef (UpdPerm b)
|
||||
type CreateUpdPerm b = CreatePerm (UpdPerm b)
|
||||
|
||||
|
||||
buildUpdPermInfo
|
||||
:: (QErrM m, TableCoreInfoRM m)
|
||||
=> QualifiedTable
|
||||
@ -294,17 +293,6 @@ instance IsPerm (UpdPerm 'Postgres) where
|
||||
buildPermInfo tn fieldInfoMap (PermDef _ a _) =
|
||||
buildUpdPermInfo tn fieldInfoMap a
|
||||
|
||||
-- Delete permission
|
||||
data DelPerm (b :: Backend)
|
||||
= DelPerm { dcFilter :: !(BoolExp b) }
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (DelPerm 'Postgres)
|
||||
instance FromJSON (DelPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON $ aesonDrop 2 snakeCase
|
||||
instance ToJSON (DelPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
type DelPermDef b = PermDef (DelPerm b)
|
||||
type CreateDelPerm b = CreatePerm (DelPerm b)
|
||||
|
||||
buildDelPermInfo
|
||||
|
||||
@ -21,27 +21,11 @@ import Language.Haskell.TH.Syntax (Lift)
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.Backends.Postgres.SQL.Value
|
||||
import Hasura.Backends.Postgres.Translate.BoolExp
|
||||
import Hasura.EncJSON
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.Server.Utils
|
||||
import Hasura.Session
|
||||
|
||||
|
||||
data PermColSpec
|
||||
= PCStar
|
||||
| PCCols ![PGCol]
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable PermColSpec
|
||||
|
||||
instance FromJSON PermColSpec where
|
||||
parseJSON (String "*") = return PCStar
|
||||
parseJSON x = PCCols <$> parseJSON x
|
||||
|
||||
instance ToJSON PermColSpec where
|
||||
toJSON (PCCols cols) = toJSON cols
|
||||
toJSON PCStar = "*"
|
||||
|
||||
convColSpec :: FieldInfoMap (FieldInfo 'Postgres) -> PermColSpec -> [PGCol]
|
||||
convColSpec _ (PCCols cols) = cols
|
||||
convColSpec cim PCStar = map pgiColumn $ getCols cim
|
||||
@ -134,25 +118,6 @@ dropPermFromCatalog (QualifiedObject sn tn) rn pt =
|
||||
|
||||
type CreatePerm a = WithTable (PermDef a)
|
||||
|
||||
data PermDef a =
|
||||
PermDef
|
||||
{ pdRole :: !RoleName
|
||||
, pdPermission :: !a
|
||||
, pdComment :: !(Maybe Text)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance (Cacheable a) => Cacheable (PermDef a)
|
||||
$(deriveFromJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''PermDef)
|
||||
|
||||
instance (ToJSON a) => ToJSON (PermDef a) where
|
||||
toJSON = object . toAesonPairs
|
||||
|
||||
instance (ToJSON a) => ToAesonPairs (PermDef a) where
|
||||
toAesonPairs (PermDef rn perm comment) =
|
||||
[ "role" .= rn
|
||||
, "permission" .= perm
|
||||
, "comment" .= comment
|
||||
]
|
||||
|
||||
data CreatePermP1Res a
|
||||
= CreatePermP1Res
|
||||
{ cprInfo :: !a
|
||||
@ -236,61 +201,3 @@ data DropPerm a
|
||||
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''DropPerm)
|
||||
|
||||
type family PermInfo a = r | r -> a
|
||||
|
||||
class (ToJSON a) => IsPerm a where
|
||||
|
||||
permAccessor
|
||||
:: PermAccessor 'Postgres (PermInfo a)
|
||||
|
||||
buildPermInfo
|
||||
:: (QErrM m, TableCoreInfoRM m)
|
||||
=> QualifiedTable
|
||||
-> FieldInfoMap (FieldInfo 'Postgres)
|
||||
-> PermDef a
|
||||
-> m (WithDeps (PermInfo a))
|
||||
|
||||
getPermAcc1
|
||||
:: PermDef a -> PermAccessor 'Postgres (PermInfo a)
|
||||
getPermAcc1 _ = permAccessor
|
||||
|
||||
getPermAcc2
|
||||
:: DropPerm a -> PermAccessor 'Postgres (PermInfo a)
|
||||
getPermAcc2 _ = permAccessor
|
||||
|
||||
addPermP2 :: (IsPerm a, MonadTx m, HasSystemDefined m) => QualifiedTable -> PermDef a -> m ()
|
||||
addPermP2 tn pd = do
|
||||
let pt = permAccToType $ getPermAcc1 pd
|
||||
systemDefined <- askSystemDefined
|
||||
liftTx $ savePermToCatalog pt tn pd systemDefined
|
||||
|
||||
runCreatePerm
|
||||
:: (UserInfoM m, CacheRWM m, IsPerm a, MonadTx m, HasSystemDefined m)
|
||||
=> CreatePerm a -> m EncJSON
|
||||
runCreatePerm (WithTable tn pd) = do
|
||||
addPermP2 tn pd
|
||||
let pt = permAccToType $ getPermAcc1 pd
|
||||
buildSchemaCacheFor $ MOTableObj tn (MTOPerm (pdRole pd) pt)
|
||||
pure successMsg
|
||||
|
||||
dropPermP1
|
||||
:: (QErrM m, CacheRM m, IsPerm a)
|
||||
=> DropPerm a -> m (PermInfo a)
|
||||
dropPermP1 dp@(DropPerm tn rn) = do
|
||||
tabInfo <- askTabInfo tn
|
||||
askPermInfo tabInfo rn $ getPermAcc2 dp
|
||||
|
||||
dropPermP2 :: forall a m. (MonadTx m, IsPerm a) => DropPerm a -> m ()
|
||||
dropPermP2 dp@(DropPerm tn rn) =
|
||||
liftTx $ dropPermFromCatalog tn rn pt
|
||||
where
|
||||
pa = getPermAcc2 dp
|
||||
pt = permAccToType pa
|
||||
|
||||
runDropPerm
|
||||
:: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m)
|
||||
=> DropPerm a -> m EncJSON
|
||||
runDropPerm defn = do
|
||||
dropPermP1 defn
|
||||
dropPermP2 defn
|
||||
withNewInconsistentObjsCheck buildSchemaCache
|
||||
return successMsg
|
||||
|
||||
@ -8,7 +8,6 @@ module Hasura.RQL.DDL.Relationship
|
||||
, delRelFromCatalog
|
||||
|
||||
, runSetRelComment
|
||||
, module Hasura.RQL.DDL.Relationship.Types
|
||||
)
|
||||
where
|
||||
|
||||
@ -26,7 +25,6 @@ import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.EncJSON
|
||||
import Hasura.RQL.DDL.Deps
|
||||
import Hasura.RQL.DDL.Permission (purgePerm)
|
||||
import Hasura.RQL.DDL.Relationship.Types
|
||||
import Hasura.RQL.Types
|
||||
|
||||
runCreateRelationship
|
||||
@ -34,7 +32,7 @@ runCreateRelationship
|
||||
=> RelType -> WithTable (RelDef a) -> m EncJSON
|
||||
runCreateRelationship relType (WithTable tableName relDef) = do
|
||||
insertRelationshipToCatalog tableName relType relDef
|
||||
buildSchemaCacheFor $ MOTableObj tableName (MTORel (rdName relDef) relType)
|
||||
buildSchemaCacheFor $ MOTableObj tableName (MTORel (_rdName relDef) relType)
|
||||
pure successMsg
|
||||
|
||||
insertRelationshipToCatalog
|
||||
@ -68,7 +66,7 @@ runDropRel (DropRel qt rn cascade) = do
|
||||
_ <- askRelType (_tciFieldInfoMap tabInfo) rn ""
|
||||
sc <- askSchemaCache
|
||||
let depObjs = getDependentObjs sc (SOTableObj qt $ TORel rn)
|
||||
when (depObjs /= [] && not (or cascade)) $ reportDeps depObjs
|
||||
when (depObjs /= [] && not cascade) $ reportDeps depObjs
|
||||
pure depObjs
|
||||
|
||||
delRelFromCatalog
|
||||
|
||||
@ -6,7 +6,6 @@ import Data.Text.Extended
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.EncJSON
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DDL.Relationship.Types
|
||||
import Hasura.RQL.DDL.Schema (renameRelInCatalog)
|
||||
import Hasura.RQL.Types
|
||||
|
||||
|
||||
@ -54,7 +54,7 @@ import Hasura.RQL.DDL.Schema.Diff
|
||||
import Hasura.RQL.DDL.Schema.Function
|
||||
import Hasura.RQL.DDL.Schema.Table
|
||||
import Hasura.RQL.DDL.Utils (clearHdbViews)
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.RQL.Types hiding (fmFunction, tmTable)
|
||||
import Hasura.RQL.Types.Catalog
|
||||
import Hasura.Server.Version (HasVersion)
|
||||
|
||||
|
||||
@ -33,7 +33,7 @@ import Data.Aeson.TH
|
||||
import Data.List.Extended (duplicates)
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.RQL.Types hiding (fmFunction, tmComputedFields, tmTable)
|
||||
import Hasura.RQL.Types.Catalog
|
||||
|
||||
data FunctionMeta
|
||||
|
||||
@ -14,8 +14,6 @@ import qualified Database.PG.Query as Q
|
||||
|
||||
import Control.Lens
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Data.Text.Extended
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
@ -23,29 +21,10 @@ import qualified Language.GraphQL.Draft.Syntax as G
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.EncJSON
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.Server.Utils (englishList, makeReasonMessage)
|
||||
|
||||
|
||||
data RawFunctionInfo
|
||||
= RawFunctionInfo
|
||||
{ rfiHasVariadic :: !Bool
|
||||
, rfiFunctionType :: !FunctionType
|
||||
, rfiReturnTypeSchema :: !SchemaName
|
||||
, rfiReturnTypeName :: !PGScalarType
|
||||
, rfiReturnTypeType :: !PGTypeKind
|
||||
, rfiReturnsSet :: !Bool
|
||||
, rfiInputArgTypes :: ![QualifiedPGType]
|
||||
, rfiInputArgNames :: ![FunctionArgName]
|
||||
, rfiDefaultArgs :: !Int
|
||||
, rfiReturnsTable :: !Bool
|
||||
, rfiDescription :: !(Maybe PGDescription)
|
||||
} deriving (Show, Eq, Generic)
|
||||
instance NFData RawFunctionInfo
|
||||
instance Cacheable RawFunctionInfo
|
||||
$(deriveJSON (aesonDrop 3 snakeCase) ''RawFunctionInfo)
|
||||
|
||||
mkFunctionArgs :: Int -> [QualifiedPGType] -> [FunctionArgName] -> [FunctionArg]
|
||||
mkFunctionArgs defArgsNo tys argNames =
|
||||
bool withNames withNoNames $ null argNames
|
||||
@ -185,17 +164,6 @@ newtype TrackFunction
|
||||
{ tfName :: QualifiedFunction}
|
||||
deriving (Show, Eq, FromJSON, ToJSON, Lift)
|
||||
|
||||
data FunctionConfig
|
||||
= FunctionConfig
|
||||
{ _fcSessionArgument :: !(Maybe FunctionArgName)
|
||||
} deriving (Show, Eq, Generic, Lift)
|
||||
instance NFData FunctionConfig
|
||||
instance Cacheable FunctionConfig
|
||||
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields = True} ''FunctionConfig)
|
||||
|
||||
emptyFunctionConfig :: FunctionConfig
|
||||
emptyFunctionConfig = FunctionConfig Nothing
|
||||
|
||||
-- | Track function, Phase 1:
|
||||
-- Validate function tracking operation. Fails if function is already being
|
||||
-- tracked, or if a table with the same name is being tracked.
|
||||
@ -244,19 +212,6 @@ runTrackFunc (TrackFunction qf)= do
|
||||
trackFunctionP1 qf
|
||||
trackFunctionP2 qf emptyFunctionConfig
|
||||
|
||||
data TrackFunctionV2
|
||||
= TrackFunctionV2
|
||||
{ _tfv2Function :: !QualifiedFunction
|
||||
, _tfv2Configuration :: !FunctionConfig
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(deriveToJSON (aesonDrop 5 snakeCase) ''TrackFunctionV2)
|
||||
|
||||
instance FromJSON TrackFunctionV2 where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
TrackFunctionV2
|
||||
<$> o .: "function"
|
||||
<*> o .:? "configuration" .!= emptyFunctionConfig
|
||||
|
||||
runTrackFunctionV2
|
||||
:: ( QErrM m, CacheRWM m, HasSystemDefined m
|
||||
, MonadTx m
|
||||
|
||||
@ -28,7 +28,6 @@ import qualified Hasura.RQL.DDL.RemoteRelationship as RR
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.RQL.DDL.Permission
|
||||
import Hasura.RQL.DDL.Permission.Internal
|
||||
import Hasura.RQL.DDL.Relationship.Types
|
||||
import Hasura.RQL.DDL.Schema.Catalog
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.Session
|
||||
@ -389,7 +388,7 @@ updateColInRemoteRelationship remoteRelationshipName renameCol = do
|
||||
) $ fieldCalls
|
||||
liftTx $ RR.updateRemoteRelInCatalog (RemoteRelationship remoteRelationshipName qt modifiedHasuraFlds remoteSchemaName (RemoteFields modifiedFieldCalls))
|
||||
where
|
||||
parseGraphQLName txt = maybe (throw400 ParseFailed $ errMsg) pure $ G.mkName txt
|
||||
parseGraphQLName txt = onNothing (G.mkName txt) $ throw400 ParseFailed $ errMsg
|
||||
where
|
||||
errMsg = txt <> " is not a valid GraphQL name"
|
||||
|
||||
|
||||
@ -55,7 +55,7 @@ import Hasura.RQL.DDL.Schema.Catalog
|
||||
import Hasura.RQL.DDL.Schema.Diff
|
||||
import Hasura.RQL.DDL.Schema.Enum
|
||||
import Hasura.RQL.DDL.Schema.Rename
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.RQL.Types hiding (fmFunction)
|
||||
import Hasura.RQL.Types.Catalog
|
||||
import Hasura.Server.Utils
|
||||
|
||||
|
||||
@ -61,14 +61,15 @@ import Hasura.RQL.Types.Function as R
|
||||
import Hasura.RQL.Types.Metadata as R
|
||||
import Hasura.RQL.Types.Permission as R
|
||||
import Hasura.RQL.Types.QueryCollection as R
|
||||
import Hasura.RQL.Types.Relationship as R
|
||||
import Hasura.RQL.Types.RemoteRelationship as R
|
||||
import Hasura.RQL.Types.RemoteSchema as R
|
||||
import Hasura.RQL.Types.ScheduledTrigger as R
|
||||
import Hasura.RQL.Types.SchemaCache as R
|
||||
import Hasura.RQL.Types.SchemaCache.Build as R
|
||||
import Hasura.RQL.Types.Table as R
|
||||
import Hasura.SQL.Backend as R
|
||||
import Hasura.Session
|
||||
import Hasura.SQL.Backend as R
|
||||
import Hasura.Tracing (TraceT)
|
||||
|
||||
data QCtx
|
||||
|
||||
@ -236,7 +236,7 @@ data ActionPermissionMetadata
|
||||
instance NFData ActionPermissionMetadata
|
||||
instance Cacheable ActionPermissionMetadata
|
||||
|
||||
$(J.deriveFromJSON
|
||||
$(J.deriveJSON
|
||||
(J.aesonDrop 4 J.snakeCase){J.omitNothingFields=True}
|
||||
''ActionPermissionMetadata)
|
||||
|
||||
@ -248,6 +248,7 @@ data ActionMetadata
|
||||
, _amDefinition :: !ActionDefinitionInput
|
||||
, _amPermissions :: ![ActionPermissionMetadata]
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(J.deriveToJSON (J.aesonDrop 3 J.snakeCase) ''ActionMetadata)
|
||||
instance NFData ActionMetadata
|
||||
instance Cacheable ActionMetadata
|
||||
|
||||
|
||||
@ -28,12 +28,12 @@ import System.Cron.Types (CronSchedule (..))
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.DDL.ComputedField
|
||||
import Hasura.RQL.DDL.Schema.Function
|
||||
import Hasura.RQL.Types.Action
|
||||
import Hasura.RQL.Types.Column
|
||||
import Hasura.RQL.Types.Common
|
||||
import Hasura.RQL.Types.CustomTypes
|
||||
import Hasura.RQL.Types.EventTrigger
|
||||
import Hasura.RQL.Types.Function
|
||||
import Hasura.RQL.Types.Permission
|
||||
import Hasura.RQL.Types.QueryCollection
|
||||
import Hasura.RQL.Types.RemoteRelationship
|
||||
|
||||
@ -48,6 +48,10 @@ module Hasura.RQL.Types.Common
|
||||
, unsafeNonNegativeInt
|
||||
, Timeout(..)
|
||||
, defaultActionTimeoutSecs
|
||||
|
||||
, UrlConf(..)
|
||||
, resolveUrlConf
|
||||
, getEnv
|
||||
) where
|
||||
|
||||
import Hasura.Prelude
|
||||
@ -99,7 +103,7 @@ rootText = mkNonEmptyTextUnsafe "root"
|
||||
|
||||
newtype RelName
|
||||
= RelName { getRelTxt :: NonEmptyText }
|
||||
deriving (Show, Eq, Hashable, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Lift, Generic, Arbitrary, NFData, Cacheable)
|
||||
deriving (Show, Eq, Hashable, FromJSON, ToJSON, ToJSONKey, Q.ToPrepArg, Q.FromCol, Lift, Generic, Arbitrary, NFData, Cacheable)
|
||||
|
||||
instance IsIdentifier RelName where
|
||||
toIdentifier rn = Identifier $ relNameToTxt rn
|
||||
@ -351,3 +355,35 @@ instance Arbitrary Timeout where
|
||||
|
||||
defaultActionTimeoutSecs :: Timeout
|
||||
defaultActionTimeoutSecs = Timeout 30
|
||||
|
||||
data UrlConf
|
||||
= UrlValue !InputWebhook
|
||||
| UrlFromEnv !T.Text
|
||||
deriving (Show, Eq, Generic, Lift)
|
||||
instance NFData UrlConf
|
||||
instance Cacheable UrlConf
|
||||
|
||||
instance ToJSON UrlConf where
|
||||
toJSON (UrlValue w) = toJSON w
|
||||
toJSON (UrlFromEnv wEnv) = object ["from_env" .= wEnv ]
|
||||
|
||||
instance FromJSON UrlConf where
|
||||
parseJSON (Object o) = UrlFromEnv <$> o .: "from_env"
|
||||
parseJSON t@(String _) =
|
||||
case (fromJSON t) of
|
||||
Error s -> fail s
|
||||
Success a -> pure $ UrlValue a
|
||||
parseJSON _ = fail "one of string or object must be provided for url/webhook"
|
||||
|
||||
resolveUrlConf
|
||||
:: MonadError QErr m => Env.Environment -> UrlConf -> m Text
|
||||
resolveUrlConf env = \case
|
||||
UrlValue v -> unResolvedWebhook <$> resolveWebhook env v
|
||||
UrlFromEnv envVar -> getEnv env envVar
|
||||
|
||||
getEnv :: QErrM m => Env.Environment -> T.Text -> m T.Text
|
||||
getEnv env k = do
|
||||
let mEnv = Env.lookupEnv env (T.unpack k)
|
||||
case mEnv of
|
||||
Nothing -> throw400 NotFound $ "environment variable '" <> k <> "' not set"
|
||||
Just envVal -> return (T.pack envVal)
|
||||
|
||||
@ -28,7 +28,7 @@ import Hasura.SQL.Backend
|
||||
|
||||
newtype ComputedFieldName =
|
||||
ComputedFieldName { unComputedFieldName :: NonEmptyText}
|
||||
deriving (Show, Eq, NFData, Lift, FromJSON, ToJSON, Q.ToPrepArg, ToTxt, Hashable, Q.FromCol, Generic, Arbitrary, Cacheable)
|
||||
deriving (Show, Eq, NFData, Lift, FromJSON, ToJSON, ToJSONKey, Q.ToPrepArg, ToTxt, Hashable, Q.FromCol, Generic, Arbitrary, Cacheable)
|
||||
|
||||
computedFieldNameToText :: ComputedFieldName -> Text
|
||||
computedFieldNameToText = unNonEmptyText . unComputedFieldName
|
||||
@ -36,6 +36,16 @@ computedFieldNameToText = unNonEmptyText . unComputedFieldName
|
||||
fromComputedField :: ComputedFieldName -> FieldName
|
||||
fromComputedField = FieldName . computedFieldNameToText
|
||||
|
||||
data ComputedFieldDefinition
|
||||
= ComputedFieldDefinition
|
||||
{ _cfdFunction :: !QualifiedFunction
|
||||
, _cfdTableArgument :: !(Maybe FunctionArgName)
|
||||
, _cfdSessionArgument :: !(Maybe FunctionArgName)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance NFData ComputedFieldDefinition
|
||||
instance Cacheable ComputedFieldDefinition
|
||||
$(deriveJSON (aesonDrop 4 snakeCase){omitNothingFields = True} ''ComputedFieldDefinition)
|
||||
|
||||
-- | The function table argument is either the very first argument or the named
|
||||
-- argument with an index. The index is 0 if the named argument is the first.
|
||||
data FunctionTableArgument
|
||||
|
||||
@ -265,7 +265,7 @@ parseWildcard =
|
||||
fromList = foldr1 (\_ x -> StarDot x)
|
||||
|
||||
-- Columns in RQL
|
||||
data SelCol b
|
||||
data SelCol (b :: Backend)
|
||||
= SCStar !Wildcard
|
||||
| SCExtSimple !(Column b)
|
||||
| SCExtRel !RelName !(Maybe RelName) !(SelectQ b)
|
||||
|
||||
@ -107,6 +107,7 @@ data RetryConf
|
||||
, rcTimeoutSec :: !(Maybe Int)
|
||||
} deriving (Show, Eq, Generic, Lift)
|
||||
instance NFData RetryConf
|
||||
instance Cacheable RetryConf
|
||||
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''RetryConf)
|
||||
|
||||
data EventHeaderInfo
|
||||
@ -222,7 +223,7 @@ data EventTriggerConf
|
||||
, etcRetryConf :: !RetryConf
|
||||
, etcHeaders :: !(Maybe [HeaderConf])
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
|
||||
instance Cacheable EventTriggerConf
|
||||
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''EventTriggerConf)
|
||||
|
||||
newtype RedeliverEventQuery
|
||||
|
||||
@ -78,3 +78,51 @@ $(deriveToJSON (aesonDrop 2 snakeCase) ''FunctionInfo)
|
||||
getInputArgs :: FunctionInfo -> Seq.Seq FunctionArg
|
||||
getInputArgs =
|
||||
Seq.fromList . mapMaybe (^? _IAUserProvided) . toList . fiInputArgs
|
||||
|
||||
type FunctionCache = HashMap QualifiedFunction FunctionInfo -- info of all functions
|
||||
|
||||
-- Metadata requests related types
|
||||
data FunctionConfig
|
||||
= FunctionConfig
|
||||
{ _fcSessionArgument :: !(Maybe FunctionArgName)
|
||||
} deriving (Show, Eq, Generic, Lift)
|
||||
instance NFData FunctionConfig
|
||||
instance Cacheable FunctionConfig
|
||||
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields = True} ''FunctionConfig)
|
||||
|
||||
emptyFunctionConfig :: FunctionConfig
|
||||
emptyFunctionConfig = FunctionConfig Nothing
|
||||
|
||||
data TrackFunctionV2
|
||||
= TrackFunctionV2
|
||||
{ _tfv2Function :: !QualifiedFunction
|
||||
, _tfv2Configuration :: !FunctionConfig
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
$(deriveToJSON (aesonDrop 5 snakeCase) ''TrackFunctionV2)
|
||||
|
||||
instance FromJSON TrackFunctionV2 where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
TrackFunctionV2
|
||||
<$> o .: "function"
|
||||
<*> o .:? "configuration" .!= emptyFunctionConfig
|
||||
|
||||
-- | Raw SQL function metadata from postgres
|
||||
data RawFunctionInfo
|
||||
= RawFunctionInfo
|
||||
{ rfiHasVariadic :: !Bool
|
||||
, rfiFunctionType :: !FunctionType
|
||||
, rfiReturnTypeSchema :: !SchemaName
|
||||
, rfiReturnTypeName :: !PGScalarType
|
||||
, rfiReturnTypeType :: !PGTypeKind
|
||||
, rfiReturnsSet :: !Bool
|
||||
, rfiInputArgTypes :: ![QualifiedPGType]
|
||||
, rfiInputArgNames :: ![FunctionArgName]
|
||||
, rfiDefaultArgs :: !Int
|
||||
, rfiReturnsTable :: !Bool
|
||||
, rfiDescription :: !(Maybe PGDescription)
|
||||
} deriving (Show, Eq, Generic)
|
||||
instance NFData RawFunctionInfo
|
||||
instance Cacheable RawFunctionInfo
|
||||
$(deriveJSON (aesonDrop 3 snakeCase) ''RawFunctionInfo)
|
||||
|
||||
type PostgresFunctionsMetadata = HashMap QualifiedFunction [RawFunctionInfo]
|
||||
|
||||
@ -1,21 +1,45 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Hasura.RQL.Types.Metadata where
|
||||
|
||||
import qualified Data.HashMap.Strict.Extended as M
|
||||
|
||||
import Control.Lens hiding ((.=))
|
||||
import Data.Aeson
|
||||
import Data.Text.Extended
|
||||
import Hasura.Prelude
|
||||
import Hasura.Session
|
||||
|
||||
import qualified Data.Aeson.Ordered as AO
|
||||
import qualified Data.HashMap.Strict.Extended as M
|
||||
import qualified Data.HashMap.Strict.InsOrd.Extended as OM
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.HashSet.InsOrd as HSIns
|
||||
import qualified Data.List.Extended as L
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.GraphQL.Draft.Syntax as G
|
||||
|
||||
import Control.Lens hiding (set, (.=))
|
||||
import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.RQL.Types.Action
|
||||
import Hasura.RQL.Types.Common
|
||||
import Hasura.RQL.Types.ComputedField
|
||||
import Hasura.RQL.Types.CustomTypes
|
||||
import Hasura.RQL.Types.EventTrigger
|
||||
import Hasura.RQL.Types.Function
|
||||
import Hasura.RQL.Types.Permission
|
||||
import Hasura.RQL.Types.QueryCollection
|
||||
import Hasura.RQL.Types.Relationship
|
||||
import Hasura.RQL.Types.RemoteRelationship
|
||||
import Hasura.RQL.Types.RemoteSchema
|
||||
import Hasura.RQL.Types.ScheduledTrigger
|
||||
import Hasura.RQL.Types.Table
|
||||
import Hasura.Session
|
||||
import Hasura.SQL.Backend
|
||||
|
||||
|
||||
data TableMetadataObjId
|
||||
= MTORel !RelName !RelType
|
||||
@ -125,3 +149,538 @@ instance ToJSON InconsistentMetadata where
|
||||
metadataObjectFields (MetadataObject objectId definition) =
|
||||
[ "type" .= String (moiTypeName objectId)
|
||||
, "definition" .= definition ]
|
||||
|
||||
-- | Raise exception if parsed list has multiple declarations
|
||||
parseListAsMap
|
||||
:: (Hashable k, Eq k, Show k)
|
||||
=> Text -> (a -> k) -> Parser [a] -> Parser (InsOrdHashMap k a)
|
||||
parseListAsMap t mapFn listP = do
|
||||
list <- listP
|
||||
let duplicates = toList $ L.duplicates $ map mapFn list
|
||||
unless (null duplicates) $ fail $ T.unpack $
|
||||
"multiple declarations exist for the following " <> t <> " : "
|
||||
<> T.pack (show duplicates)
|
||||
pure $ oMapFromL mapFn list
|
||||
|
||||
data MetadataVersion
|
||||
= MVVersion1
|
||||
| MVVersion2
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
|
||||
instance ToJSON MetadataVersion where
|
||||
toJSON = \case
|
||||
MVVersion1 -> toJSON @Int 1
|
||||
MVVersion2 -> toJSON @Int 2
|
||||
|
||||
instance FromJSON MetadataVersion where
|
||||
parseJSON v = do
|
||||
version :: Int <- parseJSON v
|
||||
case version of
|
||||
1 -> pure MVVersion1
|
||||
2 -> pure MVVersion2
|
||||
i -> fail $ "expected 1 or 2, encountered " ++ show i
|
||||
|
||||
currentMetadataVersion :: MetadataVersion
|
||||
currentMetadataVersion = MVVersion2
|
||||
|
||||
data ComputedFieldMetadata
|
||||
= ComputedFieldMetadata
|
||||
{ _cfmName :: !ComputedFieldName
|
||||
, _cfmDefinition :: !ComputedFieldDefinition
|
||||
, _cfmComment :: !(Maybe Text)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable ComputedFieldMetadata
|
||||
$(deriveJSON (aesonDrop 4 snakeCase) ''ComputedFieldMetadata)
|
||||
|
||||
data RemoteRelationshipMetadata
|
||||
= RemoteRelationshipMetadata
|
||||
{ _rrmName :: !RemoteRelationshipName
|
||||
, _rrmDefinition :: !RemoteRelationshipDef
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable RemoteRelationshipMetadata
|
||||
$(deriveJSON (aesonDrop 4 snakeCase) ''RemoteRelationshipMetadata)
|
||||
$(makeLenses ''RemoteRelationshipMetadata)
|
||||
|
||||
type Relationships a = InsOrdHashMap RelName a
|
||||
type ComputedFields = InsOrdHashMap ComputedFieldName ComputedFieldMetadata
|
||||
type RemoteRelationships = InsOrdHashMap RemoteRelationshipName RemoteRelationshipMetadata
|
||||
type Permissions a = InsOrdHashMap RoleName a
|
||||
type EventTriggers = InsOrdHashMap TriggerName EventTriggerConf
|
||||
|
||||
data TableMetadata
|
||||
= TableMetadata
|
||||
{ _tmTable :: !QualifiedTable
|
||||
, _tmIsEnum :: !Bool
|
||||
, _tmConfiguration :: !TableConfig
|
||||
, _tmObjectRelationships :: !(Relationships ObjRelDef)
|
||||
, _tmArrayRelationships :: !(Relationships ArrRelDef)
|
||||
, _tmComputedFields :: !ComputedFields
|
||||
, _tmRemoteRelationships :: !RemoteRelationships
|
||||
, _tmInsertPermissions :: !(Permissions (InsPermDef 'Postgres))
|
||||
, _tmSelectPermissions :: !(Permissions (SelPermDef 'Postgres))
|
||||
, _tmUpdatePermissions :: !(Permissions (UpdPermDef 'Postgres))
|
||||
, _tmDeletePermissions :: !(Permissions (DelPermDef 'Postgres))
|
||||
, _tmEventTriggers :: !EventTriggers
|
||||
} deriving (Show, Eq, Generic)
|
||||
instance Cacheable TableMetadata
|
||||
$(deriveToJSON (aesonDrop 3 snakeCase) ''TableMetadata)
|
||||
$(makeLenses ''TableMetadata)
|
||||
|
||||
mkTableMeta :: QualifiedTable -> Bool -> TableConfig -> TableMetadata
|
||||
mkTableMeta qt isEnum config = TableMetadata qt isEnum config
|
||||
mempty mempty mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
instance FromJSON TableMetadata where
|
||||
parseJSON = withObject "Object" $ \o -> do
|
||||
let unexpectedKeys = getUnexpectedKeys o
|
||||
unless (null unexpectedKeys) $
|
||||
fail $ "unexpected keys when parsing TableMetadata : "
|
||||
<> show (HS.toList unexpectedKeys)
|
||||
|
||||
TableMetadata
|
||||
<$> o .: tableKey
|
||||
<*> o .:? isEnumKey .!= False
|
||||
<*> o .:? configKey .!= emptyTableConfig
|
||||
<*> parseListAsMap "object relationships" _rdName (o .:? orKey .!= [])
|
||||
<*> parseListAsMap "array relationships" _rdName (o .:? arKey .!= [])
|
||||
<*> parseListAsMap "computed fields" _cfmName (o .:? cfKey .!= [])
|
||||
<*> parseListAsMap "remote relationships" _rrmName (o .:? rrKey .!= [])
|
||||
<*> parseListAsMap "insert permissions" _pdRole (o .:? ipKey .!= [])
|
||||
<*> parseListAsMap "select permissions" _pdRole (o .:? spKey .!= [])
|
||||
<*> parseListAsMap "update permissions" _pdRole (o .:? upKey .!= [])
|
||||
<*> parseListAsMap "delete permissions" _pdRole (o .:? dpKey .!= [])
|
||||
<*> parseListAsMap "event triggers" etcName (o .:? etKey .!= [])
|
||||
|
||||
where
|
||||
tableKey = "table"
|
||||
isEnumKey = "is_enum"
|
||||
configKey = "configuration"
|
||||
orKey = "object_relationships"
|
||||
arKey = "array_relationships"
|
||||
ipKey = "insert_permissions"
|
||||
spKey = "select_permissions"
|
||||
upKey = "update_permissions"
|
||||
dpKey = "delete_permissions"
|
||||
etKey = "event_triggers"
|
||||
cfKey = "computed_fields"
|
||||
rrKey = "remote_relationships"
|
||||
|
||||
getUnexpectedKeys o =
|
||||
HS.fromList (M.keys o) `HS.difference` expectedKeySet
|
||||
|
||||
expectedKeySet =
|
||||
HS.fromList [ tableKey, isEnumKey, configKey, orKey
|
||||
, arKey , ipKey, spKey, upKey, dpKey, etKey
|
||||
, cfKey, rrKey
|
||||
]
|
||||
|
||||
data FunctionMetadata
|
||||
= FunctionMetadata
|
||||
{ _fmFunction :: !QualifiedFunction
|
||||
, _fmConfiguration :: !FunctionConfig
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable FunctionMetadata
|
||||
$(makeLenses ''FunctionMetadata)
|
||||
$(deriveToJSON (aesonDrop 3 snakeCase) ''FunctionMetadata)
|
||||
|
||||
instance FromJSON FunctionMetadata where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
FunctionMetadata
|
||||
<$> o .: "function"
|
||||
<*> o .:? "configuration" .!= emptyFunctionConfig
|
||||
|
||||
type Tables = InsOrdHashMap QualifiedTable TableMetadata
|
||||
type Functions = InsOrdHashMap QualifiedFunction FunctionMetadata
|
||||
type RemoteSchemas = InsOrdHashMap RemoteSchemaName AddRemoteSchemaQuery
|
||||
type QueryCollections = InsOrdHashMap CollectionName CreateCollection
|
||||
type Allowlist = HSIns.InsOrdHashSet CollectionReq
|
||||
type Actions = InsOrdHashMap ActionName ActionMetadata
|
||||
type CronTriggers = InsOrdHashMap TriggerName CronTriggerMetadata
|
||||
|
||||
parseNonPostgresMetadata
|
||||
:: Object
|
||||
-> Parser
|
||||
( RemoteSchemas
|
||||
, QueryCollections
|
||||
, Allowlist
|
||||
, CustomTypes
|
||||
, Actions
|
||||
, CronTriggers
|
||||
)
|
||||
parseNonPostgresMetadata o = do
|
||||
remoteSchemas <- parseListAsMap "remote schemas" _arsqName $
|
||||
o .:? "remote_schemas" .!= []
|
||||
queryCollections <- parseListAsMap "query collections" _ccName $
|
||||
o .:? "query_collections" .!= []
|
||||
allowlist <- o .:? "allowlist" .!= HSIns.empty
|
||||
customTypes <- o .:? "custom_types" .!= emptyCustomTypes
|
||||
actions <- parseListAsMap "actions" _amName $ o .:? "actions" .!= []
|
||||
cronTriggers <- parseListAsMap "cron triggers" ctName $
|
||||
o .:? "cron_triggers" .!= []
|
||||
pure ( remoteSchemas, queryCollections, allowlist, customTypes
|
||||
, actions, cronTriggers
|
||||
)
|
||||
|
||||
-- | A complete GraphQL Engine metadata representation to be stored,
|
||||
-- exported/replaced via metadata queries.
|
||||
data Metadata
|
||||
= Metadata
|
||||
{ _mnsTables :: !Tables
|
||||
, _mnsFunctions :: !Functions
|
||||
, _mnsRemoteSchemas :: !RemoteSchemas
|
||||
, _mnsQueryCollections :: !QueryCollections
|
||||
, _mnsAllowlist :: !Allowlist
|
||||
, _mnsCustomTypes :: !CustomTypes
|
||||
, _mnsActions :: !Actions
|
||||
, _mnsCronTriggers :: !CronTriggers
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON Metadata where
|
||||
parseJSON = withObject "Object" $ \o -> do
|
||||
version <- o .:? "version" .!= MVVersion1
|
||||
tables <- parseListAsMap "tables" _tmTable $ o .: "tables"
|
||||
functions <-
|
||||
case version of
|
||||
MVVersion1 -> do
|
||||
functions <- parseListAsMap "functions" id $ o .:? "functions" .!= []
|
||||
pure $ flip OM.map functions $
|
||||
\function -> FunctionMetadata function emptyFunctionConfig
|
||||
MVVersion2 -> parseListAsMap "functions" _fmFunction $ o .:? "functions" .!= []
|
||||
(remoteSchemas, queryCollections, allowlist, customTypes,
|
||||
actions, cronTriggers) <- parseNonPostgresMetadata o
|
||||
pure $ Metadata tables functions remoteSchemas queryCollections
|
||||
allowlist customTypes actions cronTriggers
|
||||
|
||||
emptyMetadata :: Metadata
|
||||
emptyMetadata =
|
||||
Metadata mempty mempty mempty mempty mempty emptyCustomTypes mempty mempty
|
||||
|
||||
newtype MetadataModifier =
|
||||
MetadataModifier {unMetadataModifier :: Metadata -> Metadata}
|
||||
|
||||
instance Semigroup MetadataModifier where
|
||||
(MetadataModifier u1) <> (MetadataModifier u2) = MetadataModifier $ u2 . u1
|
||||
|
||||
instance Monoid MetadataModifier where
|
||||
mempty = MetadataModifier id
|
||||
|
||||
noMetadataModify :: MetadataModifier
|
||||
noMetadataModify = mempty
|
||||
|
||||
-- | Encode 'Metadata' to JSON with deterministic ordering. Ordering of object keys and array
|
||||
-- elements should remain consistent across versions of graphql-engine if possible!
|
||||
--
|
||||
-- Note: While modifying any part of the code below, make sure the encoded JSON of each type is
|
||||
-- parsable via its 'FromJSON' instance.
|
||||
metadataToOrdJSON :: Metadata -> AO.Value
|
||||
metadataToOrdJSON ( Metadata
|
||||
tables
|
||||
functions
|
||||
remoteSchemas
|
||||
queryCollections
|
||||
allowlist
|
||||
customTypes
|
||||
actions
|
||||
cronTriggers
|
||||
) = AO.object $ [versionPair, tablesPair] <>
|
||||
catMaybes [ functionsPair
|
||||
, remoteSchemasPair
|
||||
, queryCollectionsPair
|
||||
, allowlistPair
|
||||
, actionsPair
|
||||
, customTypesPair
|
||||
, cronTriggersPair
|
||||
]
|
||||
where
|
||||
versionPair = ("version", AO.toOrdered currentMetadataVersion)
|
||||
tablesPair = ("tables", AO.array $ map tableMetaToOrdJSON $ OM.elems tables)
|
||||
functionsPair = listToMaybeOrdPair "functions" functionMetadataToOrdJSON functions
|
||||
remoteSchemasPair = listToMaybeOrdPair "remote_schemas" remoteSchemaQToOrdJSON remoteSchemas
|
||||
queryCollectionsPair = listToMaybeOrdPair "query_collections" createCollectionToOrdJSON queryCollections
|
||||
allowlistPair = listToMaybeOrdPair "allowlist" AO.toOrdered allowlist
|
||||
customTypesPair = if customTypes == emptyCustomTypes then Nothing
|
||||
else Just ("custom_types", customTypesToOrdJSON customTypes)
|
||||
actionsPair = listToMaybeOrdPair "actions" actionMetadataToOrdJSON actions
|
||||
cronTriggersPair = listToMaybeOrdPair "cron_triggers" crontriggerQToOrdJSON cronTriggers
|
||||
|
||||
tableMetaToOrdJSON :: TableMetadata -> AO.Value
|
||||
tableMetaToOrdJSON ( TableMetadata
|
||||
table
|
||||
isEnum
|
||||
config
|
||||
objectRelationships
|
||||
arrayRelationships
|
||||
computedFields
|
||||
remoteRelationships
|
||||
insertPermissions
|
||||
selectPermissions
|
||||
updatePermissions
|
||||
deletePermissions
|
||||
eventTriggers
|
||||
) = AO.object $ [("table", AO.toOrdered table)]
|
||||
<> catMaybes [ isEnumPair
|
||||
, configPair
|
||||
, objectRelationshipsPair
|
||||
, arrayRelationshipsPair
|
||||
, computedFieldsPair
|
||||
, remoteRelationshipsPair
|
||||
, insertPermissionsPair
|
||||
, selectPermissionsPair
|
||||
, updatePermissionsPair
|
||||
, deletePermissionsPair
|
||||
, eventTriggersPair
|
||||
]
|
||||
where
|
||||
isEnumPair = if isEnum then Just ("is_enum", AO.toOrdered isEnum) else Nothing
|
||||
configPair = if config == emptyTableConfig then Nothing
|
||||
else Just ("configuration" , AO.toOrdered config)
|
||||
objectRelationshipsPair = listToMaybeOrdPair "object_relationships"
|
||||
relDefToOrdJSON objectRelationships
|
||||
arrayRelationshipsPair = listToMaybeOrdPair "array_relationships"
|
||||
relDefToOrdJSON arrayRelationships
|
||||
computedFieldsPair = listToMaybeOrdPair "computed_fields"
|
||||
computedFieldMetaToOrdJSON computedFields
|
||||
remoteRelationshipsPair = listToMaybeOrdPair "remote_relationships"
|
||||
AO.toOrdered remoteRelationships
|
||||
insertPermissionsPair = listToMaybeOrdPair "insert_permissions"
|
||||
insPermDefToOrdJSON insertPermissions
|
||||
selectPermissionsPair = listToMaybeOrdPair "select_permissions"
|
||||
selPermDefToOrdJSON selectPermissions
|
||||
updatePermissionsPair = listToMaybeOrdPair "update_permissions"
|
||||
updPermDefToOrdJSON updatePermissions
|
||||
deletePermissionsPair = listToMaybeOrdPair "delete_permissions"
|
||||
delPermDefToOrdJSON deletePermissions
|
||||
eventTriggersPair = listToMaybeOrdPair "event_triggers"
|
||||
eventTriggerConfToOrdJSON eventTriggers
|
||||
|
||||
relDefToOrdJSON :: (ToJSON a) => RelDef a -> AO.Value
|
||||
relDefToOrdJSON (RelDef name using comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("using", AO.toOrdered using)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
computedFieldMetaToOrdJSON :: ComputedFieldMetadata -> AO.Value
|
||||
computedFieldMetaToOrdJSON (ComputedFieldMetadata name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
insPermDefToOrdJSON :: InsPermDef 'Postgres -> AO.Value
|
||||
insPermDefToOrdJSON = permDefToOrdJSON insPermToOrdJSON
|
||||
where
|
||||
insPermToOrdJSON (InsPerm check set columns mBackendOnly) =
|
||||
let columnsPair = ("columns",) . AO.toOrdered <$> columns
|
||||
backendOnlyPair = ("backend_only",) . AO.toOrdered <$> mBackendOnly
|
||||
in AO.object $ [("check", AO.toOrdered check)]
|
||||
<> catMaybes [maybeSetToMaybeOrdPair set, columnsPair, backendOnlyPair]
|
||||
|
||||
selPermDefToOrdJSON :: SelPermDef 'Postgres -> AO.Value
|
||||
selPermDefToOrdJSON = permDefToOrdJSON selPermToOrdJSON
|
||||
where
|
||||
selPermToOrdJSON (SelPerm columns fltr limit allowAgg computedFieldsPerm) =
|
||||
AO.object $ catMaybes [ columnsPair
|
||||
, computedFieldsPermPair
|
||||
, filterPair
|
||||
, limitPair
|
||||
, allowAggPair
|
||||
]
|
||||
where
|
||||
columnsPair = Just ("columns", AO.toOrdered columns)
|
||||
computedFieldsPermPair = listToMaybeOrdPair "computed_fields" AO.toOrdered computedFieldsPerm
|
||||
filterPair = Just ("filter", AO.toOrdered fltr)
|
||||
limitPair = maybeAnyToMaybeOrdPair "limit" AO.toOrdered limit
|
||||
allowAggPair = if allowAgg
|
||||
then Just ("allow_aggregations", AO.toOrdered allowAgg)
|
||||
else Nothing
|
||||
|
||||
updPermDefToOrdJSON :: UpdPermDef 'Postgres -> AO.Value
|
||||
updPermDefToOrdJSON = permDefToOrdJSON updPermToOrdJSON
|
||||
where
|
||||
updPermToOrdJSON (UpdPerm columns set fltr check) =
|
||||
AO.object $ [ ("columns", AO.toOrdered columns)
|
||||
, ("filter", AO.toOrdered fltr)
|
||||
, ("check", AO.toOrdered check)
|
||||
] <> catMaybes [maybeSetToMaybeOrdPair set]
|
||||
|
||||
delPermDefToOrdJSON :: DelPermDef 'Postgres -> AO.Value
|
||||
delPermDefToOrdJSON = permDefToOrdJSON AO.toOrdered
|
||||
|
||||
permDefToOrdJSON :: (a -> AO.Value) -> PermDef a -> AO.Value
|
||||
permDefToOrdJSON permToOrdJSON (PermDef role permission comment) =
|
||||
AO.object $ [ ("role", AO.toOrdered role)
|
||||
, ("permission", permToOrdJSON permission)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
eventTriggerConfToOrdJSON :: EventTriggerConf -> AO.Value
|
||||
eventTriggerConfToOrdJSON (EventTriggerConf name definition webhook webhookFromEnv retryConf headers) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
, ("retry_conf", AO.toOrdered retryConf)
|
||||
] <> catMaybes [ maybeAnyToMaybeOrdPair "webhook" AO.toOrdered webhook
|
||||
, maybeAnyToMaybeOrdPair "webhook_from_env" AO.toOrdered webhookFromEnv
|
||||
, headers >>= listToMaybeOrdPair "headers" AO.toOrdered
|
||||
]
|
||||
|
||||
functionMetadataToOrdJSON :: FunctionMetadata -> AO.Value
|
||||
functionMetadataToOrdJSON FunctionMetadata{..} =
|
||||
AO.object $ [("function", AO.toOrdered _fmFunction)]
|
||||
<> if _fmConfiguration == emptyFunctionConfig then []
|
||||
else pure ("configuration", AO.toOrdered _fmConfiguration)
|
||||
|
||||
remoteSchemaQToOrdJSON :: AddRemoteSchemaQuery -> AO.Value
|
||||
remoteSchemaQToOrdJSON (AddRemoteSchemaQuery name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", remoteSchemaDefToOrdJSON definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
where
|
||||
remoteSchemaDefToOrdJSON :: RemoteSchemaDef -> AO.Value
|
||||
remoteSchemaDefToOrdJSON (RemoteSchemaDef url urlFromEnv headers frwrdClientHdrs timeout) =
|
||||
AO.object $ catMaybes [ maybeToPair "url" url
|
||||
, maybeToPair "url_from_env" urlFromEnv
|
||||
, maybeToPair "timeout_seconds" timeout
|
||||
, headers >>= listToMaybeOrdPair "headers" AO.toOrdered
|
||||
] <> [("forward_client_headers", AO.toOrdered frwrdClientHdrs) | frwrdClientHdrs]
|
||||
where
|
||||
maybeToPair n = maybeAnyToMaybeOrdPair n AO.toOrdered
|
||||
|
||||
createCollectionToOrdJSON :: CreateCollection -> AO.Value
|
||||
createCollectionToOrdJSON (CreateCollection name definition comment) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", AO.toOrdered definition)
|
||||
] <> catMaybes [maybeCommentToMaybeOrdPair comment]
|
||||
|
||||
crontriggerQToOrdJSON :: CronTriggerMetadata -> AO.Value
|
||||
crontriggerQToOrdJSON
|
||||
(CronTriggerMetadata name webhook schedule payload retryConf headers includeInMetadata comment) =
|
||||
AO.object $
|
||||
[ ("name", AO.toOrdered name)
|
||||
, ("webhook", AO.toOrdered webhook)
|
||||
, ("schedule", AO.toOrdered schedule)
|
||||
, ("include_in_metadata", AO.toOrdered includeInMetadata)
|
||||
]
|
||||
<> catMaybes
|
||||
[ maybeAnyToMaybeOrdPair "payload" AO.toOrdered payload
|
||||
, maybeAnyToMaybeOrdPair "retry_conf" AO.toOrdered (maybeRetryConfiguration retryConf)
|
||||
, maybeAnyToMaybeOrdPair "headers" AO.toOrdered (maybeHeader headers)
|
||||
, maybeAnyToMaybeOrdPair "comment" AO.toOrdered comment]
|
||||
where
|
||||
maybeRetryConfiguration retryConfig
|
||||
| retryConfig == defaultSTRetryConf = Nothing
|
||||
| otherwise = Just retryConfig
|
||||
|
||||
maybeHeader headerConfig
|
||||
| null headerConfig = Nothing
|
||||
| otherwise = Just headerConfig
|
||||
|
||||
customTypesToOrdJSON :: CustomTypes -> AO.Value
|
||||
customTypesToOrdJSON (CustomTypes inpObjs objs scalars enums) =
|
||||
AO.object . catMaybes $ [ listToMaybeOrdPair "input_objects" inputObjectToOrdJSON =<< inpObjs
|
||||
, listToMaybeOrdPair "objects" objectTypeToOrdJSON =<< objs
|
||||
, listToMaybeOrdPair "scalars" scalarTypeToOrdJSON =<< scalars
|
||||
, listToMaybeOrdPair "enums" enumTypeToOrdJSON =<< enums
|
||||
]
|
||||
where
|
||||
inputObjectToOrdJSON :: InputObjectTypeDefinition -> AO.Value
|
||||
inputObjectToOrdJSON (InputObjectTypeDefinition tyName descM fields) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("fields", AO.array $ map fieldDefinitionToOrdJSON $ toList fields)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
where
|
||||
fieldDefinitionToOrdJSON :: InputObjectFieldDefinition -> AO.Value
|
||||
fieldDefinitionToOrdJSON (InputObjectFieldDefinition fieldName fieldDescM ty) =
|
||||
AO.object $ [ ("name", AO.toOrdered fieldName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair fieldDescM]
|
||||
|
||||
objectTypeToOrdJSON :: ObjectType -> AO.Value
|
||||
objectTypeToOrdJSON (ObjectTypeDefinition tyName descM fields rels) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("fields", AO.array $ map fieldDefinitionToOrdJSON $ toList fields)
|
||||
]
|
||||
<> catMaybes [ maybeDescriptionToMaybeOrdPair descM
|
||||
, maybeAnyToMaybeOrdPair "relationships" AO.toOrdered rels
|
||||
]
|
||||
where
|
||||
fieldDefinitionToOrdJSON :: ObjectFieldDefinition GraphQLType -> AO.Value
|
||||
fieldDefinitionToOrdJSON (ObjectFieldDefinition fieldName argsValM fieldDescM ty) =
|
||||
AO.object $ [ ("name", AO.toOrdered fieldName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [ ("arguments", ) . AO.toOrdered <$> argsValM
|
||||
, maybeDescriptionToMaybeOrdPair fieldDescM
|
||||
]
|
||||
|
||||
scalarTypeToOrdJSON :: ScalarTypeDefinition -> AO.Value
|
||||
scalarTypeToOrdJSON (ScalarTypeDefinition tyName descM) =
|
||||
AO.object $ [("name", AO.toOrdered tyName)]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
|
||||
enumTypeToOrdJSON :: EnumTypeDefinition -> AO.Value
|
||||
enumTypeToOrdJSON (EnumTypeDefinition tyName descM values) =
|
||||
AO.object $ [ ("name", AO.toOrdered tyName)
|
||||
, ("values", AO.toOrdered values)
|
||||
]
|
||||
<> catMaybes [maybeDescriptionToMaybeOrdPair descM]
|
||||
|
||||
|
||||
actionMetadataToOrdJSON :: ActionMetadata -> AO.Value
|
||||
actionMetadataToOrdJSON (ActionMetadata name comment definition permissions) =
|
||||
AO.object $ [ ("name", AO.toOrdered name)
|
||||
, ("definition", actionDefinitionToOrdJSON definition)
|
||||
]
|
||||
<> catMaybes [ maybeCommentToMaybeOrdPair comment
|
||||
, listToMaybeOrdPair "permissions" permToOrdJSON permissions
|
||||
]
|
||||
where
|
||||
argDefinitionToOrdJSON :: ArgumentDefinition GraphQLType -> AO.Value
|
||||
argDefinitionToOrdJSON (ArgumentDefinition argName ty descM) =
|
||||
AO.object $ [ ("name", AO.toOrdered argName)
|
||||
, ("type", AO.toOrdered ty)
|
||||
]
|
||||
<> catMaybes [maybeAnyToMaybeOrdPair "description" AO.toOrdered descM]
|
||||
|
||||
actionDefinitionToOrdJSON :: ActionDefinitionInput -> AO.Value
|
||||
actionDefinitionToOrdJSON (ActionDefinition args outputType actionType
|
||||
headers frwrdClientHdrs timeout handler) =
|
||||
let typeAndKind = case actionType of
|
||||
ActionQuery -> [("type", AO.toOrdered ("query" :: String))]
|
||||
ActionMutation kind -> [ ("type", AO.toOrdered ("mutation" :: String))
|
||||
, ("kind", AO.toOrdered kind)]
|
||||
in
|
||||
AO.object $ [ ("handler", AO.toOrdered handler)
|
||||
, ("output_type", AO.toOrdered outputType)
|
||||
]
|
||||
<> [("forward_client_headers", AO.toOrdered frwrdClientHdrs) | frwrdClientHdrs]
|
||||
<> catMaybes [ listToMaybeOrdPair "headers" AO.toOrdered headers
|
||||
, listToMaybeOrdPair "arguments" argDefinitionToOrdJSON args]
|
||||
<> typeAndKind
|
||||
<> bool [("timeout",AO.toOrdered timeout)] mempty (timeout == defaultActionTimeoutSecs)
|
||||
|
||||
permToOrdJSON :: ActionPermissionMetadata -> AO.Value
|
||||
permToOrdJSON (ActionPermissionMetadata role permComment) =
|
||||
AO.object $ [("role", AO.toOrdered role)] <> catMaybes [maybeCommentToMaybeOrdPair permComment]
|
||||
|
||||
-- Utility functions
|
||||
listToMaybeOrdPair :: (Foldable t) => Text -> (a -> AO.Value) -> t a -> Maybe (Text, AO.Value)
|
||||
listToMaybeOrdPair name f ta = case toList ta of
|
||||
[] -> Nothing
|
||||
list -> Just $ (name,) $ AO.array $ map f list
|
||||
|
||||
maybeSetToMaybeOrdPair :: Maybe (ColumnValues Value) -> Maybe (Text, AO.Value)
|
||||
maybeSetToMaybeOrdPair set = set >>= \colVals -> if colVals == mempty then Nothing
|
||||
else Just ("set", AO.toOrdered colVals)
|
||||
|
||||
|
||||
maybeDescriptionToMaybeOrdPair :: Maybe G.Description -> Maybe (Text, AO.Value)
|
||||
maybeDescriptionToMaybeOrdPair = maybeAnyToMaybeOrdPair "description" AO.toOrdered
|
||||
|
||||
maybeCommentToMaybeOrdPair :: Maybe Text -> Maybe (Text, AO.Value)
|
||||
maybeCommentToMaybeOrdPair = maybeAnyToMaybeOrdPair "comment" AO.toOrdered
|
||||
|
||||
maybeAnyToMaybeOrdPair :: Text -> (a -> AO.Value) -> Maybe a -> Maybe (Text, AO.Value)
|
||||
maybeAnyToMaybeOrdPair name f = fmap ((name,) . f)
|
||||
|
||||
instance ToJSON Metadata where
|
||||
toJSON = AO.fromOrdered . metadataToOrdJSON
|
||||
|
||||
@ -1,23 +1,25 @@
|
||||
module Hasura.RQL.Types.Permission
|
||||
( PermType(..)
|
||||
, permTypeToCode
|
||||
, PermId(..)
|
||||
) where
|
||||
module Hasura.RQL.Types.Permission where
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types (PGCol, TableName, getTableTxt)
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.Types.Common
|
||||
import Hasura.RQL.Types.ComputedField
|
||||
import Hasura.RQL.Types.DML
|
||||
import Hasura.Session
|
||||
import Hasura.SQL.Backend
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.PG.Query as Q
|
||||
import qualified PostgreSQL.Binary.Decoding as PD
|
||||
|
||||
import Control.Lens (makeLenses)
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Data.Hashable
|
||||
import Instances.TH.Lift ()
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.Session
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.PG.Query as Q
|
||||
import qualified PostgreSQL.Binary.Decoding as PD
|
||||
|
||||
data PermType
|
||||
= PTInsert
|
||||
@ -62,7 +64,6 @@ instance FromJSON PermType where
|
||||
instance ToJSON PermType where
|
||||
toJSON = String . permTypeToCode
|
||||
|
||||
-- FIXME: qualify per backend
|
||||
data PermId
|
||||
= PermId
|
||||
{ pidTable :: !TableName
|
||||
@ -79,3 +80,109 @@ instance Show PermId where
|
||||
, "."
|
||||
, T.pack $ show pType
|
||||
]
|
||||
|
||||
data PermColSpec
|
||||
= PCStar
|
||||
| PCCols ![PGCol]
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable PermColSpec
|
||||
|
||||
instance FromJSON PermColSpec where
|
||||
parseJSON (String "*") = return PCStar
|
||||
parseJSON x = PCCols <$> parseJSON x
|
||||
|
||||
instance ToJSON PermColSpec where
|
||||
toJSON (PCCols cols) = toJSON cols
|
||||
toJSON PCStar = "*"
|
||||
|
||||
data PermDef a =
|
||||
PermDef
|
||||
{ _pdRole :: !RoleName
|
||||
, _pdPermission :: !a
|
||||
, _pdComment :: !(Maybe T.Text)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance (Cacheable a) => Cacheable (PermDef a)
|
||||
$(deriveFromJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''PermDef)
|
||||
$(makeLenses ''PermDef)
|
||||
|
||||
instance (ToJSON a) => ToJSON (PermDef a) where
|
||||
toJSON = object . toAesonPairs
|
||||
|
||||
instance (ToJSON a) => ToAesonPairs (PermDef a) where
|
||||
toAesonPairs (PermDef rn perm comment) =
|
||||
[ "role" .= rn
|
||||
, "permission" .= perm
|
||||
, "comment" .= comment
|
||||
]
|
||||
|
||||
-- Insert permission
|
||||
data InsPerm (b :: Backend)
|
||||
= InsPerm
|
||||
{ ipCheck :: !(BoolExp b)
|
||||
, ipSet :: !(Maybe (ColumnValues Value))
|
||||
, ipColumns :: !(Maybe PermColSpec)
|
||||
, ipBackendOnly :: !(Maybe Bool) -- see Note [Backend only permissions]
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (InsPerm 'Postgres)
|
||||
instance FromJSON (InsPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON (aesonDrop 2 snakeCase){omitNothingFields=True}
|
||||
instance ToJSON (InsPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase){omitNothingFields=True}
|
||||
|
||||
type InsPermDef b = PermDef (InsPerm b)
|
||||
|
||||
-- Select constraint
|
||||
data SelPerm (b :: Backend)
|
||||
= SelPerm
|
||||
{ spColumns :: !PermColSpec -- ^ Allowed columns
|
||||
, spFilter :: !(BoolExp b) -- ^ Filter expression
|
||||
, spLimit :: !(Maybe Int) -- ^ Limit value
|
||||
, spAllowAggregations :: !Bool -- ^ Allow aggregation
|
||||
, spComputedFields :: ![ComputedFieldName] -- ^ Allowed computed fields
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (SelPerm 'Postgres)
|
||||
instance ToJSON (SelPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
instance FromJSON (SelPerm 'Postgres) where
|
||||
parseJSON = withObject "SelPerm" $ \o ->
|
||||
SelPerm
|
||||
<$> o .: "columns"
|
||||
<*> o .: "filter"
|
||||
<*> o .:? "limit"
|
||||
<*> o .:? "allow_aggregations" .!= False
|
||||
<*> o .:? "computed_fields" .!= []
|
||||
|
||||
type SelPermDef b = PermDef (SelPerm b)
|
||||
|
||||
-- Delete permission
|
||||
data DelPerm (b :: Backend)
|
||||
= DelPerm { dcFilter :: !(BoolExp b) }
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (DelPerm 'Postgres)
|
||||
instance FromJSON (DelPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON $ aesonDrop 2 snakeCase
|
||||
instance ToJSON (DelPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase) {omitNothingFields=True}
|
||||
|
||||
type DelPermDef b = PermDef (DelPerm b)
|
||||
|
||||
-- Update constraint
|
||||
data UpdPerm (b :: Backend)
|
||||
= UpdPerm
|
||||
{ ucColumns :: !PermColSpec -- Allowed columns
|
||||
, ucSet :: !(Maybe (ColumnValues Value)) -- Preset columns
|
||||
, ucFilter :: !(BoolExp b) -- Filter expression (applied before update)
|
||||
, ucCheck :: !(Maybe (BoolExp b))
|
||||
-- ^ Check expression, which must be true after update.
|
||||
-- This is optional because we don't want to break the v1 API
|
||||
-- but Nothing should be equivalent to the expression which always
|
||||
-- returns true.
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable (UpdPerm 'Postgres)
|
||||
instance FromJSON (UpdPerm 'Postgres) where
|
||||
parseJSON = genericParseJSON (aesonDrop 2 snakeCase){omitNothingFields=True}
|
||||
instance ToJSON (UpdPerm 'Postgres) where
|
||||
toJSON = genericToJSON (aesonDrop 2 snakeCase){omitNothingFields=True}
|
||||
|
||||
type UpdPermDef b = PermDef (UpdPerm b)
|
||||
|
||||
@ -149,5 +149,5 @@ $(deriveJSON (aesonDrop 5 snakeCase) ''DropQueryFromCollection)
|
||||
newtype CollectionReq
|
||||
= CollectionReq
|
||||
{_crCollection :: CollectionName}
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
deriving (Show, Eq, Lift, Generic, Hashable)
|
||||
$(deriveJSON (aesonDrop 3 snakeCase) ''CollectionReq)
|
||||
|
||||
@ -1,26 +1,29 @@
|
||||
module Hasura.RQL.DDL.Relationship.Types where
|
||||
module Hasura.RQL.Types.Relationship where
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.Prelude
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
import Control.Lens (makeLenses)
|
||||
import Data.Aeson.Casing
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
import Hasura.RQL.Types.Common
|
||||
import Instances.TH.Lift ()
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import Hasura.Backends.Postgres.SQL.Types
|
||||
import Hasura.RQL.Types
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
|
||||
data RelDef a
|
||||
= RelDef
|
||||
{ rdName :: !RelName
|
||||
, rdUsing :: !a
|
||||
, rdComment :: !(Maybe Text)
|
||||
{ _rdName :: !RelName
|
||||
, _rdUsing :: !a
|
||||
, _rdComment :: !(Maybe T.Text)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
|
||||
$(deriveFromJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''RelDef)
|
||||
instance (Cacheable a) => Cacheable (RelDef a)
|
||||
$(deriveFromJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''RelDef)
|
||||
$(makeLenses ''RelDef)
|
||||
|
||||
instance (ToJSON a) => ToJSON (RelDef a) where
|
||||
toJSON = object . toAesonPairs
|
||||
@ -37,6 +40,7 @@ data RelManualConfig
|
||||
{ rmTable :: !QualifiedTable
|
||||
, rmColumns :: !(HashMap PGCol PGCol)
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable RelManualConfig
|
||||
|
||||
instance FromJSON RelManualConfig where
|
||||
parseJSON (Object v) =
|
||||
@ -57,6 +61,7 @@ data RelUsing a
|
||||
= RUFKeyOn !a
|
||||
| RUManual !RelManualConfig
|
||||
deriving (Show, Eq, Lift, Generic)
|
||||
instance (Cacheable a) => Cacheable (RelUsing a)
|
||||
|
||||
instance (ToJSON a) => ToJSON (RelUsing a) where
|
||||
toJSON (RUFKeyOn fkey) =
|
||||
@ -82,6 +87,7 @@ data ArrRelUsingFKeyOn
|
||||
{ arufTable :: !QualifiedTable
|
||||
, arufColumn :: !PGCol
|
||||
} deriving (Show, Eq, Lift, Generic)
|
||||
instance Cacheable ArrRelUsingFKeyOn
|
||||
|
||||
$(deriveJSON (aesonDrop 4 snakeCase){omitNothingFields=True} ''ArrRelUsingFKeyOn)
|
||||
|
||||
@ -97,19 +103,30 @@ data DropRel
|
||||
= DropRel
|
||||
{ drTable :: !QualifiedTable
|
||||
, drRelationship :: !RelName
|
||||
, drCascade :: !(Maybe Bool)
|
||||
, drCascade :: !Bool
|
||||
} deriving (Show, Eq, Lift)
|
||||
$(deriveToJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DropRel)
|
||||
|
||||
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DropRel)
|
||||
instance FromJSON DropRel where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
DropRel
|
||||
<$> o .: "table"
|
||||
<*> o .: "relationship"
|
||||
<*> o .:? "cascade" .!= False
|
||||
|
||||
data SetRelComment
|
||||
= SetRelComment
|
||||
{ arTable :: !QualifiedTable
|
||||
, arRelationship :: !RelName
|
||||
, arComment :: !(Maybe Text)
|
||||
, arComment :: !(Maybe T.Text)
|
||||
} deriving (Show, Eq, Lift)
|
||||
|
||||
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SetRelComment)
|
||||
$(deriveToJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SetRelComment)
|
||||
instance FromJSON SetRelComment where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
SetRelComment
|
||||
<$> o .: "table"
|
||||
<*> o .: "relationship"
|
||||
<*> o .:? "comment"
|
||||
|
||||
data RenameRel
|
||||
= RenameRel
|
||||
@ -117,5 +134,11 @@ data RenameRel
|
||||
, rrName :: !RelName
|
||||
, rrNewName :: !RelName
|
||||
} deriving (Show, Eq, Lift)
|
||||
$(deriveToJSON (aesonDrop 2 snakeCase) ''RenameRel)
|
||||
|
||||
$(deriveJSON (aesonDrop 2 snakeCase) ''RenameRel)
|
||||
instance FromJSON RenameRel where
|
||||
parseJSON = withObject "Object" $ \o ->
|
||||
RenameRel
|
||||
<$> o .: "table"
|
||||
<*> o .: "name"
|
||||
<*> o .: "new_name"
|
||||
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Hasura.RQL.Types.RemoteRelationship
|
||||
( RemoteRelationshipName(..)
|
||||
@ -266,6 +266,7 @@ data RemoteRelationshipDef
|
||||
, _rrdHasuraFields :: !(Set FieldName)
|
||||
, _rrdRemoteField :: !RemoteFields
|
||||
} deriving (Show, Eq, Generic, Lift)
|
||||
instance Cacheable RemoteRelationshipDef
|
||||
$(deriveJSON (aesonDrop 4 snakeCase) ''RemoteRelationshipDef)
|
||||
|
||||
data DeleteRemoteRelationship =
|
||||
|
||||
@ -226,7 +226,6 @@ incSchemaCacheVer :: SchemaCacheVer -> SchemaCacheVer
|
||||
incSchemaCacheVer (SchemaCacheVer prev) =
|
||||
SchemaCacheVer $ prev + 1
|
||||
|
||||
type FunctionCache = M.HashMap QualifiedFunction FunctionInfo -- info of all functions
|
||||
type ActionCache = M.HashMap ActionName (ActionInfo 'Postgres) -- info of all actions
|
||||
|
||||
data SchemaCache
|
||||
|
||||
@ -106,9 +106,9 @@ import Hasura.RQL.Types.Error
|
||||
import Hasura.RQL.Types.EventTrigger
|
||||
import Hasura.RQL.Types.Permission
|
||||
import Hasura.RQL.Types.RemoteRelationship
|
||||
import Hasura.SQL.Backend
|
||||
import Hasura.Server.Utils (duplicates, englishList)
|
||||
import Hasura.Session
|
||||
import Hasura.SQL.Backend
|
||||
|
||||
|
||||
data TableCustomRootFields
|
||||
|
||||
@ -115,7 +115,7 @@ data RQLQueryV1
|
||||
|
||||
| RQRunSql !RunSQL
|
||||
|
||||
| RQReplaceMetadata !ReplaceMetadata
|
||||
| RQReplaceMetadata !Metadata
|
||||
| RQExportMetadata !ExportMetadata
|
||||
| RQClearMetadata !ClearMetadata
|
||||
| RQReloadMetadata !ReloadMetadata
|
||||
|
||||
@ -9,15 +9,15 @@ import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Hasura.EncJSON
|
||||
import Hasura.RQL.DDL.Metadata.Generator (genReplaceMetadata)
|
||||
import Hasura.RQL.DDL.Metadata.Types (ReplaceMetadata, replaceMetadataToOrdJSON)
|
||||
import Hasura.RQL.DDL.Metadata.Generator (genMetadata)
|
||||
import Hasura.RQL.Types.Metadata (Metadata, metadataToOrdJSON)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "replaceMetadataToOrdJSON" $ do
|
||||
it "produces JSON that can be parsed by the FromJSON instance for ReplaceMetadata" $
|
||||
spec = describe "metadataToOrdJSON" $ do
|
||||
it "produces JSON that can be parsed by the FromJSON instance for Metadata" $
|
||||
withMaxSuccess 20 $
|
||||
forAll (resize 3 genReplaceMetadata) $ \metadata ->
|
||||
let encodedString = encJToBS $ AO.toEncJSON $ replaceMetadataToOrdJSON metadata
|
||||
in case eitherDecodeStrict @ReplaceMetadata encodedString of
|
||||
forAll (resize 3 genMetadata) $ \metadata ->
|
||||
let encodedString = encJToBS $ AO.toEncJSON $ metadataToOrdJSON metadata
|
||||
in case eitherDecodeStrict @Metadata encodedString of
|
||||
Left err -> counterexample err False
|
||||
Right _ -> property True
|
||||
|
||||
Loading…
Reference in New Issue
Block a user