hs-opentelemetry-instrumentation-persistent 0.1.0.2 → 1.0.0.0
raw patch · 6 files changed
+371/−65 lines, 6 filesdep +hs-opentelemetry-instrumentation-persistentdep +hs-opentelemetry-semantic-conventionsdep +hspecdep −clockdep ~hs-opentelemetry-apiPVP ok
version bump matches the API change (PVP)
Dependencies added: hs-opentelemetry-instrumentation-persistent, hs-opentelemetry-semantic-conventions, hspec
Dependencies removed: clock
Dependency ranges changed: hs-opentelemetry-api
API changes (from Hackage documentation)
+ OpenTelemetry.Instrumentation.Persistent: dbSpanName :: Maybe Text -> Maybe Text -> Text
+ OpenTelemetry.Instrumentation.Persistent: extractSqlOperation :: Text -> Maybe Text
+ OpenTelemetry.Instrumentation.Persistent: lookupDbNamespace :: StabilityOpt -> AttributeMap -> Maybe Text
Files
- ChangeLog.md +19/−0
- LICENSE +1/−1
- README.md +3/−1
- hs-opentelemetry-instrumentation-persistent.cabal +34/−14
- src/OpenTelemetry/Instrumentation/Persistent.hs +214/−49
- test/Spec.hs +100/−0
ChangeLog.md view
@@ -1,5 +1,24 @@ # Changelog for hs-opentelemetry-persistent +## Unreleased++## 1.0.0.0 - 2026-05-29++- Internal: `db.transaction.*` attribute keys are now typed `AttributeKey` constants+ (`db.transaction.isolation`, `db.transaction.outcome`,+ `db.transaction.commit_duration_us`, `db.transaction.rollback_duration_us`).+ Attribute names are unchanged.++- **Respect `OTEL_SEMCONV_STABILITY_OPT_IN` for database query attribute.**+ Query text is now emitted as `db.query.text` (stable), `db.statement` (old),+ or both (`database/dup`), controlled by the `databaseOption` setting.+- **Fix: span name now low-cardinality.** Previously used the full SQL string as+ the span name, which is high cardinality and violates OTel naming rules. Now uses+ `{db.operation.name} {db.namespace}` pattern (e.g. `SELECT mydb`). Full SQL text+ remains available in the `db.query.text` / `db.statement` attributes.+- Add `db.operation.name` attribute in stable mode (extracted from first SQL keyword).+- `annotateBasics` emits `db.system.name` (stable) or `db.system` (old) per config.+ ## 0.1.0.2 - Relax `hs-opentelemetry-api` bounds to support 0.3.x
LICENSE view
@@ -1,4 +1,4 @@-Copyright Ian Duncan (c) 2021+Copyright Ian Duncan (c) 2021-2026 All rights reserved.
README.md view
@@ -1,1 +1,3 @@-# hs-opentelemetry-persistent+# hs-opentelemetry-instrumentation-persistent++[](https://hackage.haskell.org/package/hs-opentelemetry-instrumentation-persistent)
hs-opentelemetry-instrumentation-persistent.cabal view
@@ -1,20 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack -name: hs-opentelemetry-instrumentation-persistent-version: 0.1.0.2-description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/persistent#readme>-homepage: https://github.com/iand675/hs-opentelemetry#readme-bug-reports: https://github.com/iand675/hs-opentelemetry/issues-author: Ian Duncan, Jade Lovelace-maintainer: ian@iankduncan.com-copyright: 2024 Ian Duncan, Mercury Technologies-license: BSD3-license-file: LICENSE-build-type: Simple+name: hs-opentelemetry-instrumentation-persistent+version: 1.0.0.0+synopsis: OpenTelemetry instrumentation for the Persistent database library+description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/persistent#readme>+category: OpenTelemetry, Database, Telemetry+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan, Jade Lovelace+maintainer: ian@iankduncan.com+copyright: 2024 Ian Duncan, Mercury Technologies+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md ChangeLog.md@@ -32,8 +34,8 @@ src build-depends: base >=4.7 && <5- , clock- , hs-opentelemetry-api ==0.3.*+ , hs-opentelemetry-api ==1.0.*+ , hs-opentelemetry-semantic-conventions >=1.40 && <2 , mtl , persistent >=2.13.3 , resourcet@@ -41,4 +43,22 @@ , unliftio , unordered-containers , vault+ default-language: Haskell2010++test-suite hs-opentelemetry-persistent-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_hs_opentelemetry_instrumentation_persistent+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , hs-opentelemetry-api ==1.0.*+ , hs-opentelemetry-instrumentation-persistent ==1.0.*+ , hs-opentelemetry-semantic-conventions >=1.40 && <2+ , hspec+ , text+ , unordered-containers default-language: Haskell2010
src/OpenTelemetry/Instrumentation/Persistent.hs view
@@ -1,13 +1,74 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{- |+Module : OpenTelemetry.Instrumentation.Persistent+Copyright : (c) Ian Duncan, 2021-2026+License : BSD-3+Description : Automatic tracing for Persistent database operations+Stability : experimental++= Overview++Instruments database queries made through the @persistent@ library by+hooking into Persistent's internal statement hooks. Every SQL query+generates a span with the query text and connection metadata.++= Quick example++Wrap each 'SqlBackend' as it is handed out from the pool (here using+extensible pool hooks; attribute maps often carry static connection info+such as server address):++@+import Database.Persist.Postgresql (createPostgresqlPool)+import Database.Persist.Sql+ ( defaultSqlPoolHooks+ , runSqlPoolWithExtensibleHooks+ , setAlterBackend+ )+import OpenTelemetry.Instrumentation.Persistent (wrapSqlBackend)++main :: IO ()+main = do+ pool <- createPostgresqlPool connStr poolSize+ runSqlPoolWithExtensibleHooks myAction pool Nothing $+ setAlterBackend defaultSqlPoolHooks $ \conn ->+ wrapSqlBackend mempty conn+@++'wrapSqlBackend' uses the process-global tracer provider; initialize it from+your application (for example 'OpenTelemetry.Trace.withTracerProvider' from+@hs-opentelemetry-sdk@). Use 'wrapSqlBackend'' when you hold a specific+'TracerProvider'.++= What gets traced++Each database operation creates a span with:++* Span name: the SQL statement (truncated)+* @db.system@, @db.statement@+* @db.operation.name@ when detectable+* Span kind: @Client@++Note: source-location (@code.*@) attributes are intentionally not captured+because the spans originate from Persistent's internal hooks, not from your+application code.+-} module OpenTelemetry.Instrumentation.Persistent ( wrapSqlBackend, wrapSqlBackend',++ -- * Span naming helpers (exported for testing)+ extractSqlOperation,+ dbSpanName,+ lookupDbNamespace, ) where import Control.Monad@@ -20,18 +81,23 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vault.Strict as Vault-import Database.Persist.Sql (IsolationLevel (..), SqlReadBackend, SqlWriteBackend, Statement (..))+import Data.Word (Word64)+import Database.Persist.Sql (SqlReadBackend, SqlWriteBackend, Statement (..)) import Database.Persist.SqlBackend (MkSqlBackendArgs (connRDBMS), emptySqlBackendHooks, getConnVault, getRDBMS, modifyConnVault, setConnHooks) import Database.Persist.SqlBackend.Internal-import OpenTelemetry.Attributes (Attributes)+import Database.Persist.SqlBackend.Internal.IsolationLevel (IsolationLevel (..))+import OpenTelemetry.Attributes (Attribute (..), Attributes)+import qualified OpenTelemetry.Attributes as A+import OpenTelemetry.Attributes.Key (AttributeKey (..), unkey) import OpenTelemetry.Attributes.Map (AttributeMap) import OpenTelemetry.Common import OpenTelemetry.Context import OpenTelemetry.Context.ThreadLocal (adjustContext, getContext)-import OpenTelemetry.Resource+import OpenTelemetry.Metric.Core+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.SemanticsConfig import OpenTelemetry.Trace.Core import OpenTelemetry.Trace.Monad (MonadTracer (..))-import System.Clock import System.IO.Unsafe (unsafePerformIO) import UnliftIO.Exception @@ -56,6 +122,26 @@ getTracer = lift OpenTelemetry.Trace.Monad.getTracer +-- | @db.transaction.isolation@ – isolation level used for the transaction.+dbTransactionIsolation :: AttributeKey Text+dbTransactionIsolation = AttributeKey "db.transaction.isolation"+++-- | @db.transaction.outcome@ – @\"committed\"@ or @\"rolled back\"@.+dbTransactionOutcome :: AttributeKey Text+dbTransactionOutcome = AttributeKey "db.transaction.outcome"+++-- | @db.transaction.commit_duration_us@ – microseconds spent in the commit call.+dbTransactionCommitDurationUs :: AttributeKey Int+dbTransactionCommitDurationUs = AttributeKey "db.transaction.commit_duration_us"+++-- | @db.transaction.rollback_duration_us@ – microseconds spent in the rollback call.+dbTransactionRollbackDurationUs :: AttributeKey Int+dbTransactionRollbackDurationUs = AttributeKey "db.transaction.rollback_duration_us"++ originalConnectionKey :: Vault.Key SqlBackend originalConnectionKey = unsafePerformIO Vault.newKey {-# NOINLINE originalConnectionKey #-}@@ -69,11 +155,6 @@ lookupOriginalConnection = Vault.lookup originalConnectionKey . getConnVault -connectionLevelAttributesKey :: Vault.Key AttributeMap-connectionLevelAttributesKey = unsafePerformIO Vault.newKey-{-# NOINLINE connectionLevelAttributesKey #-}-- {- | Wrap a 'SqlBackend' with appropriate tracing context and attributes so that queries are tracked appropriately in the tracing hierarchy. -}@@ -107,8 +188,60 @@ -} connParentSpan <- liftIO $ newIORef Nothing connSpanInFlight <- liftIO $ newIORef Nothing- -- TODO add schema to tracerOptions?+ dbSemOpt <- liftIO $ databaseOption <$> getSemanticsOptions+ mp <- liftIO getGlobalMeterProvider+ meter <- liftIO $ getMeter mp "hs-opentelemetry-instrumentation-persistent"+ dbDurHistogram <-+ liftIO $+ meterCreateHistogram+ meter+ "db.client.operation.duration"+ (Just "s")+ (Just "Duration of database client operations")+ defaultAdvisoryParameters+ { advisoryExplicitBucketBoundaries =+ Just [0.001, 0.005, 0.01, 0.025, 0.05, 0.075, 0.1, 0.25, 0.5, 0.75, 1.0, 2.5, 5.0, 10.0]+ } let t = makeTracer tp $detectInstrumentationLibrary tracerOptions+ dbNamespace = lookupDbNamespace dbSemOpt attrs+ rdbms = getRDBMS conn+ dbSystemAttrs = case dbSemOpt of+ Stable -> H.fromList [(unkey SC.db_system_name, toAttribute rdbms)]+ StableAndOld ->+ H.fromList+ [ (unkey SC.db_system_name, toAttribute rdbms)+ , (unkey SC.db_system, toAttribute rdbms)+ ]+ Old -> H.fromList [(unkey SC.db_system, toAttribute rdbms)]+ queryAttrs sql =+ let v = toAttribute sql+ opAttrs = case extractSqlOperation sql of+ Just op -> case dbSemOpt of+ Stable -> [(unkey SC.db_operation_name, toAttribute op)]+ StableAndOld -> [(unkey SC.db_operation_name, toAttribute op)]+ Old -> []+ Nothing -> []+ in H.union (H.fromList opAttrs) $ case dbSemOpt of+ Stable -> H.insert (unkey SC.db_query_text) v attrs+ StableAndOld -> H.insert (unkey SC.db_query_text) v $ H.insert (unkey SC.db_statement) v attrs+ Old -> H.insert (unkey SC.db_statement) v attrs+ spanName sql = dbSpanName (extractSqlOperation sql) dbNamespace+ metricAttrs sql =+ let base = A.addAttribute A.defaultAttributeLimits A.emptyAttributes (unkey SC.db_system_name) rdbms+ withOp = case extractSqlOperation sql of+ Just op -> A.addAttribute A.defaultAttributeLimits base (unkey SC.db_operation_name) op+ Nothing -> base+ in case dbNamespace of+ Just ns -> A.addAttribute A.defaultAttributeLimits withOp (unkey SC.db_namespace) ns+ Nothing -> withOp+ recordDbDuration sql startNs = do+ Timestamp endNs <- getTimestamp+ let !durationSec = fromIntegral @Word64 @Double (endNs - startNs) / 1_000_000_000+ histogramRecord dbDurHistogram durationSec (metricAttrs sql)+ -- We use createSpanWithoutCallStack/inSpan'' because these spans are created+ -- from persistent's internal hooks, not from user code. Using the callstack+ -- variants would capture this instrumentation library's source location,+ -- not the user's application code callsite. let hooks = emptySqlBackendHooks { hookGetStatement = \conn sql stmt -> do@@ -117,35 +250,40 @@ { stmtQuery = \ps -> do ctxt <- getContext let spanCreator = do+ Timestamp sNs <- getTimestamp s <-- createSpan+ createSpanWithoutCallStack t ctxt- sql- (defaultSpanArguments {kind = Client, attributes = H.insert "db.statement" (toAttribute sql) attrs})+ (spanName sql)+ (defaultSpanArguments {kind = Client, attributes = queryAttrs sql}) adjustContext (insertSpan s)- pure (lookupSpan ctxt, s)- spanCleanup (parent, s) = do+ pure (lookupSpan ctxt, s, sNs)+ spanCleanup (parent, s, sNs) = do+ recordDbDuration sql sNs s `endSpan` Nothing adjustContext $ \ctx -> maybe (removeSpan ctx) (`insertSpan` ctx) parent - (p, child) <- mkAcquire spanCreator spanCleanup+ (_p, child, _startNs) <- mkAcquire spanCreator spanCleanup - annotateBasics child conn+ addAttributes child dbSystemAttrs case stmtQuery stmt ps of Acquire stmtQueryAcquireF -> Acquire $ \f -> handleAny ( \(SomeException err) -> do- recordException child [("exception.escaped", toAttribute True)] Nothing err+ recordException child [(unkey SC.exception_escaped, toAttribute True)] Nothing err endSpan child Nothing throwIO err ) (stmtQueryAcquireF f) , stmtExecute = \ps -> do- inSpan' t sql (defaultSpanArguments {kind = Client, attributes = H.insert "db.statement" (toAttribute sql) attrs}) $ \s -> do- annotateBasics s conn+ Timestamp startNs <- getTimestamp+ result <- inSpan'' t (spanName sql) (defaultSpanArguments {kind = Client, attributes = queryAttrs sql}) $ \s -> do+ addAttributes s dbSystemAttrs stmtExecute stmt ps+ recordDbDuration sql startNs+ pure result , stmtReset = stmtReset stmt , stmtFinalize = stmtFinalize stmt }@@ -156,36 +294,38 @@ { connHooks = hooks , connBegin = \f mIso -> do ctxt <- getContext- s <- createSpan t ctxt "transaction" (defaultSpanArguments {kind = Client, attributes = attrs})- annotateBasics s conn+ s <- createSpanWithoutCallStack t ctxt (dbSpanName (Just "TRANSACTION") dbNamespace) (defaultSpanArguments {kind = Client, attributes = attrs})+ let isoAttrs = case mIso of+ Nothing -> H.empty+ Just iso ->+ H.singleton (unkey dbTransactionIsolation) $ toAttribute $ case iso of+ ReadUncommitted -> "read uncommitted" :: Text+ ReadCommitted -> "read committed"+ RepeatableRead -> "repeatable read"+ Serializable -> "serializable"+ addAttributes s (dbSystemAttrs `H.union` isoAttrs) writeIORef connSpanInFlight (Just s) writeIORef connParentSpan (lookupSpan ctxt) adjustContext (insertSpan s)- case mIso of- Nothing -> pure ()- Just iso -> addAttribute s "db.transaction.isolation" $ case iso of- ReadUncommitted -> "read uncommitted" :: Text- ReadCommitted -> "read committed"- RepeatableRead -> "repeatable read"- Serializable -> "serializable" connBegin conn f mIso , connCommit = \f -> do spanInFlight <- readIORef connSpanInFlight parentSpan <- readIORef connParentSpan let act = do- (Timestamp tsStart) <- getTimestamp+ Timestamp nsStart <- getTimestamp result <- tryAny $ connCommit conn f- (Timestamp tsEnd) <- getTimestamp+ Timestamp nsEnd <- getTimestamp forM_ spanInFlight $ \s -> do+ let !durationMicros = fromIntegral @Word64 @Int ((nsEnd - nsStart) `div` 1000) addAttributes s- [ ("db.transaction.outcome", toAttribute ("committed" :: Text))- , ("db.transaction.commit_duration_ns", toAttribute $ fromIntegral @Integer @Int $ toNanoSecs (diffTimeSpec tsStart tsEnd) `div` 1000)+ [ (unkey dbTransactionOutcome, toAttribute ("committed" :: Text))+ , (unkey dbTransactionCommitDurationUs, toAttribute durationMicros) ] endSpan s Nothing case result of Left (SomeException err) -> do- recordException s [("exception.escaped", toAttribute True)] Nothing err+ recordException s [(unkey SC.exception_escaped, toAttribute True)] Nothing err throwIO err Right _ -> pure () act `finally` do@@ -196,37 +336,62 @@ spanInFlight <- readIORef connSpanInFlight parentSpan <- readIORef connParentSpan let act = do- (Timestamp tsStart) <- getTimestamp+ Timestamp nsStart <- getTimestamp result <- tryAny $ connRollback conn f- e@(Timestamp tsEnd) <- getTimestamp+ Timestamp nsEnd <- getTimestamp forM_ spanInFlight $ \s -> do+ let !durationMicros = fromIntegral @Word64 @Int ((nsEnd - nsStart) `div` 1000) addAttributes s- [ ("db.transaction.outcome", toAttribute ("rolled back" :: Text))- , ("db.transaction.commit_duration_microseconds", toAttribute $ fromIntegral @Integer @Int $ toNanoSecs (diffTimeSpec tsStart tsEnd `div` 1000))+ [ (unkey dbTransactionOutcome, toAttribute ("rolled back" :: Text))+ , (unkey dbTransactionRollbackDurationUs, toAttribute durationMicros) ]- endSpan s (Just e)+ endSpan s Nothing case result of Left (SomeException err) -> do- recordException s [("exception.escaped", toAttribute True)] Nothing err+ recordException s [(unkey SC.exception_escaped, toAttribute True)] Nothing err throwIO err Right _ -> pure () act `finally` do adjustContext $ \ctx -> maybe (removeSpan ctx) (`insertSpan` ctx) parentSpan forM_ spanInFlight $ \s -> endSpan s Nothing- , -- TODO: This doesn't work when we wrap the connections for the pool.+ , -- Known limitation: connClose spans are not emitted when+ -- persistent's connection pool wraps the underlying connection,+ -- since the pool manages connection lifecycle independently. connClose = do- inSpan' t "close connection" (defaultSpanArguments {kind = Client, attributes = attrs}) $ \s -> do- annotateBasics s conn+ inSpan'' t (dbSpanName (Just "CLOSE") dbNamespace) (defaultSpanArguments {kind = Client, attributes = attrs}) $ \s -> do+ addAttributes s dbSystemAttrs connClose conn } pure $ insertOriginalConnection conn' conn -annotateBasics :: (MonadIO m) => Span -> SqlBackend -> m ()-annotateBasics span conn = do- addAttributes- span- [ ("db.system", toAttribute $ getRDBMS conn)- ]+extractSqlOperation :: Text -> Maybe Text+extractSqlOperation sql =+ let trimmed = T.dropWhile (\c -> c == ' ' || c == '\n' || c == '\r' || c == '\t') sql+ keyword = T.takeWhile (\c -> c /= ' ' && c /= '\n' && c /= '\r' && c /= '\t' && c /= '(') trimmed+ in if T.null keyword+ then Nothing+ else Just $ T.toUpper keyword+++lookupDbNamespace :: StabilityOpt -> AttributeMap -> Maybe Text+lookupDbNamespace opt attrMap =+ let tryKey k = case H.lookup k attrMap of+ Just (AttributeValue (TextAttribute v)) -> Just v+ _ -> Nothing+ in case opt of+ Stable -> tryKey (unkey SC.db_namespace)+ StableAndOld -> tryKey (unkey SC.db_namespace) <|> tryKey (unkey SC.db_name)+ Old -> tryKey (unkey SC.db_name)+ where+ Nothing <|> b = b+ a <|> _ = a+++dbSpanName :: Maybe Text -> Maybe Text -> Text+dbSpanName (Just op) (Just ns) = op <> " " <> ns+dbSpanName (Just op) Nothing = op+dbSpanName Nothing (Just ns) = ns+dbSpanName Nothing Nothing = "DB"
+ test/Spec.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.HashMap.Strict as H+import OpenTelemetry.Attributes (Attribute (..))+import OpenTelemetry.Attributes.Attribute (PrimitiveAttribute (..))+import OpenTelemetry.Attributes.Key (unkey)+import OpenTelemetry.Instrumentation.Persistent+import qualified OpenTelemetry.SemanticConventions as SC+import OpenTelemetry.SemanticsConfig (StabilityOpt (..))+import Test.Hspec+++main :: IO ()+main = hspec spec+++spec :: Spec+spec = do+ describe "extractSqlOperation" $ do+ it "extracts SELECT" $+ extractSqlOperation "SELECT * FROM users" `shouldBe` Just "SELECT"++ it "extracts INSERT" $+ extractSqlOperation "INSERT INTO users (name) VALUES (?)" `shouldBe` Just "INSERT"++ it "extracts UPDATE" $+ extractSqlOperation "UPDATE users SET name = ? WHERE id = ?" `shouldBe` Just "UPDATE"++ it "extracts DELETE" $+ extractSqlOperation "DELETE FROM users WHERE id = ?" `shouldBe` Just "DELETE"++ it "handles leading whitespace" $+ extractSqlOperation " \n\t SELECT 1" `shouldBe` Just "SELECT"++ it "returns Nothing for bare parenthesized subquery" $+ extractSqlOperation "(SELECT 1)" `shouldBe` Nothing++ it "uppercases mixed-case keywords" $+ extractSqlOperation "select * from t" `shouldBe` Just "SELECT"++ it "returns Nothing for empty string" $+ extractSqlOperation "" `shouldBe` Nothing++ it "returns Nothing for whitespace only" $+ extractSqlOperation " \n\t " `shouldBe` Nothing++ it "extracts WITH (CTE)" $+ extractSqlOperation "WITH cte AS (SELECT 1) SELECT * FROM cte" `shouldBe` Just "WITH"++ it "extracts BEGIN" $+ extractSqlOperation "BEGIN" `shouldBe` Just "BEGIN"++ it "extracts COMMIT" $+ extractSqlOperation "COMMIT" `shouldBe` Just "COMMIT"++ describe "dbSpanName" $ do+ it "combines operation and namespace" $+ dbSpanName (Just "SELECT") (Just "mydb") `shouldBe` "SELECT mydb"++ it "uses operation alone when no namespace" $+ dbSpanName (Just "INSERT") Nothing `shouldBe` "INSERT"++ it "uses namespace alone when no operation" $+ dbSpanName Nothing (Just "mydb") `shouldBe` "mydb"++ it "falls back to DB when both missing" $+ dbSpanName Nothing Nothing `shouldBe` "DB"++ describe "lookupDbNamespace" $ do+ let stableAttrs = H.fromList [(unkey SC.db_namespace, AttributeValue (TextAttribute "stabledb"))]+ oldAttrs = H.fromList [(unkey SC.db_name, AttributeValue (TextAttribute "olddb"))]+ bothAttrs =+ H.fromList+ [ (unkey SC.db_namespace, AttributeValue (TextAttribute "stabledb"))+ , (unkey SC.db_name, AttributeValue (TextAttribute "olddb"))+ ]+ emptyAttrs = H.empty++ it "reads db.namespace in Stable mode" $+ lookupDbNamespace Stable stableAttrs `shouldBe` Just "stabledb"++ it "returns Nothing for db.name in Stable mode" $+ lookupDbNamespace Stable oldAttrs `shouldBe` Nothing++ it "reads db.namespace in StableAndOld mode (prefers stable)" $+ lookupDbNamespace StableAndOld bothAttrs `shouldBe` Just "stabledb"++ it "falls back to db.name in StableAndOld mode" $+ lookupDbNamespace StableAndOld oldAttrs `shouldBe` Just "olddb"++ it "reads db.name in Old mode" $+ lookupDbNamespace Old oldAttrs `shouldBe` Just "olddb"++ it "returns Nothing for db.namespace in Old mode" $+ lookupDbNamespace Old stableAttrs `shouldBe` Nothing++ it "returns Nothing when attrs empty" $+ lookupDbNamespace Stable emptyAttrs `shouldBe` Nothing