Merge pull request #360 from digitallyinduced/config-query-debugging-…

…enabled

Only log sql queries in development mode

IHP/IDE/ToolServer.hs

@@ -71,7 +71,7 @@ startToolServer' port isDebugMode = do
                 , Cookie.setCookieSameSite = Just Cookie.sameSiteLax
                 }
     let sessionMiddleware :: Wai.Middleware = withSession store "SESSION" sessionCookie session    
-    let applicationContext = ApplicationContext { modelContext = (ModelContext (error "Not connected")), session }
+    let applicationContext = ApplicationContext { modelContext = notConnectedModelContext, session }
     let toolServerApplication = ToolServerApplication { devServerContext = ?context }
     let application :: Wai.Application = \request respond -> do
             let ?applicationContext = applicationContext

IHP/ModelSupport.hs

@@ -33,7 +33,19 @@ import qualified GHC.Types as Type
 import qualified Data.Text as Text
 import Data.Aeson (ToJSON (..))
 
-data ModelContext = ModelContext { databaseConnection :: Connection }
+-- | Provides the db connection and some IHP-specific db configuration
+data ModelContext = ModelContext
+    { databaseConnection :: Connection
+    -- | If True, prints out all SQL queries that are executed. Will be set to True by default in development mode (as configured in Config.hs) and False in production.
+    , queryDebuggingEnabled :: Bool
+    }
+
+-- | Provides a mock ModelContext to be used when a database connection is not available
+notConnectedModelContext :: ModelContext
+notConnectedModelContext = ModelContext
+    { databaseConnection = error "Not connected"
+    , queryDebuggingEnabled = False
+    }
 
 type family GetModelById id :: Type where
     GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName)
@@ -207,7 +219,7 @@ instance Default (PrimaryKey model) => Default (Id' model) where
 --
 -- Take a look at "IHP.QueryBuilder" for a typesafe approach on building simple queries.
 sqlQuery :: (?modelContext :: ModelContext) => (PG.ToRow q, PG.FromRow r) => Query -> q -> IO [r]
-sqlQuery = let (ModelContext conn) = ?modelContext in PG.query conn
+sqlQuery = let ModelContext { databaseConnection } = ?modelContext in PG.query databaseConnection
 {-# INLINE sqlQuery #-}
 
 -- | Returns the table name of a given model.
@@ -221,6 +233,12 @@ tableName :: forall model. (KnownSymbol (GetTableName model)) => Text
 tableName = Text.pack (symbolVal @(GetTableName model) Proxy)
 {-# INLINE tableName #-}
 
+logQuery :: (?modelContext :: ModelContext, Show query, Show parameters) => query -> parameters -> IO ()
+logQuery query parameters = when queryDebuggingEnabled (putStrLn (tshow (query, parameters)))
+    where
+        ModelContext { queryDebuggingEnabled } = ?modelContext
+            -- Env.isProduction FrameworkConfig.environment
+
 -- | Runs a @DELETE@ query for a record.
 --
 -- >>> let project :: Project = ...
@@ -230,12 +248,12 @@ tableName = Text.pack (symbolVal @(GetTableName model) Proxy)
 -- Use 'deleteRecords' if you want to delete multiple records.
 deleteRecord :: forall model id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName model), HasField "id" model id, ToField id) => model -> IO ()
 deleteRecord model = do
-    let (ModelContext conn) = ?modelContext
+    let ModelContext { databaseConnection}  = ?modelContext
     let id = getField @"id" model
     let theQuery = "DELETE FROM " <> tableName @model <> " WHERE id = ?"
     let theParameters = (PG.Only id)
-    putStrLn (tshow (theQuery, theParameters))
-    PG.execute conn (PG.Query . cs $! theQuery) theParameters
+    logQuery theQuery theParameters
+    PG.execute databaseConnection (PG.Query . cs $! theQuery) theParameters
     pure ()
 {-# INLINE deleteRecord #-}
 
@@ -246,13 +264,13 @@ deleteRecord model = do
 -- DELETE FROM projects WHERE id IN (..)
 deleteRecords :: forall record id. (?modelContext :: ModelContext, Show id, KnownSymbol (GetTableName record), HasField "id" record id, record ~ GetModelById id, ToField id) => [record] -> IO ()
 deleteRecords records = do
-    let (ModelContext conn) = ?modelContext
+    let ModelContext { databaseConnection } = ?modelContext
     let theQuery = "DELETE FROM " <> tableName @record <> " WHERE id IN ?"
     let theParameters = PG.Only (PG.In (ids records))
     if length records > 10
-        then putStrLn (tshow (theQuery, "More than 10 records"))
-        else putStrLn (tshow (theQuery, theParameters))
-    PG.execute conn (PG.Query . cs $! theQuery) theParameters
+        then logQuery theQuery "More than 10 records"
+        else logQuery theQuery theParameters
+    PG.execute databaseConnection (PG.Query . cs $! theQuery) theParameters
     pure ()
 {-# INLINE deleteRecords #-}
 
@@ -262,10 +280,10 @@ deleteRecords records = do
 -- DELETE FROM projects
 deleteAll :: forall record. (?modelContext :: ModelContext, KnownSymbol (GetTableName record)) => IO ()
 deleteAll = do
-    let (ModelContext conn) = ?modelContext
+    let ModelContext { databaseConnection } = ?modelContext
     let theQuery = "DELETE FROM " <> tableName @record
-    putStrLn (tshow theQuery)
-    PG.execute_ conn (PG.Query . cs $! theQuery)
+    logQuery theQuery ()
+    PG.execute_ databaseConnection (PG.Query . cs $! theQuery)
     pure ()
 {-# INLINE deleteAll #-}
 

IHP/QueryBuilder.hs

@@ -140,14 +140,14 @@ instance Fetchable (QueryBuilder model) model where
     fetch :: (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext) => QueryBuilder model -> IO [model]
     fetch !queryBuilder = do
         let !(theQuery, theParameters) = toSQL' (buildQuery queryBuilder)
-        putStrLn $! tshow (theQuery, theParameters)
+        logQuery theQuery theParameters
         sqlQuery (Query $ cs theQuery) theParameters
 
     {-# INLINE fetchOneOrNothing #-}
     fetchOneOrNothing :: (?modelContext :: ModelContext) => (PG.FromRow model, KnownSymbol (GetTableName model)) => QueryBuilder model -> IO (Maybe model)
     fetchOneOrNothing !queryBuilder = do
         let !(theQuery, theParameters) = toSQL' (buildQuery queryBuilder) { limitClause = Just "LIMIT 1"}
-        putStrLn $! tshow (theQuery, theParameters)
+        logQuery theQuery theParameters
         results <- sqlQuery (Query $ cs theQuery) theParameters
         pure $ listToMaybe results
 
@@ -174,7 +174,7 @@ fetchCount :: (?modelContext :: ModelContext, KnownSymbol (GetTableName model))
 fetchCount !queryBuilder = do
     let !(theQuery', theParameters) = toSQL' (buildQuery queryBuilder)
     let theQuery = "SELECT COUNT(*) FROM (" <> theQuery' <> ") AS _count_values"
-    putStrLn $! tshow (theQuery, theParameters)
+    logQuery theQuery theParameters
     [PG.Only count] <- sqlQuery (Query $! cs theQuery) theParameters
     pure count
 {-# INLINE fetchCount #-}
@@ -193,7 +193,7 @@ fetchExists :: (?modelContext :: ModelContext, KnownSymbol (GetTableName model))
 fetchExists !queryBuilder = do
     let !(theQuery', theParameters) = toSQL' (buildQuery queryBuilder)
     let theQuery = "SELECT EXISTS FROM (" <> theQuery' <> ") AS _exists_values"
-    putStrLn $! tshow (theQuery, theParameters)
+    logQuery theQuery theParameters
     [PG.Only exists] <- sqlQuery (Query $! cs theQuery) theParameters
     pure exists
 {-# INLINE fetchExists #-}

IHP/SchemaCompiler.hs

@@ -361,13 +361,13 @@ compileCreate table@(CreateTable { name, columns }) =
         <> indent (
             "create :: (?modelContext :: ModelContext) => " <> modelName <> " -> IO " <> modelName <> "\n"
                 <> "create model = do\n"
-                <> indent ("let (ModelContext conn) = ?modelContext\n"
-                    <> "result <- Database.PostgreSQL.Simple.query conn \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING *\" (" <> compileToRowValues bindings <> ")\n"
+                <> indent ("let ModelContext { databaseConnection } = ?modelContext\n"
+                    <> "result <- Database.PostgreSQL.Simple.query databaseConnection \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES (" <> values <> ") RETURNING *\" (" <> compileToRowValues bindings <> ")\n"
                     <> "pure (List.head result)\n"
                     )
                 <> "createMany models = do\n"
-                <> indent ("let (ModelContext conn) = ?modelContext\n"
-                    <> createManyQueryFn <> " conn (Query $ \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" <> values <> ")\") models)) <> \" RETURNING *\") " <> createManyFieldValues <> "\n"
+                <> indent ("let ModelContext { databaseConnection } = ?modelContext\n"
+                    <> createManyQueryFn <> " databaseConnection (Query $ \"INSERT INTO " <> name <> " (" <> columnNames <> ") VALUES \" <> (ByteString.intercalate \", \" (List.map (\\_ -> \"(" <> values <> ")\") models)) <> \" RETURNING *\") " <> createManyFieldValues <> "\n"
                     )
             )
 
@@ -395,8 +395,8 @@ compileUpdate table@(CreateTable { name, columns }) =
     in
         "instance CanUpdate " <> modelName <> " where\n"
         <> indent ("updateRecord model = do\n"
-                <> indent ("let (ModelContext conn) = ?modelContext\n"
-                    <> "result <- Database.PostgreSQL.Simple.query conn \"UPDATE " <> name <> " SET " <> updates <> " WHERE id = ? RETURNING *\" (" <> bindings <> ")\n"
+                <> indent ("let ModelContext { databaseConnection } = ?modelContext\n"
+                    <> "result <- Database.PostgreSQL.Simple.query databaseConnection \"UPDATE " <> name <> " SET " <> updates <> " WHERE id = ? RETURNING *\" (" <> bindings <> ")\n"
                     <> "pure (List.head result)\n"
                 )
             )

IHP/ScriptSupport.hs

@@ -7,21 +7,24 @@ module IHP.ScriptSupport (runScript, Script) where
 
 import IHP.Prelude
 import qualified IHP.FrameworkConfig as Config
+import qualified IHP.Environment as Env
 import IHP.ModelSupport
 import qualified Database.PostgreSQL.Simple as PG
 
 -- | A script is just an IO action which requires a database connection
 type Script = (?modelContext :: ModelContext) => IO ()
 
 -- | Initializes IHP and then runs the script inside the framework context
-runScript :: Script -> IO ()
+runScript :: Config.FrameworkConfig => Script -> IO ()
 runScript taskMain = do
     modelContext <- createModelContext    
     let ?modelContext = modelContext
     taskMain
 
+createModelContext :: Config.FrameworkConfig => IO ModelContext
 createModelContext = do
     databaseUrl <- Config.appDatabaseUrl
-    conn <- PG.connectPostgreSQL databaseUrl 
-    pure (ModelContext conn)
+    databaseConnection <- PG.connectPostgreSQL databaseUrl 
+    let queryDebuggingEnabled = Env.isDevelopment Config.environment
+    pure ModelContext { .. }
 

IHP/Server.hs

@@ -15,7 +15,7 @@ import IHP.ApplicationContext
 import qualified IHP.ControllerSupport as ControllerSupport
 import Database.PostgreSQL.Simple
 import qualified IHP.LoginSupport.Middleware
-import IHP.Environment (isDevelopment)
+import qualified IHP.Environment as Env
 import System.Info
 
 import qualified IHP.FrameworkConfig as FrameworkConfig
@@ -26,11 +26,13 @@ import qualified IHP.ErrorController as ErrorController
 run :: (FrameworkConfig, FrontController FrameworkConfig.RootApplication) => IO ()
 run = do
     databaseUrl <- appDatabaseUrl
-    conn <- connectPostgreSQL databaseUrl 
+    databaseConnection <- connectPostgreSQL databaseUrl 
     session <- Vault.newKey
     port <- FrameworkConfig.initAppPort
     store <- fmap clientsessionStore (ClientSession.getKey "Config/client_session_key.aes")
-    let applicationContext = ApplicationContext { modelContext = (ModelContext conn), session }
+    let isDevelopment = Env.isDevelopment FrameworkConfig.environment
+    let modelContext = ModelContext { databaseConnection, queryDebuggingEnabled = isDevelopment }
+    let applicationContext = ApplicationContext { modelContext, session }
     let application :: Application = \request respond -> do
             let ?applicationContext = applicationContext
             requestContext <- ControllerSupport.createRequestContext applicationContext request respond
@@ -47,7 +49,7 @@ run = do
     libDirectory <- cs <$> FrameworkConfig.findLibDirectory
     let staticMiddleware :: Middleware = staticPolicy (addBase "static/") . staticPolicy (addBase (libDirectory <> "static/"))
 
-    let runServer = if isDevelopment FrameworkConfig.environment
+    let runServer = if isDevelopment
             then
                 let settings = Warp.defaultSettings
                         |> Warp.setBeforeMainLoop (putStrLn "Server started")