From 039a1c78532adb84c1cad74b923483847e507e25 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 30 Nov 2018 13:01:22 +0530 Subject: [PATCH 01/15] remove phase one/two distinction and hdbquery typeclass --- server/graphql-engine.cabal | 7 +- server/src-exec/Main.hs | 17 +- server/src-exec/Ops.hs | 133 ++++---- server/src-lib/Hasura/Events/Lib.hs | 13 +- .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 2 +- .../Hasura/GraphQL/Resolve/Introspect.hs | 9 +- .../Hasura/GraphQL/Resolve/Mutation.hs | 4 +- server/src-lib/Hasura/Prelude.hs | 1 + server/src-lib/Hasura/RQL/DDL/Metadata.hs | 121 +++---- server/src-lib/Hasura/RQL/DDL/Permission.hs | 48 ++- .../Hasura/RQL/DDL/Permission/Internal.hs | 63 ++-- .../src-lib/Hasura/RQL/DDL/QueryTemplate.hs | 91 +++--- server/src-lib/Hasura/RQL/DDL/Relationship.hs | 90 ++--- server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs | 43 +-- server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs | 8 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 95 +++--- server/src-lib/Hasura/RQL/DDL/Subscribe.hs | 137 ++++---- server/src-lib/Hasura/RQL/DML/Count.hs | 45 ++- server/src-lib/Hasura/RQL/DML/Delete.hs | 39 ++- server/src-lib/Hasura/RQL/DML/Insert.hs | 39 ++- server/src-lib/Hasura/RQL/DML/Internal.hs | 48 +-- .../src-lib/Hasura/RQL/DML/QueryTemplate.hs | 48 +-- server/src-lib/Hasura/RQL/DML/Returning.hs | 2 +- server/src-lib/Hasura/RQL/DML/Select.hs | 41 ++- server/src-lib/Hasura/RQL/DML/Update.hs | 39 ++- server/src-lib/Hasura/RQL/Types.hs | 134 ++++---- server/src-lib/Hasura/RQL/Types/DML.hs | 1 - server/src-lib/Hasura/Server/App.hs | 9 +- server/src-lib/Hasura/Server/Query.hs | 307 +++++++++++------- 29 files changed, 914 insertions(+), 720 deletions(-) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 020f31a0b3c88..802a46c0e5682 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -232,7 +232,12 @@ library 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 diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 297582b1fdf92..533334f9da0df 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -27,11 +27,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 @@ -189,22 +191,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" diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index c3b0c787fe43a..7bcb4e3ac680d 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -27,22 +27,23 @@ import qualified Data.Text as T 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,32 +64,34 @@ 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 + void $ runQueryM metadataQuery -- Execute the query - void $ snd <$> tx + -- void $ snd <$> tx setAllAsSystemDefined >> addVersion initTime return "initialise: successfully initialised" @@ -102,7 +105,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 +121,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 +145,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 +171,45 @@ 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, QErrM 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 + -- tx <- liftEither $ buildTxAny adminUserInfo + -- emptySchemaCache httpMgr migrateMetadataFrom1 + void $ runQueryM migrateMetadataFrom1 -- set as system defined setAsSystemDefined -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, QErrM 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 + -- tx <- liftEither $ buildTxAny adminUserInfo + -- emptySchemaCache httpMgr migrateMetadataFrom4 + -- void tx + void $ runQueryM migrateMetadataFrom4 -- set as system defined setAsSystemDefined -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 +233,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, QErrM 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 +261,7 @@ migrateCatalog httpMgr migrationTime = do postMigrate from4ToCurrent = do - from4To5 httpMgr + from4To5 from5ToCurrent from3ToCurrent = do @@ -260,7 +273,7 @@ migrateCatalog httpMgr migrationTime = do from3ToCurrent from1ToCurrent = do - from1To2 httpMgr + from1To2 from2ToCurrent from08ToCurrent = do @@ -271,27 +284,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, QErrM 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 diff --git a/server/src-lib/Hasura/Events/Lib.hs b/server/src-lib/Hasura/Events/Lib.hs index 0d6b7e4afc647..b2c4ef2d969f4 100644 --- a/server/src-lib/Hasura/Events/Lib.hs +++ b/server/src-lib/Hasura/Events/Lib.hs @@ -195,10 +195,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 +205,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 +215,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 diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index d90a0c858da71..e86c1e3eb927c 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -29,7 +29,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 -> diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs index 323aa29c25a03..f3a6460aafeac 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs @@ -61,8 +61,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 +102,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 +221,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 -> diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index e4280c8cbbf28..fff80c6490485 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -128,7 +128,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 +142,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) diff --git a/server/src-lib/Hasura/Prelude.hs b/server/src-lib/Hasura/Prelude.hs index b867cd8a26ffa..15c24f4d74d02 100644 --- a/server/src-lib/Hasura/Prelude.hs +++ b/server/src-lib/Hasura/Prelude.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index 83f1aad042e26..27157236de389 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -6,28 +6,23 @@ {-# LANGUAGE TypeFamilies #-} module Hasura.RQL.DDL.Metadata - ( ReplaceMetadata(..) - , TableMeta(..) - , tmObjectRelationships - , tmArrayRelationships - , tmInsertPermissions - , tmSelectPermissions - , tmUpdatePermissions - , tmDeletePermissions - - , mkTableMeta - , applyQP1 - , applyQP2 + ( TableMeta - , DumpInternalState(..) + , ReplaceMetadata(..) + , runReplaceMetadata , ExportMetadata(..) + , runExportMetadata , fetchMetadata , ClearMetadata(..) - , clearMetadata + , runClearMetadata , ReloadMetadata(..) + , runReloadMetadata + + , DumpInternalState(..) + , runDumpInternalState ) where import Control.Lens @@ -131,18 +126,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 +145,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 @@ -211,9 +205,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 +261,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 +380,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 +396,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 +415,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 diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index 34ff02dd344d6..e751a340d4cc7 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -8,11 +8,10 @@ module Hasura.RQL.DDL.Permission ( CreatePerm - , SetPermComment(..) + , runCreatePerm , purgePerm , PermDef(..) - , InsPerm(..) , InsPermDef , CreateInsPerm @@ -46,6 +45,12 @@ module Hasura.RQL.DDL.Permission , IsPerm(..) , addPermP1 , addPermP2 + + , DropPerm + , runDropPerm + + , SetPermComment(..) + , runSetPermComment ) where import Hasura.Prelude @@ -165,7 +170,9 @@ clearInsInfra vn = type DropInsPerm = DropPerm InsPerm -dropInsPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropInsPerm -> QualifiedTable -> m () +dropInsPermP2 + :: (QErrM m, CacheRWM m, MonadTx m) + => DropInsPerm -> QualifiedTable -> m () dropInsPermP2 = dropPermP2 type instance PermInfo InsPerm = InsPermInfo @@ -232,8 +239,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 + :: (QErrM m, CacheRWM m, MonadTx m) + => DropSelPerm -> m () +dropSelPermP2 dp = + dropPermP2 dp () instance IsPerm SelPerm where @@ -291,7 +301,9 @@ type instance PermInfo UpdPerm = UpdPermInfo type DropUpdPerm = DropPerm UpdPerm -dropUpdPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropUpdPerm -> m () +dropUpdPermP2 + :: (QErrM m, CacheRWM m, MonadTx m) + => DropUpdPerm -> m () dropUpdPermP2 dp = dropPermP2 dp () instance IsPerm UpdPerm where @@ -337,7 +349,7 @@ buildDelPermInfo tabInfo (DelPerm fltr) = do type DropDelPerm = DropPerm DelPerm -dropDelPermP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => DropDelPerm -> m () +dropDelPermP2 :: (QErrM m, CacheRWM m, MonadTx m) => DropDelPerm -> m () dropDelPermP2 dp = dropPermP2 dp () type instance PermInfo DelPerm = DelPermInfo @@ -368,7 +380,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 +392,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 +417,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 + :: (QErrM m, CacheRWM m, MonadTx m) + => QualifiedTable -> RoleName -> PermType -> m () purgePerm qt rn pt = case pt of PTInsert -> dropInsPermP2 dp $ buildViewName qt rn PTInsert diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs index 2a8a5b5d04f94..c8673b285ee6a 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs @@ -163,11 +163,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 @@ -305,22 +300,30 @@ addPermP2 tn pd (permInfo, deps) = do pa = getPermAcc1 pd pt = permAccToType pa -instance (IsPerm a) => HDBQuery (CreatePerm a) where - - type Phase1Res (CreatePerm a) = WithDeps (PermInfo a) - - 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) +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 + +runCreatePerm + :: ( UserInfoM m, MonadError QErr 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 + +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 +340,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, QErrM m, CacheRWM m, MonadTx m) + => DropPerm a -> m RespBody +runDropPerm defn = do + permInfo <- buildDropPermP1Res defn + dropPermP2 defn permInfo + return successMsg + +-- instance (IsPerm a) => HDBQuery (DropPerm a) where - type Phase1Res (DropPerm a) = DropPermP1Res a +-- type Phase1Res (DropPerm a) = DropPermP1Res a - phaseOne = buildDropPermP1Res +-- phaseOne = buildDropPermP1Res - phaseTwo dp p1Res = dropPermP2 dp p1Res >> return successMsg +-- phaseTwo dp p1Res = dropPermP2 dp p1Res >> return successMsg - schemaCachePolicy = SCPReload +-- schemaCachePolicy = SCPReload diff --git a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs index fd28ca1b5257a..8ad7382721599 100644 --- a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs @@ -13,9 +13,14 @@ module Hasura.RQL.DDL.QueryTemplate , delQTemplateFromCatalog , TemplateParamConf(..) , CreateQueryTemplate(..) - , DropQueryTemplate(..) + , runCreateQueryTemplate , QueryTP1 + + , DropQueryTemplate(..) + , runDropQueryTemplate + , SetQueryTemplateComment(..) + , runSetQueryTemplateComment ) where import Hasura.Prelude @@ -59,9 +64,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 +80,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 +104,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 +131,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 +164,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 +187,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 +206,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 +229,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 diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index d770e13e57f36..8e69e3597eef5 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -162,7 +162,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 +223,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 +252,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 +322,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 +344,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 +356,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 + :: (QErrM m, 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 - - type Phase1Res DropRel = [SchemaObjId] - phaseOne = dropRelP1 - - phaseTwo = dropRelP2 - - schemaCachePolicy = SCPReload - -delRelFromCatalog :: QualifiedTable - -> RelName - -> Q.TxE QErr () +runDropRel + :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m) + => DropRel -> m RespBody +runDropRel defn = do + depObjs <- dropRelP1 defn + dropRelP2 defn depObjs + +delRelFromCatalog + :: QualifiedTable + -> RelName + -> Q.TxE QErr () delRelFromCatalog (QualifiedTable sn tn) rn = Q.unitQE defaultTxErrorHandler [Q.sql| DELETE FROM @@ -401,25 +401,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 () diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index aa0fa48754856..cc3d310268cc3 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -2,9 +2,15 @@ {-# 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 +24,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 +92,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 diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs index aaa1ccc86de33..d4b019c01bf24 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs @@ -153,7 +153,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 +186,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 diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 12cfb7f4ebb04..4cb8402a89a96 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -40,7 +40,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 +136,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,14 +174,14 @@ trackExistingTableOrViewP2 vn isSystemDefined = do "public" -> getTableN vn _ -> getSchemaN vn <> "_" <> getTableN vn -instance HDBQuery TrackTable where - - type Phase1Res TrackTable = () - phaseOne = trackExistingTableOrViewP1 - - phaseTwo (TrackTable tn) _ = trackExistingTableOrViewP2 tn False - - schemaCachePolicy = SCPReload +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 purgeDep :: (CacheRWM m, MonadError QErr m, MonadTx m) => SchemaObjId -> m () @@ -205,7 +205,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 +248,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 +267,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 +289,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 +330,29 @@ unTrackExistingTableOrViewP2 (UntrackTable qtn cascade) = do (SOTableObj dtn _) -> qtn == dtn _ -> False -instance HDBQuery UntrackTable where - type Phase1Res UntrackTable = () - phaseOne = unTrackExistingTableOrViewP1 - - 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 +runUntrackTableQ + :: ( QErrM m, CacheRWM m, MonadTx m + , MonadIO m, HasHttpManager m, UserInfoM m + ) + => UntrackTable -> m RespBody +runUntrackTableQ q = do + unTrackExistingTableOrViewP1 q + unTrackExistingTableOrViewP2 q + +buildSchemaCache + :: (MonadTx m, CacheRWM m, QErrM 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 +364,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 +374,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 +399,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 +520,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]] diff --git a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs index be07da5c69c53..09f7d18fd0668 100644 --- a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs +++ b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs @@ -5,10 +5,22 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Hasura.RQL.DDL.Subscribe where +module Hasura.RQL.DDL.Subscribe + ( CreateEventTriggerQuery + , runCreateEventTriggerQuery + , DeleteEventTriggerQuery + , runDeleteEventTriggerQuery + , DeliverEventQuery + , runDeliverEvent + + -- 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 +143,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 +178,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 +226,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 +252,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 +299,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 +355,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 +365,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) diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index c8c86eec12218..9ca9a9af6f44c 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -3,7 +3,14 @@ {-# 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 +75,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 +110,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 = + liftP1. flip runStateT DS.empty . 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 +128,19 @@ countP2 (u, p) = do encodeCount (Q.SingleRow (Identity c)) = BB.byteString "{\"count\":" <> BB.intDec c <> BB.char7 '}' -instance HDBQuery CountQuery where +runCount + :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) + => CountQuery -> m RespBody +runCount q = + validateCountQ q >>= countQToTx + +-- phaseTwo = phaseTwo + +-- instance HDBQuery CountQuery where - type Phase1Res CountQuery = (CountQueryP1, DS.Seq Q.PrepArg) - phaseOne = flip runStateT DS.empty . countP1 binRHSBuilder +-- type Phase1Res CountQuery = (CountQueryP1, DS.Seq Q.PrepArg) +-- validateCountQ = flip runStateT DS.empty . countP1 binRHSBuilder - phaseTwo _ = countP2 +-- phaseTwo _ = phaseTwo - schemaCachePolicy = SCPNoChange +-- schemaCachePolicy = SCPNoChange diff --git a/server/src-lib/Hasura/RQL/DML/Delete.hs b/server/src-lib/Hasura/RQL/DML/Delete.hs index 02786b944d6e7..4148f020596f3 100644 --- a/server/src-lib/Hasura/RQL/DML/Delete.hs +++ b/server/src-lib/Hasura/RQL/DML/Delete.hs @@ -3,7 +3,14 @@ {-# 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 +52,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 +94,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 = + liftP1 . flip runStateT DS.empty . 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 diff --git a/server/src-lib/Hasura/RQL/DML/Insert.hs b/server/src-lib/Hasura/RQL/DML/Insert.hs index b4db3a23ebc6f..d59678ad53f02 100644 --- a/server/src-lib/Hasura/RQL/DML/Insert.hs +++ b/server/src-lib/Hasura/RQL/DML/Insert.hs @@ -78,7 +78,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 +107,7 @@ convObj prepFn defInsVals setInsVals fieldInfoMap insObj = do <> " for role " <>> role buildConflictClause - :: (P1C m) + :: (UserInfoM m, QErrM m) => TableInfo -> [PGCol] -> OnConflict @@ -149,7 +149,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,15 +207,18 @@ 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 + :: (QErrM m, UserInfoM m, CacheRM m) + => InsertQuery + -> m (InsertQueryP1, DS.Seq Q.PrepArg) convInsQ insQ = - flip runStateT DS.empty $ convInsertQuery + liftP1 $ flip runStateT DS.empty $ convInsertQuery (withPathK "objects" . decodeInsObjs) binRHSBuilder insQ insertP2 :: (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody @@ -225,6 +228,14 @@ insertP2 (u, p) = where insertSQL = toSQL $ mkSQLInsert u +runInsert + :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) + => InsertQuery + -> m RespBody +runInsert q = do + res <- convInsQ q + liftTx $ insertP2 res + data ConflictCtx = CCUpdate !ConstraintName ![PGCol] | CCDoNothing !(Maybe ConstraintName) @@ -269,14 +280,14 @@ setConflictCtx conflictCtxM = do encToText $ InsertTxConflictCtx CAUpdate (Just constr) $ Just $ toSQLTxt $ S.buildSEWithExcluded updCols -instance HDBQuery InsertQuery where +-- instance HDBQuery InsertQuery where - type Phase1Res InsertQuery = (InsertQueryP1, DS.Seq Q.PrepArg) - phaseOne = convInsQ +-- type Phase1Res InsertQuery = (InsertQueryP1, DS.Seq Q.PrepArg) +-- phaseOne = convInsQ - phaseTwo _ p1Res = do - role <- userRole <$> askUserInfo - liftTx $ - bool (nonAdminInsert p1Res) (insertP2 p1Res) $ isAdmin role +-- phaseTwo _ p1Res = do +-- role <- userRole <$> askUserInfo +-- liftTx $ +-- bool (nonAdminInsert p1Res) (insertP2 p1Res) $ isAdmin role - schemaCachePolicy = SCPNoChange +-- schemaCachePolicy = SCPNoChange diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index 27e7b41fd6574..9cb2e9fe5772a 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -10,11 +11,11 @@ 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 @@ -32,10 +33,10 @@ instance CacheRM DMLP1 where 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) +-- 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) 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,12 @@ checkPermOnCol pt allowedCols pgCol = do , permTypeToCode pt <> " column " <>> pgCol ] -binRHSBuilder :: PGColType -> Value -> DMLP1 S.SQLExp +-- type PrepArgsM m = (MonadState (DS.Seq Q.PrepArg) m) + +-- type BinRHS = StateT (DS.Seq Q.PrepArg) + +binRHSBuilder + :: PGColType -> Value -> DMLP1 S.SQLExp binRHSBuilder colType val = do preparedArgs <- get binVal <- runAesonParser (convToBin colType) val @@ -141,7 +147,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 +155,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 +177,7 @@ fetchRelDet relName refTabName = do ] checkOnColExp - :: (P1C m) + :: (UserInfoM m, QErrM m, CacheRM m) => SelPermInfo -> AnnBoolExpFldSQL -> m AnnBoolExpFldSQL @@ -186,7 +192,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 +200,7 @@ checkSelPerm spi = traverse (checkOnColExp spi) convBoolExp' - :: (P1C m) + :: ( UserInfoM m, QErrM m, CacheRM m) => FieldInfoMap -> SelPermInfo -> BoolExp @@ -207,7 +213,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 +231,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 -> diff --git a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs index 397cbed85cbce..3a2ea36ee39c9 100644 --- a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs @@ -5,7 +5,10 @@ {-# 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 +20,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 @@ -62,7 +65,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) @@ -98,7 +101,7 @@ mkSelQWithArgs (DMLQuery tn (SelectG c w o lim offset)) args = do return $ DMLQuery tn $ SelectG c w o intLim intOffset convQT - :: (P1C m) + :: (UserInfoM m, QErrM m, CacheRM m) => TemplateArgs -> QueryT -> m QueryTProc @@ -107,9 +110,9 @@ convQT args qt = case qt of R.convInsertQuery decodeParam binRHSBuilder q QTSelect q -> fmap QTPSelect $ peelSt $ 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 $ peelSt $ R.validateUpdateQueryWith f q + QTDelete q -> fmap QTPDelete $ peelSt $ R.validateDeleteQWith f q + QTCount q -> fmap QTPCount $ peelSt $ RC.validateCountQWith f q QTBulk q -> fmap QTPBulk $ mapM (convQT args) q where decodeParam val = do @@ -118,33 +121,30 @@ 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 + peelSt m = + liftP1 $ 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 diff --git a/server/src-lib/Hasura/RQL/DML/Returning.hs b/server/src-lib/Hasura/RQL/DML/Returning.hs index f678096d4188f..1bf0141373b6a 100644 --- a/server/src-lib/Hasura/RQL/DML/Returning.hs +++ b/server/src-lib/Hasura/RQL/DML/Returning.hs @@ -89,7 +89,7 @@ encodeJSONVector builder xs where go v b = BB.char7 ',' <> builder v <> b checkRetCols - :: (P1C m) + :: (UserInfoM m, QErrM m) => FieldInfoMap -> SelPermInfo -> [PGCol] diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index da4730a448e84..7bc16eda8dd3b 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -12,6 +12,7 @@ module Hasura.RQL.DML.Select , convSelectQuery , getSelectDeps , module Hasura.RQL.DML.Select.Internal + , runSelect ) where @@ -35,7 +36,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 @@ -55,7 +56,7 @@ convSelCol fieldInfoMap spi (SCStar wildcard) = convWildcard fieldInfoMap spi wildcard convWildcard - :: (P1C m) + :: (UserInfoM m, QErrM m, CacheRM m) => FieldInfoMap -> SelPermInfo -> Wildcard @@ -83,7 +84,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 @@ -109,7 +110,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 @@ -148,7 +149,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 @@ -194,7 +195,7 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do mPermLimit = spiLimit selPermInfo convExtSimple - :: (P1C m) + :: (UserInfoM m, QErrM m) => FieldInfoMap -> SelPermInfo -> PGCol @@ -206,7 +207,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 @@ -267,7 +268,7 @@ getSelectDeps (AnnSelG flds tabFrm _ tableArgs) = SchemaDependency (SOTableObj tn (TORel rn)) "untyped" convSelectQuery - :: (P1C m) + :: (UserInfoM m, QErrM m, CacheRM m) => (PGColType -> Value -> m S.SQLExp) -> SelectQuery -> m AnnSel @@ -311,12 +312,18 @@ selectP2 asSingleObject (sel, p) = where selectSQL = toSQL $ mkSQLSelect asSingleObject sel -instance HDBQuery SelectQuery where - - -- 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 _ = liftTx . selectP2 False - - schemaCachePolicy = SCPNoChange +phaseOne + :: (QErrM m, UserInfoM m, CacheRM m) + => SelectQuery -> m (AnnSel, DS.Seq Q.PrepArg) +phaseOne = + liftP1 . flip runStateT DS.empty . convSelectQuery binRHSBuilder + +phaseTwo :: (MonadTx m) => (AnnSel, DS.Seq Q.PrepArg) -> m RespBody +phaseTwo = + liftTx . selectP2 False + +runSelect + :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) + => SelectQuery -> m RespBody +runSelect q = + phaseOne q >>= phaseTwo diff --git a/server/src-lib/Hasura/RQL/DML/Update.hs b/server/src-lib/Hasura/RQL/DML/Update.hs index c57979afa3fac..65b4355cad78e 100644 --- a/server/src-lib/Hasura/RQL/DML/Update.hs +++ b/server/src-lib/Hasura/RQL/DML/Update.hs @@ -3,7 +3,14 @@ {-# 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 +112,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 +175,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 updQ = + liftP1 $ flip runStateT DS.empty $ validateUpdateQueryWith binRHSBuilder updQ -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 diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index 0649c4b256f88..e64accc408e63 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -6,22 +6,25 @@ {-# LANGUAGE TypeFamilies #-} module Hasura.RQL.Types - ( HasSchemaCache(..) - , ProvidesFieldInfoMap(..) - , HDBQuery(..) - , SchemaCachePolicy(..) - , queryModifiesSchema - - , P1 - , P1C + ( -- HasSchemaCache(..) + -- , ProvidesFieldInfoMap(..) + -- , HDBQuery(..) + -- , SchemaCachePolicy(..) + -- , queryModifiesSchema + -- LazyTx(..) + + P1 + , liftP1 + , liftP1WithQCtx + -- , P1C , MonadTx(..) , UserInfoM(..) , RespBody --, P2C - , P2Ctx (..) + -- , P2Ctx (..) -- , P2Res - , liftP1 - , runP1 + -- , liftP1 + -- , runER , successMsg , HasHttpManager (..) @@ -74,54 +77,57 @@ import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Network.HTTP.Client as HTTP -class ProvidesFieldInfoMap r where - getFieldInfoMap :: QualifiedTable -> r -> Maybe FieldInfoMap +-- class ProvidesFieldInfoMap r where +-- getFieldInfoMap :: QualifiedTable -> r -> Maybe FieldInfoMap -class HasSchemaCache a where - getSchemaCache :: a -> SchemaCache +-- class HasSchemaCache a where +-- getSchemaCache :: a -> SchemaCache -instance HasSchemaCache QCtx where - getSchemaCache = qcSchemaCache +-- instance HasSchemaCache QCtx where +-- getSchemaCache = qcSchemaCache -instance HasSchemaCache SchemaCache where - getSchemaCache = id +-- instance HasSchemaCache SchemaCache where +-- getSchemaCache = id -instance ProvidesFieldInfoMap SchemaCache where - getFieldInfoMap tn = - fmap tiFieldInfoMap . M.lookup tn . scTables +-- instance ProvidesFieldInfoMap SchemaCache where +getFieldInfoMap + :: QualifiedTable + -> SchemaCache -> Maybe FieldInfoMap +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 +-- class HDBQuery q where +-- type Phase1Res q -- Phase 1 result - -- Use QCtx - phaseOne :: q -> P1 (Phase1Res q) +-- -- Use QCtx +-- phaseOne :: q -> P1 (Phase1Res q) - -- Hit Postgres - phaseTwo :: q -> Phase1Res q -> P2 BL.ByteString +-- -- Hit Postgres +-- phaseTwo :: q -> Phase1Res q -> P2 BL.ByteString - schemaCachePolicy :: SchemaCachePolicy q +-- schemaCachePolicy :: SchemaCachePolicy q -data SchemaCachePolicy a - = SCPReload - | SCPNoChange - deriving (Show, Eq) +-- data SchemaCachePolicy a +-- = SCPReload +-- | SCPNoChange +-- deriving (Show, Eq) -schemaCachePolicyToBool :: SchemaCachePolicy a -> Bool -schemaCachePolicyToBool SCPReload = True -schemaCachePolicyToBool SCPNoChange = False +-- schemaCachePolicyToBool :: SchemaCachePolicy a -> Bool +-- schemaCachePolicyToBool SCPReload = True +-- schemaCachePolicyToBool SCPNoChange = False -getSchemaCachePolicy :: (HDBQuery a) => a -> SchemaCachePolicy a -getSchemaCachePolicy _ = schemaCachePolicy +-- getSchemaCachePolicy :: (HDBQuery a) => a -> SchemaCachePolicy a +-- getSchemaCachePolicy _ = schemaCachePolicy type RespBody = BL.ByteString -queryModifiesSchema :: (HDBQuery q) => q -> Bool -queryModifiesSchema = - schemaCachePolicyToBool . getSchemaCachePolicy +-- queryModifiesSchema :: (HDBQuery q) => q -> Bool +-- queryModifiesSchema = +-- schemaCachePolicyToBool . getSchemaCachePolicy data QCtx = QCtx @@ -138,13 +144,13 @@ instance HasQCtx QCtx where mkAdminQCtx :: SchemaCache -> QCtx mkAdminQCtx = QCtx adminUserInfo -data P2Ctx - = P2Ctx - { _p2cUserInfo :: !UserInfo - , _p2cHttpManager :: !HTTP.Manager - } +-- data P2Ctx +-- = P2Ctx +-- { _p2cUserInfo :: !UserInfo +-- , _p2cHttpManager :: !HTTP.Manager +-- } -type P2 = StateT SchemaCache (ReaderT P2Ctx (Q.TxE QErr)) +-- type P2 = StateT SchemaCache (ReaderT P2Ctx (LazyTx QErr)) class (Monad m) => UserInfoM m where askUserInfo :: m UserInfo @@ -171,7 +177,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,14 +199,14 @@ instance UserInfoM P1 where instance CacheRM P1 where askSchemaCache = qcSchemaCache <$> ask -instance UserInfoM P2 where - askUserInfo = _p2cUserInfo <$> 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 +-- instance HasHttpManager P2 where +-- askHttpManager = _p2cHttpManager <$> ask class (Monad m) => HasGCtxMap m where askGCtxMap :: m GC.GCtxMap @@ -222,16 +228,30 @@ instance (MonadTx m) => MonadTx (ReaderT s m) where instance MonadTx (Q.TxE QErr) where liftTx = id -type P1 = ExceptT QErr (Reader QCtx) +type ER e r = ExceptT e (Reader r) +type P1 = ER QErr QCtx -runP1 :: QCtx -> P1 a -> Either QErr a -runP1 qEnv m = runReader (runExceptT m) qEnv +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) diff --git a/server/src-lib/Hasura/RQL/Types/DML.hs b/server/src-lib/Hasura/RQL/Types/DML.hs index 97ab63c3165ff..ba165d627b465 100644 --- a/server/src-lib/Hasura/RQL/Types/DML.hs +++ b/server/src-lib/Hasura/RQL/Types/DML.hs @@ -7,7 +7,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Hasura.RQL.Types.DML ( BoolExp(..) diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index be199149f352c..07b4cb6ec20b4 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -279,10 +279,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 () diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 55a86b1b1c25c..034dff4d15e21 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Hasura.Server.Query where @@ -13,7 +17,6 @@ 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,9 +26,16 @@ 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 @@ -89,20 +99,83 @@ $(deriveJSON } ''RQLQuery) -buildTx - :: (HDBQuery q) - => UserInfo - -> SchemaCache +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 + +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 MonadIO (LazyTx QErr) where + liftIO = LTTx . liftIO + +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) = + case lazyTx of + LTErr e -> throwError e + LTNoTx a -> return a + LTTx tx -> Q.runTx pgPool (txIso, Nothing) $ + setHeadersTx (userVars userInfo) >> tx where - p2Ctx = P2Ctx userInfo httpManager - qEnv = QCtx userInfo sc + lazyTx = runReaderT (runStateT m sc) (userInfo, httMgr) runQuery :: (MonadIO m, MonadError QErr m) @@ -110,130 +183,120 @@ 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 - - RQCreateObjectRelationship q -> buildTx' q - RQCreateArrayRelationship q -> buildTx' q - RQDropRelationship q -> buildTx' q - RQSetRelationshipComment q -> buildTx' q - - RQCreateInsertPermission q -> buildTx' q - RQCreateSelectPermission q -> buildTx' q - RQCreateUpdatePermission q -> buildTx' q - RQCreateDeletePermission q -> buildTx' q - - RQDropInsertPermission q -> buildTx' q - RQDropSelectPermission q -> buildTx' q - RQDropUpdatePermission q -> buildTx' q - RQDropDeletePermission q -> buildTx' q - RQSetPermissionComment q -> buildTx' q - - RQInsert q -> buildTx' q - RQSelect q -> buildTx' q - RQUpdate q -> buildTx' q - RQDelete q -> buildTx' q - RQCount q -> buildTx' q - - RQAddRemoteSchema q -> buildTx' q - RQRemoveRemoteSchema q -> buildTx' q - - RQCreateEventTrigger q -> buildTx' q - RQDeleteEventTrigger q -> buildTx' q - RQDeliverEvent q -> buildTx' q - - RQCreateQueryTemplate q -> buildTx' q - RQDropQueryTemplate q -> buildTx' q - RQExecuteQueryTemplate q -> buildTx' q - RQSetQueryTemplateComment q -> buildTx' q - - RQReplaceMetadata q -> buildTx' q - RQClearMetadata q -> buildTx' q - RQExportMetadata q -> buildTx' q - RQReloadMetadata q -> buildTx' q - - RQDumpInternalState q -> buildTx' q - - RQRunSql q -> buildTx' q +runQueryM + :: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m + , MonadIO m, HasHttpManager m + ) + => RQLQuery + -> m RespBody +runQueryM rq = case rq of + RQAddExistingTableOrView q -> runTrackTableQ q + RQTrackTable q -> runTrackTableQ q + RQUntrackTable q -> runUntrackTableQ q + + RQCreateObjectRelationship q -> runCreateObjRel q + RQCreateArrayRelationship q -> runCreateArrRel q + RQDropRelationship q -> runDropRel q + RQSetRelationshipComment q -> runSetRelComment q + + RQCreateInsertPermission q -> runCreatePerm q + RQCreateSelectPermission q -> runCreatePerm q + RQCreateUpdatePermission q -> runCreatePerm q + RQCreateDeletePermission q -> runCreatePerm q + + RQDropInsertPermission q -> runDropPerm q + RQDropSelectPermission q -> runDropPerm q + RQDropUpdatePermission q -> runDropPerm q + RQDropDeletePermission q -> runDropPerm q + RQSetPermissionComment q -> runSetPermComment q + + RQInsert q -> runInsert q + RQSelect q -> runSelect q + RQUpdate q -> runUpdate q + RQDelete q -> runDelete q + RQCount q -> runCount q + + RQAddRemoteSchema q -> runAddRemoteSchema q + RQRemoveRemoteSchema q -> runRemoveRemoteSchema q + + RQCreateEventTrigger q -> runCreateEventTriggerQuery q + RQDeleteEventTrigger q -> runDeleteEventTriggerQuery q + RQDeliverEvent q -> runDeliverEvent q + + RQCreateQueryTemplate q -> runCreateQueryTemplate q + RQDropQueryTemplate q -> runDropQueryTemplate q + RQExecuteQueryTemplate q -> runExecQueryTemplate q + RQSetQueryTemplateComment q -> runSetQueryTemplateComment q + + RQReplaceMetadata q -> runReplaceMetadata q + RQClearMetadata q -> runClearMetadata q + RQExportMetadata q -> runExportMetadata q + RQReloadMetadata q -> runReloadMetadata q + + RQDumpInternalState q -> runDumpInternalState 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 + withPathK "args" $ do + respList <- indexedMapM runQueryM qs + let bsVector = V.fromList respList + return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector setHeadersTx :: UserVars -> Q.TxE QErr () setHeadersTx uVars = From 2e683ac009be03b6a28a96cfb9ce015cefc0ed0f Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Mon, 3 Dec 2018 17:44:35 +0530 Subject: [PATCH 02/15] move extensions to default-extensions --- server/.stylish-haskell.yaml | 249 ++++++++++++++++++ server/graphql-engine.cabal | 46 +++- server/src-exec/Main.hs | 4 - server/src-exec/Ops.hs | 6 - server/src-exec/TH.hs | 11 +- server/src-lib/Data/TByteString.hs | 2 - server/src-lib/Data/Text/Extended.hs | 1 - server/src-lib/Hasura/Events/HTTP.hs | 10 - server/src-lib/Hasura/Events/Lib.hs | 6 - server/src-lib/Hasura/GraphQL/Context.hs | 8 - server/src-lib/Hasura/GraphQL/Explain.hs | 5 - server/src-lib/Hasura/GraphQL/RemoteServer.hs | 8 - server/src-lib/Hasura/GraphQL/Resolve.hs | 5 - .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 6 - .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 7 - .../Hasura/GraphQL/Resolve/InputValue.hs | 7 - .../src-lib/Hasura/GraphQL/Resolve/Insert.hs | 6 - .../Hasura/GraphQL/Resolve/Introspect.hs | 7 - .../Hasura/GraphQL/Resolve/LiveQuery.hs | 3 - .../Hasura/GraphQL/Resolve/Mutation.hs | 5 - .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 8 - server/src-lib/Hasura/GraphQL/Schema.hs | 14 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 5 - .../Hasura/GraphQL/Transport/HTTP/Protocol.hs | 7 - .../Hasura/GraphQL/Transport/WebSocket.hs | 5 +- .../GraphQL/Transport/WebSocket/Protocol.hs | 5 - .../GraphQL/Transport/WebSocket/Server.hs | 6 +- server/src-lib/Hasura/GraphQL/Utils.hs | 5 - server/src-lib/Hasura/GraphQL/Validate.hs | 4 - .../Hasura/GraphQL/Validate/Context.hs | 6 - .../src-lib/Hasura/GraphQL/Validate/Field.hs | 5 - .../Hasura/GraphQL/Validate/InputValue.hs | 6 - .../src-lib/Hasura/GraphQL/Validate/Types.hs | 8 - server/src-lib/Hasura/HTTP/Utils.hs | 2 - server/src-lib/Hasura/Logging.hs | 6 +- server/src-lib/Hasura/RQL/DDL/Deps.hs | 4 - server/src-lib/Hasura/RQL/DDL/Headers.hs | 5 - server/src-lib/Hasura/RQL/DDL/Metadata.hs | 7 - server/src-lib/Hasura/RQL/DDL/Permission.hs | 8 - .../Hasura/RQL/DDL/Permission/Internal.hs | 8 - .../Hasura/RQL/DDL/Permission/Triggers.hs | 5 - .../src-lib/Hasura/RQL/DDL/QueryTemplate.hs | 9 - server/src-lib/Hasura/RQL/DDL/Relationship.hs | 10 - server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs | 5 - server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs | 5 - server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 11 - server/src-lib/Hasura/RQL/DDL/Subscribe.hs | 7 - server/src-lib/Hasura/RQL/DDL/Utils.hs | 2 - server/src-lib/Hasura/RQL/DML/Count.hs | 5 - server/src-lib/Hasura/RQL/DML/Delete.hs | 5 - server/src-lib/Hasura/RQL/DML/Insert.hs | 6 - server/src-lib/Hasura/RQL/DML/Internal.hs | 7 - .../src-lib/Hasura/RQL/DML/QueryTemplate.hs | 7 - server/src-lib/Hasura/RQL/DML/Returning.hs | 5 - server/src-lib/Hasura/RQL/DML/Select.hs | 6 - .../src-lib/Hasura/RQL/DML/Select/Internal.hs | 8 +- server/src-lib/Hasura/RQL/DML/Update.hs | 5 - server/src-lib/Hasura/RQL/GBoolExp.hs | 8 - server/src-lib/Hasura/RQL/Instances.hs | 1 - server/src-lib/Hasura/RQL/Types.hs | 22 +- server/src-lib/Hasura/RQL/Types/BoolExp.hs | 9 - server/src-lib/Hasura/RQL/Types/Common.hs | 8 - server/src-lib/Hasura/RQL/Types/DML.hs | 12 +- server/src-lib/Hasura/RQL/Types/Error.hs | 5 +- server/src-lib/Hasura/RQL/Types/Permission.hs | 6 - .../src-lib/Hasura/RQL/Types/RemoteSchema.hs | 10 - .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 11 +- .../Hasura/RQL/Types/SchemaCacheTypes.hs | 4 - server/src-lib/Hasura/RQL/Types/Subscribe.hs | 4 - server/src-lib/Hasura/SQL/DML.hs | 6 - server/src-lib/Hasura/SQL/GeoJSON.hs | 5 - server/src-lib/Hasura/SQL/Rewrite.hs | 4 - server/src-lib/Hasura/SQL/Time.hs | 2 - server/src-lib/Hasura/SQL/Types.hs | 6 - server/src-lib/Hasura/SQL/Value.hs | 2 - server/src-lib/Hasura/Server/App.hs | 11 +- server/src-lib/Hasura/Server/Auth.hs | 9 +- server/src-lib/Hasura/Server/Auth/JWT.hs | 6 - .../Hasura/Server/Auth/JWT/Internal.hs | 2 - .../src-lib/Hasura/Server/Auth/JWT/Logging.hs | 2 - server/src-lib/Hasura/Server/CheckUpdates.hs | 3 - server/src-lib/Hasura/Server/Init.hs | 4 - server/src-lib/Hasura/Server/Logging.hs | 4 - server/src-lib/Hasura/Server/Middleware.hs | 2 - server/src-lib/Hasura/Server/Query.hs | 9 - server/src-lib/Hasura/Server/Utils.hs | 3 - server/src-lib/Hasura/Server/Version.hs | 3 - 87 files changed, 320 insertions(+), 497 deletions(-) create mode 100644 server/.stylish-haskell.yaml diff --git a/server/.stylish-haskell.yaml b/server/.stylish-haskell.yaml new file mode 100644 index 0000000000000..c76e3b1e670ef --- /dev/null +++ b/server/.stylish-haskell.yaml @@ -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'. + # + # - : 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 diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 802a46c0e5682..0a2b79fac0e23 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -23,7 +23,6 @@ flag developer manual: True library - default-extensions: NoImplicitPrelude hs-source-dirs: src-lib , src-exec default-language: Haskell2010 @@ -228,6 +227,28 @@ library 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 @@ -240,7 +261,28 @@ library -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 diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 533334f9da0df..2f6c7a4753dfc 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - module Main where import Ops diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 7bcb4e3ac680d..012cad5cf524d 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - module Ops ( initCatalogSafe , cleanCatalog diff --git a/server/src-exec/TH.hs b/server/src-exec/TH.hs index 836b38048c05e..2944b23fa60c5 100644 --- a/server/src-exec/TH.hs +++ b/server/src-exec/TH.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - module TH ( metadataQuery , migrateMetadataFrom1 @@ -19,7 +14,9 @@ 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))) +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))) +migrateMetadataFrom4 = + $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_4_to_5.yaml" :: Q (TExp RQLQuery))) diff --git a/server/src-lib/Data/TByteString.hs b/server/src-lib/Data/TByteString.hs index f5129542f2691..f0a44c1772ef1 100644 --- a/server/src-lib/Data/TByteString.hs +++ b/server/src-lib/Data/TByteString.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Data.TByteString ( TByteString , fromText diff --git a/server/src-lib/Data/Text/Extended.hs b/server/src-lib/Data/Text/Extended.hs index f769b5ea06d45..c633057821c8a 100644 --- a/server/src-lib/Data/Text/Extended.hs +++ b/server/src-lib/Data/Text/Extended.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Data.Text.Extended ( module DT , squote diff --git a/server/src-lib/Hasura/Events/HTTP.hs b/server/src-lib/Hasura/Events/HTTP.hs index c7f8370f7a4b2..4f75f9f1b7a2c 100644 --- a/server/src-lib/Hasura/Events/HTTP.hs +++ b/server/src-lib/Hasura/Events/HTTP.hs @@ -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 - diff --git a/server/src-lib/Hasura/Events/Lib.hs b/server/src-lib/Hasura/Events/Lib.hs index b2c4ef2d969f4..61064fb2b0421 100644 --- a/server/src-lib/Hasura/Events/Lib.hs +++ b/server/src-lib/Hasura/Events/Lib.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.Events.Lib ( initEventEngineCtx , processEventQueue diff --git a/server/src-lib/Hasura/GraphQL/Context.hs b/server/src-lib/Hasura/GraphQL/Context.hs index dd3a0f30bef93..e9813041c1f28 100644 --- a/server/src-lib/Hasura/GraphQL/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Context.hs @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Explain.hs b/server/src-lib/Hasura/GraphQL/Explain.hs index 7662d96f70902..8957a0c51dcd1 100644 --- a/server/src-lib/Hasura/GraphQL/Explain.hs +++ b/server/src-lib/Hasura/GraphQL/Explain.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Explain ( explainGQLQuery , GQLExplain diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index d7301e03171fc..6884eb698d646 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -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) diff --git a/server/src-lib/Hasura/GraphQL/Resolve.hs b/server/src-lib/Hasura/GraphQL/Resolve.hs index a2f59df1415d2..db44dec12acb1 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Resolve ( resolveSelSet ) where diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index e86c1e3eb927c..6e85dd859ecda 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Resolve.BoolExp ( parseBoolExp , pgColValToBoolExp diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index 67977dcbbece9..461cf7621e267 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Resolve.Context ( FieldMap , RelationInfoMap diff --git a/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs b/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs index bcdc8e23cbe58..21171f02b316d 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - module Hasura.GraphQL.Resolve.InputValue ( withNotNull , tyMismatch diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs index d47b9b3ceb608..3d2d89fa78d71 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Resolve.Insert (convertInsert) where diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs index f3a6460aafeac..9add4edb1c265 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Hasura.GraphQL.Resolve.Introspect ( schemaR , typeR diff --git a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs index b049048f5e2b6..7eb51f42f6563 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} - module Hasura.GraphQL.Resolve.LiveQuery ( LiveQuery(..) , LiveQueryMap diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index fff80c6490485..23ad40ee656ff 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Resolve.Mutation ( convertUpdate , convertDelete diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 3f99a09c7b046..4e19decaea106 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 0980673487673..b3c2843156051 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Schema ( mkGCtxMap , GCtxMap @@ -1256,6 +1248,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 @@ -1384,14 +1378,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 diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 172b4408009a1..8beb5815b0d46 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Transport.HTTP ( runGQ , getTopLevelNodes diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs index c7df6a2dc8820..eea31cc290c1d 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Transport.HTTP.Protocol ( GraphQLRequest(..) , GraphQLQuery(..) diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 39fe92e73e956..027b13c80944d 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} module Hasura.GraphQL.Transport.WebSocket ( createWSServerApp diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs index 914f37da98e7c..259ddfbc798bc 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Transport.WebSocket.Protocol ( OperationId(..) , ConnParams(..) diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs index 7868b251ee688..052bf366781d8 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} module Hasura.GraphQL.Transport.WebSocket.Server ( WSId(..) diff --git a/server/src-lib/Hasura/GraphQL/Utils.hs b/server/src-lib/Hasura/GraphQL/Utils.hs index 696c63f16ad17..6e779e013b87a 100644 --- a/server/src-lib/Hasura/GraphQL/Utils.hs +++ b/server/src-lib/Hasura/GraphQL/Utils.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Utils ( onNothing , showName diff --git a/server/src-lib/Hasura/GraphQL/Validate.hs b/server/src-lib/Hasura/GraphQL/Validate.hs index 44673414bb707..76499da261802 100644 --- a/server/src-lib/Hasura/GraphQL/Validate.hs +++ b/server/src-lib/Hasura/GraphQL/Validate.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Validate ( validateGQ , getTypedOp diff --git a/server/src-lib/Hasura/GraphQL/Validate/Context.hs b/server/src-lib/Hasura/GraphQL/Validate/Context.hs index 30475866600e4..b82c133812f67 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/Context.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Validate.Context ( ValidationCtx(..) , getFieldInfo diff --git a/server/src-lib/Hasura/GraphQL/Validate/Field.hs b/server/src-lib/Hasura/GraphQL/Validate/Field.hs index a29a9ea9a9b87..05b317baecea0 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/Field.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/Field.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Validate.Field ( ArgsMap , Field(..) diff --git a/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs b/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs index b8ce8adcbd7bc..35ca78dcb981b 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.GraphQL.Validate.InputValue ( validateInputValue , jsonParser diff --git a/server/src-lib/Hasura/GraphQL/Validate/Types.hs b/server/src-lib/Hasura/GraphQL/Validate/Types.hs index dfc3c42d8c5b0..bc5aad3f6b608 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/Types.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/Types.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.GraphQL.Validate.Types ( InpValInfo(..) , ParamMap diff --git a/server/src-lib/Hasura/HTTP/Utils.hs b/server/src-lib/Hasura/HTTP/Utils.hs index 7f46818d2766a..f63d12c958bab 100644 --- a/server/src-lib/Hasura/HTTP/Utils.hs +++ b/server/src-lib/Hasura/HTTP/Utils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.HTTP.Utils where import Control.Lens diff --git a/server/src-lib/Hasura/Logging.hs b/server/src-lib/Hasura/Logging.hs index b45971c4e89fb..9721367c5456c 100644 --- a/server/src-lib/Hasura/Logging.hs +++ b/server/src-lib/Hasura/Logging.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} module Hasura.Logging ( LoggerSettings(..) diff --git a/server/src-lib/Hasura/RQL/DDL/Deps.hs b/server/src-lib/Hasura/RQL/DDL/Deps.hs index b80b1d39dba20..685cfba8e596f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Deps.hs +++ b/server/src-lib/Hasura/RQL/DDL/Deps.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - module Hasura.RQL.DDL.Deps ( purgeRel , parseDropNotice diff --git a/server/src-lib/Hasura/RQL/DDL/Headers.hs b/server/src-lib/Hasura/RQL/DDL/Headers.hs index ee584b8d8efd1..3b4591780f2f6 100644 --- a/server/src-lib/Hasura/RQL/DDL/Headers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Headers.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.RQL.DDL.Headers where import Data.Aeson diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index 27157236de389..464b6bbb870e4 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DDL.Metadata ( TableMeta diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index e751a340d4cc7..1c569a14bba38 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DDL.Permission ( CreatePerm , runCreatePerm diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs index c8673b285ee6a..8e2344bcb860f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs @@ -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 #-} diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs index e4f786d506d4d..7bae1b5b9ce2a 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.RQL.DDL.Permission.Triggers where import Hasura.Prelude diff --git a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs index 8ad7382721599..f9179f74b7197 100644 --- a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DDL.QueryTemplate ( createQueryTemplateP1 , createQueryTemplateP2 diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index 8e69e3597eef5..d64bba576b778 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index cc3d310268cc3..97eb677b8a0ef 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DDL.RemoteSchema ( runAddRemoteSchema , runRemoveRemoteSchema diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs index d4b019c01bf24..c38a263315125 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Diff.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.RQL.DDL.Schema.Diff ( TableMeta(..) , PGColMeta(..) diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 4cb8402a89a96..577ca9ba76413 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs index 09f7d18fd0668..c4555ae5209f9 100644 --- a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs +++ b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DDL.Subscribe ( CreateEventTriggerQuery , runCreateEventTriggerQuery diff --git a/server/src-lib/Hasura/RQL/DDL/Utils.hs b/server/src-lib/Hasura/RQL/DDL/Utils.hs index 00712ee258d8a..13483cfe8cc89 100644 --- a/server/src-lib/Hasura/RQL/DDL/Utils.hs +++ b/server/src-lib/Hasura/RQL/DDL/Utils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.RQL.DDL.Utils ( clearHdbViews ) where diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index 9ca9a9af6f44c..1c49f3be65ab3 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Count ( CountQueryP1(..) , getCountDeps diff --git a/server/src-lib/Hasura/RQL/DML/Delete.hs b/server/src-lib/Hasura/RQL/DML/Delete.hs index 4148f020596f3..f1d26f45f4a7c 100644 --- a/server/src-lib/Hasura/RQL/DML/Delete.hs +++ b/server/src-lib/Hasura/RQL/DML/Delete.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Delete ( validateDeleteQWith , validateDeleteQ diff --git a/server/src-lib/Hasura/RQL/DML/Insert.hs b/server/src-lib/Hasura/RQL/DML/Insert.hs index d59678ad53f02..86669c4154747 100644 --- a/server/src-lib/Hasura/RQL/DML/Insert.hs +++ b/server/src-lib/Hasura/RQL/DML/Insert.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Insert where import Data.Aeson.Types diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index 9cb2e9fe5772a..357dddb830849 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Internal where import qualified Database.PG.Query as Q diff --git a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs index 3a2ea36ee39c9..6b8a5ea5ea323 100644 --- a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.QueryTemplate ( ExecQueryTemplate(..) , runExecQueryTemplate diff --git a/server/src-lib/Hasura/RQL/DML/Returning.hs b/server/src-lib/Hasura/RQL/DML/Returning.hs index 1bf0141373b6a..dddfb3de96394 100644 --- a/server/src-lib/Hasura/RQL/DML/Returning.hs +++ b/server/src-lib/Hasura/RQL/DML/Returning.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.RQL.DML.Returning where import Hasura.Prelude diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index 7bc16eda8dd3b..586420bf95816 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Select ( selectP2 , selectAggP2 diff --git a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs index 5f2e9606782cc..c8a0486102367 100644 --- a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - module Hasura.RQL.DML.Select.Internal where import Control.Arrow ((&&&)) @@ -284,9 +279,12 @@ buildJsonObject pfx parAls 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 diff --git a/server/src-lib/Hasura/RQL/DML/Update.hs b/server/src-lib/Hasura/RQL/DML/Update.hs index 65b4355cad78e..1c771750ad525 100644 --- a/server/src-lib/Hasura/RQL/DML/Update.hs +++ b/server/src-lib/Hasura/RQL/DML/Update.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - module Hasura.RQL.DML.Update ( validateUpdateQueryWith , validateUpdateQuery diff --git a/server/src-lib/Hasura/RQL/GBoolExp.hs b/server/src-lib/Hasura/RQL/GBoolExp.hs index 84fcf91924bea..30b9d830872ec 100644 --- a/server/src-lib/Hasura/RQL/GBoolExp.hs +++ b/server/src-lib/Hasura/RQL/GBoolExp.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} - module Hasura.RQL.GBoolExp ( toSQLBoolExp , getBoolExpDeps diff --git a/server/src-lib/Hasura/RQL/Instances.hs b/server/src-lib/Hasura/RQL/Instances.hs index 906f5ee768038..90f016f553a15 100644 --- a/server/src-lib/Hasura/RQL/Instances.hs +++ b/server/src-lib/Hasura/RQL/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hasura.RQL.Instances where diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index e64accc408e63..91af84aad429b 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -1,30 +1,12 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module Hasura.RQL.Types - ( -- HasSchemaCache(..) - -- , ProvidesFieldInfoMap(..) - -- , HDBQuery(..) - -- , SchemaCachePolicy(..) - -- , queryModifiesSchema - -- LazyTx(..) - - P1 + ( P1 , liftP1 , liftP1WithQCtx - -- , P1C , MonadTx(..) , UserInfoM(..) , RespBody - --, P2C - -- , P2Ctx (..) - -- , P2Res - -- , liftP1 - -- , runER , successMsg , HasHttpManager (..) diff --git a/server/src-lib/Hasura/RQL/Types/BoolExp.hs b/server/src-lib/Hasura/RQL/Types/BoolExp.hs index a22841326fa92..969bad22b40be 100644 --- a/server/src-lib/Hasura/RQL/Types/BoolExp.hs +++ b/server/src-lib/Hasura/RQL/Types/BoolExp.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/Types/Common.hs b/server/src-lib/Hasura/RQL/Types/Common.hs index 3743adc29ea88..4124cee26be0e 100644 --- a/server/src-lib/Hasura/RQL/Types/Common.hs +++ b/server/src-lib/Hasura/RQL/Types/Common.hs @@ -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(..) diff --git a/server/src-lib/Hasura/RQL/Types/DML.hs b/server/src-lib/Hasura/RQL/Types/DML.hs index ba165d627b465..d04e6cb6e266a 100644 --- a/server/src-lib/Hasura/RQL/Types/DML.hs +++ b/server/src-lib/Hasura/RQL/Types/DML.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.RQL.Types.DML ( BoolExp(..) , ColExp(..) @@ -49,8 +39,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 diff --git a/server/src-lib/Hasura/RQL/Types/Error.hs b/server/src-lib/Hasura/RQL/Types/Error.hs index cda2d5a294c4c..7e96c332beefc 100644 --- a/server/src-lib/Hasura/RQL/Types/Error.hs +++ b/server/src-lib/Hasura/RQL/Types/Error.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} module Hasura.RQL.Types.Error ( Code(..) diff --git a/server/src-lib/Hasura/RQL/Types/Permission.hs b/server/src-lib/Hasura/RQL/Types/Permission.hs index 0ec191b553c13..55380490c8984 100644 --- a/server/src-lib/Hasura/RQL/Types/Permission.hs +++ b/server/src-lib/Hasura/RQL/Types/Permission.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.RQL.Types.Permission ( RoleName(..) , UserId(..) diff --git a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs index 45ef7709c403a..95e0b119d7ac0 100644 --- a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 21731e44bf150..ce169988224e5 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs b/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs index 3054d04b4ec2e..4740349acaae1 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.RQL.Types.SchemaCacheTypes where import Data.Aeson diff --git a/server/src-lib/Hasura/RQL/Types/Subscribe.hs b/server/src-lib/Hasura/RQL/Types/Subscribe.hs index b12b779a05b87..34d99e4f203eb 100644 --- a/server/src-lib/Hasura/RQL/Types/Subscribe.hs +++ b/server/src-lib/Hasura/RQL/Types/Subscribe.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.RQL.Types.Subscribe ( CreateEventTriggerQuery(..) , SubscribeOpSpec(..) diff --git a/server/src-lib/Hasura/SQL/DML.hs b/server/src-lib/Hasura/SQL/DML.hs index e118a148eab01..f577741a61f0a 100644 --- a/server/src-lib/Hasura/SQL/DML.hs +++ b/server/src-lib/Hasura/SQL/DML.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.SQL.DML where import Hasura.Prelude diff --git a/server/src-lib/Hasura/SQL/GeoJSON.hs b/server/src-lib/Hasura/SQL/GeoJSON.hs index 066d962674103..9baed8168f2b2 100644 --- a/server/src-lib/Hasura/SQL/GeoJSON.hs +++ b/server/src-lib/Hasura/SQL/GeoJSON.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.SQL.GeoJSON ( Point(..) , MultiPoint(..) diff --git a/server/src-lib/Hasura/SQL/Rewrite.hs b/server/src-lib/Hasura/SQL/Rewrite.hs index b608d2028900a..10bb94ba1e6c7 100644 --- a/server/src-lib/Hasura/SQL/Rewrite.hs +++ b/server/src-lib/Hasura/SQL/Rewrite.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - module Hasura.SQL.Rewrite ( prefixNumToAliases ) where diff --git a/server/src-lib/Hasura/SQL/Time.hs b/server/src-lib/Hasura/SQL/Time.hs index c0ae0a36cdb29..202345a06a5ce 100644 --- a/server/src-lib/Hasura/SQL/Time.hs +++ b/server/src-lib/Hasura/SQL/Time.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Hasura.SQL.Time ( ZonedTimeOfDay(..) ) where diff --git a/server/src-lib/Hasura/SQL/Types.hs b/server/src-lib/Hasura/SQL/Types.hs index f02efbb514ea3..73d257e6922ab 100644 --- a/server/src-lib/Hasura/SQL/Types.hs +++ b/server/src-lib/Hasura/SQL/Types.hs @@ -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 diff --git a/server/src-lib/Hasura/SQL/Value.hs b/server/src-lib/Hasura/SQL/Value.hs index 64a04302361a7..fd36b789f91b6 100644 --- a/server/src-lib/Hasura/SQL/Value.hs +++ b/server/src-lib/Hasura/SQL/Value.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.SQL.Value where import Hasura.SQL.GeoJSON diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index 07b4cb6ec20b4..b5aa8a94e9cdf 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Auth.hs b/server/src-lib/Hasura/Server/Auth.hs index 88243cbb318fb..0eb983eddff49 100644 --- a/server/src-lib/Hasura/Server/Auth.hs +++ b/server/src-lib/Hasura/Server/Auth.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Auth/JWT.hs b/server/src-lib/Hasura/Server/Auth/JWT.hs index b8e359ac9b893..6f1f916c77885 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.Server.Auth.JWT ( processJwt , RawJWT diff --git a/server/src-lib/Hasura/Server/Auth/JWT/Internal.hs b/server/src-lib/Hasura/Server/Auth/JWT/Internal.hs index 73582d865ee77..39bf8d69c7fcc 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT/Internal.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT/Internal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.Server.Auth.JWT.Internal where import Control.Lens diff --git a/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs b/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs index 5b03a3205e9bf..da618444ae90c 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.Server.Auth.JWT.Logging ( JwkRefreshLog (..) , JwkRefreshHttpError (..) diff --git a/server/src-lib/Hasura/Server/CheckUpdates.hs b/server/src-lib/Hasura/Server/CheckUpdates.hs index be1e512c8dc1f..9ddec2052e0d7 100644 --- a/server/src-lib/Hasura/Server/CheckUpdates.hs +++ b/server/src-lib/Hasura/Server/CheckUpdates.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.Server.CheckUpdates ( checkForUpdates ) where diff --git a/server/src-lib/Hasura/Server/Init.hs b/server/src-lib/Hasura/Server/Init.hs index f9e76d76a8cbf..0a3a65770ddd8 100644 --- a/server/src-lib/Hasura/Server/Init.hs +++ b/server/src-lib/Hasura/Server/Init.hs @@ -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 - data InitError = InitError !String deriving (Show, Eq) diff --git a/server/src-lib/Hasura/Server/Logging.hs b/server/src-lib/Hasura/Server/Logging.hs index 9cd7b0011d483..5f02d6a19312a 100644 --- a/server/src-lib/Hasura/Server/Logging.hs +++ b/server/src-lib/Hasura/Server/Logging.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Middleware.hs b/server/src-lib/Hasura/Server/Middleware.hs index 252803b3a22ce..24f94c92689b3 100644 --- a/server/src-lib/Hasura/Server/Middleware.hs +++ b/server/src-lib/Hasura/Server/Middleware.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Hasura.Server.Middleware where import Data.Maybe (fromMaybe) diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 034dff4d15e21..8d4ba57616f7b 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.Server.Query where import Data.Aeson diff --git a/server/src-lib/Hasura/Server/Utils.hs b/server/src-lib/Hasura/Server/Utils.hs index 0f32917edea1e..82ee4b6657821 100644 --- a/server/src-lib/Hasura/Server/Utils.hs +++ b/server/src-lib/Hasura/Server/Utils.hs @@ -1,6 +1,3 @@ - -{-# LANGUAGE OverloadedStrings #-} - module Hasura.Server.Utils where import qualified Database.PG.Query.Connection as Q diff --git a/server/src-lib/Hasura/Server/Version.hs b/server/src-lib/Hasura/Server/Version.hs index ca50d954ad2fe..43b1a5f83701c 100644 --- a/server/src-lib/Hasura/Server/Version.hs +++ b/server/src-lib/Hasura/Server/Version.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - module Hasura.Server.Version ( currentVersion , consoleVersion From 9c462622fc8bad1b0561189785ca93f14008614b Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Mon, 3 Dec 2018 18:02:42 +0530 Subject: [PATCH 03/15] bump stackage to 12.21 --- server/stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/server/stack.yaml b/server/stack.yaml index 80fbc5dedf522..2174902904225 100644 --- a/server/stack.yaml +++ b/server/stack.yaml @@ -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.21 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 From 5e42732cc11ff19ee206c7e6b88d8c288c50cf7c Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Mon, 3 Dec 2018 18:40:55 +0530 Subject: [PATCH 04/15] update stackage nightly --- server/stack-nightly.yaml | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/server/stack-nightly.yaml b/server/stack-nightly.yaml index 8831526511952..a66a9753bc7e4 100644 --- a/server/stack-nightly.yaml +++ b/server/stack-nightly.yaml @@ -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-03 # 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: {} From aeaa27a75a5511d4f1c8bf30ee0d7ebc91125ffe Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 4 Dec 2018 13:36:50 +0530 Subject: [PATCH 05/15] use lazy tx everywhere --- server/src-lib/Hasura/GraphQL/Explain.hs | 9 +- server/src-lib/Hasura/GraphQL/Resolve.hs | 12 +- .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 2 + .../Hasura/GraphQL/Resolve/LiveQuery.hs | 8 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 6 +- .../Hasura/GraphQL/Transport/WebSocket.hs | 7 +- server/src-lib/Hasura/RQL/Types.hs | 140 ++++++++++-------- server/src-lib/Hasura/Server/App.hs | 2 +- server/src-lib/Hasura/Server/Query.hs | 65 +------- 9 files changed, 100 insertions(+), 151 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Explain.hs b/server/src-lib/Hasura/GraphQL/Explain.hs index 8957a0c51dcd1..38a5ed0496a47 100644 --- a/server/src-lib/Hasura/GraphQL/Explain.hs +++ b/server/src-lib/Hasura/GraphQL/Explain.hs @@ -27,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 @@ -59,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 @@ -130,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 diff --git a/server/src-lib/Hasura/GraphQL/Resolve.hs b/server/src-lib/Hasura/GraphQL/Resolve.hs index db44dec12acb1..13ee63b851686 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve.hs @@ -65,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 @@ -83,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 diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index 461cf7621e267..098dd7b6c8c98 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -7,6 +7,7 @@ module Hasura.GraphQL.Resolve.Context , InsCtx(..) , InsCtxMap , RespTx + , LazyRespTx , InsertTxConflictCtx(..) , getFldInfo , getPGColInfo @@ -66,6 +67,7 @@ $(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp) -- deriving (Show, Eq) type RespTx = Q.TxE QErr BL.ByteString +type LazyRespTx = LazyTx QErr BL.ByteString -- -- order by context -- data OrdByItem diff --git a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs index 7eb51f42f6563..1a937587cb434 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs @@ -14,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 @@ -33,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 @@ -50,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) @@ -92,7 +92,7 @@ addLiveQuery -- the query -> LiveQuery -- the transaction associated with this query - -> RespTx + -> LazyTx QErr BL.ByteString -- a unique operation id -> k -- the action to be executed when result changes diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 8beb5815b0d46..f46b99431aad5 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -31,7 +31,6 @@ 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 @@ -92,7 +91,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 @@ -110,9 +108,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) diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 027b13c80944d..dbc8c064dc592 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -26,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 @@ -42,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 @@ -203,7 +202,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 = RQ.setHeadersTx (userVars userInfo) >> + let qTx = withUserInfo userInfo $ resolveSelSet userInfo gCtx opTy fields case opTy of diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index 91af84aad429b..2dc3fd8b891e8 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -5,6 +5,11 @@ module Hasura.RQL.Types , liftP1 , liftP1WithQCtx , MonadTx(..) + + , LazyTx + , runLazyTx + , withUserInfo + , UserInfoM(..) , RespBody , successMsg @@ -54,63 +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 :: QualifiedTable -> SchemaCache -> Maybe FieldInfoMap 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 - type RespBody = BL.ByteString --- queryModifiesSchema :: (HDBQuery q) => q -> Bool --- queryModifiesSchema = --- schemaCachePolicyToBool . getSchemaCachePolicy - data QCtx = QCtx { qcUserInfo :: !UserInfo @@ -126,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 (LazyTx QErr)) - class (Monad m) => UserInfoM m where askUserInfo :: m UserInfo @@ -181,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 @@ -207,9 +151,77 @@ 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 +instance MonadIO (LazyTx QErr) where + liftIO = LTTx . liftIO + type ER e r = ExceptT e (Reader r) type P1 = ER QErr QCtx diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index b5aa8a94e9cdf..30af0c3f5dc42 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -289,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 diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 8d4ba57616f7b..c4e5137538fe6 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -5,10 +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.Text.Lazy as LT import qualified Data.Vector as V import qualified Network.HTTP.Client as HTTP @@ -28,7 +26,6 @@ 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 @@ -90,51 +87,6 @@ $(deriveJSON } ''RQLQuery) -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 - -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 MonadIO (LazyTx QErr) where - liftIO = LTTx . liftIO - newtype Run a = Run {unRun :: StateT SchemaCache (ReaderT (UserInfo, HTTP.Manager) (LazyTx QErr)) a} deriving ( Functor, Applicative, Monad @@ -160,11 +112,7 @@ peelRun -> Q.PGPool -> Q.TxIsolation -> Run a -> ExceptT QErr IO (a, SchemaCache) peelRun sc userInfo httMgr pgPool txIso (Run m) = - case lazyTx of - LTErr e -> throwError e - LTNoTx a -> return a - LTTx tx -> Q.runTx pgPool (txIso, Nothing) $ - setHeadersTx (userVars userInfo) >> tx + runLazyTx pgPool txIso $ withUserInfo userInfo lazyTx where lazyTx = runReaderT (runStateT m sc) (userInfo, httMgr) @@ -235,7 +183,7 @@ runQueryM ) => RQLQuery -> m RespBody -runQueryM rq = case rq of +runQueryM rq = withPathK "args" $ case rq of RQAddExistingTableOrView q -> runTrackTableQ q RQTrackTable q -> runTrackTableQ q RQUntrackTable q -> runUntrackTableQ q @@ -288,12 +236,3 @@ runQueryM rq = case rq of respList <- indexedMapM runQueryM qs let bsVector = V.fromList respList return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector - -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) From b19ed01d93411865e4080b591213530ab9bc3fac Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 4 Dec 2018 15:29:55 +0530 Subject: [PATCH 06/15] remove more warnings --- server/src-exec/Ops.hs | 8 +-- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 4 +- server/src-lib/Hasura/RQL/DDL/Metadata.hs | 1 - server/src-lib/Hasura/RQL/DDL/Permission.hs | 10 ++-- .../Hasura/RQL/DDL/Permission/Internal.hs | 6 +-- server/src-lib/Hasura/RQL/DDL/Relationship.hs | 2 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 4 +- .../src-lib/Hasura/RQL/DML/Select/Internal.hs | 3 +- server/src-lib/Hasura/RQL/Types/DML.hs | 49 ++++++++++++++++--- .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 8 --- .../Hasura/RQL/Types/SchemaCacheTypes.hs | 1 + server/src-lib/Hasura/SQL/DML.hs | 4 ++ 12 files changed, 68 insertions(+), 32 deletions(-) diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 012cad5cf524d..8a98e7d03a8de 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -166,7 +166,7 @@ from08To1 = liftTx $ Q.catchE defaultTxErrorHandler $ do |] () False from1To2 - :: (MonadTx m, HasHttpManager m, QErrM m, CacheRWM m, UserInfoM m, MonadIO m) + :: (MonadTx m, HasHttpManager m, CacheRWM m, UserInfoM m, MonadIO m) => m () from1To2 = do -- migrate database @@ -188,7 +188,7 @@ from2To3 = liftTx $ Q.catchE defaultTxErrorHandler $ do -- custom resolver from4To5 - :: (MonadTx m, HasHttpManager m, QErrM m, CacheRWM m, UserInfoM m, MonadIO m) + :: (MonadTx m, HasHttpManager m, CacheRWM m, UserInfoM m, MonadIO m) => m () from4To5 = do Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler @@ -235,7 +235,7 @@ from5To6 = liftTx $ do return () migrateCatalog - :: (MonadTx m, CacheRWM m, QErrM m, MonadIO m, UserInfoM m, HasHttpManager m) + :: (MonadTx m, CacheRWM m, MonadIO m, UserInfoM m, HasHttpManager m) => UTCTime -> m String migrateCatalog migrationTime = do preVer <- getCatalogVersion @@ -291,7 +291,7 @@ migrateCatalog migrationTime = do |] (curCatalogVer, migrationTime) False execQuery - :: (MonadTx m, CacheRWM m, QErrM m, MonadIO m, UserInfoM m, HasHttpManager m) + :: (MonadTx m, CacheRWM m, MonadIO m, UserInfoM m, HasHttpManager m) => BL.ByteString -> m BL.ByteString execQuery queryBs = do query <- case A.decode queryBs of diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 4e19decaea106..85fa0a62822b9 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -155,7 +155,9 @@ 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)] + let annObItem = OrderByItemG (Just $ OrderType ordTy) aobCol + (Just $ NullsOrder nullsOrd) + return [annObItem] OBIRel ri fltr -> do let annObColFn = f . RS.AOCRel ri fltr withObject (getAnnObItems annObColFn) v diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index 464b6bbb870e4..a6c2cc58c31bc 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -188,7 +188,6 @@ applyQP1 (ReplaceMetadata tables templates mSchemas) = do applyQP2 :: ( UserInfoM m - , QErrM m , CacheRWM m , MonadTx m , MonadIO m diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index 1c569a14bba38..800c96732e7c6 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -163,7 +163,7 @@ clearInsInfra vn = type DropInsPerm = DropPerm InsPerm dropInsPermP2 - :: (QErrM m, CacheRWM m, MonadTx m) + :: (CacheRWM m, MonadTx m) => DropInsPerm -> QualifiedTable -> m () dropInsPermP2 = dropPermP2 @@ -232,7 +232,7 @@ type DropSelPerm = DropPerm SelPerm type instance PermInfo SelPerm = SelPermInfo dropSelPermP2 - :: (QErrM m, CacheRWM m, MonadTx m) + :: (CacheRWM m, MonadTx m) => DropSelPerm -> m () dropSelPermP2 dp = dropPermP2 dp () @@ -294,7 +294,7 @@ type instance PermInfo UpdPerm = UpdPermInfo type DropUpdPerm = DropPerm UpdPerm dropUpdPermP2 - :: (QErrM m, CacheRWM m, MonadTx m) + :: (CacheRWM m, MonadTx m) => DropUpdPerm -> m () dropUpdPermP2 dp = dropPermP2 dp () @@ -341,7 +341,7 @@ buildDelPermInfo tabInfo (DelPerm fltr) = do type DropDelPerm = DropPerm DelPerm -dropDelPermP2 :: (QErrM m, CacheRWM m, MonadTx m) => DropDelPerm -> m () +dropDelPermP2 :: (CacheRWM m, MonadTx m) => DropDelPerm -> m () dropDelPermP2 dp = dropPermP2 dp () type instance PermInfo DelPerm = DelPermInfo @@ -410,7 +410,7 @@ setPermCommentTx (SetPermComment (QualifiedTable sn tn) rn pt comment) = |] (comment, sn, tn, rn, permTypeToCode pt) True purgePerm - :: (QErrM m, CacheRWM m, MonadTx m) + :: (CacheRWM m, MonadTx m) => QualifiedTable -> RoleName -> PermType -> m () purgePerm qt rn pt = case pt of diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs index 8e2344bcb860f..a21981f56e009 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs @@ -244,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) @@ -304,7 +304,7 @@ createPermP1 (WithTable tn pd) = do addPermP1 tabInfo pd runCreatePerm - :: ( UserInfoM m, MonadError QErr m + :: ( UserInfoM m , CacheRWM m, IsPerm a, MonadTx m ) => CreatePerm a -> m RespBody @@ -333,7 +333,7 @@ dropPermP2 dp@(DropPerm tn rn) p1Res = do pt = permAccToType pa runDropPerm - :: (IsPerm a, UserInfoM m, QErrM m, CacheRWM m, MonadTx m) + :: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m) => DropPerm a -> m RespBody runDropPerm defn = do permInfo <- buildDropPermP1Res defn diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index d64bba576b778..7df823ce5551f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -347,7 +347,7 @@ dropRelP1 (DropRel qt rn cascade) = do relObjId = SOTableObj qt $ TORel rn purgeRelDep - :: (QErrM m, CacheRWM m, MonadTx m) => SchemaObjId -> m () + :: (CacheRWM m, MonadTx m) => SchemaObjId -> m () purgeRelDep (SOTableObj tn (TOPerm rn pt)) = purgePerm tn rn pt purgeRelDep d = throw500 $ "unexpected dependency of relationship : " diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 577ca9ba76413..1697ae28449de 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -172,7 +172,7 @@ runTrackTableQ q = do trackExistingTableOrViewP1 q trackExistingTableOrViewP2 (tName q) False -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 @@ -329,7 +329,7 @@ runUntrackTableQ q = do unTrackExistingTableOrViewP2 q buildSchemaCache - :: (MonadTx m, CacheRWM m, QErrM m, MonadIO m, HasHttpManager m) + :: (MonadTx m, CacheRWM m, MonadIO m, HasHttpManager m) => m () buildSchemaCache = do -- reset the current schemacache diff --git a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs index c8a0486102367..b01f7616b13bf 100644 --- a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs @@ -331,7 +331,8 @@ processAnnOrderByItem pfx (OrderByItemG obTyM annObCol obNullsM) = ((obColAls, obColExp), relNodeM) = processAnnOrderByCol pfx annObCol sqlOrdByItem = - S.OrderByItem (S.SEIden $ toIden obColAls) obTyM obNullsM + S.OrderByItem (S.SEIden $ toIden obColAls) + (unOrderType <$> obTyM) (unNullsOrder <$> obNullsM) processAnnOrderByCol :: Iden diff --git a/server/src-lib/Hasura/RQL/Types/DML.hs b/server/src-lib/Hasura/RQL/Types/DML.hs index d04e6cb6e266a..2b8beef4f2b0e 100644 --- a/server/src-lib/Hasura/RQL/Types/DML.hs +++ b/server/src-lib/Hasura/RQL/Types/DML.hs @@ -2,6 +2,8 @@ module Hasura.RQL.Types.DML ( BoolExp(..) , ColExp(..) , DMLQuery(..) + , OrderType(..) + , NullsOrder(..) , OrderByExp(..) , OrderByItemG(..) @@ -89,9 +91,44 @@ 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 2} + ''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 2} + ''S.NullsOrder) + +-- $(deriveJSON defaultOptions{constructorTagModifier = snakeCase . drop 2} ''S.OrderType) +-- $(deriveJSON defaultOptions{constructorTagModifier = snakeCase . drop 1} ''S.NullsOrder) data OrderByCol = OCPG !FieldName @@ -136,9 +173,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 @@ -178,8 +215,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 diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index ce169988224e5..d0deeab74b814 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -96,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 @@ -169,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" @@ -264,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 diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs b/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs index 4740349acaae1..dc37154b5cfcf 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCacheTypes.hs @@ -76,6 +76,7 @@ data SchemaDependency } deriving (Show, Eq, Generic) $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaDependency) +instance Hashable SchemaDependency -- data RelInfo -- = RelInfo diff --git a/server/src-lib/Hasura/SQL/DML.hs b/server/src-lib/Hasura/SQL/DML.hs index f577741a61f0a..82e0fe4553575 100644 --- a/server/src-lib/Hasura/SQL/DML.hs +++ b/server/src-lib/Hasura/SQL/DML.hs @@ -6,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 @@ -265,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) From 1b3416730237d5c1e284631185601be69ec4ca3f Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 4 Dec 2018 15:57:37 +0530 Subject: [PATCH 07/15] fix v1/query insert --- server/src-lib/Hasura/RQL/DML/Insert.hs | 27 ++++++++----------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DML/Insert.hs b/server/src-lib/Hasura/RQL/DML/Insert.hs index 86669c4154747..fb4d6da922b9b 100644 --- a/server/src-lib/Hasura/RQL/DML/Insert.hs +++ b/server/src-lib/Hasura/RQL/DML/Insert.hs @@ -222,14 +222,6 @@ insertP2 (u, p) = where insertSQL = toSQL $ mkSQLInsert u -runInsert - :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) - => InsertQuery - -> m RespBody -runInsert q = do - res <- convInsQ q - liftTx $ insertP2 res - data ConflictCtx = CCUpdate !ConstraintName ![PGCol] | CCDoNothing !(Maybe ConstraintName) @@ -274,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 From 6864cb977f282620d652103c1ae43d6185d512bb Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 4 Dec 2018 17:51:50 +0530 Subject: [PATCH 08/15] fix json instances for order_by nulls order --- server/src-lib/Hasura/RQL/Types/DML.hs | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/server/src-lib/Hasura/RQL/Types/DML.hs b/server/src-lib/Hasura/RQL/Types/DML.hs index 2b8beef4f2b0e..ddab2aa12e3d8 100644 --- a/server/src-lib/Hasura/RQL/Types/DML.hs +++ b/server/src-lib/Hasura/RQL/Types/DML.hs @@ -110,7 +110,7 @@ instance FromJSON NullsOrder where parseJSON = fmap NullsOrder . f where f = $(mkParseJSON - defaultOptions{constructorTagModifier = snakeCase . drop 2} + defaultOptions{constructorTagModifier = snakeCase . drop 1} ''S.NullsOrder) instance ToJSON OrderType where @@ -124,21 +124,14 @@ instance ToJSON NullsOrder where toJSON = f . unNullsOrder where f = $(mkToJSON - defaultOptions{constructorTagModifier = snakeCase . drop 2} + defaultOptions{constructorTagModifier = snakeCase . drop 1} ''S.NullsOrder) --- $(deriveJSON defaultOptions{constructorTagModifier = snakeCase . drop 2} ''S.OrderType) --- $(deriveJSON 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 From f0e0e2c64da4f94ee087fb92ebbd25f47acb8b82 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 15:20:42 +0530 Subject: [PATCH 09/15] remove the extra 'args' path --- server/src-lib/Hasura/Server/Query.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index c4e5137538fe6..e940e2dde4671 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -231,8 +231,6 @@ runQueryM rq = withPathK "args" $ case rq of RQRunSql q -> runRunSQL q - RQBulk qs -> - withPathK "args" $ do - respList <- indexedMapM runQueryM qs - let bsVector = V.fromList respList - return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector + RQBulk qs -> do + respVector <- V.fromList <$> indexedMapM runQueryM qs + return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString respVector From aa10de2e13a391081c7cf93c959309177ae540c8 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 17:23:07 +0530 Subject: [PATCH 10/15] move defns from TH module into Ops module --- server/graphql-engine.cabal | 2 -- server/src-exec/Ops.hs | 22 +++++++++++----------- server/src-exec/TH.hs | 22 ---------------------- 3 files changed, 11 insertions(+), 35 deletions(-) delete mode 100644 server/src-exec/TH.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 0a2b79fac0e23..1d72f0d85a9dc 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -222,7 +222,6 @@ library , Hasura.Logging , Network.URI.Extended , Ops - , TH other-modules: Hasura.Server.Auth.JWT.Internal , Hasura.Server.Auth.JWT.Logging @@ -307,7 +306,6 @@ executable graphql-engine , string-conversions other-modules: Ops - TH if flag(developer) ghc-prof-options: -rtsopts -fprof-auto -fno-prof-count-entries diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 8a98e7d03a8de..34b72d42db84c 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -6,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 @@ -18,6 +18,7 @@ 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 @@ -81,15 +82,15 @@ initCatalogStrict createSchema initTime = do Q.Discard () <- Q.multiQ $(Q.sqlFromFile "src-rsr/initialise.sql") return () - -- Build the metadata query + -- 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 @@ -172,12 +173,12 @@ from1To2 = do -- migrate database Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/migrate_from_1.sql") - -- migrate metadata - -- tx <- liftEither $ buildTxAny adminUserInfo - -- emptySchemaCache httpMgr migrateMetadataFrom1 void $ runQueryM migrateMetadataFrom1 -- set as system defined setAsSystemDefined + where + migrateMetadataFrom1 = + $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_1.yaml" :: Q (TExp RQLQuery))) from2To3 :: (MonadTx m) => m () from2To3 = liftTx $ Q.catchE defaultTxErrorHandler $ do @@ -193,13 +194,12 @@ from4To5 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 :: (MonadTx m) => m () diff --git a/server/src-exec/TH.hs b/server/src-exec/TH.hs deleted file mode 100644 index 2944b23fa60c5..0000000000000 --- a/server/src-exec/TH.hs +++ /dev/null @@ -1,22 +0,0 @@ -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))) From 31ec7ed632771d5f1be922a2f4473eb723c7448e Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 19:19:50 +0530 Subject: [PATCH 11/15] minor cleanup --- server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs | 2 +- server/src-lib/Hasura/RQL/DML/Count.hs | 11 ----------- server/src-lib/Hasura/RQL/DML/Internal.hs | 9 --------- 3 files changed, 1 insertion(+), 21 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs index 1a937587cb434..5f9e5ed7a3785 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs @@ -92,7 +92,7 @@ addLiveQuery -- the query -> LiveQuery -- the transaction associated with this query - -> LazyTx QErr BL.ByteString + -> LazyRespTx -- a unique operation id -> k -- the action to be executed when result changes diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index 1c49f3be65ab3..c1c44edcdef87 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -128,14 +128,3 @@ runCount => CountQuery -> m RespBody runCount q = validateCountQ q >>= countQToTx - --- phaseTwo = phaseTwo - --- instance HDBQuery CountQuery where - --- type Phase1Res CountQuery = (CountQueryP1, DS.Seq Q.PrepArg) --- validateCountQ = flip runStateT DS.empty . countP1 binRHSBuilder - --- phaseTwo _ = phaseTwo - --- schemaCachePolicy = SCPNoChange diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index 357dddb830849..ab039e98568cb 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -26,11 +26,6 @@ instance CacheRM DMLP1 where 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) - mkAdminRolePermInfo :: TableInfo -> RolePermInfo mkAdminRolePermInfo ti = RolePermInfo (Just i) (Just s) (Just u) (Just d) @@ -127,10 +122,6 @@ checkPermOnCol pt allowedCols pgCol = do , permTypeToCode pt <> " column " <>> pgCol ] --- type PrepArgsM m = (MonadState (DS.Seq Q.PrepArg) m) - --- type BinRHS = StateT (DS.Seq Q.PrepArg) - binRHSBuilder :: PGColType -> Value -> DMLP1 S.SQLExp binRHSBuilder colType val = do From d7ad94abba758921ab0f39025f6e8dfc0e181087 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 19:24:27 +0530 Subject: [PATCH 12/15] remove tojson orphan instance for http exception --- server/graphql-engine.cabal | 2 +- server/src-lib/Hasura/GraphQL/RemoteServer.hs | 2 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 2 +- .../src-lib/Hasura/{HTTP/Utils.hs => HTTP.hs} | 25 ++++++++++++++-- server/src-lib/Hasura/Server/Auth.hs | 5 ++-- server/src-lib/Hasura/Server/Auth/JWT.hs | 5 ++-- .../src-lib/Hasura/Server/Auth/JWT/Logging.hs | 4 +-- server/src-lib/Hasura/Server/CheckUpdates.hs | 2 +- server/src-lib/Hasura/Server/Logging.hs | 29 +++++++------------ 9 files changed, 44 insertions(+), 32 deletions(-) rename server/src-lib/Hasura/{HTTP/Utils.hs => HTTP.hs} (52%) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 1d72f0d85a9dc..a544d8e5d0827 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -205,7 +205,7 @@ library , Hasura.Events.Lib , Hasura.Events.HTTP - , Hasura.HTTP.Utils + , Hasura.HTTP , Data.Text.Extended , Data.Sequence.NonEmpty diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index 6884eb698d646..5b119e1d58384 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -17,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 diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index f46b99431aad5..778274c439d78 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -24,7 +24,7 @@ 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 diff --git a/server/src-lib/Hasura/HTTP/Utils.hs b/server/src-lib/Hasura/HTTP.hs similarity index 52% rename from server/src-lib/Hasura/HTTP/Utils.hs rename to server/src-lib/Hasura/HTTP.hs index f63d12c958bab..0f4358393c56c 100644 --- a/server/src-lib/Hasura/HTTP/Utils.hs +++ b/server/src-lib/Hasura/HTTP.hs @@ -1,8 +1,12 @@ -module Hasura.HTTP.Utils where +module Hasura.HTTP + ( wreqOptions + , HttpException(..) + ) 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 @@ -10,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 @@ -22,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 + ] diff --git a/server/src-lib/Hasura/Server/Auth.hs b/server/src-lib/Hasura/Server/Auth.hs index 2df87ac2d9b7d..ad6e10e51af1c 100644 --- a/server/src-lib/Hasura/Server/Auth.hs +++ b/server/src-lib/Hasura/Server/Auth.hs @@ -35,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 @@ -213,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, _) -> diff --git a/server/src-lib/Hasura/Server/Auth/JWT.hs b/server/src-lib/Hasura/Server/Auth/JWT.hs index 6f1f916c77885..240afc162991e 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -21,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 @@ -144,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) diff --git a/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs b/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs index da618444ae90c..e03a879e5113f 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT/Logging.hs @@ -7,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 @@ -27,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) diff --git a/server/src-lib/Hasura/Server/CheckUpdates.hs b/server/src-lib/Hasura/Server/CheckUpdates.hs index 9ddec2052e0d7..de9f6a8993d1a 100644 --- a/server/src-lib/Hasura/Server/CheckUpdates.hs +++ b/server/src-lib/Hasura/Server/CheckUpdates.hs @@ -16,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) diff --git a/server/src-lib/Hasura/Server/Logging.hs b/server/src-lib/Hasura/Server/Logging.hs index a11edec3abb09..af1e90c55ec34 100644 --- a/server/src-lib/Hasura/Server/Logging.hs +++ b/server/src-lib/Hasura/Server/Logging.hs @@ -5,6 +5,7 @@ module Hasura.Server.Logging , getRequestHeader , WebHookLog(..) , WebHookLogger + , HttpException ) where import Crypto.Hash (Digest, SHA1, hash) @@ -26,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 @@ -34,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 @@ -42,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) @@ -50,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 () From 8efc27a56ec0b5d00441cd5b194ab184fd73cc88 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 20:46:43 +0530 Subject: [PATCH 13/15] remove orphan instance for dmlp1 --- server/src-lib/Hasura/RQL/DML/Count.hs | 2 +- server/src-lib/Hasura/RQL/DML/Delete.hs | 2 +- server/src-lib/Hasura/RQL/DML/Insert.hs | 6 ++--- server/src-lib/Hasura/RQL/DML/Internal.hs | 18 ++++++++++++--- .../src-lib/Hasura/RQL/DML/QueryTemplate.hs | 22 ++++++++----------- server/src-lib/Hasura/RQL/DML/Select.hs | 2 +- server/src-lib/Hasura/RQL/DML/Update.hs | 4 ++-- 7 files changed, 32 insertions(+), 24 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index c1c44edcdef87..d5ecd5dfeaea1 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -109,7 +109,7 @@ validateCountQ :: (QErrM m, UserInfoM m, CacheRM m) => CountQuery -> m (CountQueryP1, DS.Seq Q.PrepArg) validateCountQ = - liftP1. flip runStateT DS.empty . validateCountQWith binRHSBuilder + liftDMLP1 . validateCountQWith binRHSBuilder countQToTx :: (QErrM m, MonadTx m) diff --git a/server/src-lib/Hasura/RQL/DML/Delete.hs b/server/src-lib/Hasura/RQL/DML/Delete.hs index f1d26f45f4a7c..382919b806877 100644 --- a/server/src-lib/Hasura/RQL/DML/Delete.hs +++ b/server/src-lib/Hasura/RQL/DML/Delete.hs @@ -93,7 +93,7 @@ validateDeleteQ :: (QErrM m, UserInfoM m, CacheRM m) => DeleteQuery -> m (DeleteQueryP1, DS.Seq Q.PrepArg) validateDeleteQ = - liftP1 . flip runStateT DS.empty . validateDeleteQWith binRHSBuilder + liftDMLP1 . validateDeleteQWith binRHSBuilder deleteQueryToTx :: (DeleteQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody deleteQueryToTx (u, p) = diff --git a/server/src-lib/Hasura/RQL/DML/Insert.hs b/server/src-lib/Hasura/RQL/DML/Insert.hs index fb4d6da922b9b..26539f86304f0 100644 --- a/server/src-lib/Hasura/RQL/DML/Insert.hs +++ b/server/src-lib/Hasura/RQL/DML/Insert.hs @@ -211,9 +211,9 @@ convInsQ :: (QErrM m, UserInfoM m, CacheRM m) => InsertQuery -> m (InsertQueryP1, DS.Seq Q.PrepArg) -convInsQ insQ = - liftP1 $ flip runStateT DS.empty $ convInsertQuery - (withPathK "objects" . decodeInsObjs) binRHSBuilder insQ +convInsQ = + liftDMLP1 . + convInsertQuery (withPathK "objects" . decodeInsObjs) binRHSBuilder insertP2 :: (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody insertP2 (u, p) = diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index ab039e98568cb..b0efbe7f22f40 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -18,13 +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 + askUserInfo = DMLP1 $ lift askUserInfo mkAdminRolePermInfo :: TableInfo -> RolePermInfo mkAdminRolePermInfo ti = diff --git a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs index 6b8a5ea5ea323..9411e22375de7 100644 --- a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs @@ -41,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 @@ -66,7 +64,7 @@ buildPrepArg :: TemplateArgs -> PGColType -> Value - -> EQTP1 S.SQLExp + -> DMLP1 S.SQLExp buildPrepArg args pct val = case val of Object _ -> do @@ -78,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 @@ -87,7 +85,7 @@ 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 @@ -99,13 +97,13 @@ convQT -> 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.validateUpdateQueryWith f q - QTDelete q -> fmap QTPDelete $ peelSt $ R.validateDeleteQWith f q - QTCount q -> fmap QTPCount $ peelSt $ RC.validateCountQWith 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 @@ -114,8 +112,6 @@ convQT args qt = case qt of R.decodeInsObjs v f = buildPrepArg args - peelSt m = - liftP1 $ runStateT m DS.empty execQueryTemplateP1 :: (UserInfoM m, QErrM m, CacheRM m) diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index 586420bf95816..5c0ce618778dc 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -310,7 +310,7 @@ phaseOne :: (QErrM m, UserInfoM m, CacheRM m) => SelectQuery -> m (AnnSel, DS.Seq Q.PrepArg) phaseOne = - liftP1 . flip runStateT DS.empty . convSelectQuery binRHSBuilder + liftDMLP1 . convSelectQuery binRHSBuilder phaseTwo :: (MonadTx m) => (AnnSel, DS.Seq Q.PrepArg) -> m RespBody phaseTwo = diff --git a/server/src-lib/Hasura/RQL/DML/Update.hs b/server/src-lib/Hasura/RQL/DML/Update.hs index 1c771750ad525..b1961bdbaf47c 100644 --- a/server/src-lib/Hasura/RQL/DML/Update.hs +++ b/server/src-lib/Hasura/RQL/DML/Update.hs @@ -173,8 +173,8 @@ validateUpdateQueryWith f uq = do validateUpdateQuery :: (QErrM m, UserInfoM m, CacheRM m) => UpdateQuery -> m (UpdateQueryP1, DS.Seq Q.PrepArg) -validateUpdateQuery updQ = - liftP1 $ flip runStateT DS.empty $ validateUpdateQueryWith binRHSBuilder updQ +validateUpdateQuery = + liftDMLP1 . validateUpdateQueryWith binRHSBuilder updateQueryToTx :: (UpdateQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody updateQueryToTx (u, p) = From 70b2b3cba47fd67ce85c5e116201c6280c9a49fb Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 11 Dec 2018 20:46:55 +0530 Subject: [PATCH 14/15] bump stackage version --- server/stack-nightly.yaml | 2 +- server/stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/server/stack-nightly.yaml b/server/stack-nightly.yaml index a66a9753bc7e4..5e87ed983b5e1 100644 --- a/server/stack-nightly.yaml +++ b/server/stack-nightly.yaml @@ -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-12-03 +resolver: nightly-2018-12-10 # Local packages, usually specified by relative directory name packages: diff --git a/server/stack.yaml b/server/stack.yaml index 2174902904225..d46d828c551be 100644 --- a/server/stack.yaml +++ b/server/stack.yaml @@ -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.21 +resolver: lts-12.22 compiler: ghc-8.4.4 # Local packages, usually specified by relative directory name From 6ef5e90bf585e05bb4afbf38e54d6954d1934d5b Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Wed, 12 Dec 2018 12:23:37 +0530 Subject: [PATCH 15/15] getTopLevelNodes will not throw any exceptions --- server/src-lib/Hasura/GraphQL/Transport/HTTP.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 778274c439d78..28c4076e270e0 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -77,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 =