Merge pull request #45 from nikita-volkov/extend-ready-for-use

Extend the ReadyForUse connection status in observations with more details

CHANGELOG.md

@@ -1,3 +1,7 @@
+# 1.1
+
+- `ReadyForUseConnectionStatus` got extended with the `ConnectionReadyForUseReason` details
+
 # 1
 
 - Optional observability event stream added. Provides a flexible mechanism for monitoring the healthiness of the pool via logs and metrics.

diagrams/observation-status-model.mmd

@@ -0,0 +1,10 @@
+stateDiagram-v2
+
+[*] --> Connecting
+Connecting --> ReadyForUse
+ReadyForUse --> InUse
+InUse --> ReadyForUse
+Connecting --> Terminated
+ReadyForUse --> Terminated
+InUse --> Terminated
+Terminated --> [*]

hasql-pool.cabal

@@ -10,7 +10,12 @@ maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>
 copyright: (c) 2015, Nikita Volkov
 license: MIT
 license-file: LICENSE
-extra-source-files: CHANGELOG.md
+extra-source-files:
+  CHANGELOG.md
+  diagrams-output/*.png
+
+extra-doc-files:
+  diagrams-output/*.png
 
 source-repository head
   type: git
@@ -41,6 +46,8 @@ common base-settings
     MagicHash
     MultiParamTypeClasses
     MultiWayIf
+    NoImplicitPrelude
+    NoMonomorphismRestriction
     NumericUnderscores
     OverloadedStrings
     ParallelListComp
@@ -57,8 +64,6 @@ common base-settings
     TypeFamilies
     TypeOperators
     UnboxedTuples
-    NoImplicitPrelude
-    NoMonomorphismRestriction
 
   default-language: Haskell2010
 

src/library/exposed/Hasql/Pool.hs

@@ -170,7 +170,7 @@ use Pool {..} sess = do
           atomically $ modifyTVar' poolCapacity succ
           return $ Left $ ConnectionUsageError connErr
         Right connection -> do
-          poolObserver (ConnectionObservation id ReadyForUseConnectionStatus)
+          poolObserver (ConnectionObservation id (ReadyForUseConnectionStatus EstablishedConnectionReadyForUseReason))
           onLiveConn reuseVar (Entry connection now now id)
 
     onConn reuseVar entry = do
@@ -205,11 +205,11 @@ use Pool {..} sess = do
             return $ Left $ SessionUsageError err
           _ -> do
             returnConn
-            poolObserver (ConnectionObservation (entryId entry) ReadyForUseConnectionStatus)
+            poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus (SessionFailedConnectionReadyForUseReason err)))
             return $ Left $ SessionUsageError err
         Right (Right res) -> do
           returnConn
-          poolObserver (ConnectionObservation (entryId entry) ReadyForUseConnectionStatus)
+          poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus SessionSucceededConnectionReadyForUseReason))
           return $ Right res
       where
         returnConn =

src/library/exposed/Hasql/Pool/Observation.hs

@@ -5,6 +5,7 @@
 module Hasql.Pool.Observation where
 
 import Hasql.Pool.Prelude
+import qualified Hasql.Session as Hasql
 
 -- | An observation of a change of the state of a pool.
 data Observation
@@ -18,13 +19,15 @@ data Observation
   deriving (Show, Eq)
 
 -- | Status of a connection.
+--
+-- <<diagrams-output/observation-status-model.png>>
 data ConnectionStatus
   = -- | Connection is being established.
     --
     -- This is the initial status of every connection.
     ConnectingConnectionStatus
   | -- | Connection is established and not occupied.
-    ReadyForUseConnectionStatus
+    ReadyForUseConnectionStatus ConnectionReadyForUseReason
   | -- | Is being used by some session.
     --
     -- After it's done the status will transition to 'ReadyForUseConnectionStatus' or 'TerminatedConnectionStatus'.
@@ -33,6 +36,15 @@ data ConnectionStatus
     TerminatedConnectionStatus ConnectionTerminationReason
   deriving (Show, Eq)
 
+data ConnectionReadyForUseReason
+  = -- | Connection just got established.
+    EstablishedConnectionReadyForUseReason
+  | -- | Session execution ended with a failure that does not require a connection reset.
+    SessionFailedConnectionReadyForUseReason Hasql.QueryError
+  | -- | Session execution ended with success.
+    SessionSucceededConnectionReadyForUseReason
+  deriving (Show, Eq)
+
 -- | Explanation of why a connection was terminated.
 data ConnectionTerminationReason
   = -- | The age timeout of the connection has passed.