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

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) ""