server: RQL code health

This PR is a combination of the following other PRs:
- #169: move HasHttpManager out of RQL.Types
- #170: move UserInfoM to Hasura.Session
- #179: delete dead code from RQL.Types
- #180: move event related code to EventTrigger

server/graphql-engine.cabal

@@ -491,6 +491,7 @@ library
                      , Hasura.SQL.Time
                      , Hasura.SQL.Types
                      , Hasura.Tracing
+                     , Network.HTTP.Client.Extended
                      , Network.URI.Extended
                      , Network.Wai.Extended
                      , Network.Wai.Handler.WebSockets.Custom

server/src-lib/Hasura/App.hs

@@ -3,23 +3,7 @@
 
 module Hasura.App where
 
-import           Control.Concurrent.STM.TVar               (TVar, readTVarIO)
-import           Control.Exception                         (bracket_, throwIO)
-import           Control.Monad.Base
-import           Control.Monad.Catch                       (Exception, MonadCatch, MonadMask,
-                                                            MonadThrow, onException)
-import           Control.Monad.Morph                       (hoist)
-import           Control.Monad.Stateless
-import           Control.Monad.STM                         (atomically)
-import           Control.Monad.Trans.Control               (MonadBaseControl (..))
-import           Control.Monad.Trans.Managed               (ManagedT (..), allocate)
-import           Control.Monad.Unique
-import           Data.Time.Clock                           (UTCTime)
-#ifndef PROFILING
-import           GHC.AssertNF
-#endif
-import           Options.Applicative
-import           System.Environment                        (getEnvironment)
+import           Hasura.Prelude
 
 import qualified Control.Concurrent.Async.Lifted.Safe      as LA
 import qualified Control.Concurrent.Extended               as C
@@ -38,8 +22,33 @@ import qualified Network.HTTP.Client                       as HTTP
 import qualified Network.HTTP.Client.TLS                   as HTTP
 import qualified Network.Wai.Handler.Warp                  as Warp
 import qualified System.Log.FastLogger                     as FL
+import qualified System.Metrics                            as EKG
+import qualified System.Metrics.Gauge                      as EKG.Gauge
 import qualified Text.Mustache.Compile                     as M
 
+import           Control.Concurrent.STM.TVar               (TVar, readTVarIO)
+import           Control.Exception                         (bracket_, throwIO)
+import           Control.Monad.Catch                       (Exception, MonadCatch, MonadMask,
+                                                            MonadThrow, onException)
+import           Control.Monad.Morph                       (hoist)
+import           Control.Monad.STM                         (atomically)
+import           Control.Monad.Stateless
+import           Control.Monad.Trans.Control               (MonadBaseControl (..))
+import           Control.Monad.Trans.Managed               (ManagedT (..), allocate)
+import           Control.Monad.Unique
+import           Data.Time.Clock                           (UTCTime)
+#ifndef PROFILING
+import           GHC.AssertNF
+#endif
+import           Network.HTTP.Client.Extended
+import           Options.Applicative
+import           System.Environment                        (getEnvironment)
+
+import qualified Hasura.GraphQL.Execute.LiveQuery.Poll     as EL
+import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
+import qualified Hasura.Server.API.V2Query                 as V2Q
+import qualified Hasura.Tracing                            as Tracing
+
 import           Hasura.Backends.Postgres.Connection
 import           Hasura.EncJSON
 import           Hasura.Eventing.Common
@@ -55,7 +64,6 @@ import           Hasura.GraphQL.Transport.HTTP             (MonadExecuteQuery (.
 import           Hasura.GraphQL.Transport.HTTP.Protocol    (toParsed)
 import           Hasura.Logging
 import           Hasura.Metadata.Class
-import           Hasura.Prelude
 import           Hasura.RQL.DDL.Schema.Cache
 import           Hasura.RQL.DDL.Schema.Cache.Common
 import           Hasura.RQL.DDL.Schema.Catalog
@@ -75,13 +83,6 @@ import           Hasura.Server.Types
 import           Hasura.Server.Version
 import           Hasura.Session
 
-import qualified Hasura.GraphQL.Execute.LiveQuery.Poll     as EL
-import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
-import qualified Hasura.Server.API.V2Query                 as V2Q
-import qualified Hasura.Tracing                            as Tracing
-import qualified System.Metrics                            as EKG
-import qualified System.Metrics.Gauge                      as EKG.Gauge
-
 
 data ExitCode
 -- these are used during server initialization:
@@ -635,7 +636,7 @@ execQuery
      , MonadIO m
      , MonadBaseControl IO m
      , MonadUnique m
-     , HasHttpManager m
+     , HasHttpManagerM m
      , HasSQLGenCtx m
      , UserInfoM m
      , Tracing.MonadTrace m

server/src-lib/Hasura/Backends/Postgres/Connection.hs

@@ -36,6 +36,7 @@ import           Control.Monad.Morph                    (hoist)
 import           Control.Monad.Trans.Control            (MonadBaseControl (..))
 import           Control.Monad.Unique
 import           Control.Monad.Validate
+import           Network.HTTP.Client.Extended           (HasHttpManagerM (..))
 
 import qualified Hasura.Backends.Postgres.SQL.DML       as S
 import qualified Hasura.Tracing                         as Tracing
@@ -44,8 +45,8 @@ import           Hasura.Backends.Postgres.Execute.Types as ET
 import           Hasura.Backends.Postgres.SQL.Types
 import           Hasura.EncJSON
 import           Hasura.RQL.Types.Error
-import           Hasura.Session
 import           Hasura.SQL.Types
+import           Hasura.Session
 
 class (MonadError QErr m) => MonadTx m where
   liftTx :: Q.TxE QErr a -> m a
@@ -184,6 +185,12 @@ instance (Tracing.MonadTrace m) => Tracing.MonadTrace (LazyTxT e m) where
   currentReporter = lift Tracing.currentReporter
   attachMetadata  = lift . Tracing.attachMetadata
 
+instance UserInfoM m => UserInfoM (LazyTxT e m) where
+  askUserInfo = lift askUserInfo
+
+instance HasHttpManagerM m => HasHttpManagerM (LazyTxT e m) where
+  askHttpManager = lift askHttpManager
+
 instance (MonadIO m) => MonadTx (LazyTxT QErr m) where
   liftTx = LTTx . (hoist liftIO)
 

server/src-lib/Hasura/Backends/Postgres/Translate/Returning.hs

@@ -21,6 +21,7 @@ import           Hasura.RQL.DML.Internal
 import           Hasura.RQL.IR.Returning
 import           Hasura.RQL.IR.Select
 import           Hasura.RQL.Types                          hiding (Identifier)
+import           Hasura.Session
 
 
 -- | The postgres common table expression (CTE) for mutation queries.

server/src-lib/Hasura/RQL/DDL/EventTrigger.hs

@@ -42,6 +42,7 @@ import           Hasura.RQL.DDL.Headers
 import           Hasura.RQL.DML.Internal
 import           Hasura.RQL.Types
 import           Hasura.SQL.Types
+import           Hasura.Session
 
 
 data OpVar = OLD | NEW deriving (Show)
@@ -80,13 +81,13 @@ mkTriggerQ trn qt@(QualifiedObject schema table) allCols op (SubscribeOpSpec col
         mkQId opVar colInfo = toJSONableExp strfyNum (pgiType colInfo) False $
           S.SEQIdentifier $ S.QIdentifier (opToQual opVar) $ toIdentifier $ pgiColumn colInfo
         getRowExpression opVar = case payloadColumns of
-          SubCStar -> applyRowToJson $ S.SEUnsafe $ opToTxt opVar
+          SubCStar -> applyRowToJson $ S.SEUnsafe $ tshow opVar
           SubCArray cols -> applyRowToJson $
             S.mkRowExp $ map (toExtr . mkQId opVar) $
             getColInfos cols allCols
 
         renderRow opVar = case columns of
-          SubCStar -> applyRow $ S.SEUnsafe $ opToTxt opVar
+          SubCStar -> applyRow $ S.SEUnsafe $ tshow opVar
           SubCArray cols -> applyRow $
             S.mkRowExp $ map (toExtr . mkQId opVar) $
             getColInfos cols allCols
@@ -119,8 +120,7 @@ mkTriggerQ trn qt@(QualifiedObject schema table) allCols op (SubscribeOpSpec col
     applyRowToJson e = S.SEFnApp "row_to_json" [e] Nothing
     applyRow e = S.SEFnApp "row" [e] Nothing
     toExtr = flip S.Extractor Nothing
-    opToQual = S.QualVar . opToTxt
-    opToTxt = tshow
+    opToQual = S.QualVar . tshow
 
 delTriggerQ :: TriggerName -> Q.TxE QErr ()
 delTriggerQ trn =
@@ -378,3 +378,24 @@ getEventTriggerDef triggerName = do
      FROM hdb_catalog.event_triggers e where e.name = $1
            |] (Identity triggerName) False
   return (QualifiedObject sn tn, etc)
+
+askTabInfoFromTrigger
+  :: (QErrM m, CacheRM m)
+  => SourceName -> TriggerName -> m (TableInfo 'Postgres)
+askTabInfoFromTrigger sourceName trn = do
+  sc <- askSchemaCache
+  let tabInfos = HM.elems $ maybe mempty _pcTables $ HM.lookup sourceName $ scPostgres sc
+  find (isJust . HM.lookup trn . _tiEventTriggerInfoMap) tabInfos
+    `onNothing` throw400 NotExists errMsg
+  where
+    errMsg = "event trigger " <> triggerNameToTxt trn <<> " does not exist"
+
+askEventTriggerInfo
+  :: (QErrM m, CacheRM m)
+  => SourceName -> TriggerName -> m EventTriggerInfo
+askEventTriggerInfo sourceName trn = do
+  ti <- askTabInfoFromTrigger sourceName trn
+  let etim = _tiEventTriggerInfoMap ti
+  HM.lookup trn etim `onNothing` throw400 NotExists errMsg
+  where
+    errMsg = "event trigger " <> triggerNameToTxt trn <<> " does not exist"

server/src-lib/Hasura/RQL/DDL/QueryCollection.hs

@@ -22,6 +22,7 @@ import           Data.Text.NonEmpty
 import           Hasura.EncJSON
 import           Hasura.RQL.Types
 import           Hasura.RQL.Types.QueryCollection
+import           Hasura.Session
 
 
 addCollectionP2

server/src-lib/Hasura/RQL/DDL/Relationship.hs

@@ -27,6 +27,7 @@ import           Hasura.RQL.DDL.Deps
 import           Hasura.RQL.DDL.Permission
 import           Hasura.RQL.Types
 
+
 runCreateRelationship
   :: (MonadError QErr m, CacheRWM m, ToJSON a, MetadataM m)
   => RelType -> WithTable (RelDef a) -> m EncJSON

server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs

@@ -21,22 +21,23 @@ import qualified Data.HashSet                           as S
 
 import           Control.Monad.Unique
 import           Data.Text.Extended
+import           Network.HTTP.Client.Extended
 
 import           Hasura.EncJSON
 import           Hasura.GraphQL.RemoteServer
 import           Hasura.RQL.DDL.Deps
 import           Hasura.RQL.Types
 import           Hasura.Server.Version                  (HasVersion)
-
 import           Hasura.Session
 
+
 runAddRemoteSchema
   :: ( HasVersion
      , QErrM m
      , CacheRWM m
      , MonadIO m
      , MonadUnique m
-     , HasHttpManager m
+     , HasHttpManagerM m
      , MetadataM m
      )
   => Env.Environment
@@ -113,7 +114,7 @@ addRemoteSchemaP1 name = do
     <> name <<> " already exists"
 
 addRemoteSchemaP2Setup
-  :: (HasVersion, QErrM m, MonadIO m, MonadUnique m, HasHttpManager m)
+  :: (HasVersion, QErrM m, MonadIO m, MonadUnique m, HasHttpManagerM m)
   => Env.Environment
   -> AddRemoteSchemaQuery -> m RemoteSchemaCtx
 addRemoteSchemaP2Setup env (AddRemoteSchemaQuery name def _) = do

server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs

@@ -35,6 +35,7 @@ import           Control.Monad.Trans.Control              (MonadBaseControl)
 import           Control.Monad.Unique
 import           Data.Aeson
 import           Data.Text.Extended
+import           Network.HTTP.Client.Extended
 
 import qualified Hasura.Incremental                       as Inc
 import qualified Hasura.Tracing                           as Tracing
@@ -62,9 +63,9 @@ import           Hasura.RQL.DDL.Schema.Source
 import           Hasura.RQL.DDL.Schema.Table
 import           Hasura.RQL.Types                         hiding (fmFunction, tmTable)
 import           Hasura.Server.Version                    (HasVersion)
-
 import           Hasura.Session
 
+
 buildRebuildableSchemaCache
   :: (HasVersion)
   => Env.Environment
@@ -91,7 +92,7 @@ newtype CacheRWT m a
   = CacheRWT (StateT (RebuildableSchemaCache, CacheInvalidations) m a)
   deriving
     ( Functor, Applicative, Monad, MonadIO, MonadUnique, MonadReader r, MonadError e, MonadTx
-    , UserInfoM, HasHttpManager, HasSQLGenCtx, HasSystemDefined, MonadMetadataStorage
+    , UserInfoM, HasHttpManagerM, HasSQLGenCtx, HasSystemDefined, MonadMetadataStorage
     , MonadMetadataStorageQueryAPI, HasRemoteSchemaPermsCtx, Tracing.MonadTrace)
 
 deriving instance (MonadBase IO m) => MonadBase IO (CacheRWT m)
@@ -109,7 +110,7 @@ instance MonadTrans CacheRWT where
 instance (Monad m) => CacheRM (CacheRWT m) where
   askSchemaCache = CacheRWT $ gets (lastBuiltSchemaCache . (^. _1))
 
-instance (MonadIO m, MonadError QErr m, HasHttpManager m, HasSQLGenCtx m
+instance (MonadIO m, MonadError QErr m, HasHttpManagerM m, HasSQLGenCtx m
          , HasRemoteSchemaPermsCtx m, MonadResolveSource m) => CacheRWM (CacheRWT m) where
   buildSchemaCacheWithOptions buildReason invalidations metadata = CacheRWT do
     (RebuildableSchemaCache _ invalidationKeys rule, oldInvalidations) <- get
@@ -133,7 +134,7 @@ buildSchemaCacheRule
   -- what we want!
   :: ( HasVersion, ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
      , MonadIO m, MonadUnique m, MonadBaseControl IO m, MonadError QErr m
-     , MonadReader BuildReason m, HasHttpManager m, HasSQLGenCtx m , HasRemoteSchemaPermsCtx m, MonadResolveSource m)
+     , MonadReader BuildReason m, HasHttpManagerM m, HasSQLGenCtx m , HasRemoteSchemaPermsCtx m, MonadResolveSource m)
   => Env.Environment
   -> (Metadata, InvalidationKeys) `arr` SchemaCache
 buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do
@@ -275,7 +276,7 @@ buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do
       :: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
          , ArrowWriter (Seq CollectedInfo) arr, MonadIO m, MonadUnique m, MonadError QErr m
          , MonadReader BuildReason m, MonadBaseControl IO m
-         , HasHttpManager m, HasSQLGenCtx m, MonadResolveSource m)
+         , HasHttpManagerM m, HasSQLGenCtx m, MonadResolveSource m)
       => (Metadata, Inc.Dependency InvalidationKeys) `arr` BuildOutputs
     buildAndCollectInfo = proc (metadata, invalidationKeys) -> do
       let Metadata sources remoteSchemas collections allowlists
@@ -504,7 +505,7 @@ buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do
 
     buildRemoteSchemas
       :: ( ArrowChoice arr, Inc.ArrowDistribute arr, ArrowWriter (Seq CollectedInfo) arr
-         , Inc.ArrowCache m arr , MonadIO m, MonadUnique m, HasHttpManager m )
+         , Inc.ArrowCache m arr , MonadIO m, MonadUnique m, HasHttpManagerM m )
       => ( Inc.Dependency (HashMap RemoteSchemaName Inc.InvalidationKey)
          , [RemoteSchemaMetadata]
          ) `arr` HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject)

server/src-lib/Hasura/RQL/DDL/Schema/Cache/Common.hs

@@ -12,7 +12,7 @@ import qualified Data.HashMap.Strict.Extended       as M
 import qualified Data.HashMap.Strict.InsOrd         as OMap
 import qualified Data.HashSet                       as HS
 import qualified Data.Sequence                      as Seq
-import qualified Network.HTTP.Client                as HTTP
+import qualified Network.HTTP.Client.Extended       as HTTP
 
 import           Control.Arrow.Extended
 import           Control.Lens
@@ -134,7 +134,7 @@ newtype CacheBuild a
            , MonadUnique
            )
 
-instance HasHttpManager CacheBuild where
+instance HTTP.HasHttpManagerM CacheBuild where
   askHttpManager = asks _cbpManager
 
 instance HasSQLGenCtx CacheBuild where
@@ -158,15 +158,15 @@ runCacheBuild params (CacheBuild m) = do
 runCacheBuildM
   :: ( MonadIO m
      , MonadError QErr m
-     , HasHttpManager m
+     , HTTP.HasHttpManagerM m
      , HasSQLGenCtx m
      , HasRemoteSchemaPermsCtx m
      , MonadResolveSource m
      )
   => CacheBuild a -> m a
 runCacheBuildM m = do
   params <- CacheBuildParams
-            <$> askHttpManager
+            <$> HTTP.askHttpManager
             <*> askSQLGenCtx
             <*> askRemoteSchemaPermsCtx
             <*> getSourceResolver

server/src-lib/Hasura/RQL/DML/Count.hs

@@ -27,6 +27,7 @@ import           Hasura.RQL.IR.BoolExp
 import           Hasura.RQL.Types
 import           Hasura.RQL.Types.Run
 import           Hasura.SQL.Types
+import           Hasura.Session
 
 
 data CountQueryP1

server/src-lib/Hasura/RQL/DML/Delete.hs

@@ -30,6 +30,7 @@ import           Hasura.RQL.IR.Delete
 import           Hasura.RQL.Types
 import           Hasura.RQL.Types.Run
 import           Hasura.Server.Version                        (HasVersion)
+import           Hasura.Session
 
 
 validateDeleteQWith

server/src-lib/Hasura/RQL/DML/Select.hs

@@ -29,6 +29,7 @@ import           Hasura.RQL.IR.Select
 import           Hasura.RQL.Types
 import           Hasura.RQL.Types.Run
 import           Hasura.SQL.Types
+import           Hasura.Session
 
 
 type SelectQExt b = SelectG (ExtCol b) (BoolExp b) Int