refactor: remove IO from the Query.hs module

Will make logging SQL queries to stderr possible

src/PostgREST/App.hs

@@ -146,7 +146,17 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
 
   (parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestError $ ApiRequest.userApiRequest conf req body sCache
   (planTime, plan)                   <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
-  (queryTime, queryResult)           <- withTiming $ Query.runQuery appState conf authResult apiReq plan sCache pgVer (Just authRole /= configDbAnonRole)
+
+  let query = Query.query conf authResult apiReq plan sCache pgVer
+
+  (queryTime, queryResult) <- withTiming $ do
+    case query of
+      Query.NoDbQuery r -> pure r
+      Query.DbQuery{..} -> do
+        dbRes <- lift $ AppState.usePool appState (dqTransaction dqIsoLevel dqTxMode $ runExceptT dqDbHandler)
+        err <- liftEither . mapLeft Error.PgErr . mapLeft (Error.PgError (Just authRole /= configDbAnonRole)) $ dbRes
+        liftEither err
+
   (respTime, resp) <- withTiming $ liftEither $ Response.actionResponse queryResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache iSchema iNegotiatedByProfile
 
   return $ toWaiResponse (ServerTiming jwtTime parseTime planTime queryTime respTime) resp

src/PostgREST/Query.hs

@@ -2,25 +2,24 @@
 {-# LANGUAGE RecordWildCards #-}
 -- TODO: This module shouldn't depend on SchemaCache
 module PostgREST.Query
-  ( QueryResult (..)
+  ( Query (..)
-  , runQuery
+  , QueryResult (..)
+  , query
   ) where
 
-import           Control.Monad.Except              (liftEither)
 import qualified Data.Aeson                        as JSON
 import qualified Data.Aeson.KeyMap                 as KM
 import qualified Data.ByteString                   as BS
 import qualified Data.ByteString.Lazy.Char8        as LBS
-import           Data.Either.Combinators           (mapLeft)
 import qualified Data.HashMap.Strict               as HM
 import qualified Data.Set                          as S
 import qualified Hasql.Decoders                    as HD
 import qualified Hasql.DynamicStatements.Snippet   as SQL (Snippet)
 import qualified Hasql.DynamicStatements.Statement as SQL
+import qualified Hasql.Session                     as SQL (Session)
 import qualified Hasql.Transaction                 as SQL
 import qualified Hasql.Transaction.Sessions        as SQL
 
-import qualified PostgREST.AppState           as AppState
 import qualified PostgREST.Error              as Error
 import qualified PostgREST.Query.QueryBuilder as QueryBuilder
 import qualified PostgREST.Query.Statements   as Statements
@@ -49,7 +48,6 @@ import PostgREST.Plan                    (ActionPlan (..),
                                           InfoPlan (..),
                                           InspectPlan (..))
 import PostgREST.Plan.MutatePlan         (MutatePlan (..))
-import PostgREST.Plan.ReadPlan           (ReadPlanTree)
 import PostgREST.Query.SqlFragment       (escapeIdentList, fromQi,
                                           intercalateSnippet,
                                           setConfigWithConstantName,
@@ -58,34 +56,34 @@ import PostgREST.Query.SqlFragment       (escapeIdentList, fromQi,
 import PostgREST.Query.Statements        (ResultSet (..))
 import PostgREST.SchemaCache             (SchemaCache (..))
 import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
-import PostgREST.SchemaCache.Routine     (MediaHandler, Routine (..),
+import PostgREST.SchemaCache.Routine     (Routine (..), RoutineMap)
-                                          RoutineMap)
 import PostgREST.SchemaCache.Table       (TablesMap)
 
 import Protolude hiding (Handler)
 
 type DbHandler = ExceptT Error SQL.Transaction
 
+data Query
+  = DbQuery {
+      dqIsoLevel    :: SQL.IsolationLevel
+    , dqTxMode      :: SQL.Mode
+    , dqDbHandler   :: DbHandler QueryResult
+    , dqTransaction :: SQL.IsolationLevel -> SQL.Mode -> SQL.Transaction (Either Error QueryResult) -> SQL.Session (Either Error QueryResult)
+    }
+  | NoDbQuery QueryResult
+
 data QueryResult
   = DbCrudResult  CrudPlan ResultSet
   | DbCallResult  CallReadPlan  ResultSet
   | MaybeDbResult InspectPlan  (Maybe (TablesMap, RoutineMap, Maybe Text))
   | NoDbResult    InfoPlan
 
--- TODO This function needs to be free from IO, only App.hs should do IO
+query :: AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> PgVersion -> Query
-runQuery :: AppState.AppState -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> PgVersion -> Bool -> ExceptT Error IO QueryResult
+query _ _ _ (NoDb x) _ _ = NoDbQuery $ NoDbResult x
-runQuery _ _ _ _ (NoDb x) _ _ _ = pure $ NoDbResult x
+query config AuthResult{..} apiReq (Db plan) sCache pgVer =
-runQuery appState config AuthResult{..} apiReq (Db plan) sCache pgVer authenticated = do
+  DbQuery isoLvl txMode dbHandler transaction
-  dbResp <- lift $ do
-    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
-    AppState.usePool appState (transaction isoLvl txMode $ runExceptT dbHandler)
-
-  resp <-
-    liftEither . mapLeft Error.PgErr $
-      mapLeft (Error.PgError authenticated) dbResp
-
-  liftEither resp
   where
+    transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
     prepared = configDbPreparedStatements config
     isoLvl = planIsoLvl config authRole plan
     txMode = planTxMode plan
@@ -107,12 +105,11 @@ planIsoLvl AppConfig{configRoleIsoLvl} role actPlan = case actPlan of
     roleIsoLvl = HM.findWithDefault SQL.ReadCommitted role configRoleIsoLvl
 
 actionQuery :: DbActionPlan -> AppConfig -> ApiRequest -> PgVersion -> SchemaCache -> DbHandler QueryResult
-
+actionQuery (DbCrud plan@WrappedReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ _ =
-actionQuery (DbCrud plan@WrappedReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ _ = do
+  mainActionQuery
-  let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan
+  where
-  resultSet <-
+    countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan
-     lift . SQL.statement mempty $
+    result = Statements.prepareRead
-      Statements.prepareRead
       (QueryBuilder.readPlanToQuery wrReadPlan)
       (if preferCount == Just EstimatedCount then
          -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
@@ -124,40 +121,48 @@ actionQuery (DbCrud plan@WrappedReadPlan{..}) conf@AppConfig{..} apiReq@ApiReque
       wrMedia
       wrHandler
       configDbPreparedStatements
+    mainActionQuery = do
+      resultSet <- lift $ SQL.statement mempty result
       failNotSingular wrMedia resultSet
       optionalRollback conf apiReq
       DbCrudResult plan <$> resultSetWTotal conf apiReq resultSet countQuery
 
-actionQuery (DbCrud plan@MutateReadPlan{mrMutation=MutationCreate, ..}) conf apiReq _ _ = do
+actionQuery (DbCrud plan@MutateReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} _ _ =
-  resultSet <- writeQuery mrReadPlan mrMutatePlan mrMedia mrHandler apiReq conf
+  mainActionQuery
+  where
+    (isPut, isInsert, pkCols) = case mrMutatePlan of {Insert{where_,insPkCols} -> ((not . null) where_, True, insPkCols); _ -> (False,False, mempty);}
+    result = Statements.prepareWrite
+      (QueryBuilder.readPlanToQuery mrReadPlan)
+      (QueryBuilder.mutatePlanToQuery mrMutatePlan)
+      isInsert
+      isPut
+      mrMedia
+      mrHandler
+      preferRepresentation
+      preferResolution
+      pkCols
+      configDbPreparedStatements
+    failMutation resultSet = case mrMutation of
+      MutationCreate -> do
         failNotSingular mrMedia resultSet
-  optionalRollback conf apiReq
+      MutationUpdate -> do
-  pure $ DbCrudResult plan resultSet
-
-actionQuery (DbCrud plan@MutateReadPlan{mrMutation=MutationUpdate, ..}) conf apiReq@ApiRequest{iPreferences=Preferences{..}} _ _ = do
-  resultSet <- writeQuery mrReadPlan mrMutatePlan mrMedia mrHandler apiReq conf
         failNotSingular mrMedia resultSet
         failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
-  optionalRollback conf apiReq
+      MutationSingleUpsert -> do
-  pure $ DbCrudResult plan resultSet
-
-actionQuery (DbCrud plan@MutateReadPlan{mrMutation=MutationSingleUpsert, ..}) conf apiReq _ _ = do
-  resultSet <- writeQuery mrReadPlan mrMutatePlan mrMedia mrHandler apiReq conf
         failPut resultSet
-  optionalRollback conf apiReq
+      MutationDelete -> do
-  pure $ DbCrudResult plan resultSet
-
-actionQuery (DbCrud plan@MutateReadPlan{mrMutation=MutationDelete, ..}) conf apiReq@ApiRequest{iPreferences=Preferences{..}} _ _ = do
-  resultSet <- writeQuery mrReadPlan mrMutatePlan mrMedia mrHandler apiReq conf
         failNotSingular mrMedia resultSet
         failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
+    mainActionQuery = do
+      resultSet <- lift $ SQL.statement mempty result
+      failMutation resultSet
       optionalRollback conf apiReq
       pure $ DbCrudResult plan resultSet
 
-actionQuery (DbCall plan@CallReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} pgVer _ = do
+actionQuery (DbCall plan@CallReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} pgVer _ =
-  resultSet <-
+  mainActionQuery
-    lift . SQL.statement mempty $
+  where
-      Statements.prepareCall
+    result = Statements.prepareCall
       crProc
       (QueryBuilder.callPlanToQuery crCallPlan pgVer)
       (QueryBuilder.readPlanToQuery crReadPlan)
@@ -166,7 +171,8 @@ actionQuery (DbCall plan@CallReadPlan{..}) conf@AppConfig{..} apiReq@ApiRequest{
       crMedia
       crHandler
       configDbPreparedStatements
-
+    mainActionQuery = do
+      resultSet <- lift $ SQL.statement mempty result
       optionalRollback conf apiReq
       failNotSingular crMedia resultSet
       failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
@@ -188,24 +194,6 @@ actionQuery (MaybeDb plan@InspectPlan{ipSchema=tSchema}) AppConfig{..} _ _ sCach
     OADisabled ->
       pure $ MaybeDbResult plan Nothing
 
-writeQuery :: ReadPlanTree -> MutatePlan -> MediaType -> MediaHandler -> ApiRequest -> AppConfig  -> DbHandler ResultSet
-writeQuery readPlan mutatePlan mType mHandler ApiRequest{iPreferences=Preferences{..}} conf =
-  let
-    (isPut, isInsert, pkCols) = case mutatePlan of {Insert{where_,insPkCols} -> ((not . null) where_, True, insPkCols); _ -> (False,False, mempty);}
-  in
-  lift . SQL.statement mempty $
-    Statements.prepareWrite
-      (QueryBuilder.readPlanToQuery readPlan)
-      (QueryBuilder.mutatePlanToQuery mutatePlan)
-      isInsert
-      isPut
-      mType
-      mHandler
-      preferRepresentation
-      preferResolution
-      pkCols
-      (configDbPreparedStatements conf)
-
 -- Makes sure the querystring pk matches the payload pk
 -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted,
 -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected.