feat: log connection pool events on log-level=info

CHANGELOG.md

@@ -13,6 +13,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
  - #3171, #3046, Log schema cache stats to stderr - @steve-chavez
  - #3210, Dump schema cache through admin API - @taimoorzaeem
  - #2676, Performance improvement on bulk json inserts, around 10% increase on requests per second by removing `json_typeof` from write queries - @steve-chavez
+ - #3214, Log connection pool events on log-level=info - @steve-chavez
 
 ### Fixed
 

nix/overlays/haskell-packages.nix

@@ -60,18 +60,26 @@ let
           }
           { };
 
+      hasql-pool =
+        lib.dontCheck (prev.callHackageDirect
+          {
+            pkg = "hasql-pool";
+            ver = "1.0.1";
+            sha256 = "sha256-Hf1f7lX0LWkjrb25SDBovCYPRdmUP1H6pAxzi7kT4Gg=";
+          }
+          { }
+        );
+
       postgresql-libpq = lib.dontCheck
         (prev.postgresql-libpq_0_10_0_0.override {
           postgresql = super.libpq;
         });
 
-      hasql-pool = lib.dontCheck prev.hasql-pool_0_10;
-
       hasql-notifications = lib.dontCheck (prev.callHackageDirect
         {
           pkg = "hasql-notifications";
-          ver = "0.2.1.0";
-          sha256 = "sha256-MEIirDKR81KpiBOnWJbVInWevL6Kdb/XD1Qtd8e6KsQ=";
+          ver = "0.2.1.1";
+          sha256 = "sha256-oPhKA/pSQGJvgQyhsi7CVr9iDT7uWpKUz0iJfXsaxXo=";
         }
         { }
       );

postgrest.cabal

@@ -108,8 +108,8 @@ library
                     , gitrev                    >= 1.2 && < 1.4
                     , hasql                     >= 1.6.1.1 && < 1.7
                     , hasql-dynamic-statements  >= 0.3.1 && < 0.4
-                    , hasql-notifications       >= 0.2.1.0 && < 0.3
-                    , hasql-pool                >= 0.10 && < 0.11
+                    , hasql-notifications       >= 0.2.1.1 && < 0.3
+                    , hasql-pool                >= 1.0.1 && < 1.1
                     , hasql-transaction         >= 1.0.1 && < 1.1
                     , heredoc                   >= 0.2 && < 0.3
                     , http-types                >= 0.12.2 && < 0.13
@@ -254,7 +254,7 @@ test-suite spec
                     , bytestring        >= 0.10.8 && < 0.13
                     , case-insensitive  >= 1.2 && < 1.3
                     , containers        >= 0.5.7 && < 0.7
-                    , hasql-pool        >= 0.10 && < 0.11
+                    , hasql-pool        >= 1.0.1 && < 1.1
                     , hasql-transaction >= 1.0.1 && < 1.1
                     , heredoc           >= 0.2 && < 0.3
                     , hspec             >= 2.3 && < 2.12

src/PostgREST/AppState.hs

@@ -39,6 +39,7 @@ import qualified Data.Text                  as T (unpack)
 import           Hasql.Connection           (acquire)
 import qualified Hasql.Notifications        as SQL
 import qualified Hasql.Pool                 as SQL
+import qualified Hasql.Pool.Config          as SQL
 import qualified Hasql.Session              as SQL
 import qualified Hasql.Transaction.Sessions as SQL
 import qualified Network.HTTP.Types.Status  as HTTP
@@ -122,7 +123,7 @@ init :: AppConfig -> IO AppState
 init conf@AppConfig{configLogLevel} = do
   loggerState <- Logger.init
   let observer = Logger.observationLogger loggerState configLogLevel
-  pool <- initPool conf
+  pool <- initPool conf observer
   (sock, adminSock) <- initSockets conf
   state' <- initWithPool (sock, adminSock) pool conf loggerState observer
   pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock}
@@ -193,14 +194,16 @@ initSockets AppConfig{..} = do
 
   pure (sock, adminSock)
 
-initPool :: AppConfig -> IO SQL.Pool
-initPool AppConfig{..} =
-  SQL.acquire
-    configDbPoolSize
-    (fromIntegral configDbPoolAcquisitionTimeout)
-    (fromIntegral configDbPoolMaxLifetime)
-    (fromIntegral configDbPoolMaxIdletime)
-    (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
+initPool :: AppConfig -> ObservationHandler -> IO SQL.Pool
+initPool AppConfig{..} observer =
+  SQL.acquire $ SQL.settings
+    [ SQL.size configDbPoolSize
+    , SQL.acquisitionTimeout $ fromIntegral configDbPoolAcquisitionTimeout
+    , SQL.agingTimeout $ fromIntegral configDbPoolMaxLifetime
+    , SQL.idlenessTimeout $ fromIntegral configDbPoolMaxIdletime
+    , SQL.staticConnectionSettings (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
+    , SQL.observationHandler $ observer . HasqlPoolObs
+    ]
 
 -- | Run an action with a database connection.
 usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a)

src/PostgREST/Logger.hs

@@ -81,6 +81,9 @@ observationLogger loggerState logLevel obs = case obs of
   o@(QueryErrorCodeHighObs _) -> do
     when (logLevel >= LogError) $ do
       logWithZTime loggerState $ observationMessage o
+  o@(HasqlPoolObs _) -> do
+    when (logLevel >= LogInfo) $ do
+      logWithZTime loggerState $ observationMessage o
   o ->
     logWithZTime loggerState $ observationMessage o
 

src/PostgREST/Observation.hs

@@ -9,14 +9,15 @@ module PostgREST.Observation
   , ObservationHandler
   ) where
 
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Text            as T
-import qualified Data.Text.Encoding   as T
-import qualified Hasql.Connection     as SQL
-import qualified Hasql.Pool           as SQL
-import qualified Network.Socket       as NS
-import           Numeric              (showFFloat)
-import qualified PostgREST.Error      as Error
+import qualified Data.ByteString.Lazy   as LBS
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as T
+import qualified Hasql.Connection       as SQL
+import qualified Hasql.Pool             as SQL
+import qualified Hasql.Pool.Observation as SQL
+import qualified Network.Socket         as NS
+import           Numeric                (showFFloat)
+import qualified PostgREST.Error        as Error
 
 import Protolude
 import Protolude.Partial (fromJust)
@@ -50,6 +51,7 @@ data Observation
   | QueryRoleSettingsErrorObs SQL.UsageError
   | QueryErrorCodeHighObs SQL.UsageError
   | PoolAcqTimeoutObs SQL.UsageError
+  | HasqlPoolObs SQL.Observation
 
 type ObservationHandler = Observation -> IO ()
 
@@ -111,6 +113,18 @@ observationMessage = \case
      "Config reloaded"
   PoolAcqTimeoutObs usageErr ->
     jsonMessage usageErr
+  HasqlPoolObs (SQL.ConnectionObservation uuid status) ->
+    "Connection " <> show uuid <> (
+      case status of
+        SQL.ConnectingConnectionStatus   -> " is being established"
+        SQL.ReadyForUseConnectionStatus  -> " is available"
+        SQL.InUseConnectionStatus        -> " is used"
+        SQL.TerminatedConnectionStatus reason -> " is terminated due to " <> case reason of
+          SQL.AgingConnectionTerminationReason          -> "max lifetime"
+          SQL.IdlenessConnectionTerminationReason       -> "max idletime"
+          SQL.ReleaseConnectionTerminationReason        -> "release"
+          SQL.NetworkErrorConnectionTerminationReason _ -> "network error" -- usage error is already logged, no need to repeat the same message.
+    )
   where
     showMillis :: Double -> Text
     showMillis x = toS $ showFFloat (Just 1) (x * 1000) ""

test/spec/Main.hs

@@ -1,6 +1,7 @@
 module Main where
 
 import qualified Hasql.Pool                 as P
+import qualified Hasql.Pool.Config          as P
 import qualified Hasql.Transaction.Sessions as HT
 
 import Data.Function (id)
@@ -70,7 +71,13 @@ import qualified Feature.RpcPreRequestGucsSpec
 main :: IO ()
 main = do
   let observer = const $ pure ()
-  pool <- P.acquire 3 10 60 60 $ toUtf8 $ configDbUri testCfg
+  pool <- P.acquire $ P.settings
+    [ P.size 3
+    , P.acquisitionTimeout 10
+    , P.agingTimeout 60
+    , P.idlenessTimeout 60
+    , P.staticConnectionSettings (toUtf8 $ configDbUri testCfg)
+    ]
 
   actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False)