From e804a2c4caf8656b5852a6c4346ed7b53a03aaec Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Thu, 27 Aug 2020 18:35:18 +0200 Subject: [PATCH] Only log sql queries in development mode Previous all sql queries have been printed to stdout all the time. This change adds a new option queryDebuggingEnabled to the modelContext. Depending on this setting queries will be logged. By default this will be set to True in dev mode, and to False in Production mode --- IHP/IDE/ToolServer.hs | 2 +- IHP/ModelSupport.hs | 42 ++++++++++++++++++++++++++++++------------ IHP/QueryBuilder.hs | 8 ++++---- IHP/SchemaCompiler.hs | 12 ++++++------ IHP/ScriptSupport.hs | 9 ++++++--- IHP/Server.hs | 10 ++++++---- 6 files changed, 53 insertions(+), 30 deletions(-) diff --git a/IHP/IDE/ToolServer.hs b/IHP/IDE/ToolServer.hs index 71409dadc..1357eaadf 100644 --- a/IHP/IDE/ToolServer.hs +++ b/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 diff --git a/IHP/ModelSupport.hs b/IHP/ModelSupport.hs index 816fb16c1..da550dd97 100644 --- a/IHP/ModelSupport.hs +++ b/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 #-} diff --git a/IHP/QueryBuilder.hs b/IHP/QueryBuilder.hs index 4ee4f5588..32102253f 100644 --- a/IHP/QueryBuilder.hs +++ b/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 #-} diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 80b4b1385..908c74033 100644 --- a/IHP/SchemaCompiler.hs +++ b/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" ) ) diff --git a/IHP/ScriptSupport.hs b/IHP/ScriptSupport.hs index 8f507b1af..03511d971 100644 --- a/IHP/ScriptSupport.hs +++ b/IHP/ScriptSupport.hs @@ -7,6 +7,7 @@ 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 @@ -14,14 +15,16 @@ import qualified Database.PostgreSQL.Simple as PG 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 { .. } \ No newline at end of file diff --git a/IHP/Server.hs b/IHP/Server.hs index dd3ad12cb..025fc276c 100644 --- a/IHP/Server.hs +++ b/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")