hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-09-21 23:47:17 +03:00
Code Issues Projects Releases Wiki Activity

refactor to remove warnings especially with orphan instances (#1163)

Browse Source 
* remove phase one/two distinction and hdbquery typeclass

* move extensions to default-extensions

* switch to LazyTx which only acquires a connection if needed

* move defns from TH module into Ops module

* remove tojson orphan instance for http exception

* remove orphan instance for dmlp1

* getTopLevelNodes will not throw any exceptions
This commit is contained in:
Vamshi Surabhi 2018-12-13 12:56:15 +05:30 committed by GitHub
parent b76039b6be
commit ec8b2c80b5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
91 changed files with 1478 additions and 1548 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

294
console/src/components/Services/Data/TablePermissions/Permissions.js
View File

@ -460,21 +460,21 @@ class Permissions extends Component {
const bulkSelect = permsState.bulkSelect;
const currentInputSelection = bulkSelect.filter(e => e === role)
.length ? (
<input
onChange={dispatchBulkSelect}
checked="checked"
data-role={role}
className={styles.bulkSelect}
type="checkbox"
/>
) : (
<input
onChange={dispatchBulkSelect}
data-role={role}
className={styles.bulkSelect}
type="checkbox"
/>
);
<input
onChange={dispatchBulkSelect}
checked="checked"
data-role={role}
className={styles.bulkSelect}
type="checkbox"
/>
) : (
<input
onChange={dispatchBulkSelect}
data-role={role}
className={styles.bulkSelect}
type="checkbox"
/>
);
_permissionsRowHtml.push(
<td key={-1}>
<div>
@ -770,164 +770,164 @@ class Permissions extends Component {
const setOptions =
insertState && insertState.localSet && insertState.localSet.length > 0
? insertState.localSet.map((s, i) => {
return (
<div className={styles.insertSetConfigRow} key={i}>
<div
className={
styles.display_inline +
return (
<div className={styles.insertSetConfigRow} key={i}>
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
}
>
<select
className="input-sm form-control"
value={s.key}
onChange={this.onSetKeyChange.bind(this)}
data-index-id={i}
disabled={disableInput}
>
<select
className="input-sm form-control"
value={s.key}
onChange={this.onSetKeyChange.bind(this)}
data-index-id={i}
disabled={disableInput}
>
<option value="" disabled>
<option value="" disabled>
Column Name
</option>
{columns && columns.length > 0
? columns.map((c, key) => (
<option
value={c.column_name}
data-column-type={c.data_type}
key={key}
>
{c.column_name}
</option>
))
: null}
</select>
</div>
<div
className={
styles.display_inline +
</option>
{columns && columns.length > 0
? columns.map((c, key) => (
<option
value={c.column_name}
data-column-type={c.data_type}
key={key}
>
{c.column_name}
</option>
))
: null}
</select>
</div>
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
}
>
<select
className="input-sm form-control"
onChange={this.onSetTypeChange.bind(this)}
data-index-id={i}
value={setConfigValueType(s.value) || ''}
disabled={disableInput}
>
<select
className="input-sm form-control"
onChange={this.onSetTypeChange.bind(this)}
data-index-id={i}
value={setConfigValueType(s.value) || ''}
disabled={disableInput}
>
<option value="" disabled>
<option value="" disabled>
Select Preset Type
</option>
<option value="static">static</option>
<option value="session">from session variable</option>
</select>
</div>
<div
className={
styles.display_inline +
</option>
<option value="static">static</option>
<option value="session">from session variable</option>
</select>
</div>
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
>
{setConfigValueType(s.value) === 'session' ? (
<InputGroup>
<InputGroup.Addon>X-Hasura-</InputGroup.Addon>
<input
className={'input-sm form-control '}
placeholder="column_value"
value={s.value.slice(X_HASURA_CONST.length)}
onChange={this.onSetValueChange.bind(this)}
onBlur={e => this.onSetValueBlur(e, i, null)}
data-index-id={i}
data-prefix-val={X_HASURA_CONST}
disabled={disableInput}
/>
</InputGroup>
) : (
<EnhancedInput
}
>
{setConfigValueType(s.value) === 'session' ? (
<InputGroup>
<InputGroup.Addon>X-Hasura-</InputGroup.Addon>
<input
className={'input-sm form-control '}
placeholder="column_value"
type={
i in this.state.insertSetOperations.columnTypeMap
? this.state.insertSetOperations.columnTypeMap[i]
: ''
}
value={s.value}
value={s.value.slice(X_HASURA_CONST.length)}
onChange={this.onSetValueChange.bind(this)}
onBlur={this.onSetValueBlur}
indexId={i}
onBlur={e => this.onSetValueBlur(e, i, null)}
data-index-id={i}
data-prefix-val={X_HASURA_CONST}
disabled={disableInput}
/>
)}
</div>
{setConfigValueType(s.value) === 'session' ? (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper +
' ' +
styles.e_g_text
}
>
e.g. X-Hasura-User-Id
</div>
</InputGroup>
) : (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper +
' ' +
styles.e_g_text
}
>
e.g. false, 1, some-text
</div>
)}
{i !== insertState.localSet.length - 1 ? (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
>
<i
className="fa-lg fa fa-times"
onClick={
!disableInput ? this.deleteSetKeyVal.bind(this) : ''
}
data-index-id={i}
/>
</div>
) : (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
<EnhancedInput
placeholder="column_value"
type={
i in this.state.insertSetOperations.columnTypeMap
? this.state.insertSetOperations.columnTypeMap[i]
: ''
}
value={s.value}
onChange={this.onSetValueChange.bind(this)}
onBlur={this.onSetValueBlur}
indexId={i}
data-prefix-val={X_HASURA_CONST}
disabled={disableInput}
/>
)}
</div>
);
})
{setConfigValueType(s.value) === 'session' ? (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper +
' ' +
styles.e_g_text
}
>
e.g. X-Hasura-User-Id
</div>
) : (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper +
' ' +
styles.e_g_text
}
>
e.g. false, 1, some-text
</div>
)}
{i !== insertState.localSet.length - 1 ? (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
>
<i
className="fa-lg fa fa-times"
onClick={
!disableInput ? this.deleteSetKeyVal.bind(this) : ''
}
data-index-id={i}
/>
</div>
) : (
<div
className={
styles.display_inline +
' ' +
styles.add_mar_right +
' ' +
styles.input_element_wrapper
}
/>
)}
</div>
);
})
: null;
return (

249
server/.stylish-haskell.yaml Normal file
View File

@ -0,0 +1,249 @@
# stylish-haskell configuration file
# ==================================
# The stylish-haskell tool is mainly configured by specifying steps. These steps
# are a list, so they have an order, and one specific step may appear more than
# once (if needed). Each file is processed by these steps in the given order.
steps:
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
# by default.
# - unicode_syntax:
# # In order to make this work, we also need to insert the UnicodeSyntax
# # language pragma. If this flag is set to true, we insert it when it's
# # not already present. You may want to disable it if you configure
# # language extensions using some other method than pragmas. Default:
# # true.
# add_language_pragma: true
# Align the right hand side of some elements. This is quite conservative
# and only applies to statements where each element occupies a single
# line.
- simple_align:
cases: true
top_level_patterns: true
records: true
# Import cleanup
- imports:
# There are different ways we can align names and lists.
#
# - global: Align the import names and import list throughout the entire
# file.
#
# - file: Like global, but don't add padding when there are no qualified
# imports in the file.
#
# - group: Only align the imports per group (a group is formed by adjacent
# import lines).
#
# - none: Do not perform any alignment.
#
# Default: global.
align: global
# The following options affect only import list alignment.
#
# List align has following options:
#
# - after_alias: Import list is aligned with end of import including
# 'as' and 'hiding' keywords.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_alias: Import list is aligned with start of alias or hiding.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - new_line: Import list starts always on new line.
#
# > import qualified Data.List as List
# > (concat, foldl, foldr, head, init, last, length)
#
# Default: after_alias
list_align: after_alias
# Right-pad the module names to align imports in a group:
#
# - true: a little more readable
#
# > import qualified Data.List as List (concat, foldl, foldr,
# > init, last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# - false: diff-safe
#
# > import qualified Data.List as List (concat, foldl, foldr, init,
# > last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# Default: true
pad_module_names: true
# Long list align style takes effect when import is too long. This is
# determined by 'columns' setting.
#
# - inline: This option will put as much specs on same line as possible.
#
# - new_line: Import list will start on new line.
#
# - new_line_multiline: Import list will start on new line when it's
# short enough to fit to single line. Otherwise it'll be multiline.
#
# - multiline: One line per import list entry.
# Type with constructor list acts like single import.
#
# > import qualified Data.Map as M
# > ( empty
# > , singleton
# > , ...
# > , delete
# > )
#
# Default: inline
long_list_align: inline
# Align empty list (importing instances)
#
# Empty list align has following options
#
# - inherit: inherit list_align setting
#
# - right_after: () is right after the module name:
#
# > import Vector.Instances ()
#
# Default: inherit
empty_list_align: inherit
# List padding determines indentation of import list on lines after import.
# This option affects 'long_list_align'.
#
# - <integer>: constant value
#
# - module_name: align under start of module name.
# Useful for 'file' and 'group' align settings.
list_padding: 4
# Separate lists option affects formatting of import list for type
# or class. The only difference is single space between type and list
# of constructors, selectors and class functions.
#
# - true: There is single space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable (fold, foldl, foldMap))
#
# - false: There is no space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable(fold, foldl, foldMap))
#
# Default: true
separate_lists: true
# Space surround option affects formatting of import lists on a single
# line. The only difference is single space after the initial
# parenthesis and a single space before the terminal parenthesis.
#
# - true: There is single space associated with the enclosing
# parenthesis.
#
# > import Data.Foo ( foo )
#
# - false: There is no space associated with the enclosing parenthesis
#
# > import Data.Foo (foo)
#
# Default: false
space_surround: false
# Language pragmas
- language_pragmas:
# We can generate different styles of language pragma lists.
#
# - vertical: Vertical-spaced language pragmas, one per line.
#
# - compact: A more compact style.
#
# - compact_line: Similar to compact, but wrap each line with
# `{-#LANGUAGE #-}'.
#
# Default: vertical.
style: vertical
# Align affects alignment of closing pragma brackets.
#
# - true: Brackets are aligned in same column.
#
# - false: Brackets are not aligned together. There is only one space
# between actual import and closing bracket.
#
# Default: true
align: true
# stylish-haskell can detect redundancy of some language pragmas. If this
# is set to true, it will remove those redundant pragmas. Default: true.
remove_redundant: true
# Replace tabs by spaces. This is disabled by default.
# - tabs:
# # Number of spaces to use for each tab. Default: 8, as specified by the
# # Haskell report.
# spaces: 8
# Remove trailing whitespace
- trailing_whitespace: {}
# Squash multiple spaces between the left and right hand sides of some
# elements into single spaces. Basically, this undoes the effect of
# simple_align but is a bit less conservative.
# - squash: {}
# A common setting is the number of columns (parts of) code will be wrapped
# to. Different steps take this into account. Default: 80.
columns: 80
# By default, line endings are converted according to the OS. You can override
# preferred format here.
#
# - native: Native newline format. CRLF on Windows, LF on other OSes.
#
# - lf: Convert to LF ("\n").
#
# - crlf: Convert to CRLF ("\r\n").
#
# Default: native.
newline: native
# Sometimes, language extensions are specified in a cabal file or from the
# command line instead of using language pragmas in the file. stylish-haskell
# needs to be aware of these, so it can parse the file correctly.
#
# No language extensions are enabled by default.
language_extensions:
- TemplateHaskell
- QuasiQuotes
- EmptyCase
- FlexibleContexts
- FlexibleInstances
- InstanceSigs
- MultiParamTypeClasses
- LambdaCase
- MultiWayIf
- TupleSections
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- GeneralizedNewtypeDeriving
- BangPatterns
- OverloadedStrings
- ScopedTypeVariables
- TemplateHaskell
- QuasiQuotes
- TypeFamilies

57
server/graphql-engine.cabal
View File

@ -23,7 +23,6 @@ flag developer
manual: True
library
default-extensions: NoImplicitPrelude
hs-source-dirs: src-lib
, src-exec
default-language: Haskell2010
@ -207,7 +206,7 @@ library
, Hasura.Events.Lib
, Hasura.Events.HTTP
, Hasura.HTTP.Utils
, Hasura.HTTP
, Data.Text.Extended
, Data.Sequence.NonEmpty
@ -224,19 +223,66 @@ library
, Hasura.Logging
, Network.URI.Extended
, Ops
, TH
other-modules: Hasura.Server.Auth.JWT.Internal
, Hasura.Server.Auth.JWT.Logging
default-extensions: EmptyCase
FlexibleContexts
FlexibleInstances
InstanceSigs
MultiParamTypeClasses
LambdaCase
MultiWayIf
TupleSections
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveLift
DeriveTraversable
GeneralizedNewtypeDeriving
BangPatterns
OverloadedStrings
ScopedTypeVariables
TemplateHaskell
QuasiQuotes
TypeFamilies
NoImplicitPrelude
if flag(developer)
ghc-prof-options: -rtsopts -fprof-auto -fno-prof-count-entries
ghc-options: -O2 -Wall
ghc-options: -O2
-Wall
-Wcompat
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wredundant-constraints
executable graphql-engine
default-extensions: NoImplicitPrelude
default-extensions: EmptyCase
FlexibleContexts
FlexibleInstances
InstanceSigs
MultiParamTypeClasses
LambdaCase
MultiWayIf
TupleSections
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveLift
DeriveTraversable
GeneralizedNewtypeDeriving
BangPatterns
OverloadedStrings
ScopedTypeVariables
TemplateHaskell
QuasiQuotes
TypeFamilies
NoImplicitPrelude
main-is: Main.hs
default-language: Haskell2010
hs-source-dirs: src-exec
@ -261,7 +307,6 @@ executable graphql-engine
, string-conversions
other-modules: Ops
TH
if flag(developer)
ghc-prof-options: -rtsopts -fprof-auto -fno-prof-count-entries

21
server/src-exec/Main.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Ops
@ -27,11 +23,13 @@ import Hasura.Events.Lib
import Hasura.Logging (defaultLoggerSettings, mkLoggerCtx)
import Hasura.Prelude
import Hasura.RQL.DDL.Metadata (fetchMetadata)
import Hasura.RQL.Types (RoleName (..))
import Hasura.RQL.Types (RoleName (..), adminUserInfo, QErr,
emptySchemaCache)
import Hasura.Server.App (mkWaiApp)
import Hasura.Server.Auth
import Hasura.Server.CheckUpdates (checkForUpdates)
import Hasura.Server.Init
import Hasura.Server.Query (peelRun)
import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client.TLS as TLS
@ -190,22 +188,29 @@ main = do
either ((>> exitFailure) . printJSON) (const cleanSuccess) res
ROExecute -> do
queryBs <- BL.getContents
res <- runTx ci $ execQuery httpManager queryBs
res <- runAsAdmin ci httpManager $ execQuery queryBs
either ((>> exitFailure) . printJSON) BLC.putStrLn res
where
runTx :: Q.ConnInfo -> Q.TxE QErr a -> IO (Either QErr a)
runTx ci tx = do
pool <- getMinimalPool ci
runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx
runAsAdmin ci httpManager m = do
pool <- getMinimalPool ci
res <- runExceptT $ peelRun emptySchemaCache adminUserInfo
httpManager pool Q.Serializable m
return $ fmap fst res
getMinimalPool ci = do
let connParams = Q.defaultConnParams { Q.cpConns = 1 }
Q.initPGPool ci connParams
initialise ci httpMgr = do
currentTime <- getCurrentTime
res <- runTx ci $ initCatalogSafe currentTime httpMgr
res <- runAsAdmin ci httpMgr $ initCatalogSafe currentTime
either ((>> exitFailure) . printJSON) putStrLn res
migrate ci httpMgr = do
currentTime <- getCurrentTime
res <- runTx ci $ migrateCatalog httpMgr currentTime
res <- runAsAdmin ci httpMgr $ migrateCatalog currentTime
either ((>> exitFailure) . printJSON) putStrLn res
prepareEvents ci = do
putStrLn "event_triggers: preparing data"

149
server/src-exec/Ops.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Ops
( initCatalogSafe
, cleanCatalog
@ -12,7 +6,7 @@ module Ops
) where
import Data.Time.Clock (UTCTime)
import TH
import Language.Haskell.TH.Syntax (Q, TExp, unTypeQ)
import Hasura.Prelude
import Hasura.RQL.DDL.Schema.Table
@ -24,25 +18,27 @@ import Hasura.SQL.Types
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Yaml.TH as Y
import qualified Database.PG.Query as Q
import qualified Database.PG.Query.Connection as Q
import qualified Network.HTTP.Client as HTTP
curCatalogVer :: T.Text
curCatalogVer = "6"
initCatalogSafe :: UTCTime -> HTTP.Manager -> Q.TxE QErr String
initCatalogSafe initTime httpMgr = do
hdbCatalogExists <- Q.catchE defaultTxErrorHandler $
initCatalogSafe
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> UTCTime -> m String
initCatalogSafe initTime = do
hdbCatalogExists <- liftTx $ Q.catchE defaultTxErrorHandler $
doesSchemaExist $ SchemaName "hdb_catalog"
bool (initCatalogStrict True initTime httpMgr) onCatalogExists hdbCatalogExists
bool (initCatalogStrict True initTime) onCatalogExists hdbCatalogExists
where
onCatalogExists = do
versionExists <- Q.catchE defaultTxErrorHandler $
versionExists <- liftTx $ Q.catchE defaultTxErrorHandler $
doesVersionTblExist
(SchemaName "hdb_catalog") (TableName "hdb_version")
bool (initCatalogStrict False initTime httpMgr) (return initialisedMsg) versionExists
bool (initCatalogStrict False initTime) (return initialisedMsg) versionExists
initialisedMsg = "initialise: the state is already initialised"
@ -63,36 +59,38 @@ initCatalogSafe initTime httpMgr = do
)
|] (Identity sn) False
initCatalogStrict :: Bool -> UTCTime -> HTTP.Manager -> Q.TxE QErr String
initCatalogStrict createSchema initTime httpMgr = do
Q.catchE defaultTxErrorHandler $
initCatalogStrict
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> Bool -> UTCTime -> m String
initCatalogStrict createSchema initTime = do
liftTx $ Q.catchE defaultTxErrorHandler $
when createSchema $ do
Q.unitQ "CREATE SCHEMA hdb_catalog" () False
-- This is where the generated views and triggers are stored
Q.unitQ "CREATE SCHEMA hdb_views" () False
pgcryptoExtExists <- Q.catchE defaultTxErrorHandler $ isExtAvailable "pgcrypto"
pgcryptoExtExists <- liftTx $
Q.catchE defaultTxErrorHandler $ isExtAvailable "pgcrypto"
if pgcryptoExtExists
-- only if we created the schema, create the extension
then when createSchema $
Q.unitQE needsPgCryptoExt
"CREATE EXTENSION IF NOT EXISTS pgcrypto SCHEMA public" () False
then when createSchema $ liftTx $ Q.unitQE needsPgCryptoExt
"CREATE EXTENSION IF NOT EXISTS pgcrypto SCHEMA public" () False
else throw500 "FATAL: Could not find extension pgcrytpo. This extension is required."
Q.catchE defaultTxErrorHandler $ do
liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.Discard () <- Q.multiQ $(Q.sqlFromFile "src-rsr/initialise.sql")
return ()
-- Build the metadata query
tx <- liftEither $ buildTxAny adminUserInfo emptySchemaCache httpMgr metadataQuery
-- add default metadata
void $ runQueryM metadataQuery
-- Execute the query
void $ snd <$> tx
setAllAsSystemDefined >> addVersion initTime
return "initialise: successfully initialised"
where
metadataQuery =
$(unTypeQ (Y.decodeFile "src-rsr/hdb_metadata.yaml" :: Q (TExp RQLQuery)))
needsPgCryptoExt :: Q.PGTxErr -> QErr
needsPgCryptoExt e@(Q.PGTxErr _ _ _ err) =
case err of
@ -102,7 +100,7 @@ initCatalogStrict createSchema initTime httpMgr = do
Just "42501" -> err500 PostgresError pgcryptoPermsMsg
_ -> (err500 PostgresError pgcryptoReqdMsg) { qeInternal = Just $ A.toJSON e }
addVersion modTime = Q.catchE defaultTxErrorHandler $
addVersion modTime = liftTx $ Q.catchE defaultTxErrorHandler $
Q.unitQ [Q.sql|
INSERT INTO "hdb_catalog"."hdb_version" VALUES ($1, $2)
|] (curCatalogVer, modTime) False
@ -118,15 +116,16 @@ initCatalogStrict createSchema initTime httpMgr = do
|] (Identity sn) False
setAllAsSystemDefined :: Q.TxE QErr ()
setAllAsSystemDefined = Q.catchE defaultTxErrorHandler $ do
setAllAsSystemDefined :: (MonadTx m) => m ()
setAllAsSystemDefined = liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.unitQ "UPDATE hdb_catalog.hdb_table SET is_system_defined = 'true'" () False
Q.unitQ "UPDATE hdb_catalog.hdb_relationship SET is_system_defined = 'true'" () False
Q.unitQ "UPDATE hdb_catalog.hdb_permission SET is_system_defined = 'true'" () False
Q.unitQ "UPDATE hdb_catalog.hdb_query_template SET is_system_defined = 'true'" () False
setAsSystemDefined :: Q.TxE QErr ()
setAsSystemDefined = Q.catchE defaultTxErrorHandler $
setAsSystemDefined :: (MonadTx m) => m ()
setAsSystemDefined =
liftTx $ Q.catchE defaultTxErrorHandler $
Q.multiQ [Q.sql|
UPDATE hdb_catalog.hdb_table
SET is_system_defined = 'true'
@ -141,21 +140,23 @@ setAsSystemDefined = Q.catchE defaultTxErrorHandler $
WHERE table_schema = 'hdb_catalog';
|]
cleanCatalog :: Q.TxE QErr ()
cleanCatalog = Q.catchE defaultTxErrorHandler $ do
cleanCatalog :: (MonadTx m) => m ()
cleanCatalog = liftTx $ Q.catchE defaultTxErrorHandler $ do
-- This is where the generated views and triggers are stored
Q.unitQ "DROP SCHEMA IF EXISTS hdb_views CASCADE" () False
Q.unitQ "DROP SCHEMA hdb_catalog CASCADE" () False
getCatalogVersion :: Q.TxE QErr T.Text
getCatalogVersion
:: (MonadTx m)
=> m T.Text
getCatalogVersion = do
res <- Q.withQE defaultTxErrorHandler [Q.sql|
res <- liftTx $ Q.withQE defaultTxErrorHandler [Q.sql|
SELECT version FROM hdb_catalog.hdb_version
|] () False
return $ runIdentity $ Q.getRow res
from08To1 :: Q.TxE QErr ()
from08To1 = Q.catchE defaultTxErrorHandler $ do
from08To1 :: (MonadTx m) => m ()
from08To1 = liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.unitQ "ALTER TABLE hdb_catalog.hdb_relationship ADD COLUMN comment TEXT NULL" () False
Q.unitQ "ALTER TABLE hdb_catalog.hdb_permission ADD COLUMN comment TEXT NULL" () False
Q.unitQ "ALTER TABLE hdb_catalog.hdb_query_template ADD COLUMN comment TEXT NULL" () False
@ -165,40 +166,44 @@ from08To1 = Q.catchE defaultTxErrorHandler $ do
json_build_object('type', 'select', 'args', template_defn->'select');
|] () False
from1To2 :: HTTP.Manager -> Q.TxE QErr ()
from1To2 httpMgr = do
from1To2
:: (MonadTx m, HasHttpManager m, CacheRWM m, UserInfoM m, MonadIO m)
=> m ()
from1To2 = do
-- migrate database
Q.Discard () <- Q.multiQE defaultTxErrorHandler
Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/migrate_from_1.sql")
-- migrate metadata
tx <- liftEither $ buildTxAny adminUserInfo
emptySchemaCache httpMgr migrateMetadataFrom1
void tx
void $ runQueryM migrateMetadataFrom1
-- set as system defined
setAsSystemDefined
where
migrateMetadataFrom1 =
$(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_1.yaml" :: Q (TExp RQLQuery)))
from2To3 :: Q.TxE QErr ()
from2To3 = Q.catchE defaultTxErrorHandler $ do
from2To3 :: (MonadTx m) => m ()
from2To3 = liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.unitQ "ALTER TABLE hdb_catalog.event_triggers ADD COLUMN headers JSON" () False
Q.unitQ "ALTER TABLE hdb_catalog.event_log ADD COLUMN next_retry_at TIMESTAMP" () False
Q.unitQ "CREATE INDEX ON hdb_catalog.event_log (trigger_id)" () False
Q.unitQ "CREATE INDEX ON hdb_catalog.event_invocation_logs (event_id)" () False
-- custom resolver
from4To5 :: HTTP.Manager -> Q.TxE QErr ()
from4To5 httpMgr = do
Q.Discard () <- Q.multiQE defaultTxErrorHandler
from4To5
:: (MonadTx m, HasHttpManager m, CacheRWM m, UserInfoM m, MonadIO m)
=> m ()
from4To5 = do
Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/migrate_from_4_to_5.sql")
-- migrate metadata
tx <- liftEither $ buildTxAny adminUserInfo
emptySchemaCache httpMgr migrateMetadataFrom4
void tx
void $ runQueryM migrateMetadataFrom4
-- set as system defined
setAsSystemDefined
where
migrateMetadataFrom4 =
$(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_4_to_5.yaml" :: Q (TExp RQLQuery)))
from3To4 :: Q.TxE QErr ()
from3To4 = Q.catchE defaultTxErrorHandler $ do
from3To4 :: (MonadTx m) => m ()
from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.unitQ "ALTER TABLE hdb_catalog.event_triggers ADD COLUMN configuration JSON" () False
eventTriggers <- map uncurryEventTrigger <$> Q.listQ [Q.sql|
SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json
@ -222,15 +227,17 @@ from3To4 = Q.catchE defaultTxErrorHandler $ do
WHERE name = $2
|] (Q.AltJ $ A.toJSON etc, name) True
from5To6 :: Q.TxE QErr ()
from5To6 = do
from5To6 :: (MonadTx m) => m ()
from5To6 = liftTx $ do
-- migrate database
Q.Discard () <- Q.multiQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/migrate_from_5_to_6.sql")
return ()
migrateCatalog :: HTTP.Manager -> UTCTime -> Q.TxE QErr String
migrateCatalog httpMgr migrationTime = do
migrateCatalog
:: (MonadTx m, CacheRWM m, MonadIO m, UserInfoM m, HasHttpManager m)
=> UTCTime -> m String
migrateCatalog migrationTime = do
preVer <- getCatalogVersion
if | preVer == curCatalogVer ->
return "migrate: already at the latest version"
@ -248,7 +255,7 @@ migrateCatalog httpMgr migrationTime = do
postMigrate
from4ToCurrent = do
from4To5 httpMgr
from4To5
from5ToCurrent
from3ToCurrent = do
@ -260,7 +267,7 @@ migrateCatalog httpMgr migrationTime = do
from3ToCurrent
from1ToCurrent = do
from1To2 httpMgr
from1To2
from2ToCurrent
from08ToCurrent = do
@ -271,27 +278,27 @@ migrateCatalog httpMgr migrationTime = do
-- update the catalog version
updateVersion
-- clean hdb_views
Q.catchE defaultTxErrorHandler clearHdbViews
liftTx $ Q.catchE defaultTxErrorHandler clearHdbViews
-- try building the schema cache
void $ buildSchemaCache httpMgr
void buildSchemaCache
return $ "migrate: successfully migrated to " ++ show curCatalogVer
updateVersion =
Q.unitQE defaultTxErrorHandler [Q.sql|
liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql|
UPDATE "hdb_catalog"."hdb_version"
SET "version" = $1,
"upgraded_on" = $2
|] (curCatalogVer, migrationTime) False
execQuery :: HTTP.Manager -> BL.ByteString -> Q.TxE QErr BL.ByteString
execQuery httpMgr queryBs = do
execQuery
:: (MonadTx m, CacheRWM m, MonadIO m, UserInfoM m, HasHttpManager m)
=> BL.ByteString -> m BL.ByteString
execQuery queryBs = do
query <- case A.decode queryBs of
Just jVal -> decodeValue jVal
Nothing -> throw400 InvalidJSON "invalid json"
schemaCache <- buildSchemaCache httpMgr
tx <- liftEither $ buildTxAny adminUserInfo schemaCache
httpMgr query
fst <$> tx
buildSchemaCache
runQueryM query
-- error messages

25
server/src-exec/TH.hs
View File

@ -1,25 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module TH
( metadataQuery
, migrateMetadataFrom1
, migrateMetadataFrom4
) where
import Language.Haskell.TH.Syntax (Q, TExp, unTypeQ)
import qualified Data.Yaml.TH as Y
import Hasura.Server.Query
metadataQuery :: RQLQuery
metadataQuery = $(unTypeQ (Y.decodeFile "src-rsr/hdb_metadata.yaml" :: Q (TExp RQLQuery)))
migrateMetadataFrom1 :: RQLQuery
migrateMetadataFrom1 = $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_1.yaml" :: Q (TExp RQLQuery)))
migrateMetadataFrom4 :: RQLQuery
migrateMetadataFrom4 = $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_4_to_5.yaml" :: Q (TExp RQLQuery)))

2
server/src-lib/Data/TByteString.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Data.TByteString
( TByteString
, fromText

1
server/src-lib/Data/Text/Extended.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Data.Text.Extended
( module DT
, squote

10
server/src-lib/Hasura/Events/HTTP.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Events.HTTP
( HTTP(..)
, mkAnyHTTPPost
@ -262,4 +253,3 @@ mkHLogger (LoggerCtx loggerSet serverLogLevel timeGetter) (logLevel, logTy, logD
when (logLevel >= serverLogLevel) $
FL.pushLogStrLn loggerSet $ FL.toLogStr $
J.encode $ EngineLog localTime logLevel logTy logDet

19
server/src-lib/Hasura/Events/Lib.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Events.Lib
( initEventEngineCtx
, processEventQueue
@ -195,10 +189,8 @@ processEvent logenv pool e = do
errorFn
:: ( MonadReader r m
, MonadIO m
, Has WS.Session r
, Has HLogger r
, Has CacheRef r
, Has EventEngineCtx r
)
=> HTTPErr -> m (Either QErr ())
errorFn err = do
@ -207,13 +199,7 @@ processEvent logenv pool e = do
checkError err
successFn
:: ( MonadReader r m
, MonadIO m
, Has WS.Session r
, Has HLogger r
, Has CacheRef r
, Has EventEngineCtx r
)
:: (MonadIO m)
=> HTTPResp -> m (Either QErr ())
successFn _ = liftIO $ runExceptT $ runUnlockQ pool e
@ -223,10 +209,7 @@ processEvent logenv pool e = do
checkError
:: ( MonadReader r m
, MonadIO m
, Has WS.Session r
, Has HLogger r
, Has CacheRef r
, Has EventEngineCtx r
)
=> HTTPErr -> m (Either QErr ())
checkError err = do

8
server/src-lib/Hasura/GraphQL/Context.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Context where
import Data.Aeson

14
server/src-lib/Hasura/GraphQL/Explain.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Explain
( explainGQLQuery
, GQLExplain
@ -32,7 +27,6 @@ import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Validate as GV
import qualified Hasura.GraphQL.Validate.Types as VT
import qualified Hasura.RQL.DML.Select as RS
import qualified Hasura.Server.Query as RQ
import qualified Hasura.SQL.DML as S
data GQLExplain
@ -64,7 +58,8 @@ runExplain ctx m =
either throwError return $ runExcept $ runReaderT m ctx
explainField
:: UserInfo -> GCtx -> Field -> Q.TxE QErr FieldPlan
:: (MonadTx m)
=> UserInfo -> GCtx -> Field -> m FieldPlan
explainField userInfo gCtx fld =
case fName of
"__type" -> return $ FieldPlan fName Nothing Nothing
@ -135,9 +130,8 @@ explainGQLQuery pool iso sc (GQLExplain query userVarsRaw)= do
gCtxMap = scGCtxMap sc
usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw
userInfo = mkUserInfo (fromMaybe adminRole $ roleFromVars usrVars) usrVars
runTx tx =
Q.runTx pool (iso, Nothing) $
RQ.setHeadersTx (userVars userInfo) >> tx
runTx tx = runLazyTx pool iso $ withUserInfo userInfo tx
allHasuraNodes gCtx nodes =
let typeLocs = TH.gatherTypeLocs gCtx nodes

10
server/src-lib/Hasura/GraphQL/RemoteServer.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.RemoteServer where
import Control.Exception (try)
@ -25,7 +17,7 @@ import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.HTTP.Client as HTTP
import qualified Network.Wreq as Wreq
import Hasura.HTTP.Utils (wreqOptions)
import Hasura.HTTP (wreqOptions)
import Hasura.RQL.DDL.Headers (getHeadersFromConf)
import Hasura.RQL.Types

17
server/src-lib/Hasura/GraphQL/Resolve.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Resolve
( resolveSelSet
) where
@ -70,16 +65,17 @@ buildTx userInfo gCtx fld = do
-- {-# SCC resolveFld #-}
resolveFld
:: UserInfo -> GCtx
:: (MonadTx m)
=> UserInfo -> GCtx
-> G.OperationType
-> Field
-> Q.TxE QErr BL.ByteString
-> m BL.ByteString
resolveFld userInfo gCtx opTy fld =
case _fName fld of
"__type" -> J.encode <$> runReaderT (typeR fld) gCtx
"__schema" -> J.encode <$> runReaderT (schemaR fld) gCtx
"__typename" -> return $ J.encode $ mkRootTypeName opTy
_ -> buildTx userInfo gCtx fld
_ -> liftTx $ buildTx userInfo gCtx fld
where
mkRootTypeName :: G.OperationType -> Text
mkRootTypeName = \case
@ -88,10 +84,11 @@ resolveFld userInfo gCtx opTy fld =
G.OperationTypeSubscription -> "subscription_root"
resolveSelSet
:: UserInfo -> GCtx
:: (MonadTx m)
=> UserInfo -> GCtx
-> G.OperationType
-> SelSet
-> Q.TxE QErr BL.ByteString
-> m BL.ByteString
resolveSelSet userInfo gCtx opTy fields =
fmap mkJSONObj $ forM (toList fields) $ \fld -> do
fldResp <- resolveFld userInfo gCtx opTy fld

8
server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Resolve.BoolExp
( parseBoolExp
, pgColValToBoolExp
@ -27,7 +21,7 @@ import Hasura.SQL.Value
type OpExp = OpExpG (PGColType, PGColValue)
parseOpExps
:: (MonadError QErr m, MonadReader r m, Has FieldMap r)
:: (MonadError QErr m)
=> AnnGValue -> m [OpExp]
parseOpExps annVal = do
opExpsM <- flip withObjectM annVal $ \nt objM -> forM objM $ \obj ->

47
server/src-lib/Hasura/GraphQL/Resolve/Context.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Resolve.Context
( FieldMap
, RelationInfoMap
@ -14,6 +7,7 @@ module Hasura.GraphQL.Resolve.Context
, InsCtx(..)
, InsCtxMap
, RespTx
, LazyRespTx
, PrepFn
, InsertTxConflictCtx(..)
, getFldInfo
@ -59,47 +53,10 @@ data InsResp
} deriving (Show, Eq)
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp)
-- type FieldMap
-- = Map.HashMap (G.NamedType, G.Name)
-- (Either PGColInfo (RelInfo, Bool, AnnBoolExpSQL, Maybe Int))
-- data OrdTy
-- = OAsc
-- | ODesc
-- deriving (Show, Eq)
-- data NullsOrder
-- = NFirst
-- | NLast
-- deriving (Show, Eq)
type RespTx = Q.TxE QErr BL.ByteString
type LazyRespTx = LazyTx QErr BL.ByteString
type PrepFn m = (PGColType, PGColValue) -> m S.SQLExp
-- -- order by context
-- data OrdByItem
-- = OBIPGCol !PGColInfo
-- | OBIRel !RelInfo !AnnBoolExpSQL
-- | OBIAgg !RelInfo !AnnBoolExpSQL
-- deriving (Show, Eq)
-- type OrdByItemMap = Map.HashMap G.Name OrdByItem
-- type OrdByCtx = Map.HashMap G.NamedType OrdByItemMap
-- -- insert context
-- type RelationInfoMap = Map.HashMap RelName RelInfo
-- data InsCtx
-- = InsCtx
-- { icView :: !QualifiedTable
-- , icColumns :: ![PGColInfo]
-- , icSet :: !InsSetCols
-- , icRelations :: !RelationInfoMap
-- } deriving (Show, Eq)
-- type InsCtxMap = Map.HashMap QualifiedTable InsCtx
getFldInfo
:: (MonadError QErr m, MonadReader r m, Has FieldMap r)
=> G.NamedType -> G.Name

7
server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Hasura.GraphQL.Resolve.InputValue
( withNotNull
, tyMismatch

6
server/src-lib/Hasura/GraphQL/Resolve/Insert.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Resolve.Insert
(convertInsert)
where

16
server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hasura.GraphQL.Resolve.Introspect
( schemaR
, typeR
@ -61,8 +54,7 @@ retJT = pure . J.toJSON
-- 4.5.2.1
scalarR
:: ( MonadReader r m, Has TypeMap r
, MonadError QErr m)
:: (Monad m)
=> ScalarTyInfo
-> Field
-> m J.Object
@ -103,8 +95,7 @@ notBuiltinFld f =
-- 4.5.2.5
enumTypeR
:: ( MonadReader r m, Has TypeMap r
, MonadError QErr m)
:: ( Monad m )
=> EnumTyInfo
-> Field
-> m J.Object
@ -223,8 +214,7 @@ inputValueR fld (InpValInfo descM n ty) =
-- 4.5.5
enumValueR
:: ( MonadReader r m, Has TypeMap r
, MonadError QErr m)
:: (Monad m)
=> Field -> EnumValInfo -> m J.Object
enumValueR fld (EnumValInfo descM enumVal isDeprecated) =
withSubFields (_fSelSet fld) $ \subFld ->

11
server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
module Hasura.GraphQL.Resolve.LiveQuery
( LiveQuery(..)
, LiveQueryMap
@ -17,7 +14,7 @@ import qualified STMContainers.Map as STMMap
import Control.Concurrent (threadDelay)
import Hasura.GraphQL.Resolve.Context (RespTx)
import Hasura.GraphQL.Resolve.Context (LazyRespTx)
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.GraphQL.Utils
import Hasura.Prelude
@ -36,7 +33,7 @@ type OnChange k = GQResp -> IO ()
data LQHandler k
= LQHandler
-- the tx to be executed
{ _lqhRespTx :: !RespTx
{ _lqhRespTx :: !LazyRespTx
-- previous result
, _lqhPrevRes :: !(STM.TVar (Maybe GQResp))
-- the actions that have been run previously
@ -53,7 +50,7 @@ type LiveQueryMap k = STMMap.Map LiveQuery (LQHandler k, ThreadTM)
newLiveQueryMap :: STM.STM (LiveQueryMap k)
newLiveQueryMap = STMMap.new
type TxRunner = RespTx -> IO (Either QErr BL.ByteString)
type TxRunner = LazyRespTx -> IO (Either QErr BL.ByteString)
removeLiveQuery
:: (Eq k, Hashable k)
@ -95,7 +92,7 @@ addLiveQuery
-- the query
-> LiveQuery
-- the transaction associated with this query
-> RespTx
-> LazyRespTx
-- a unique operation id
-> k
-- the action to be executed when result changes

9
server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Resolve.Mutation
( convertUpdate
, convertDelete
@ -128,7 +123,7 @@ convertUpdate tn filterExp fld = do
"atleast any one of _set, _inc, _append, _prepend, _delete_key, _delete_elem and "
<> " _delete_at_path operator is expected"
let p1 = RU.UpdateQueryP1 tn updExp (filterExp, whereExp) mutFlds
return $ RU.updateP2 (p1, prepArgs)
return $ RU.updateQueryToTx (p1, prepArgs)
where
args = _fArguments fld
@ -142,4 +137,4 @@ convertDelete tn filterExp fld = do
mutFlds <- convertMutResp (_fType fld) $ _fSelSet fld
args <- get
let p1 = RD.DeleteQueryP1 tn (filterExp, whereExp) mutFlds
return $ RD.deleteP2 (p1, args)
return $ RD.deleteQueryToTx (p1, args)

19
server/src-lib/Hasura/GraphQL/Resolve/Select.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Hasura.GraphQL.Resolve.Select
( convertSelect
, convertSelectByPKey
@ -162,8 +154,7 @@ getAnnObItems f nt obj = do
let aobCol = f $ RS.AOCPG ci
(_, enumVal) <- asEnumVal v
(ordTy, nullsOrd) <- parseOrderByEnum enumVal
return [OrderByItemG (Just ordTy) aobCol (Just nullsOrd)]
return [mkOrdByItemG ordTy aobCol nullsOrd]
OBIRel ri fltr -> do
let annObColFn = f . RS.AOCObj ri fltr
withObject (getAnnObItems annObColFn) v
@ -172,6 +163,10 @@ getAnnObItems f nt obj = do
let aobColFn = f . RS.AOCAgg ri fltr
flip withObject v $ \_ o -> parseAggOrdBy aobColFn o
mkOrdByItemG :: S.OrderType -> a -> S.NullsOrder -> OrderByItemG a
mkOrdByItemG ordTy aobCol nullsOrd =
OrderByItemG (Just $ OrderType ordTy) aobCol (Just $ NullsOrder nullsOrd)
parseAggOrdBy
:: (MonadError QErr m)
=> (RS.AnnAggOrdBy -> RS.AnnObCol)
@ -182,14 +177,14 @@ parseAggOrdBy f annObj =
case op of
"count" -> do
(ordTy, nullsOrd) <- parseAsEnum obVal
return [OrderByItemG (Just ordTy) (f RS.AAOCount) $ Just nullsOrd]
return [mkOrdByItemG ordTy (f RS.AAOCount) nullsOrd]
G.Name opT ->
flip withObject obVal $ \_ opObObj ->
forM (OMap.toList opObObj) $ \(col, eVal) -> do
(ordTy, nullsOrd) <- parseAsEnum eVal
let aobCol = f $ RS.AAOOp opT $ PGCol $ G.unName col
return $ OrderByItemG (Just ordTy) aobCol $ Just nullsOrd
return $ mkOrdByItemG ordTy aobCol nullsOrd
where
parseAsEnum v = do
(_, enumVal) <- asEnumVal v

14
server/src-lib/Hasura/GraphQL/Schema.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Schema
( mkGCtxMap
, GCtxMap
@ -1320,6 +1312,8 @@ mkGCtxRole' tn insPermM selPermM updColsM delPermM pkeyCols constraints viM allC
, TIObj <$> mutRespObjM
, TIEnum <$> selColInpTyM
]
mutHelper :: (ViewInfo -> Bool) -> Maybe a -> Maybe a
mutHelper f objM = bool Nothing objM $ isMutable f viM
fieldMap = Map.unions $ catMaybes
@ -1452,14 +1446,18 @@ getRootFldsRole' tn primCols constraints fields insM selM updM delM viM =
, getSelDet <$> selM, getSelAggDet selM
, getPKeySelDet selM $ getColInfos primCols colInfos
]
mutHelper :: (ViewInfo -> Bool) -> (a -> b) -> Maybe a -> Maybe b
mutHelper f getDet mutM =
bool Nothing (getDet <$> mutM) $ isMutable f viM
colInfos = fst $ validPartitionFieldInfoMap fields
getInsDet (hdrs, upsertPerm) =
let isUpsertable = upsertable constraints upsertPerm $ isJust viM
in ( OCInsert tn hdrs
, Right $ mkInsMutFld tn isUpsertable
)
getUpdDet (updCols, updFltr, hdrs) =
( OCUpdate tn updFltr hdrs
, Right $ mkUpdMutFld tn $ getColInfos updCols colInfos

22
server/src-lib/Hasura/GraphQL/Transport/HTTP.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Transport.HTTP
( runGQ
, getTopLevelNodes
@ -29,14 +24,13 @@ import qualified Network.Wreq as Wreq
import Hasura.GraphQL.Schema
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP.Utils
import Hasura.HTTP
import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types
import qualified Hasura.GraphQL.Resolve as R
import qualified Hasura.GraphQL.Validate as VQ
import qualified Hasura.GraphQL.Validate.Types as VT
import qualified Hasura.Server.Query as RQ
runGQ
@ -83,9 +77,16 @@ assertSameLocationNodes typeLocs =
_ -> Set.size (Set.fromList xs) == 1
msg = "cannot mix nodes from two different graphql servers"
-- TODO: we should retire the function asap
getTopLevelNodes :: G.TypedOperationDefinition -> [G.Name]
getTopLevelNodes opDef =
map (\(G.SelectionField f) -> G._fName f) $ G._todSelectionSet opDef
mapMaybe f $ G._todSelectionSet opDef
where
-- TODO: this will fail when there is a fragment at the top level
f = \case
G.SelectionField fld -> Just $ G._fName fld
G.SelectionFragmentSpread _ -> Nothing
G.SelectionInlineFragment _ -> Nothing
gatherTypeLocs :: GCtx -> [G.Name] -> [VT.TypeLoc]
gatherTypeLocs gCtx nodes =
@ -97,7 +98,6 @@ gatherTypeLocs gCtx nodes =
mr = VT._otiFields <$> _gMutRoot gCtx
in maybe qr (Map.union qr) mr
runHasuraGQ
:: (MonadIO m, MonadError QErr m)
=> Q.PGPool -> Q.TxIsolation
@ -115,9 +115,7 @@ runHasuraGQ pool isoL userInfo sc queryParts = do
return $ encodeGQResp $ GQSuccess resp
where
gCtxMap = scGCtxMap sc
runTx tx =
Q.runTx pool (isoL, Nothing) $
RQ.setHeadersTx (userVars userInfo) >> tx
runTx tx = runLazyTx pool isoL $ withUserInfo userInfo tx
runRemoteGQ
:: (MonadIO m, MonadError QErr m)

7
server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Transport.HTTP.Protocol
( GraphQLRequest(..)
, GraphQLQuery(..)

19
server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs
View File

@ -1,7 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.GraphQL.Transport.WebSocket
( createWSServerApp
@ -29,7 +26,7 @@ import Control.Concurrent (threadDelay)
import qualified Data.IORef as IORef
import Hasura.GraphQL.Resolve (resolveSelSet)
import Hasura.GraphQL.Resolve.Context (RespTx)
import Hasura.GraphQL.Resolve.Context (LazyRespTx)
import qualified Hasura.GraphQL.Resolve.LiveQuery as LQ
import Hasura.GraphQL.Schema (getGCtx)
import qualified Hasura.GraphQL.Transport.HTTP as TH
@ -45,12 +42,11 @@ import Hasura.Prelude
import Hasura.RQL.Types
import Hasura.Server.Auth (AuthMode,
getUserInfo)
import qualified Hasura.Server.Query as RQ
-- uniquely identifies an operation
type GOperationId = (WS.WSId, OperationId)
type TxRunner = RespTx -> IO (Either QErr BL.ByteString)
type TxRunner = LazyRespTx -> IO (Either QErr BL.ByteString)
type OperationMap
= STMMap.Map OperationId LQ.LiveQuery
@ -208,10 +204,7 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do
runHasuraQ userInfo gCtx queryParts = do
(opTy, fields) <- either (withComplete . preExecErr) return $
runReaderT (validateGQ queryParts) gCtx
let qTx = onlyOneSubcriptionField fields >>
RQ.setHeadersTx (userVars userInfo) >>
resolveSelSet userInfo gCtx opTy fields
let qTx = withUserInfo userInfo $ resolveSelSet userInfo gCtx opTy fields
case opTy of
G.OperationTypeSubscription -> do
let lq = LQ.LiveQuery userInfo q
@ -266,10 +259,6 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do
catchAndIgnore :: ExceptT () IO () -> IO ()
catchAndIgnore m = void $ runExceptT m
onlyOneSubcriptionField fields =
unless (length fields == 1) $
VT.throwVE "subscription must select only one top level field"
onMessage
:: AuthMode
-> WSServerEnv

5
server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Transport.WebSocket.Protocol
( OperationId(..)
, ConnParams(..)

6
server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs
View File

@ -1,8 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.GraphQL.Transport.WebSocket.Server
( WSId(..)

5
server/src-lib/Hasura/GraphQL/Utils.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Utils
( onNothing
, showName

8
server/src-lib/Hasura/GraphQL/Validate.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Validate
( validateGQ
, getTypedOp
@ -149,6 +145,10 @@ validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do
selSet <- flip runReaderT valCtx $ denormSelSet [] opRoot $
G._todSelectionSet opDef
when (G._todType opDef == G.OperationTypeSubscription && length selSet > 1) $
throwVE "subscription must select only one top level field"
return (G._todType opDef, selSet)

6
server/src-lib/Hasura/GraphQL/Validate/Context.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.GraphQL.Validate.Context
( ValidationCtx(..)
, getFieldInfo

5
server/src-lib/Hasura/GraphQL/Validate/Field.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Validate.Field
( ArgsMap
, Field(..)

8
server/src-lib/Hasura/GraphQL/Validate/InputValue.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Hasura.GraphQL.Validate.InputValue
( validateInputValue
, jsonParser

9
server/src-lib/Hasura/GraphQL/Validate/Types.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.GraphQL.Validate.Types
( InpValInfo(..)
, ParamMap

27
server/src-lib/Hasura/HTTP/Utils.hs → server/src-lib/Hasura/HTTP.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.HTTP
( wreqOptions
, HttpException(..)
) where
module Hasura.HTTP.Utils where
import Control.Lens
import Control.Lens hiding ((.=))
import Hasura.Prelude
import qualified Data.Aeson as J
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
@ -12,7 +14,6 @@ import qualified Network.Wreq as Wreq
import Hasura.Server.Version (currentVersion)
wreqOptions :: HTTP.Manager -> [HTTP.Header] -> Wreq.Options
wreqOptions manager hdrs =
Wreq.defaults
@ -24,3 +25,19 @@ wreqOptions manager hdrs =
userAgent = ( "User-Agent"
, "hasura-graphql-engine/" <> T.encodeUtf8 currentVersion
)
newtype HttpException
= HttpException
{ unHttpException :: HTTP.HttpException }
deriving (Show)
instance J.ToJSON HttpException where
toJSON = \case
(HttpException (HTTP.InvalidUrlException _ e)) ->
J.object [ "type" J..= ("invalid_url" :: Text)
, "message" J..= e
]
(HttpException (HTTP.HttpExceptionRequest _ cont)) ->
J.object [ "type" J..= ("http_exception" :: Text)
, "message" J..= show cont
]

6
server/src-lib/Hasura/Logging.hs
View File

@ -1,8 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.Logging
( LoggerSettings(..)

1
server/src-lib/Hasura/Prelude.hs
View File

@ -4,6 +4,7 @@ module Hasura.Prelude
import Control.Applicative as M ((<|>))
import Control.Monad as M (void, when)
import Control.Monad.Base as M
import Control.Monad.Except as M
import Control.Monad.Fail as M (MonadFail)
import Control.Monad.Identity as M

4
server/src-lib/Hasura/RQL/DDL/Deps.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Hasura.RQL.DDL.Deps
( purgeRel
, parseDropNotice

5
server/src-lib/Hasura/RQL/DDL/Headers.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.DDL.Headers where
import Data.Aeson

129
server/src-lib/Hasura/RQL/DDL/Metadata.hs
View File

@ -1,33 +1,21 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.Metadata
( ReplaceMetadata(..)
, TableMeta(..)
, tmObjectRelationships
, tmArrayRelationships
, tmInsertPermissions
, tmSelectPermissions
, tmUpdatePermissions
, tmDeletePermissions
( TableMeta
, mkTableMeta
, applyQP1
, applyQP2
, DumpInternalState(..)
, ReplaceMetadata(..)
, runReplaceMetadata
, ExportMetadata(..)
, runExportMetadata
, fetchMetadata
, ClearMetadata(..)
, clearMetadata
, runClearMetadata
, ReloadMetadata(..)
, runReloadMetadata
, DumpInternalState(..)
, runDumpInternalState
) where
import Control.Lens
@ -131,18 +119,15 @@ clearMetadata = Q.catchE defaultTxErrorHandler $ do
Q.unitQ "DELETE FROM hdb_catalog.remote_schemas" () False
clearHdbViews
instance HDBQuery ClearMetadata where
type Phase1Res ClearMetadata = ()
phaseOne _ = adminOnly
phaseTwo _ _ = do
hMgr <- askHttpManager
newSc <- liftTx $ clearMetadata >> DT.buildSchemaCache hMgr
writeSchemaCache newSc
return successMsg
schemaCachePolicy = SCPReload
runClearMetadata
:: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m
, MonadIO m, HasHttpManager m)
=> ClearMetadata -> m RespBody
runClearMetadata _ = do
adminOnly
liftTx clearMetadata
DT.buildSchemaCache
return successMsg
data ReplaceMetadata
= ReplaceMetadata
@ -153,7 +138,9 @@ data ReplaceMetadata
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''ReplaceMetadata)
applyQP1 :: ReplaceMetadata -> P1 ()
applyQP1
:: (QErrM m, UserInfoM m)
=> ReplaceMetadata -> m ()
applyQP1 (ReplaceMetadata tables templates mSchemas) = do
adminOnly
@ -201,7 +188,6 @@ applyQP1 (ReplaceMetadata tables templates mSchemas) = do
applyQP2
:: ( UserInfoM m
, QErrM m
, CacheRWM m
, MonadTx m
, MonadIO m
@ -211,9 +197,8 @@ applyQP2
-> m RespBody
applyQP2 (ReplaceMetadata tables templates mSchemas) = do
hMgr <- askHttpManager
defaultSchemaCache <- liftTx $ clearMetadata >> DT.buildSchemaCache hMgr
writeSchemaCache defaultSchemaCache
liftTx clearMetadata
DT.buildSchemaCache
withPathK "tables" $ do
@ -268,15 +253,12 @@ applyQP2 (ReplaceMetadata tables templates mSchemas) = do
permInfo <- DP.addPermP1 tabInfo permDef
DP.addPermP2 (tiName tabInfo) permDef permInfo
instance HDBQuery ReplaceMetadata where
type Phase1Res ReplaceMetadata = ()
phaseOne = applyQP1
phaseTwo q _ = applyQP2 q
schemaCachePolicy = SCPReload
runReplaceMetadata
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> ReplaceMetadata -> m RespBody
runReplaceMetadata q = do
applyQP1 q
applyQP2 q
data ExportMetadata
= ExportMetadata
@ -390,15 +372,12 @@ fetchMetadata = do
FROM hdb_catalog.event_triggers e
|] () False
instance HDBQuery ExportMetadata where
type Phase1Res ExportMetadata = ()
phaseOne _ = adminOnly
phaseTwo _ _ = encode <$> liftTx fetchMetadata
schemaCachePolicy = SCPNoChange
runExportMetadata
:: (QErrM m, UserInfoM m, MonadTx m)
=> ExportMetadata -> m RespBody
runExportMetadata _ = do
adminOnly
encode <$> liftTx fetchMetadata
data ReloadMetadata
= ReloadMetadata
@ -409,20 +388,15 @@ instance FromJSON ReloadMetadata where
$(deriveToJSON defaultOptions ''ReloadMetadata)
instance HDBQuery ReloadMetadata where
type Phase1Res ReloadMetadata = ()
phaseOne _ = adminOnly
phaseTwo _ _ = do
hMgr <- askHttpManager
sc <- liftTx $ do
Q.catchE defaultTxErrorHandler clearHdbViews
DT.buildSchemaCache hMgr
writeSchemaCache sc
return successMsg
schemaCachePolicy = SCPReload
runReloadMetadata
:: ( QErrM m, UserInfoM m, CacheRWM m
, MonadTx m, MonadIO m, HasHttpManager m)
=> ReloadMetadata -> m RespBody
runReloadMetadata _ = do
adminOnly
liftTx $ Q.catchE defaultTxErrorHandler clearHdbViews
DT.buildSchemaCache
return successMsg
data DumpInternalState
= DumpInternalState
@ -433,12 +407,9 @@ instance FromJSON DumpInternalState where
$(deriveToJSON defaultOptions ''DumpInternalState)
instance HDBQuery DumpInternalState where
type Phase1Res DumpInternalState = ()
phaseOne _ = adminOnly
phaseTwo _ _ =
encode <$> askSchemaCache
schemaCachePolicy = SCPNoChange
runDumpInternalState
:: (QErrM m, UserInfoM m, CacheRM m)
=> DumpInternalState -> m RespBody
runDumpInternalState _ = do
adminOnly
encode <$> askSchemaCache

56
server/src-lib/Hasura/RQL/DDL/Permission.hs
View File

@ -1,18 +1,9 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.Permission
( CreatePerm
, SetPermComment(..)
, runCreatePerm
, purgePerm
, PermDef(..)
, InsPerm(..)
, InsPermDef
, CreateInsPerm
@ -46,6 +37,12 @@ module Hasura.RQL.DDL.Permission
, IsPerm(..)
, addPermP1
, addPermP2
, DropPerm
, runDropPerm
, SetPermComment(..)
, runSetPermComment
) where
import Hasura.Prelude
@ -165,7 +162,9 @@ clearInsInfra vn =
type DropInsPerm = DropPerm InsPerm
dropInsPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropInsPerm -> QualifiedTable -> m ()
dropInsPermP2
:: (CacheRWM m, MonadTx m)
=> DropInsPerm -> QualifiedTable -> m ()
dropInsPermP2 = dropPermP2
type instance PermInfo InsPerm = InsPermInfo
@ -232,8 +231,11 @@ type DropSelPerm = DropPerm SelPerm
type instance PermInfo SelPerm = SelPermInfo
dropSelPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropSelPerm -> m ()
dropSelPermP2 dp = dropPermP2 dp ()
dropSelPermP2
:: (CacheRWM m, MonadTx m)
=> DropSelPerm -> m ()
dropSelPermP2 dp =
dropPermP2 dp ()
instance IsPerm SelPerm where
@ -291,7 +293,9 @@ type instance PermInfo UpdPerm = UpdPermInfo
type DropUpdPerm = DropPerm UpdPerm
dropUpdPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropUpdPerm -> m ()
dropUpdPermP2
:: (CacheRWM m, MonadTx m)
=> DropUpdPerm -> m ()
dropUpdPermP2 dp = dropPermP2 dp ()
instance IsPerm UpdPerm where
@ -337,7 +341,7 @@ buildDelPermInfo tabInfo (DelPerm fltr) = do
type DropDelPerm = DropPerm DelPerm
dropDelPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropDelPerm -> m ()
dropDelPermP2 :: (CacheRWM m, MonadTx m) => DropDelPerm -> m ()
dropDelPermP2 dp = dropPermP2 dp ()
type instance PermInfo DelPerm = DelPermInfo
@ -368,7 +372,7 @@ data SetPermComment
$(deriveJSON (aesonDrop 2 snakeCase) ''SetPermComment)
setPermCommentP1 :: (P1C m) => SetPermComment -> m ()
setPermCommentP1 :: (UserInfoM m, QErrM m, CacheRM m) => SetPermComment -> m ()
setPermCommentP1 (SetPermComment qt rn pt _) = do
adminOnly
tabInfo <- askTabInfo qt
@ -380,19 +384,17 @@ setPermCommentP1 (SetPermComment qt rn pt _) = do
PTUpdate -> assertPermDefined rn PAUpdate tabInfo
PTDelete -> assertPermDefined rn PADelete tabInfo
setPermCommentP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SetPermComment -> m RespBody
setPermCommentP2 :: (QErrM m, MonadTx m) => SetPermComment -> m RespBody
setPermCommentP2 apc = do
liftTx $ setPermCommentTx apc
return successMsg
instance HDBQuery SetPermComment where
type Phase1Res SetPermComment = ()
phaseOne = setPermCommentP1
phaseTwo q _ = setPermCommentP2 q
schemaCachePolicy = SCPNoChange
runSetPermComment
:: (QErrM m, CacheRM m, MonadTx m, UserInfoM m)
=> SetPermComment -> m RespBody
runSetPermComment defn = do
setPermCommentP1 defn
setPermCommentP2 defn
setPermCommentTx
:: SetPermComment
@ -407,7 +409,9 @@ setPermCommentTx (SetPermComment (QualifiedTable sn tn) rn pt comment) =
AND perm_type = $5
|] (comment, sn, tn, rn, permTypeToCode pt) True
purgePerm :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => QualifiedTable -> RoleName -> PermType -> m ()
purgePerm
:: (CacheRWM m, MonadTx m)
=> QualifiedTable -> RoleName -> PermType -> m ()
purgePerm qt rn pt =
case pt of
PTInsert -> dropInsPermP2 dp $ buildViewName qt rn PTInsert

69
server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs
View File

@ -1,12 +1,4 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
@ -163,11 +155,6 @@ data CreatePermP1Res a
, cprDeps :: ![SchemaDependency]
} deriving (Show, Eq)
createPermP1 :: (P1C m) => QualifiedTable -> m TableInfo
createPermP1 tn = do
adminOnly
askTabInfo tn
procBoolExp
:: (QErrM m, CacheRM m)
=> QualifiedTable -> FieldInfoMap -> BoolExp
@ -257,7 +244,7 @@ class (ToJSON a) => IsPerm a where
-> m (WithDeps (PermInfo a))
addPermP2Setup
:: (MonadTx m, QErrM m) => QualifiedTable -> PermDef a -> PermInfo a -> m ()
:: (MonadTx m) => QualifiedTable -> PermDef a -> PermInfo a -> m ()
buildDropPermP1Res
:: (QErrM m, CacheRM m, UserInfoM m)
@ -305,22 +292,30 @@ addPermP2 tn pd (permInfo, deps) = do
pa = getPermAcc1 pd
pt = permAccToType pa
instance (IsPerm a) => HDBQuery (CreatePerm a) where
createPermP1
:: ( UserInfoM m, MonadError QErr m
, CacheRM m, IsPerm a
)
=> WithTable (PermDef a) -> m (WithDeps (PermInfo a))
createPermP1 (WithTable tn pd) = do
adminOnly
tabInfo <- askTabInfo tn
validateViewPerm pd tabInfo
addPermP1 tabInfo pd
type Phase1Res (CreatePerm a) = WithDeps (PermInfo a)
runCreatePerm
:: ( UserInfoM m
, CacheRWM m, IsPerm a, MonadTx m
)
=> CreatePerm a -> m RespBody
runCreatePerm defn@(WithTable tn pd) = do
permInfo <- createPermP1 defn
addPermP2 tn pd permInfo
return successMsg
phaseOne (WithTable tn pd) = do
tabInfo <- createPermP1 tn
validateViewPerm pd tabInfo
addPermP1 tabInfo pd
phaseTwo (WithTable tn pd) permInfo = do
addPermP2 tn pd permInfo
return successMsg
schemaCachePolicy = SCPReload
dropPermP1 :: (QErrM m, CacheRM m, UserInfoM m, IsPerm a) => DropPerm a -> m (PermInfo a)
dropPermP1
:: (QErrM m, CacheRM m, UserInfoM m, IsPerm a)
=> DropPerm a -> m (PermInfo a)
dropPermP1 dp@(DropPerm tn rn) = do
adminOnly
tabInfo <- askTabInfo tn
@ -337,12 +332,20 @@ dropPermP2 dp@(DropPerm tn rn) p1Res = do
pa = getPermAcc2 dp
pt = permAccToType pa
instance (IsPerm a) => HDBQuery (DropPerm a) where
runDropPerm
:: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m)
=> DropPerm a -> m RespBody
runDropPerm defn = do
permInfo <- buildDropPermP1Res defn
dropPermP2 defn permInfo
return successMsg
type Phase1Res (DropPerm a) = DropPermP1Res a
-- instance (IsPerm a) => HDBQuery (DropPerm a) where
phaseOne = buildDropPermP1Res
-- type Phase1Res (DropPerm a) = DropPermP1Res a
phaseTwo dp p1Res = dropPermP2 dp p1Res >> return successMsg
-- phaseOne = buildDropPermP1Res
schemaCachePolicy = SCPReload
-- phaseTwo dp p1Res = dropPermP2 dp p1Res >> return successMsg
-- schemaCachePolicy = SCPReload

5
server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.DDL.Permission.Triggers where
import Hasura.Prelude

100
server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs
View File

@ -1,21 +1,17 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.QueryTemplate
( createQueryTemplateP1
, createQueryTemplateP2
, delQTemplateFromCatalog
, TemplateParamConf(..)
, CreateQueryTemplate(..)
, DropQueryTemplate(..)
, runCreateQueryTemplate
, QueryTP1
, DropQueryTemplate(..)
, runDropQueryTemplate
, SetQueryTemplateComment(..)
, runSetQueryTemplateComment
) where
import Hasura.Prelude
@ -59,9 +55,10 @@ data CreateQueryTemplate
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''CreateQueryTemplate)
validateParam
:: PGColType
:: (QErrM m)
=> PGColType
-> Value
-> P1 PS.SQLExp
-> m PS.SQLExp
validateParam pct val =
case val of
Object _ -> do
@ -74,7 +71,7 @@ validateParam pct val =
validateDefault =
void . runAesonParser (convToBin pct)
mkSelQ :: SelectQueryT -> P1 SelectQuery
mkSelQ :: (QErrM m) => SelectQueryT -> m SelectQuery
mkSelQ (DMLQuery tn (SelectG c w o lim offset)) = do
intLim <- withPathK "limit" $ maybe returnNothing parseAsInt lim
intOffset <- withPathK "offset" $ maybe returnNothing parseAsInt offset
@ -98,15 +95,16 @@ data QueryTP1
deriving (Show, Eq)
validateTQuery
:: QueryT
-> P1 QueryTP1
:: (QErrM m, UserInfoM m, CacheRM m)
=> QueryT
-> m QueryTP1
validateTQuery qt = withPathK "args" $ case qt of
QTInsert q -> QTP1Insert <$> R.convInsertQuery decodeInsObjs validateParam q
QTSelect q -> QTP1Select <$> (mkSelQ q >>= R.convSelectQuery validateParam)
QTUpdate q -> QTP1Update <$> R.convUpdateQuery validateParam q
QTDelete q -> QTP1Delete <$> R.convDeleteQuery validateParam q
QTCount q -> QTP1Count <$> R.countP1 validateParam q
QTBulk q -> QTP1Bulk <$> mapM validateTQuery q
QTUpdate q -> QTP1Update <$> R.validateUpdateQueryWith validateParam q
QTDelete q -> QTP1Delete <$> R.validateDeleteQWith validateParam q
QTCount q -> QTP1Count <$> R.validateCountQWith validateParam q
QTBulk q -> QTP1Bulk <$> mapM validateTQuery q
where
decodeInsObjs val = do
tpc <- decodeValue val
@ -124,17 +122,15 @@ collectDeps qt = case qt of
QTP1Bulk qp1 -> concatMap collectDeps qp1
createQueryTemplateP1
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> CreateQueryTemplate
-> m (WithDeps QueryTemplateInfo)
createQueryTemplateP1 (CreateQueryTemplate qtn qt _) = do
adminOnly
ui <- askUserInfo
sc <- askSchemaCache
withPathK "name" $ when (isJust $ M.lookup qtn $ scQTemplates sc) $
throw400 AlreadyExists $ "the query template already exists : " <>> qtn
let qCtx = QCtx ui sc
qtp1 <- withPathK "template" $ liftP1 qCtx $ validateTQuery qt
qtp1 <- withPathK "template" $ liftP1 $ validateTQuery qt
let deps = collectDeps qtp1
return (QueryTemplateInfo qtn qt, deps)
@ -159,14 +155,11 @@ createQueryTemplateP2 cqt (qti, deps) = do
liftTx $ addQTemplateToCatalog cqt
return successMsg
instance HDBQuery CreateQueryTemplate where
type Phase1Res CreateQueryTemplate = WithDeps QueryTemplateInfo
phaseOne = createQueryTemplateP1
phaseTwo = createQueryTemplateP2
schemaCachePolicy = SCPReload
runCreateQueryTemplate
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> CreateQueryTemplate -> m RespBody
runCreateQueryTemplate q =
createQueryTemplateP1 q >>= createQueryTemplateP2 q
data DropQueryTemplate
= DropQueryTemplate
@ -185,18 +178,16 @@ delQTemplateFromCatalog qtn =
WHERE template_name = $1
|] (Identity qtn) False
instance HDBQuery DropQueryTemplate where
type Phase1Res DropQueryTemplate = ()
phaseOne (DropQueryTemplate qtn) =
withPathK "name" $ void $ askQTemplateInfo qtn
phaseTwo (DropQueryTemplate qtn) _ = do
delQTemplateFromCache qtn
liftTx $ delQTemplateFromCatalog qtn
return successMsg
schemaCachePolicy = SCPReload
runDropQueryTemplate
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> DropQueryTemplate -> m RespBody
runDropQueryTemplate q = do
withPathK "name" $ void $ askQTemplateInfo qtn
delQTemplateFromCache qtn
liftTx $ delQTemplateFromCatalog qtn
return successMsg
where
qtn = dqtName q
data SetQueryTemplateComment
= SetQueryTemplateComment
@ -206,25 +197,19 @@ data SetQueryTemplateComment
$(deriveJSON (aesonDrop 4 snakeCase) ''SetQueryTemplateComment)
setQueryTemplateCommentP1 :: (P1C m) => SetQueryTemplateComment -> m ()
setQueryTemplateCommentP1
:: (UserInfoM m, QErrM m, CacheRM m)
=> SetQueryTemplateComment -> m ()
setQueryTemplateCommentP1 (SetQueryTemplateComment qtn _) = do
adminOnly
void $ askQTemplateInfo qtn
setQueryTemplateCommentP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SetQueryTemplateComment -> m RespBody
setQueryTemplateCommentP2
:: (QErrM m, MonadTx m) => SetQueryTemplateComment -> m RespBody
setQueryTemplateCommentP2 apc = do
liftTx $ setQueryTemplateCommentTx apc
return successMsg
instance HDBQuery SetQueryTemplateComment where
type Phase1Res SetQueryTemplateComment = ()
phaseOne = setQueryTemplateCommentP1
phaseTwo q _ = setQueryTemplateCommentP2 q
schemaCachePolicy = SCPNoChange
setQueryTemplateCommentTx
:: SetQueryTemplateComment
-> Q.TxE QErr ()
@ -235,3 +220,10 @@ setQueryTemplateCommentTx (SetQueryTemplateComment qtn comment) =
SET comment = $1
WHERE template_name = $2
|] (comment, qtn) False
runSetQueryTemplateComment
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> SetQueryTemplateComment -> m RespBody
runSetQueryTemplateComment q = do
setQueryTemplateCommentP1 q
setQueryTemplateCommentP2 q

98
server/src-lib/Hasura/RQL/DDL/Relationship.hs
View File

@ -1,13 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.Relationship where
import qualified Database.PG.Query as Q
@ -162,7 +152,7 @@ objRelP1 tabInfo (RelDef rn ru _) = do
RUManual (ObjRelManualConfig rm) -> validateManualConfig fim rm
createObjRelP1
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> CreateObjRel
-> m ()
createObjRelP1 (WithTable qt rd) = do
@ -223,19 +213,18 @@ objRelP2 qt rd@(RelDef rn ru comment) = do
objRelP2Setup qt rd
liftTx $ persistRel qt rn ObjRel (toJSON ru) comment
createObjRelP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => CreateObjRel -> m RespBody
createObjRelP2
:: (QErrM m, CacheRWM m, MonadTx m) => CreateObjRel -> m RespBody
createObjRelP2 (WithTable qt rd) = do
objRelP2 qt rd
return successMsg
instance HDBQuery CreateObjRel where
type Phase1Res CreateObjRel = ()
phaseOne = createObjRelP1
phaseTwo cor _ = createObjRelP2 cor
schemaCachePolicy = SCPReload
runCreateObjRel
:: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
=> CreateObjRel -> m RespBody
runCreateObjRel defn = do
createObjRelP1 defn
createObjRelP2 defn
data ArrRelUsingFKeyOn
= ArrRelUsingFKeyOn
@ -253,7 +242,7 @@ type ArrRelUsing = RelUsing ArrRelUsingFKeyOn ArrRelManualConfig
type ArrRelDef = RelDef ArrRelUsing
type CreateArrRel = WithTable ArrRelDef
createArrRelP1 :: (P1C m) => CreateArrRel -> m ()
createArrRelP1 :: (UserInfoM m, QErrM m, CacheRM m) => CreateArrRel -> m ()
createArrRelP1 (WithTable qt rd) = do
adminOnly
tabInfo <- askTabInfo qt
@ -323,19 +312,18 @@ arrRelP2 qt rd@(RelDef rn u comment) = do
arrRelP2Setup qt rd
liftTx $ persistRel qt rn ArrRel (toJSON u) comment
createArrRelP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => CreateArrRel -> m RespBody
createArrRelP2
:: (QErrM m, CacheRWM m, MonadTx m) => CreateArrRel -> m RespBody
createArrRelP2 (WithTable qt rd) = do
arrRelP2 qt rd
return successMsg
instance HDBQuery CreateArrRel where
type Phase1Res CreateArrRel = ()
phaseOne = createArrRelP1
phaseTwo car _ = createArrRelP2 car
schemaCachePolicy = SCPReload
runCreateArrRel
:: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
=> CreateArrRel -> m RespBody
runCreateArrRel defn = do
createArrRelP1 defn
createArrRelP2 defn
data DropRel
= DropRel
@ -346,7 +334,7 @@ data DropRel
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DropRel)
dropRelP1 :: (P1C m) => DropRel -> m [SchemaObjId]
dropRelP1 :: (UserInfoM m, QErrM m, CacheRM m) => DropRel -> m [SchemaObjId]
dropRelP1 (DropRel qt rn cascade) = do
adminOnly
tabInfo <- askTabInfo qt
@ -358,31 +346,33 @@ dropRelP1 (DropRel qt rn cascade) = do
where
relObjId = SOTableObj qt $ TORel rn
purgeRelDep :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SchemaObjId -> m ()
purgeRelDep
:: (CacheRWM m, MonadTx m) => SchemaObjId -> m ()
purgeRelDep (SOTableObj tn (TOPerm rn pt)) =
purgePerm tn rn pt
purgeRelDep d = throw500 $ "unexpected dependency of relationship : "
<> reportSchemaObj d
dropRelP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropRel -> [SchemaObjId] -> m RespBody
dropRelP2
:: (QErrM m, CacheRWM m, MonadTx m)
=> DropRel -> [SchemaObjId] -> m RespBody
dropRelP2 (DropRel qt rn _) depObjs = do
mapM_ purgeRelDep depObjs
delRelFromCache rn qt
liftTx $ delRelFromCatalog qt rn
return successMsg
instance HDBQuery DropRel where
runDropRel
:: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
=> DropRel -> m RespBody
runDropRel defn = do
depObjs <- dropRelP1 defn
dropRelP2 defn depObjs
type Phase1Res DropRel = [SchemaObjId]
phaseOne = dropRelP1
phaseTwo = dropRelP2
schemaCachePolicy = SCPReload
delRelFromCatalog :: QualifiedTable
-> RelName
-> Q.TxE QErr ()
delRelFromCatalog
:: QualifiedTable
-> RelName
-> Q.TxE QErr ()
delRelFromCatalog (QualifiedTable sn tn) rn =
Q.unitQE defaultTxErrorHandler [Q.sql|
DELETE FROM
@ -401,25 +391,25 @@ data SetRelComment
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SetRelComment)
setRelCommentP1 :: (P1C m) => SetRelComment -> m ()
setRelCommentP1 :: (UserInfoM m, QErrM m, CacheRM m) => SetRelComment -> m ()
setRelCommentP1 (SetRelComment qt rn _) = do
adminOnly
tabInfo <- askTabInfo qt
void $ askRelType (tiFieldInfoMap tabInfo) rn ""
setRelCommentP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SetRelComment -> m RespBody
setRelCommentP2
:: (QErrM m, MonadTx m)
=> SetRelComment -> m RespBody
setRelCommentP2 arc = do
liftTx $ setRelComment arc
return successMsg
instance HDBQuery SetRelComment where
type Phase1Res SetRelComment = ()
phaseOne = setRelCommentP1
phaseTwo q _ = setRelCommentP2 q
schemaCachePolicy = SCPNoChange
runSetRelComment
:: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
=> SetRelComment -> m RespBody
runSetRelComment defn = do
setRelCommentP1 defn
setRelCommentP2 defn
setRelComment :: SetRelComment
-> Q.TxE QErr ()

48
server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hasura.RQL.DDL.RemoteSchema where
module Hasura.RQL.DDL.RemoteSchema
( runAddRemoteSchema
, runRemoveRemoteSchema
, writeRemoteSchemasToCache
, refreshGCtxMapInSchema
, fetchRemoteSchemas
, addRemoteSchemaP2
) where
import Hasura.Prelude
@ -18,17 +19,15 @@ import Hasura.RQL.Types
import qualified Hasura.GraphQL.Schema as GS
instance HDBQuery AddRemoteSchemaQuery where
type Phase1Res AddRemoteSchemaQuery = AddRemoteSchemaQuery
phaseOne = addRemoteSchemaP1
phaseTwo _ = addRemoteSchemaP2
schemaCachePolicy = SCPReload
addRemoteSchemaP1
:: (P1C m)
=> AddRemoteSchemaQuery -> m AddRemoteSchemaQuery
addRemoteSchemaP1 q = adminOnly >> return q
runAddRemoteSchema
:: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m
, MonadIO m
, HasHttpManager m
)
=> AddRemoteSchemaQuery -> m RespBody
runAddRemoteSchema q = do
adminOnly
addRemoteSchemaP2 q
addRemoteSchemaP2
:: ( QErrM m
@ -88,15 +87,14 @@ refreshGCtxMapInSchema = do
writeSchemaCache sc { scGCtxMap = mergedGCtxMap
, scDefaultRemoteGCtx = defGCtx }
instance HDBQuery RemoveRemoteSchemaQuery where
type Phase1Res RemoveRemoteSchemaQuery = RemoveRemoteSchemaQuery
phaseOne = removeRemoteSchemaP1
phaseTwo _ = removeRemoteSchemaP2
schemaCachePolicy = SCPReload
runRemoveRemoteSchema
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> RemoveRemoteSchemaQuery -> m RespBody
runRemoveRemoteSchema q =
removeRemoteSchemaP1 q >>= removeRemoteSchemaP2
removeRemoteSchemaP1
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> RemoveRemoteSchemaQuery -> m RemoveRemoteSchemaQuery
removeRemoteSchemaP1 q = adminOnly >> return q

13
server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.DDL.Schema.Diff
( TableMeta(..)
, PGColMeta(..)
@ -153,7 +148,9 @@ getTableDiff oldtm newtm =
map cmConstraintName $ getDifference cmConstraintOid
(tmConstraints oldtm) (tmConstraints newtm)
getTableChangeDeps :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => TableInfo -> TableDiff -> m [SchemaObjId]
getTableChangeDeps
:: (QErrM m, CacheRWM m)
=> TableInfo -> TableDiff -> m [SchemaObjId]
getTableChangeDeps ti tableDiff = do
sc <- askSchemaCache
-- for all the dropped columns
@ -184,7 +181,9 @@ getSchemaDiff oldMeta newMeta =
flip map (getOverlap tmOid oldMeta newMeta) $ \(oldtm, newtm) ->
(tmTable oldtm, getTableDiff oldtm newtm)
getSchemaChangeDeps :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SchemaDiff -> m [SchemaObjId]
getSchemaChangeDeps
:: (QErrM m, CacheRWM m)
=> SchemaDiff -> m [SchemaObjId]
getSchemaChangeDeps schemaDiff = do
-- Get schema cache
sc <- askSchemaCache

106
server/src-lib/Hasura/RQL/DDL/Schema/Table.hs
View File

@ -1,14 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.Schema.Table where
import Hasura.GraphQL.RemoteServer
@ -40,7 +29,6 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.HTTP.Client as HTTP
delTableFromCatalog :: QualifiedTable -> Q.Tx ()
delTableFromCatalog (QualifiedTable sn tn) =
@ -137,10 +125,11 @@ newtype TrackTable
{ tName :: QualifiedTable }
deriving (Show, Eq, FromJSON, ToJSON, Lift)
trackExistingTableOrViewP1 :: TrackTable -> P1 ()
trackExistingTableOrViewP1
:: (CacheRM m, UserInfoM m, QErrM m) => TrackTable -> m ()
trackExistingTableOrViewP1 (TrackTable vn) = do
adminOnly
rawSchemaCache <- getSchemaCache <$> lift ask
rawSchemaCache <- askSchemaCache
when (M.member vn $ scTables rawSchemaCache) $
throw400 AlreadyTracked $ "view/table already tracked : " <>> vn
@ -174,16 +163,16 @@ trackExistingTableOrViewP2 vn isSystemDefined = do
"public" -> getTableN vn
_ -> getSchemaN vn <> "_" <> getTableN vn
instance HDBQuery TrackTable where
runTrackTableQ
:: ( QErrM m, CacheRWM m, MonadTx m
, MonadIO m, HasHttpManager m, UserInfoM m
)
=> TrackTable -> m RespBody
runTrackTableQ q = do
trackExistingTableOrViewP1 q
trackExistingTableOrViewP2 (tName q) False
type Phase1Res TrackTable = ()
phaseOne = trackExistingTableOrViewP1
phaseTwo (TrackTable tn) _ = trackExistingTableOrViewP2 tn False
schemaCachePolicy = SCPReload
purgeDep :: (CacheRWM m, MonadError QErr m, MonadTx m)
purgeDep :: (CacheRWM m, MonadTx m)
=> SchemaObjId -> m ()
purgeDep schemaObjId = case schemaObjId of
(SOTableObj tn (TOPerm rn pt)) -> do
@ -205,7 +194,8 @@ purgeDep schemaObjId = case schemaObjId of
_ -> throw500 $
"unexpected dependent object : " <> reportSchemaObj schemaObjId
processTableChanges :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => TableInfo -> TableDiff -> m ()
processTableChanges
:: (QErrM m, CacheRWM m) => TableInfo -> TableDiff -> m ()
processTableChanges ti tableDiff = do
when (isJust mNewName) $
@ -247,7 +237,8 @@ processTableChanges ti tableDiff = do
tn = tiName ti
TableDiff mNewName droppedCols addedCols alteredCols _ = tableDiff
delTableAndDirectDeps :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => QualifiedTable -> m ()
delTableAndDirectDeps
:: (QErrM m, CacheRWM m, MonadTx m) => QualifiedTable -> m ()
delTableAndDirectDeps qtn@(QualifiedTable sn tn) = do
liftTx $ Q.catchE defaultTxErrorHandler $ do
Q.unitQ [Q.sql|
@ -265,7 +256,8 @@ delTableAndDirectDeps qtn@(QualifiedTable sn tn) = do
delTableFromCatalog qtn
delTableFromCache qtn
processSchemaChanges :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => SchemaDiff -> m ()
processSchemaChanges
:: (QErrM m, CacheRWM m, MonadTx m) => SchemaDiff -> m ()
processSchemaChanges schemaDiff = do
-- Purge the dropped tables
mapM_ delTableAndDirectDeps droppedTables
@ -286,10 +278,11 @@ data UntrackTable =
} deriving (Show, Eq, Lift)
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UntrackTable)
unTrackExistingTableOrViewP1 :: UntrackTable -> P1 ()
unTrackExistingTableOrViewP1
:: (CacheRM m, UserInfoM m, QErrM m) => UntrackTable -> m ()
unTrackExistingTableOrViewP1 (UntrackTable vn _) = do
adminOnly
rawSchemaCache <- getSchemaCache <$> lift ask
rawSchemaCache <- askSchemaCache
case M.lookup vn (scTables rawSchemaCache) of
Just ti ->
-- Check if table/view is system defined
@ -326,23 +319,29 @@ unTrackExistingTableOrViewP2 (UntrackTable qtn cascade) = do
(SOTableObj dtn _) -> qtn == dtn
_ -> False
instance HDBQuery UntrackTable where
type Phase1Res UntrackTable = ()
phaseOne = unTrackExistingTableOrViewP1
runUntrackTableQ
:: ( QErrM m, CacheRWM m, MonadTx m
, MonadIO m, HasHttpManager m, UserInfoM m
)
=> UntrackTable -> m RespBody
runUntrackTableQ q = do
unTrackExistingTableOrViewP1 q
unTrackExistingTableOrViewP2 q
phaseTwo q _ = unTrackExistingTableOrViewP2 q
schemaCachePolicy = SCPReload
buildSchemaCache :: HTTP.Manager -> Q.TxE QErr SchemaCache
buildSchemaCache httpManager = flip execStateT emptySchemaCache $ do
tables <- lift $ Q.catchE defaultTxErrorHandler fetchTables
buildSchemaCache
:: (MonadTx m, CacheRWM m, MonadIO m, HasHttpManager m)
=> m ()
buildSchemaCache = do
-- reset the current schemacache
writeSchemaCache emptySchemaCache
hMgr <- askHttpManager
tables <- liftTx $ Q.catchE defaultTxErrorHandler fetchTables
forM_ tables $ \(sn, tn, isSystemDefined) ->
modifyErr (\e -> "table " <> tn <<> "; " <> e) $
trackExistingTableOrViewP2Setup (QualifiedTable sn tn) isSystemDefined
-- Fetch all the relationships
relationships <- lift $ Q.catchE defaultTxErrorHandler fetchRelationships
relationships <- liftTx $ Q.catchE defaultTxErrorHandler fetchRelationships
forM_ relationships $ \(sn, tn, rn, rt, Q.AltJ rDef) ->
modifyErr (\e -> "table " <> tn <<> "; rel " <> rn <<> "; " <> e) $ case rt of
@ -354,7 +353,7 @@ buildSchemaCache httpManager = flip execStateT emptySchemaCache $ do
arrRelP2Setup (QualifiedTable sn tn) $ RelDef rn using Nothing
-- Fetch all the permissions
permissions <- lift $ Q.catchE defaultTxErrorHandler fetchPermissions
permissions <- liftTx $ Q.catchE defaultTxErrorHandler fetchPermissions
forM_ permissions $ \(sn, tn, rn, pt, Q.AltJ pDef) ->
modifyErr (\e -> "table " <> tn <<> "; role " <> rn <<> "; " <> e) $ case pt of
@ -364,15 +363,15 @@ buildSchemaCache httpManager = flip execStateT emptySchemaCache $ do
PTDelete -> permHelper sn tn rn pDef PADelete
-- Fetch all the query templates
qtemplates <- lift $ Q.catchE defaultTxErrorHandler fetchQTemplates
qtemplates <- liftTx $ Q.catchE defaultTxErrorHandler fetchQTemplates
forM_ qtemplates $ \(qtn, Q.AltJ qtDefVal) -> do
qtDef <- decodeValue qtDefVal
qCtx <- mkAdminQCtx <$> get
(qti, deps) <- liftP1 qCtx $ createQueryTemplateP1 $
qCtx <- mkAdminQCtx <$> askSchemaCache
(qti, deps) <- liftP1WithQCtx qCtx $ createQueryTemplateP1 $
CreateQueryTemplate qtn qtDef Nothing
addQTemplateToCache qti deps
eventTriggers <- lift $ Q.catchE defaultTxErrorHandler fetchEventTriggers
eventTriggers <- liftTx $ Q.catchE defaultTxErrorHandler fetchEventTriggers
forM_ eventTriggers $ \(sn, tn, trid, trn, Q.AltJ configuration) -> do
etc <- decodeValue configuration
@ -389,19 +388,19 @@ buildSchemaCache httpManager = flip execStateT emptySchemaCache $ do
remoteScConf <- forM res $ \(AddRemoteSchemaQuery n def _) ->
(,) n <$> validateRemoteSchemaDef def
let rmScMap = M.fromList remoteScConf
(mergedGCtxMap, defGCtx) <- mergeSchemas rmScMap gCtxMap httpManager
(mergedGCtxMap, defGCtx) <- mergeSchemas rmScMap gCtxMap hMgr
writeRemoteSchemasToCache mergedGCtxMap rmScMap
postMergeSc <- askSchemaCache
writeSchemaCache postMergeSc { scDefaultRemoteGCtx = defGCtx }
where
permHelper sn tn rn pDef pa = do
qCtx <- mkAdminQCtx <$> get
qCtx <- mkAdminQCtx <$> askSchemaCache
perm <- decodeValue pDef
let qt = QualifiedTable sn tn
permDef = PermDef rn perm Nothing
createPerm = WithTable qt permDef
(permInfo, deps) <- liftP1 qCtx $ phaseOne createPerm
(permInfo, deps) <- liftP1WithQCtx qCtx $ createPermP1 createPerm
addPermP2Setup qt permDef permInfo
addPermToCache qt rn pa permInfo deps
-- p2F qt rn p1Res
@ -510,14 +509,11 @@ runSqlP2 (RunSQL t cascade) = do
let e = err400 PostgresError "query execution failed"
in e {qeInternal = Just $ toJSON txe}
instance HDBQuery RunSQL where
type Phase1Res RunSQL = ()
phaseOne _ = adminOnly
phaseTwo q _ = runSqlP2 q
schemaCachePolicy = SCPReload
runRunSQL
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> RunSQL -> m RespBody
runRunSQL q =
adminOnly >> runSqlP2 q
-- Should be used only after checking the status
resToCSV :: PQ.Result -> ExceptT T.Text IO [[T.Text]]

142
server/src-lib/Hasura/RQL/DDL/Subscribe.hs
View File

@ -1,14 +1,19 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DDL.Subscribe
( CreateEventTriggerQuery
, runCreateEventTriggerQuery
, DeleteEventTriggerQuery
, runDeleteEventTriggerQuery
, DeliverEventQuery
, runDeliverEvent
module Hasura.RQL.DDL.Subscribe where
-- TODO: review
, delEventTriggerFromCatalog
, subTableP2
, subTableP2Setup
, mkTriggerQ
) where
import Data.Aeson
import Data.Int (Int64)
import Hasura.Prelude
import Hasura.RQL.DDL.Headers
import Hasura.RQL.DML.Internal
@ -131,17 +136,21 @@ addEventTriggerToCatalog
-> [PGColInfo]
-> EventTriggerConf
-> Q.TxE QErr TriggerId
addEventTriggerToCatalog qt@(QualifiedTable sn tn) allCols etc@(EventTriggerConf name opsdef _ _ _ _) = do
ids <- map runIdentity <$> Q.listQE defaultTxErrorHandler [Q.sql|
INSERT into hdb_catalog.event_triggers (name, type, schema_name, table_name, configuration)
VALUES ($1, 'table', $2, $3, $4)
RETURNING id
|] (name, sn, tn, Q.AltJ $ toJSON etc) True
addEventTriggerToCatalog qt allCols etc = do
ids <- map runIdentity <$> Q.listQE defaultTxErrorHandler
[Q.sql|
INSERT into hdb_catalog.event_triggers
(name, type, schema_name, table_name, configuration)
VALUES ($1, 'table', $2, $3, $4)
RETURNING id
|] (name, sn, tn, Q.AltJ $ toJSON etc) True
trid <- getTrid ids
mkTriggerQ trid name qt allCols opsdef
return trid
where
QualifiedTable sn tn = qt
(EventTriggerConf name opsdef _ _ _ _) = etc
getTrid [] = throw500 "could not create event-trigger"
getTrid (x:_) = return x
@ -162,30 +171,33 @@ updateEventTriggerToCatalog
-> [PGColInfo]
-> EventTriggerConf
-> Q.TxE QErr TriggerId
updateEventTriggerToCatalog qt allCols etc@(EventTriggerConf name opsdef _ _ _ _) = do
ids <- map runIdentity <$> Q.listQE defaultTxErrorHandler [Q.sql|
UPDATE hdb_catalog.event_triggers
SET
configuration = $1
WHERE name = $2
RETURNING id
|] (Q.AltJ $ toJSON etc, name) True
updateEventTriggerToCatalog qt allCols etc = do
ids <- map runIdentity <$> Q.listQE defaultTxErrorHandler
[Q.sql|
UPDATE hdb_catalog.event_triggers
SET
configuration = $1
WHERE name = $2
RETURNING id
|] (Q.AltJ $ toJSON etc, name) True
trid <- getTrid ids
mkTriggerQ trid name qt allCols opsdef
return trid
where
EventTriggerConf name opsdef _ _ _ _ = etc
getTrid [] = throw500 "could not update event-trigger"
getTrid (x:_) = return x
fetchEvent :: EventId -> Q.TxE QErr (EventId, Bool)
fetchEvent eid = do
events <- Q.listQE defaultTxErrorHandler [Q.sql|
SELECT l.id, l.locked
FROM hdb_catalog.event_log l
JOIN hdb_catalog.event_triggers e
ON l.trigger_id = e.id
WHERE l.id = $1
|] (Identity eid) True
events <- Q.listQE defaultTxErrorHandler
[Q.sql|
SELECT l.id, l.locked
FROM hdb_catalog.event_log l
JOIN hdb_catalog.event_triggers e
ON l.trigger_id = e.id
WHERE l.id = $1
|] (Identity eid) True
event <- getEvent events
assertEventUnlocked event
return event
@ -207,7 +219,7 @@ markForDelivery eid =
WHERE id = $1
|] (Identity eid) True
subTableP1 :: (P1C m) => CreateEventTriggerQuery -> m (QualifiedTable, Bool, EventTriggerConf)
subTableP1 :: (UserInfoM m, QErrM m, CacheRM m) => CreateEventTriggerQuery -> m (QualifiedTable, Bool, EventTriggerConf)
subTableP1 (CreateEventTriggerQuery name qt insert update delete retryConf webhook webhookFromEnv mheaders replace) = do
adminOnly
ti <- askTabInfo qt
@ -233,7 +245,7 @@ subTableP1 (CreateEventTriggerQuery name qt insert update delete retryConf webho
--(QErrM m, CacheRWM m, MonadTx m, MonadIO m)
subTableP2Setup
:: (QErrM m, CacheRWM m, MonadTx m, MonadIO m)
:: (QErrM m, CacheRWM m, MonadIO m)
=> QualifiedTable -> TriggerId -> EventTriggerConf -> m ()
subTableP2Setup qt trid (EventTriggerConf name def webhook webhookFromEnv rconf mheaders) = do
webhookConf <- case (webhook, webhookFromEnv) of
@ -280,51 +292,53 @@ subTableP2 qt replace etc = do
liftTx $ addEventTriggerToCatalog qt allCols etc
subTableP2Setup qt trid etc
subTableP2shim
:: (QErrM m, CacheRWM m, MonadTx m, MonadIO m)
=> (QualifiedTable, Bool, EventTriggerConf) -> m RespBody
subTableP2shim (qt, replace, etc) = do
runCreateEventTriggerQuery
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m)
=> CreateEventTriggerQuery -> m RespBody
runCreateEventTriggerQuery q = do
(qt, replace, etc) <- subTableP1 q
subTableP2 qt replace etc
return successMsg
instance HDBQuery CreateEventTriggerQuery where
type Phase1Res CreateEventTriggerQuery = (QualifiedTable, Bool, EventTriggerConf)
phaseOne = subTableP1
phaseTwo _ = subTableP2shim
schemaCachePolicy = SCPReload
unsubTableP1 :: (P1C m) => DeleteEventTriggerQuery -> m QualifiedTable
unsubTableP1
:: (UserInfoM m, QErrM m, CacheRM m)
=> DeleteEventTriggerQuery -> m QualifiedTable
unsubTableP1 (DeleteEventTriggerQuery name) = do
adminOnly
ti <- askTabInfoFromTrigger name
return $ tiName ti
unsubTableP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => QualifiedTable -> DeleteEventTriggerQuery -> m RespBody
unsubTableP2 qt (DeleteEventTriggerQuery name) = do
unsubTableP2
:: (QErrM m, CacheRWM m, MonadTx m)
=> DeleteEventTriggerQuery -> QualifiedTable -> m RespBody
unsubTableP2 (DeleteEventTriggerQuery name) qt = do
delEventTriggerFromCache qt name
liftTx $ delEventTriggerFromCatalog name
return successMsg
instance HDBQuery DeleteEventTriggerQuery where
type Phase1Res DeleteEventTriggerQuery = QualifiedTable
phaseOne = unsubTableP1
phaseTwo q qt = unsubTableP2 qt q
schemaCachePolicy = SCPReload
runDeleteEventTriggerQuery
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> DeleteEventTriggerQuery -> m RespBody
runDeleteEventTriggerQuery q =
unsubTableP1 q >>= unsubTableP2 q
deliverEvent :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DeliverEventQuery -> m RespBody
deliverEvent
:: (QErrM m, MonadTx m)
=> DeliverEventQuery -> m RespBody
deliverEvent (DeliverEventQuery eventId) = do
_ <- liftTx $ fetchEvent eventId
liftTx $ markForDelivery eventId
return successMsg
instance HDBQuery DeliverEventQuery where
type Phase1Res DeliverEventQuery = ()
phaseOne _ = adminOnly
phaseTwo q _ = deliverEvent q
schemaCachePolicy = SCPNoChange
runDeliverEvent
:: (QErrM m, UserInfoM m, MonadTx m)
=> DeliverEventQuery -> m RespBody
runDeliverEvent q =
adminOnly >> deliverEvent q
getHeaderInfosFromConf :: (QErrM m, MonadIO m) => [HeaderConf] -> m [EventHeaderInfo]
getHeaderInfosFromConf
:: (QErrM m, MonadIO m)
=> [HeaderConf] -> m [EventHeaderInfo]
getHeaderInfosFromConf = mapM getHeader
where
getHeader :: (QErrM m, MonadIO m) => HeaderConf -> m EventHeaderInfo
@ -334,7 +348,8 @@ getHeaderInfosFromConf = mapM getHeader
envVal <- getEnv val
return $ EventHeaderInfo hconf envVal
getWebhookInfoFromConf :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => WebhookConf -> m WebhookConfInfo
getWebhookInfoFromConf
:: (QErrM m, MonadIO m) => WebhookConf -> m WebhookConfInfo
getWebhookInfoFromConf wc = case wc of
WCValue w -> return $ WebhookConfInfo wc w
WCEnv we -> do
@ -343,10 +358,7 @@ getWebhookInfoFromConf wc = case wc of
getEnv :: (QErrM m, MonadIO m) => T.Text -> m T.Text
getEnv env = do
mEnv <- liftIO $ lookupEnv (T.unpack env)
case mEnv of
Nothing -> throw400 NotFound $ "environment variable '" <> env <> "' not set"
Just envVal -> return (T.pack envVal)
toInt64 :: (Integral a) => a -> Int64
toInt64 = fromIntegral
mEnv <- liftIO $ lookupEnv (T.unpack env)
case mEnv of
Nothing -> throw400 NotFound $ "environment variable '" <> env <> "' not set"
Just envVal -> return (T.pack envVal)

2
server/src-lib/Hasura/RQL/DDL/Utils.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.DDL.Utils
( clearHdbViews
) where

45
server/src-lib/Hasura/RQL/DML/Count.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Count where
module Hasura.RQL.DML.Count
( CountQueryP1(..)
, getCountDeps
, validateCountQWith
, validateCountQ
, runCount
, countQToTx
) where
import Data.Aeson
import Instances.TH.Lift ()
@ -68,12 +70,12 @@ mkSQLCount (CountQueryP1 tn (permFltr, mWc) mDistCols) =
-- SELECT count(*) FROM (SELECT DISTINCT c1, .. cn FROM .. WHERE ..) r;
-- SELECT count(*) FROM (SELECT * FROM .. WHERE ..) r;
countP1
:: (P1C m)
validateCountQWith
:: (UserInfoM m, QErrM m, CacheRM m)
=> (PGColType -> Value -> m S.SQLExp)
-> CountQuery
-> m CountQueryP1
countP1 prepValBuilder (CountQuery qt mDistCols mWhere) = do
validateCountQWith prepValBuilder (CountQuery qt mDistCols mWhere) = do
tableInfo <- askTabInfo qt
-- Check if select is allowed
@ -103,8 +105,16 @@ countP1 prepValBuilder (CountQuery qt mDistCols mWhere) = do
relInDistColsErr =
"Relationships can't be used in \"distinct\"."
countP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => (CountQueryP1, DS.Seq Q.PrepArg) -> m RespBody
countP2 (u, p) = do
validateCountQ
:: (QErrM m, UserInfoM m, CacheRM m)
=> CountQuery -> m (CountQueryP1, DS.Seq Q.PrepArg)
validateCountQ =
liftDMLP1 . validateCountQWith binRHSBuilder
countQToTx
:: (QErrM m, MonadTx m)
=> (CountQueryP1, DS.Seq Q.PrepArg) -> m RespBody
countQToTx (u, p) = do
qRes <- liftTx $ Q.rawQE dmlTxErrorHandler
(Q.fromBuilder countSQL) (toList p) True
return $ BB.toLazyByteString $ encodeCount qRes
@ -113,11 +123,8 @@ countP2 (u, p) = do
encodeCount (Q.SingleRow (Identity c)) =
BB.byteString "{\"count\":" <> BB.intDec c <> BB.char7 '}'
instance HDBQuery CountQuery where
type Phase1Res CountQuery = (CountQueryP1, DS.Seq Q.PrepArg)
phaseOne = flip runStateT DS.empty . countP1 binRHSBuilder
phaseTwo _ = countP2
schemaCachePolicy = SCPNoChange
runCount
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> CountQuery -> m RespBody
runCount q =
validateCountQ q >>= countQToTx

44
server/src-lib/Hasura/RQL/DML/Delete.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Delete where
module Hasura.RQL.DML.Delete
( validateDeleteQWith
, validateDeleteQ
, DeleteQueryP1(..)
, deleteQueryToTx
, getDeleteDeps
, runDelete
) where
import Data.Aeson
import Instances.TH.Lift ()
@ -45,12 +47,12 @@ getDeleteDeps (DeleteQueryP1 tn (_, wc) mutFlds) =
retDeps = map (mkColDep "untyped" tn . fst) $
pgColsFromMutFlds mutFlds
convDeleteQuery
:: (P1C m)
validateDeleteQWith
:: (UserInfoM m, QErrM m, CacheRM m)
=> (PGColType -> Value -> m S.SQLExp)
-> DeleteQuery
-> m DeleteQueryP1
convDeleteQuery prepValBuilder (DeleteQuery tableName rqlBE mRetCols) = do
validateDeleteQWith prepValBuilder (DeleteQuery tableName rqlBE mRetCols) = do
tableInfo <- askTabInfo tableName
-- If table is view then check if it deletable
@ -87,21 +89,21 @@ convDeleteQuery prepValBuilder (DeleteQuery tableName rqlBE mRetCols) = do
<> "has \"select\" permission as \"where\" can't be used "
<> "without \"select\" permission on the table"
convDelQ :: DeleteQuery -> P1 (DeleteQueryP1, DS.Seq Q.PrepArg)
convDelQ delQ = flip runStateT DS.empty $ convDeleteQuery binRHSBuilder delQ
validateDeleteQ
:: (QErrM m, UserInfoM m, CacheRM m)
=> DeleteQuery -> m (DeleteQueryP1, DS.Seq Q.PrepArg)
validateDeleteQ =
liftDMLP1 . validateDeleteQWith binRHSBuilder
deleteP2 :: (DeleteQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
deleteP2 (u, p) =
deleteQueryToTx :: (DeleteQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
deleteQueryToTx (u, p) =
runIdentity . Q.getRow
<$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder deleteSQL) (toList p) True
where
deleteSQL = toSQL $ mkSQLDelete u
instance HDBQuery DeleteQuery where
type Phase1Res DeleteQuery = (DeleteQueryP1, DS.Seq Q.PrepArg)
phaseOne = convDelQ
phaseTwo _ = liftTx . deleteP2
schemaCachePolicy = SCPNoChange
runDelete
:: (QErrM m, UserInfoM m, CacheRM m, MonadTx m)
=> DeleteQuery -> m RespBody
runDelete q =
validateDeleteQ q >>= liftTx . deleteQueryToTx

44
server/src-lib/Hasura/RQL/DML/Insert.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Insert where
import Data.Aeson.Types
@ -78,7 +72,7 @@ getInsertDeps (InsertQueryP1 tn _ _ _ _ mutFlds) =
pgColsFromMutFlds mutFlds
convObj
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> (PGColType -> Value -> m S.SQLExp)
-> HM.HashMap PGCol S.SQLExp
-> HM.HashMap PGCol S.SQLExp
@ -107,7 +101,7 @@ convObj prepFn defInsVals setInsVals fieldInfoMap insObj = do
<> " for role " <>> role
buildConflictClause
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> TableInfo
-> [PGCol]
-> OnConflict
@ -149,7 +143,7 @@ buildConflictClause tableInfo inpCols (OnConflict mTCol mTCons act) =
convInsertQuery
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> (Value -> m [InsObj])
-> (PGColType -> Value -> m S.SQLExp)
-> InsertQuery
@ -207,16 +201,19 @@ convInsertQuery objsParser prepFn (InsertQuery tableName val oC mRetCols) = do
"; \"returning\" can only be used if the role has "
<> "\"select\" permission on the table"
decodeInsObjs :: (P1C m) => Value -> m [InsObj]
decodeInsObjs :: (UserInfoM m, QErrM m) => Value -> m [InsObj]
decodeInsObjs v = do
objs <- decodeValue v
when (null objs) $ throw400 UnexpectedPayload "objects should not be empty"
return objs
convInsQ :: InsertQuery -> P1 (InsertQueryP1, DS.Seq Q.PrepArg)
convInsQ insQ =
flip runStateT DS.empty $ convInsertQuery
(withPathK "objects" . decodeInsObjs) binRHSBuilder insQ
convInsQ
:: (QErrM m, UserInfoM m, CacheRM m)
=> InsertQuery
-> m (InsertQueryP1, DS.Seq Q.PrepArg)
convInsQ =
liftDMLP1 .
convInsertQuery (withPathK "objects" . decodeInsObjs) binRHSBuilder
insertP2 :: (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
insertP2 (u, p) =
@ -269,14 +266,11 @@ setConflictCtx conflictCtxM = do
encToText $ InsertTxConflictCtx CAUpdate (Just constr) $
Just $ toSQLTxt $ S.buildSEWithExcluded updCols
instance HDBQuery InsertQuery where
type Phase1Res InsertQuery = (InsertQueryP1, DS.Seq Q.PrepArg)
phaseOne = convInsQ
phaseTwo _ p1Res = do
role <- userRole <$> askUserInfo
liftTx $
bool (nonAdminInsert p1Res) (insertP2 p1Res) $ isAdmin role
schemaCachePolicy = SCPNoChange
runInsert
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> InsertQuery
-> m RespBody
runInsert q = do
res <- convInsQ q
role <- userRole <$> askUserInfo
liftTx $ bool (nonAdminInsert res) (insertP2 res) $ isAdmin role

64
server/src-lib/Hasura/RQL/DML/Internal.hs
View File

@ -1,20 +1,14 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Internal where
import qualified Database.PG.Query as Q
import qualified Database.PG.Query.Connection as Q
import qualified Hasura.SQL.DML as S
import Hasura.SQL.Types
import Hasura.SQL.Value
import Hasura.Prelude
import Hasura.RQL.GBoolExp
import Hasura.RQL.Types
import Hasura.Prelude
import Hasura.SQL.Types
import Hasura.SQL.Value
import Control.Lens
import Data.Aeson.Types
@ -24,18 +18,25 @@ import qualified Data.HashSet as HS
import qualified Data.Sequence as DS
import qualified Data.Text as T
type DMLP1 = StateT (DS.Seq Q.PrepArg) P1
newtype DMLP1 a
= DMLP1 {unDMLP1 :: StateT (DS.Seq Q.PrepArg) P1 a}
deriving ( Functor, Applicative
, Monad
, MonadState (DS.Seq Q.PrepArg)
, MonadError QErr
)
liftDMLP1
:: (QErrM m, UserInfoM m, CacheRM m)
=> DMLP1 a -> m (a, DS.Seq Q.PrepArg)
liftDMLP1 =
liftP1 . flip runStateT DS.empty . unDMLP1
instance CacheRM DMLP1 where
askSchemaCache = lift askSchemaCache
askSchemaCache = DMLP1 $ lift askSchemaCache
instance UserInfoM DMLP1 where
askUserInfo = lift askUserInfo
peelDMLP1 :: QCtx -> DMLP1 a -> Either QErr (a, [Q.PrepArg])
peelDMLP1 qEnv m = do
(a, prepSeq) <- runP1 qEnv $ runStateT m DS.empty
return (a, toList prepSeq)
askUserInfo = DMLP1 $ lift askUserInfo
mkAdminRolePermInfo :: TableInfo -> RolePermInfo
mkAdminRolePermInfo ti =
@ -53,7 +54,7 @@ mkAdminRolePermInfo ti =
d = DelPermInfo tn annBoolExpTrue []
askPermInfo'
:: (P1C m)
:: (UserInfoM m)
=> PermAccessor c
-> TableInfo
-> m (Maybe c)
@ -68,7 +69,7 @@ askPermInfo' pa tableInfo = do
| otherwise = M.lookup roleName rpim
askPermInfo
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> PermAccessor c
-> TableInfo
-> m c
@ -86,22 +87,22 @@ askPermInfo pa tableInfo = do
pt = permTypeToCode $ permAccToType pa
askInsPermInfo
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> TableInfo -> m InsPermInfo
askInsPermInfo = askPermInfo PAInsert
askSelPermInfo
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> TableInfo -> m SelPermInfo
askSelPermInfo = askPermInfo PASelect
askUpdPermInfo
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> TableInfo -> m UpdPermInfo
askUpdPermInfo = askPermInfo PAUpdate
askDelPermInfo
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> TableInfo -> m DelPermInfo
askDelPermInfo = askPermInfo PADelete
@ -133,7 +134,8 @@ checkPermOnCol pt allowedCols pgCol = do
, permTypeToCode pt <> " column " <>> pgCol
]
binRHSBuilder :: PGColType -> Value -> DMLP1 S.SQLExp
binRHSBuilder
:: PGColType -> Value -> DMLP1 S.SQLExp
binRHSBuilder colType val = do
preparedArgs <- get
binVal <- runAesonParser (convToBin colType) val
@ -141,7 +143,7 @@ binRHSBuilder colType val = do
return $ toPrepParam (DS.length preparedArgs + 1) colType
fetchRelTabInfo
:: (P1C m)
:: (QErrM m, CacheRM m)
=> QualifiedTable
-> m TableInfo
fetchRelTabInfo refTabName =
@ -149,7 +151,7 @@ fetchRelTabInfo refTabName =
modifyErrAndSet500 ("foreign " <> ) $ askTabInfo refTabName
fetchRelDet
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> RelName -> QualifiedTable
-> m (FieldInfoMap, SelPermInfo)
fetchRelDet relName refTabName = do
@ -171,7 +173,7 @@ fetchRelDet relName refTabName = do
]
checkOnColExp
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> SelPermInfo
-> AnnBoolExpFldSQL
-> m AnnBoolExpFldSQL
@ -186,7 +188,7 @@ checkOnColExp spi annFld = case annFld of
andAnnBoolExps modAnn $ spiFilter relSPI
checkSelPerm
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> SelPermInfo
-> AnnBoolExpSQL
-> m AnnBoolExpSQL
@ -194,7 +196,7 @@ checkSelPerm spi =
traverse (checkOnColExp spi)
convBoolExp'
:: (P1C m)
:: ( UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap
-> SelPermInfo
-> BoolExp
@ -207,7 +209,7 @@ convBoolExp' cim spi be prepValBuilder = do
dmlTxErrorHandler :: Q.PGTxErr -> QErr
dmlTxErrorHandler p2Res =
case err of
Nothing -> defaultTxErrorHandler p2Res
Nothing -> defaultTxErrorHandler p2Res
Just (code, msg) -> err400 code msg
where err = simplifyError p2Res
@ -225,7 +227,7 @@ toJSONableExp colTy expn
| otherwise = expn
-- validate headers
validateHeaders :: (P1C m) => [T.Text] -> m ()
validateHeaders :: (UserInfoM m, QErrM m) => [T.Text] -> m ()
validateHeaders depHeaders = do
headers <- getVarNames . userVars <$> askUserInfo
forM_ depHeaders $ \hdr ->

67
server/src-lib/Hasura/RQL/DML/QueryTemplate.hs
View File

@ -1,11 +1,7 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.QueryTemplate where
module Hasura.RQL.DML.QueryTemplate
( ExecQueryTemplate(..)
, runExecQueryTemplate
) where
import Hasura.Prelude
import Hasura.RQL.DDL.QueryTemplate
@ -17,7 +13,7 @@ import Hasura.RQL.Types
import Hasura.SQL.Types
import qualified Database.PG.Query as Q
import qualified Hasura.RQL.DML.Count as R
import qualified Hasura.RQL.DML.Count as RC
import qualified Hasura.RQL.DML.Delete as R
import qualified Hasura.RQL.DML.Insert as R
import qualified Hasura.RQL.DML.Select as R
@ -45,12 +41,10 @@ data ExecQueryTemplate
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''ExecQueryTemplate)
type EQTP1 = StateT (DS.Seq Q.PrepArg) P1
getParamValue
:: TemplateArgs
-> TemplateParamConf
-> EQTP1 Value
-> DMLP1 Value
getParamValue params (TemplateParamConf paramName paramVal) =
maybe paramMissing return $ M.lookup paramName params <|> paramVal
where
@ -62,7 +56,7 @@ data QueryTProc
| QTPSelect !(R.AnnSel, DS.Seq Q.PrepArg)
| QTPUpdate !(R.UpdateQueryP1, DS.Seq Q.PrepArg)
| QTPDelete !(R.DeleteQueryP1, DS.Seq Q.PrepArg)
| QTPCount !(R.CountQueryP1, DS.Seq Q.PrepArg)
| QTPCount !(RC.CountQueryP1, DS.Seq Q.PrepArg)
| QTPBulk ![QueryTProc]
deriving (Show, Eq)
@ -70,7 +64,7 @@ buildPrepArg
:: TemplateArgs
-> PGColType
-> Value
-> EQTP1 S.SQLExp
-> DMLP1 S.SQLExp
buildPrepArg args pct val =
case val of
Object _ -> do
@ -82,7 +76,7 @@ buildPrepArg args pct val =
withParamErrMsg tpc t =
"when processing parameter " <> tpcParam tpc <<> " : " <> t
decodeIntValue :: TemplateArgs -> Value -> EQTP1 Int
decodeIntValue :: TemplateArgs -> Value -> DMLP1 Int
decodeIntValue args val =
case val of
Object _ -> do
@ -91,25 +85,25 @@ decodeIntValue args val =
decodeValue v
_ -> decodeValue val
mkSelQWithArgs :: SelectQueryT -> TemplateArgs -> EQTP1 SelectQuery
mkSelQWithArgs :: SelectQueryT -> TemplateArgs -> DMLP1 SelectQuery
mkSelQWithArgs (DMLQuery tn (SelectG c w o lim offset)) args = do
intLim <- mapM (decodeIntValue args) lim
intOffset <- mapM (decodeIntValue args) offset
return $ DMLQuery tn $ SelectG c w o intLim intOffset
convQT
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> TemplateArgs
-> QueryT
-> m QueryTProc
convQT args qt = case qt of
QTInsert q -> fmap QTPInsert $ peelSt $
QTInsert q -> fmap QTPInsert $ liftDMLP1 $
R.convInsertQuery decodeParam binRHSBuilder q
QTSelect q -> fmap QTPSelect $ peelSt $
QTSelect q -> fmap QTPSelect $ liftDMLP1 $
mkSelQWithArgs q args >>= R.convSelectQuery f
QTUpdate q -> fmap QTPUpdate $ peelSt $ R.convUpdateQuery f q
QTDelete q -> fmap QTPDelete $ peelSt $ R.convDeleteQuery f q
QTCount q -> fmap QTPCount $ peelSt $ R.countP1 f q
QTUpdate q -> fmap QTPUpdate $ liftDMLP1 $ R.validateUpdateQueryWith f q
QTDelete q -> fmap QTPDelete $ liftDMLP1 $ R.validateDeleteQWith f q
QTCount q -> fmap QTPCount $ liftDMLP1 $ RC.validateCountQWith f q
QTBulk q -> fmap QTPBulk $ mapM (convQT args) q
where
decodeParam val = do
@ -118,33 +112,28 @@ convQT args qt = case qt of
R.decodeInsObjs v
f = buildPrepArg args
peelSt m = do
sc <- askSchemaCache
ui <- askUserInfo
liftEither $ runP1 (QCtx ui sc) $ runStateT m DS.empty
execQueryTemplateP1 :: ExecQueryTemplate -> P1 QueryTProc
execQueryTemplateP1
:: (UserInfoM m, QErrM m, CacheRM m)
=> ExecQueryTemplate -> m QueryTProc
execQueryTemplateP1 (ExecQueryTemplate qtn args) = do
(QueryTemplateInfo _ qt) <- askQTemplateInfo qtn
convQT args qt
execQueryTP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => QueryTProc -> m RespBody
execQueryTP2 :: (QErrM m, CacheRM m, MonadTx m) => QueryTProc -> m RespBody
execQueryTP2 qtProc = case qtProc of
QTPInsert qp -> liftTx $ R.insertP2 qp
QTPSelect qp -> liftTx $ R.selectP2 False qp
QTPUpdate qp -> liftTx $ R.updateP2 qp
QTPDelete qp -> liftTx $ R.deleteP2 qp
QTPCount qp -> R.countP2 qp
QTPUpdate qp -> liftTx $ R.updateQueryToTx qp
QTPDelete qp -> liftTx $ R.deleteQueryToTx qp
QTPCount qp -> RC.countQToTx qp
QTPBulk qps -> do
respList <- mapM execQueryTP2 qps
let bsVector = V.fromList respList
return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector
instance HDBQuery ExecQueryTemplate where
type Phase1Res ExecQueryTemplate = QueryTProc
phaseOne = execQueryTemplateP1
phaseTwo _ = execQueryTP2
schemaCachePolicy = SCPNoChange
runExecQueryTemplate
:: (QErrM m, UserInfoM m, CacheRM m, MonadTx m)
=> ExecQueryTemplate -> m RespBody
runExecQueryTemplate q =
execQueryTemplateP1 q >>= execQueryTP2

7
server/src-lib/Hasura/RQL/DML/Returning.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.DML.Returning where
import Hasura.Prelude
@ -89,7 +84,7 @@ encodeJSONVector builder xs
where go v b = BB.char7 ',' <> builder v <> b
checkRetCols
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> FieldInfoMap
-> SelPermInfo
-> [PGCol]

43
server/src-lib/Hasura/RQL/DML/Select.hs
View File

@ -1,15 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Select
( selectP2
, selectAggP2
, convSelectQuery
, getSelectDeps
, module Hasura.RQL.DML.Select.Internal
, runSelect
)
where
@ -32,7 +27,7 @@ import Hasura.SQL.Types
import qualified Database.PG.Query as Q
import qualified Hasura.SQL.DML as S
convSelCol :: (P1C m)
convSelCol :: (UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap
-> SelPermInfo
-> SelCol
@ -52,7 +47,7 @@ convSelCol fieldInfoMap spi (SCStar wildcard) =
convWildcard fieldInfoMap spi wildcard
convWildcard
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap
-> SelPermInfo
-> Wildcard
@ -80,7 +75,7 @@ convWildcard fieldInfoMap (SelPermInfo cols _ _ _ _ _) wildcard =
relExtCols wc = mapM (mkRelCol wc) relColInfos
resolveStar :: (P1C m)
resolveStar :: (UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap
-> SelPermInfo
-> SelectQ
@ -106,7 +101,7 @@ resolveStar fim spi (SelectG selCols mWh mOb mLt mOf) = do
equals _ _ = False
convOrderByElem
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> (FieldInfoMap, SelPermInfo)
-> OrderByCol
-> m AnnObCol
@ -145,7 +140,7 @@ convOrderByElem (flds, spi) = \case
convOrderByElem (relFim, relSpi) rest
convSelectQ
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap -- Table information of current table
-> SelPermInfo -- Additional select permission info
-> SelectQExt -- Given Select Query
@ -193,7 +188,7 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do
mPermLimit = spiLimit selPermInfo
convExtSimple
:: (P1C m)
:: (UserInfoM m, QErrM m)
=> FieldInfoMap
-> SelPermInfo
-> PGCol
@ -205,7 +200,7 @@ convExtSimple fieldInfoMap selPermInfo pgCol = do
relWhenPGErr = "relationships have to be expanded"
convExtRel
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> FieldInfoMap
-> RelName
-> Maybe RelName
@ -281,7 +276,7 @@ getSelectDeps (AnnSelG flds tabFrm _ tableArgs) =
getAnnSel (ASAgg _) = Nothing
convSelectQuery
:: (P1C m)
:: (UserInfoM m, QErrM m, CacheRM m)
=> (PGColType -> Value -> m S.SQLExp)
-> SelectQuery
-> m AnnSel
@ -308,12 +303,18 @@ selectP2 asSingleObject (sel, p) =
where
selectSQL = toSQL $ mkSQLSelect asSingleObject sel
instance HDBQuery SelectQuery where
phaseOne
:: (QErrM m, UserInfoM m, CacheRM m)
=> SelectQuery -> m (AnnSel, DS.Seq Q.PrepArg)
phaseOne =
liftDMLP1 . convSelectQuery binRHSBuilder
-- type Phase1Res SelectQuery = (SelectQueryP1, DS.Seq Q.PrepArg)
type Phase1Res SelectQuery = (AnnSel, DS.Seq Q.PrepArg)
phaseOne q = flip runStateT DS.empty $ convSelectQuery binRHSBuilder q
phaseTwo :: (MonadTx m) => (AnnSel, DS.Seq Q.PrepArg) -> m RespBody
phaseTwo =
liftTx . selectP2 False
phaseTwo _ = liftTx . selectP2 False
schemaCachePolicy = SCPNoChange
runSelect
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> SelectQuery -> m RespBody
runSelect q =
phaseOne q >>= phaseTwo

9
server/src-lib/Hasura/RQL/DML/Select/Internal.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.DML.Select.Internal
( mkSQLSelect
, mkAggSelect
@ -137,9 +134,12 @@ buildJsonObject pfx parAls arrRelCtx flds =
withAlsExp fldName sqlExp =
[S.SELit $ getFieldNameTxt fldName, sqlExp]
withAlsExtr fldName sqlExp =
S.Extractor sqlExp $ Just $ S.toAlias fldName
toSQLFld :: (FieldName -> S.SQLExp -> f)
-> (FieldName, AnnFld) -> f
toSQLFld f (fldAls, fld) = f fldAls $ case fld of
FCol col -> toJSONableExp (pgiType col) $
S.mkQIdenExp (mkBaseTableAls pfx) $ pgiName col
@ -207,7 +207,8 @@ processAnnOrderByItem pfx parAls arrRelCtx (OrderByItemG obTyM annObCol obNullsM
((obColAls, obColExp), relNodeM) = processAnnOrderByCol pfx parAls arrRelCtx annObCol
sqlOrdByItem =
S.OrderByItem (S.SEIden $ toIden obColAls) obTyM obNullsM
S.OrderByItem (S.SEIden $ toIden obColAls)
(unOrderType <$> obTyM) (unNullsOrder <$> obNullsM)
processAnnOrderByCol
:: Iden

44
server/src-lib/Hasura/RQL/DML/Update.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.DML.Update where
module Hasura.RQL.DML.Update
( validateUpdateQueryWith
, validateUpdateQuery
, UpdateQueryP1(..)
, updateQueryToTx
, getUpdateDeps
, runUpdate
) where
import Data.Aeson.Types
import Instances.TH.Lift ()
@ -105,12 +107,12 @@ convOp fieldInfoMap updPerm objs conv =
allowedCols = upiCols updPerm
relWhenPgErr = "relationships can't be updated"
convUpdateQuery
:: (P1C m)
validateUpdateQueryWith
:: (UserInfoM m, QErrM m, CacheRM m)
=> (PGColType -> Value -> m S.SQLExp)
-> UpdateQuery
-> m UpdateQueryP1
convUpdateQuery f uq = do
validateUpdateQueryWith f uq = do
let tableName = uqTable uq
tableInfo <- withPathK "table" $ askTabInfo tableName
@ -168,21 +170,21 @@ convUpdateQuery f uq = do
<> "has \"select\" permission as \"where\" can't be used "
<> "without \"select\" permission on the table"
convUpdQ :: UpdateQuery -> P1 (UpdateQueryP1, DS.Seq Q.PrepArg)
convUpdQ updQ = flip runStateT DS.empty $ convUpdateQuery binRHSBuilder updQ
validateUpdateQuery
:: (QErrM m, UserInfoM m, CacheRM m)
=> UpdateQuery -> m (UpdateQueryP1, DS.Seq Q.PrepArg)
validateUpdateQuery =
liftDMLP1 . validateUpdateQueryWith binRHSBuilder
updateP2 :: (UpdateQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
updateP2 (u, p) =
updateQueryToTx :: (UpdateQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
updateQueryToTx (u, p) =
runIdentity . Q.getRow
<$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder updateSQL) (toList p) True
where
updateSQL = toSQL $ mkSQLUpdate u
instance HDBQuery UpdateQuery where
type Phase1Res UpdateQuery = (UpdateQueryP1, DS.Seq Q.PrepArg)
phaseOne = convUpdQ
phaseTwo _ = liftTx . updateP2
schemaCachePolicy = SCPNoChange
runUpdate
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m)
=> UpdateQuery -> m RespBody
runUpdate q =
validateUpdateQuery q >>= liftTx . updateQueryToTx

8
server/src-lib/Hasura/RQL/GBoolExp.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Hasura.RQL.GBoolExp
( toSQLBoolExp
, getBoolExpDeps

1
server/src-lib/Hasura/RQL/Instances.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hasura.RQL.Instances where

196
server/src-lib/Hasura/RQL/Types.hs
View File

@ -1,27 +1,17 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Hasura.RQL.Types
( HasSchemaCache(..)
, ProvidesFieldInfoMap(..)
, HDBQuery(..)
, SchemaCachePolicy(..)
, queryModifiesSchema
, P1
, P1C
( P1
, liftP1
, liftP1WithQCtx
, MonadTx(..)
, LazyTx
, runLazyTx
, withUserInfo
, UserInfoM(..)
, RespBody
--, P2C
, P2Ctx (..)
-- , P2Res
, liftP1
, runP1
, successMsg
, HasHttpManager (..)
@ -69,60 +59,21 @@ import qualified Database.PG.Query as Q
import Data.Aeson
import qualified Data.Aeson.Text as AT
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Network.HTTP.Client as HTTP
class ProvidesFieldInfoMap r where
getFieldInfoMap :: QualifiedTable -> r -> Maybe FieldInfoMap
class HasSchemaCache a where
getSchemaCache :: a -> SchemaCache
instance HasSchemaCache QCtx where
getSchemaCache = qcSchemaCache
instance HasSchemaCache SchemaCache where
getSchemaCache = id
instance ProvidesFieldInfoMap SchemaCache where
getFieldInfoMap tn =
fmap tiFieldInfoMap . M.lookup tn . scTables
-- There are two phases to every query.
-- Phase 1 : Use the cached env to validate or invalidate
-- Phase 2 : Hit Postgres if need to
class HDBQuery q where
type Phase1Res q -- Phase 1 result
-- Use QCtx
phaseOne :: q -> P1 (Phase1Res q)
-- Hit Postgres
phaseTwo :: q -> Phase1Res q -> P2 BL.ByteString
schemaCachePolicy :: SchemaCachePolicy q
data SchemaCachePolicy a
= SCPReload
| SCPNoChange
deriving (Show, Eq)
schemaCachePolicyToBool :: SchemaCachePolicy a -> Bool
schemaCachePolicyToBool SCPReload = True
schemaCachePolicyToBool SCPNoChange = False
getSchemaCachePolicy :: (HDBQuery a) => a -> SchemaCachePolicy a
getSchemaCachePolicy _ = schemaCachePolicy
getFieldInfoMap
:: QualifiedTable
-> SchemaCache -> Maybe FieldInfoMap
getFieldInfoMap tn =
fmap tiFieldInfoMap . M.lookup tn . scTables
type RespBody = BL.ByteString
queryModifiesSchema :: (HDBQuery q) => q -> Bool
queryModifiesSchema =
schemaCachePolicyToBool . getSchemaCachePolicy
data QCtx
= QCtx
{ qcUserInfo :: !UserInfo
@ -138,14 +89,6 @@ instance HasQCtx QCtx where
mkAdminQCtx :: SchemaCache -> QCtx
mkAdminQCtx = QCtx adminUserInfo
data P2Ctx
= P2Ctx
{ _p2cUserInfo :: !UserInfo
, _p2cHttpManager :: !HTTP.Manager
}
type P2 = StateT SchemaCache (ReaderT P2Ctx (Q.TxE QErr))
class (Monad m) => UserInfoM m where
askUserInfo :: m UserInfo
@ -171,7 +114,7 @@ askTabInfoFromTrigger trn = do
errMsg = "event trigger " <> trn <<> " does not exist"
askEventTriggerInfo
:: (QErrM m, CacheRM m)
:: (QErrM m)
=> EventTriggerInfoMap -> TriggerName -> m EventTriggerInfo
askEventTriggerInfo etim trn = liftMaybe (err400 NotExists errMsg) $ M.lookup trn etim
where
@ -193,24 +136,13 @@ instance UserInfoM P1 where
instance CacheRM P1 where
askSchemaCache = qcSchemaCache <$> ask
instance UserInfoM P2 where
askUserInfo = _p2cUserInfo <$> ask
class (Monad m) => HasHttpManager m where
askHttpManager :: m HTTP.Manager
instance HasHttpManager P2 where
askHttpManager = _p2cHttpManager <$> ask
class (Monad m) => HasGCtxMap m where
askGCtxMap :: m GC.GCtxMap
-- instance HasGCtxMap P2 where
-- askGCtxMap = _p2cGCtxMap <$> ask
--type P2C m = (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
class (Monad m) => MonadTx m where
class (MonadError QErr m) => MonadTx m where
liftTx :: Q.TxE QErr a -> m a
instance (MonadTx m) => MonadTx (StateT s m) where
@ -219,19 +151,101 @@ instance (MonadTx m) => MonadTx (StateT s m) where
instance (MonadTx m) => MonadTx (ReaderT s m) where
liftTx = lift . liftTx
data LazyTx e a
= LTErr e
| LTNoTx a
| LTTx (Q.TxE e a)
lazyTxToQTx :: LazyTx e a -> Q.TxE e a
lazyTxToQTx = \case
LTErr e -> throwError e
LTNoTx r -> return r
LTTx tx -> tx
runLazyTx
:: Q.PGPool -> Q.TxIsolation
-> LazyTx QErr a -> ExceptT QErr IO a
runLazyTx pgPool txIso = \case
LTErr e -> throwError e
LTNoTx a -> return a
LTTx tx -> Q.runTx pgPool (txIso, Nothing) tx
setHeadersTx :: UserVars -> Q.TxE QErr ()
setHeadersTx uVars =
Q.unitQE defaultTxErrorHandler setSess () False
where
toStrictText = LT.toStrict . AT.encodeToLazyText
setSess = Q.fromText $
"SET LOCAL \"hasura.user\" = " <>
pgFmtLit (toStrictText uVars)
withUserInfo :: UserInfo -> LazyTx QErr a -> LazyTx QErr a
withUserInfo uInfo = \case
LTErr e -> LTErr e
LTNoTx a -> LTNoTx a
LTTx tx -> LTTx $ setHeadersTx (userVars uInfo) >> tx
instance Functor (LazyTx e) where
fmap f = \case
LTErr e -> LTErr e
LTNoTx a -> LTNoTx $ f a
LTTx tx -> LTTx $ fmap f tx
instance Applicative (LazyTx e) where
pure = LTNoTx
LTErr e <*> _ = LTErr e
LTNoTx f <*> r = fmap f r
LTTx _ <*> LTErr e = LTErr e
LTTx txf <*> LTNoTx a = LTTx $ txf <*> pure a
LTTx txf <*> LTTx tx = LTTx $ txf <*> tx
instance Monad (LazyTx e) where
LTErr e >>= _ = LTErr e
LTNoTx a >>= f = f a
LTTx txa >>= f =
LTTx $ txa >>= lazyTxToQTx . f
instance MonadError e (LazyTx e) where
throwError = LTErr
LTErr e `catchError` f = f e
LTNoTx a `catchError` _ = LTNoTx a
LTTx txe `catchError` f =
LTTx $ txe `catchError` (lazyTxToQTx . f)
instance MonadTx (LazyTx QErr) where
liftTx = LTTx
instance MonadTx (Q.TxE QErr) where
liftTx = id
type P1 = ExceptT QErr (Reader QCtx)
instance MonadIO (LazyTx QErr) where
liftIO = LTTx . liftIO
runP1 :: QCtx -> P1 a -> Either QErr a
runP1 qEnv m = runReader (runExceptT m) qEnv
type ER e r = ExceptT e (Reader r)
type P1 = ER QErr QCtx
runER :: r -> ER e r a -> Either e a
runER r m = runReader (runExceptT m) r
liftMaybe :: (QErrM m) => QErr -> Maybe a -> m a
liftMaybe e = maybe (throwError e) return
liftP1 :: (MonadError QErr m) => QCtx -> P1 a -> m a
liftP1 r m = liftEither $ runP1 r m
liftP1
:: ( QErrM m
, UserInfoM m
, CacheRM m
) => P1 a -> m a
liftP1 m = do
ui <- askUserInfo
sc <- askSchemaCache
let qCtx = QCtx ui sc
liftP1WithQCtx qCtx m
liftP1WithQCtx
:: (MonadError e m) => r -> ER e r a -> m a
liftP1WithQCtx r m =
liftEither $ runER r m
askFieldInfoMap
:: (QErrM m, CacheRM m)

9
server/src-lib/Hasura/RQL/Types/BoolExp.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.Types.BoolExp
( GBoolExp(..)
, gBoolExpTrue

8
server/src-lib/Hasura/RQL/Types/Common.hs
View File

@ -1,11 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.Types.Common
( PGColInfo(..)
, RelName(..)

63
server/src-lib/Hasura/RQL/Types/DML.hs
View File

@ -1,18 +1,9 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hasura.RQL.Types.DML
( BoolExp(..)
, ColExp(..)
, DMLQuery(..)
, OrderType(..)
, NullsOrder(..)
, OrderByExp(..)
, OrderByItemG(..)
@ -50,8 +41,8 @@ module Hasura.RQL.Types.DML
import qualified Hasura.SQL.DML as S
import Hasura.Prelude
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.BoolExp
import Hasura.RQL.Types.Common
import Hasura.SQL.Types
import Data.Aeson
@ -100,19 +91,47 @@ instance (FromJSON a) => FromJSON (DMLQuery a) where
parseJSON _ =
fail "Expected an object for query"
$(deriveJSON defaultOptions{constructorTagModifier = snakeCase . drop 2} ''S.OrderType)
newtype OrderType
= OrderType { unOrderType :: S.OrderType }
deriving (Show, Eq, Lift, Generic)
$(deriveJSON defaultOptions{constructorTagModifier = snakeCase . drop 1} ''S.NullsOrder)
instance FromJSON OrderType where
parseJSON =
fmap OrderType . f
where f = $(mkParseJSON
defaultOptions{constructorTagModifier = snakeCase . drop 2}
''S.OrderType)
newtype NullsOrder
= NullsOrder { unNullsOrder :: S.NullsOrder }
deriving (Show, Eq, Lift, Generic)
instance FromJSON NullsOrder where
parseJSON =
fmap NullsOrder . f
where f = $(mkParseJSON
defaultOptions{constructorTagModifier = snakeCase . drop 1}
''S.NullsOrder)
instance ToJSON OrderType where
toJSON =
f . unOrderType
where f = $(mkToJSON
defaultOptions{constructorTagModifier = snakeCase . drop 2}
''S.OrderType)
instance ToJSON NullsOrder where
toJSON =
f . unNullsOrder
where f = $(mkToJSON
defaultOptions{constructorTagModifier = snakeCase . drop 1}
''S.NullsOrder)
data OrderByCol
= OCPG !FieldName
| OCRel !FieldName !OrderByCol
deriving (Show, Eq, Lift)
-- newtype OrderByCol
-- = OrderByCol { getOrderByColPath :: [T.Text] }
-- deriving (Show, Eq, Lift)
orderByColToTxt :: OrderByCol -> Text
orderByColToTxt = \case
OCPG pgCol -> getFieldNameTxt pgCol
@ -147,9 +166,9 @@ instance FromJSON OrderByCol where
data OrderByItemG a
= OrderByItemG
{ obiType :: !(Maybe S.OrderType)
{ obiType :: !(Maybe OrderType)
, obiColumn :: !a
, obiNulls :: !(Maybe S.NullsOrder)
, obiNulls :: !(Maybe NullsOrder)
} deriving (Show, Eq, Lift, Functor, Foldable, Traversable)
type OrderByItem = OrderByItemG OrderByCol
@ -189,8 +208,8 @@ orderByParser :: AttoT.Parser T.Text OrderByItem
orderByParser =
OrderByItemG <$> otP <*> colP <*> return Nothing
where
otP = ("+" *> return (Just S.OTAsc))
<|> ("-" *> return (Just S.OTDesc))
otP = ("+" *> return (Just $ OrderType S.OTAsc))
<|> ("-" *> return (Just $ OrderType S.OTDesc))
<|> return Nothing
colP = Atto.takeText >>= orderByColFromTxt

5
server/src-lib/Hasura/RQL/Types/Error.hs
View File

@ -1,7 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
module Hasura.RQL.Types.Error
( Code(..)

6
server/src-lib/Hasura/RQL/Types/Permission.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.RQL.Types.Permission
( RoleName(..)
, UserId(..)

10
server/src-lib/Hasura/RQL/Types/RemoteSchema.hs
View File

@ -1,12 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hasura.RQL.Types.RemoteSchema where
import Hasura.Prelude
@ -22,7 +13,6 @@ import qualified Network.URI.Extended as N
import Hasura.RQL.DDL.Headers (HeaderConf (..))
import Hasura.RQL.Types.Error
type UrlFromEnv = Text
type RemoteSchemaName = Text

19
server/src-lib/Hasura/RQL/Types/SchemaCache.hs
View File

@ -1,12 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.RQL.Types.SchemaCache
( TableCache
@ -103,7 +96,6 @@ import Hasura.RQL.Types.Permission
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.SchemaCacheTypes
import Hasura.RQL.Types.Subscribe
import qualified Hasura.SQL.DML as S
import Hasura.SQL.Types
import Control.Lens
@ -176,8 +168,6 @@ reportSchemaObjs = T.intercalate ", " . map reportSchemaObj
-- $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaDependency)
instance Hashable SchemaDependency
mkParentDep :: QualifiedTable -> SchemaDependency
mkParentDep tn = SchemaDependency (SOTable tn) "table"
@ -271,11 +261,6 @@ isPGColInfo :: FieldInfo -> Bool
isPGColInfo (FIColumn _) = True
isPGColInfo _ = False
instance ToJSON S.SQLExp where
toJSON = String . T.pack . show
--type InsSetCols = M.HashMap PGCol S.SQLExp
data InsPermInfo
= InsPermInfo
{ ipiView :: !QualifiedTable

5
server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.Types.SchemaCacheTypes where
import Data.Aeson
@ -80,6 +76,7 @@ data SchemaDependency
} deriving (Show, Eq, Generic)
$(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaDependency)
instance Hashable SchemaDependency
-- data RelInfo
-- = RelInfo

4
server/src-lib/Hasura/RQL/Types/Subscribe.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.RQL.Types.Subscribe
( CreateEventTriggerQuery(..)
, SubscribeOpSpec(..)

10
server/src-lib/Hasura/SQL/DML.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.SQL.DML where
import Hasura.Prelude
@ -12,6 +6,7 @@ import Hasura.SQL.Types
import Data.String (fromString)
import Language.Haskell.TH.Syntax (Lift)
import qualified Data.Aeson as J
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Extended as T
import qualified Text.Builder as TB
@ -271,6 +266,9 @@ data SQLExp
| SECount !CountType
deriving (Show, Eq)
instance J.ToJSON SQLExp where
toJSON = J.toJSON . toSQLTxt
newtype Alias
= Alias { getAlias :: Iden }
deriving (Show, Eq, Hashable)

5
server/src-lib/Hasura/SQL/GeoJSON.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.SQL.GeoJSON
( Point(..)
, MultiPoint(..)

4
server/src-lib/Hasura/SQL/Rewrite.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.SQL.Rewrite
( prefixNumToAliases
) where

2
server/src-lib/Hasura/SQL/Time.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Hasura.SQL.Time
( ZonedTimeOfDay(..)
) where

6
server/src-lib/Hasura/SQL/Types.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.SQL.Types where
import qualified Database.PG.Query as Q

2
server/src-lib/Hasura/SQL/Value.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.SQL.Value where
import Hasura.SQL.GeoJSON

22
server/src-lib/Hasura/Server/App.hs
View File

@ -1,10 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.Server.App where
@ -41,7 +36,6 @@ import qualified Hasura.Logging as L
import Hasura.GraphQL.RemoteServer
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema.Table
--import Hasura.RQL.DML.Explain
import Hasura.RQL.DML.QueryTemplate
import Hasura.RQL.Types
import Hasura.Server.Auth (AuthMode (..),
@ -163,6 +157,7 @@ mkSpockAction qErrEncoder serverCtx handler = do
where
logger = scLogger serverCtx
-- encode error response
qErrToResp :: (MonadIO m) => Bool -> QErr -> ActionCtxT ctx m b
qErrToResp includeInternal qErr = do
setStatus $ qeStatus qErr
json $ qErrEncoder includeInternal qErr
@ -279,10 +274,11 @@ mkWaiApp
-> IO (Wai.Application, IORef SchemaCache)
mkWaiApp isoLevel mRootDir loggerCtx pool httpManager mode corsCfg enableConsole = do
cacheRef <- do
pgResp <- liftIO $ runExceptT $ Q.runTx pool (Q.Serializable, Nothing) $ do
Q.catchE defaultTxErrorHandler initStateTx
buildSchemaCache httpManager
either initErrExit return pgResp >>= newIORef
pgResp <- runExceptT $
peelRun emptySchemaCache adminUserInfo httpManager pool Q.Serializable $ do
liftTx $ Q.catchE defaultTxErrorHandler initStateTx
buildSchemaCache
either initErrExit return pgResp >>= newIORef . snd
cacheLock <- newMVar ()
@ -293,7 +289,7 @@ mkWaiApp isoLevel mRootDir loggerCtx pool httpManager mode corsCfg enableConsole
spockApp <- spockAsApp $ spockT id $
httpApp mRootDir corsCfg serverCtx enableConsole
let runTx tx = runExceptT $ Q.runTx pool (isoLevel, Nothing) tx
let runTx tx = runExceptT $ runLazyTx pool isoLevel tx
wsServerEnv <- WS.createWSServerEnv (scLogger serverCtx) httpManager cacheRef runTx
let wsServerApp = WS.createWSServerApp mode wsServerEnv

14
server/src-lib/Hasura/Server/Auth.hs
View File

@ -1,10 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
module Hasura.Server.Auth
( getUserInfo
@ -40,7 +35,7 @@ import qualified Network.HTTP.Client as H
import qualified Network.HTTP.Types as N
import qualified Network.Wreq as Wreq
import Hasura.HTTP.Utils (wreqOptions)
import Hasura.HTTP
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.Types
@ -218,7 +213,8 @@ userInfoFromAuthHook logger manager hook reqHeaders = do
logAndThrow err = do
liftIO $ L.unLogger logger $
WebHookLog L.LevelError Nothing urlT method (Just err) Nothing
WebHookLog L.LevelError Nothing urlT method
(Just $ HttpException err) Nothing
throw500 "Internal Server Error"
filteredHeaders = flip filter reqHeaders $ \(n, _) ->

11
server/src-lib/Hasura/Server/Auth/JWT.hs
View File

@ -1,9 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Server.Auth.JWT
( processJwt
, RawJWT
@ -27,7 +21,7 @@ import Data.Time.Clock (NominalDiffTime, diffUTCTime,
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Network.URI (URI)
import Hasura.HTTP.Utils
import Hasura.HTTP
import Hasura.Logging (Logger (..))
import Hasura.Prelude
import Hasura.RQL.Types
@ -150,7 +144,8 @@ updateJwkRef (Logger logger) manager url jwkRef = do
logAndThrowHttp :: (MonadIO m, MonadError T.Text m) => HTTP.HttpException -> m a
logAndThrowHttp err = do
let httpErr = JwkRefreshHttpError Nothing (T.pack $ show url) (Just err) Nothing
let httpErr = JwkRefreshHttpError Nothing (T.pack $ show url)
(Just $ HttpException err) Nothing
errMsg = "error fetching JWK: " <> T.pack (show err)
logAndThrow errMsg (Just httpErr)

2
server/src-lib/Hasura/Server/Auth/JWT/Internal.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.Server.Auth.JWT.Internal where
import Control.Lens

6
server/src-lib/Hasura/Server/Auth/JWT/Logging.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.Server.Auth.JWT.Logging
( JwkRefreshLog (..)
, JwkRefreshHttpError (..)
@ -9,12 +7,12 @@ module Hasura.Server.Auth.JWT.Logging
import Data.Aeson
import Hasura.HTTP
import Hasura.Logging (LogLevel (..), ToEngineLog (..))
import Hasura.Prelude
import Hasura.Server.Logging ()
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
@ -29,7 +27,7 @@ data JwkRefreshHttpError
= JwkRefreshHttpError
{ jrheStatus :: !(Maybe HTTP.Status)
, jrheUrl :: !T.Text
, jrheHttpException :: !(Maybe HTTP.HttpException)
, jrheHttpException :: !(Maybe HttpException)
, jrheResponse :: !(Maybe T.Text)
} deriving (Show)

5
server/src-lib/Hasura/Server/CheckUpdates.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Server.CheckUpdates
( checkForUpdates
) where
@ -19,7 +16,7 @@ import qualified Network.HTTP.Client as H
import qualified Network.Wreq as Wreq
import qualified System.Log.FastLogger as FL
import Hasura.HTTP.Utils
import Hasura.HTTP
import Hasura.Logging (LoggerCtx (..))
import Hasura.Prelude
import Hasura.Server.Version (currentVersion)

4
server/src-lib/Hasura/Server/Init.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Hasura.Server.Init where
import qualified Database.PG.Query as Q
@ -16,7 +13,6 @@ import Hasura.RQL.Types (RoleName (..))
import Hasura.Server.Auth
import Hasura.Server.Utils
newtype InitError
= InitError String
deriving (Show, Eq)

33
server/src-lib/Hasura/Server/Logging.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- This is taken from wai-logger and customised for our use
module Hasura.Server.Logging
@ -9,6 +5,7 @@ module Hasura.Server.Logging
, getRequestHeader
, WebHookLog(..)
, WebHookLogger
, HttpException
) where
import Crypto.Hash (Digest, SHA1, hash)
@ -30,7 +27,6 @@ import Text.Printf (printf)
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import qualified Network.HTTP.Client as H
import qualified Network.HTTP.Types as N
import qualified Hasura.Logging as L
@ -38,7 +34,7 @@ import Hasura.Prelude
import Hasura.RQL.Types.Error
import Hasura.RQL.Types.Permission
import Hasura.Server.Utils
import Hasura.HTTP
data WebHookLog
= WebHookLog
@ -46,7 +42,7 @@ data WebHookLog
, whlStatusCode :: !(Maybe N.Status)
, whlUrl :: !T.Text
, whlMethod :: !N.StdMethod
, whlError :: !(Maybe H.HttpException)
, whlError :: !(Maybe HttpException)
, whlResponse :: !(Maybe T.Text)
} deriving (Show)
@ -54,23 +50,14 @@ instance L.ToEngineLog WebHookLog where
toEngineLog webHookLog =
(whlLogLevel webHookLog, "webhook-log", toJSON webHookLog)
instance ToJSON H.HttpException where
toJSON (H.InvalidUrlException _ e) =
object [ "type" .= ("invalid_url" :: T.Text)
, "message" .= e
]
toJSON (H.HttpExceptionRequest _ cont) =
object [ "type" .= ("http_exception" :: T.Text)
, "message" .= show cont
]
instance ToJSON WebHookLog where
toJSON whl = object [ "status_code" .= (N.statusCode <$> whlStatusCode whl)
, "url" .= whlUrl whl
, "method" .= show (whlMethod whl)
, "http_error" .= whlError whl
, "response" .= whlResponse whl
]
toJSON whl =
object [ "status_code" .= (N.statusCode <$> whlStatusCode whl)
, "url" .= whlUrl whl
, "method" .= show (whlMethod whl)
, "http_error" .= whlError whl
, "response" .= whlResponse whl
]
type WebHookLogger = WebHookLog -> IO ()

2
server/src-lib/Hasura/Server/Middleware.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.Server.Middleware where
import Data.Maybe (fromMaybe)

243
server/src-lib/Hasura/Server/Query.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Server.Query where
import Data.Aeson
@ -10,11 +5,8 @@ import Data.Aeson.Casing
import Data.Aeson.TH
import Language.Haskell.TH.Syntax (Lift)
import qualified Data.Aeson.Text as AT
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as LT
import qualified Data.Vector as V
import qualified Network.HTTP.Client as HTTP
@ -23,11 +15,17 @@ import Hasura.RQL.DDL.Metadata
import Hasura.RQL.DDL.Permission
import Hasura.RQL.DDL.QueryTemplate
import Hasura.RQL.DDL.Relationship
import Hasura.RQL.DDL.RemoteSchema
import Hasura.RQL.DDL.Schema.Table
import Hasura.RQL.DDL.Subscribe
import Hasura.RQL.DML.Count
import Hasura.RQL.DML.Delete
import Hasura.RQL.DML.Insert
import Hasura.RQL.DML.QueryTemplate
import Hasura.RQL.DML.Returning (encodeJSONVector)
import Hasura.RQL.DML.Select
import Hasura.RQL.DML.Update
import Hasura.RQL.Types
import Hasura.SQL.Types
import qualified Database.PG.Query as Q
@ -89,20 +87,34 @@ $(deriveJSON
}
''RQLQuery)
buildTx
:: (HDBQuery q)
=> UserInfo
-> SchemaCache
newtype Run a
= Run {unRun :: StateT SchemaCache (ReaderT (UserInfo, HTTP.Manager) (LazyTx QErr)) a}
deriving ( Functor, Applicative, Monad
, MonadError QErr
, MonadState SchemaCache
, MonadReader (UserInfo, HTTP.Manager)
, CacheRM
, CacheRWM
, MonadTx
, MonadIO
)
instance UserInfoM Run where
askUserInfo = asks fst
instance HasHttpManager Run where
askHttpManager = asks snd
peelRun
:: SchemaCache
-> UserInfo
-> HTTP.Manager
-> q
-> Either QErr (Q.TxE QErr (BL.ByteString, SchemaCache))
buildTx userInfo sc httpManager q = do
p1Res <- withPathK "args" $ runP1 qEnv $ phaseOne q
return $ flip runReaderT p2Ctx $
flip runStateT sc $ withPathK "args" $ phaseTwo q p1Res
-> Q.PGPool -> Q.TxIsolation
-> Run a -> ExceptT QErr IO (a, SchemaCache)
peelRun sc userInfo httMgr pgPool txIso (Run m) =
runLazyTx pgPool txIso $ withUserInfo userInfo lazyTx
where
p2Ctx = P2Ctx userInfo httpManager
qEnv = QCtx userInfo sc
lazyTx = runReaderT (runStateT m sc) (userInfo, httMgr)
runQuery
:: (MonadIO m, MonadError QErr m)
@ -110,136 +122,115 @@ runQuery
-> UserInfo -> SchemaCache -> HTTP.Manager
-> RQLQuery -> m (BL.ByteString, SchemaCache)
runQuery pool isoL userInfo sc hMgr query = do
tx <- liftEither $ buildTxAny userInfo sc hMgr query
res <- liftIO $ runExceptT $ Q.runTx pool (isoL, Nothing) $
setHeadersTx (userVars userInfo) >> tx
res <- liftIO $ runExceptT $
peelRun sc userInfo hMgr pool isoL $ runQueryM query
liftEither res
queryNeedsReload :: RQLQuery -> Bool
queryNeedsReload qi = case qi of
RQAddExistingTableOrView q -> queryModifiesSchema q
RQTrackTable q -> queryModifiesSchema q
RQUntrackTable q -> queryModifiesSchema q
RQAddExistingTableOrView _ -> True
RQTrackTable _ -> True
RQUntrackTable _ -> True
RQCreateObjectRelationship q -> queryModifiesSchema q
RQCreateArrayRelationship q -> queryModifiesSchema q
RQDropRelationship q -> queryModifiesSchema q
RQSetRelationshipComment q -> queryModifiesSchema q
RQCreateObjectRelationship _ -> True
RQCreateArrayRelationship _ -> True
RQDropRelationship _ -> True
RQSetRelationshipComment _ -> False
RQCreateInsertPermission q -> queryModifiesSchema q
RQCreateSelectPermission q -> queryModifiesSchema q
RQCreateUpdatePermission q -> queryModifiesSchema q
RQCreateDeletePermission q -> queryModifiesSchema q
RQCreateInsertPermission _ -> True
RQCreateSelectPermission _ -> True
RQCreateUpdatePermission _ -> True
RQCreateDeletePermission _ -> True
RQDropInsertPermission q -> queryModifiesSchema q
RQDropSelectPermission q -> queryModifiesSchema q
RQDropUpdatePermission q -> queryModifiesSchema q
RQDropDeletePermission q -> queryModifiesSchema q
RQSetPermissionComment q -> queryModifiesSchema q
RQDropInsertPermission _ -> True
RQDropSelectPermission _ -> True
RQDropUpdatePermission _ -> True
RQDropDeletePermission _ -> True
RQSetPermissionComment _ -> False
RQInsert q -> queryModifiesSchema q
RQSelect q -> queryModifiesSchema q
RQUpdate q -> queryModifiesSchema q
RQDelete q -> queryModifiesSchema q
RQCount q -> queryModifiesSchema q
RQInsert _ -> False
RQSelect _ -> False
RQUpdate _ -> False
RQDelete _ -> False
RQCount _ -> False
RQAddRemoteSchema q -> queryModifiesSchema q
RQRemoveRemoteSchema q -> queryModifiesSchema q
RQAddRemoteSchema _ -> True
RQRemoveRemoteSchema _ -> True
RQCreateEventTrigger q -> queryModifiesSchema q
RQDeleteEventTrigger q -> queryModifiesSchema q
RQDeliverEvent q -> queryModifiesSchema q
RQCreateEventTrigger _ -> True
RQDeleteEventTrigger _ -> True
RQDeliverEvent _ -> False
RQCreateQueryTemplate q -> queryModifiesSchema q
RQDropQueryTemplate q -> queryModifiesSchema q
RQExecuteQueryTemplate q -> queryModifiesSchema q
RQSetQueryTemplateComment q -> queryModifiesSchema q
RQCreateQueryTemplate _ -> True
RQDropQueryTemplate _ -> True
RQExecuteQueryTemplate _ -> False
RQSetQueryTemplateComment _ -> False
RQRunSql q -> queryModifiesSchema q
RQRunSql _ -> True
RQReplaceMetadata q -> queryModifiesSchema q
RQExportMetadata q -> queryModifiesSchema q
RQClearMetadata q -> queryModifiesSchema q
RQReloadMetadata q -> queryModifiesSchema q
RQReplaceMetadata _ -> True
RQExportMetadata _ -> False
RQClearMetadata _ -> True
RQReloadMetadata _ -> True
RQDumpInternalState q -> queryModifiesSchema q
RQDumpInternalState _ -> False
RQBulk qs -> any queryNeedsReload qs
buildTxAny
:: UserInfo
-> SchemaCache
-> HTTP.Manager
-> RQLQuery
-> Either QErr (Q.TxE QErr (BL.ByteString, SchemaCache))
buildTxAny userInfo sc hMgr rq = case rq of
RQAddExistingTableOrView q -> buildTx' q
RQTrackTable q -> buildTx' q
RQUntrackTable q -> buildTx' q
runQueryM
:: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m
, MonadIO m, HasHttpManager m
)
=> RQLQuery
-> m RespBody
runQueryM rq = withPathK "args" $ case rq of
RQAddExistingTableOrView q -> runTrackTableQ q
RQTrackTable q -> runTrackTableQ q
RQUntrackTable q -> runUntrackTableQ q
RQCreateObjectRelationship q -> buildTx' q
RQCreateArrayRelationship q -> buildTx' q
RQDropRelationship q -> buildTx' q
RQSetRelationshipComment q -> buildTx' q
RQCreateObjectRelationship q -> runCreateObjRel q
RQCreateArrayRelationship q -> runCreateArrRel q
RQDropRelationship q -> runDropRel q
RQSetRelationshipComment q -> runSetRelComment q
RQCreateInsertPermission q -> buildTx' q
RQCreateSelectPermission q -> buildTx' q
RQCreateUpdatePermission q -> buildTx' q
RQCreateDeletePermission q -> buildTx' q
RQCreateInsertPermission q -> runCreatePerm q
RQCreateSelectPermission q -> runCreatePerm q
RQCreateUpdatePermission q -> runCreatePerm q
RQCreateDeletePermission q -> runCreatePerm q
RQDropInsertPermission q -> buildTx' q
RQDropSelectPermission q -> buildTx' q
RQDropUpdatePermission q -> buildTx' q
RQDropDeletePermission q -> buildTx' q
RQSetPermissionComment q -> buildTx' q
RQDropInsertPermission q -> runDropPerm q
RQDropSelectPermission q -> runDropPerm q
RQDropUpdatePermission q -> runDropPerm q
RQDropDeletePermission q -> runDropPerm q
RQSetPermissionComment q -> runSetPermComment q
RQInsert q -> buildTx' q
RQSelect q -> buildTx' q
RQUpdate q -> buildTx' q
RQDelete q -> buildTx' q
RQCount q -> buildTx' q
RQInsert q -> runInsert q
RQSelect q -> runSelect q
RQUpdate q -> runUpdate q
RQDelete q -> runDelete q
RQCount q -> runCount q
RQAddRemoteSchema q -> buildTx' q
RQRemoveRemoteSchema q -> buildTx' q
RQAddRemoteSchema q -> runAddRemoteSchema q
RQRemoveRemoteSchema q -> runRemoveRemoteSchema q
RQCreateEventTrigger q -> buildTx' q
RQDeleteEventTrigger q -> buildTx' q
RQDeliverEvent q -> buildTx' q
RQCreateEventTrigger q -> runCreateEventTriggerQuery q
RQDeleteEventTrigger q -> runDeleteEventTriggerQuery q
RQDeliverEvent q -> runDeliverEvent q
RQCreateQueryTemplate q -> buildTx' q
RQDropQueryTemplate q -> buildTx' q
RQExecuteQueryTemplate q -> buildTx' q
RQSetQueryTemplateComment q -> buildTx' q
RQCreateQueryTemplate q -> runCreateQueryTemplate q
RQDropQueryTemplate q -> runDropQueryTemplate q
RQExecuteQueryTemplate q -> runExecQueryTemplate q
RQSetQueryTemplateComment q -> runSetQueryTemplateComment q
RQReplaceMetadata q -> buildTx' q
RQClearMetadata q -> buildTx' q
RQExportMetadata q -> buildTx' q
RQReloadMetadata q -> buildTx' q
RQReplaceMetadata q -> runReplaceMetadata q
RQClearMetadata q -> runClearMetadata q
RQExportMetadata q -> runExportMetadata q
RQReloadMetadata q -> runReloadMetadata q
RQDumpInternalState q -> buildTx' q
RQDumpInternalState q -> runDumpInternalState q
RQRunSql q -> buildTx' q
RQRunSql q -> runRunSQL q
RQBulk qs ->
let f (respList, scf) q = do
dbAction <- liftEither $ buildTxAny userInfo scf hMgr q
(resp, newSc) <- dbAction
return ((Seq.|>) respList resp, newSc)
in
return $ withPathK "args" $ do
(respList, finalSc) <- indexedFoldM f (Seq.empty, sc) qs
let bsVector = V.fromList $ toList respList
return ( BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector
, finalSc
)
where buildTx' q = buildTx userInfo sc hMgr q
setHeadersTx :: UserVars -> Q.TxE QErr ()
setHeadersTx uVars =
Q.unitQE defaultTxErrorHandler setSess () False
where
toStrictText = LT.toStrict . AT.encodeToLazyText
setSess = Q.fromText $
"SET LOCAL \"hasura.user\" = " <>
pgFmtLit (toStrictText uVars)
RQBulk qs -> do
respVector <- V.fromList <$> indexedMapM runQueryM qs
return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString respVector

3
server/src-lib/Hasura/Server/Utils.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hasura.Server.Utils where
import qualified Database.PG.Query.Connection as Q

3
server/src-lib/Hasura/Server/Version.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Server.Version
( currentVersion
, consoleVersion

20
server/stack-nightly.yaml
View File

@ -2,7 +2,7 @@
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
# resolver: lts-10.8
resolver: nightly-2018-06-27
resolver: nightly-2018-12-10
# Local packages, usually specified by relative directory name
packages:
@ -13,13 +13,19 @@ packages:
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps:
# - graphql-api-0.3.0
- git: git@github.com:hasura/pg-client-hs.git
commit: 77995388cab656f9180b851f33f3d603cf1017c7
- git: git@github.com:hasura/graphql-parser-hs.git
commit: 59426f985a68a71cef566fe4ee11ae3b11deaa65
- Spock-core-0.13.0.0
- git: https://github.com/hasura/pg-client-hs.git
commit: 47b168d252d4adc800137a8b2cd3fc977cb3468d
- git: https://github.com/hasura/graphql-parser-hs.git
commit: 75782ae894cce05ed31e5b87fd696fc10e88baf9
- ginger-0.8.1.0
- wreq-0.5.3.0
- primitive-extras-0.7.1
- stm-hamt-1.2.0.2
- stm-containers-1.1.0.2
- reroute-0.5.0.0
- Spock-core-0.13.0.0
# Override default flag values for local packages and extra-deps
flags: {}

4
server/stack.yaml
View File

@ -2,7 +2,7 @@
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
# resolver: lts-10.8
resolver: lts-12.13
resolver: lts-12.22
compiler: ghc-8.4.4
# Local packages, usually specified by relative directory name
@ -20,7 +20,7 @@ extra-deps:
commit: 47b168d252d4adc800137a8b2cd3fc977cb3468d
- git: https://github.com/hasura/graphql-parser-hs.git
commit: 75782ae894cce05ed31e5b87fd696fc10e88baf9
- ginger-0.8.0.1
- ginger-0.8.1.0
# for text-builder
- text-builder-0.6.4