{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{- |
[New HTTP semantic conventions have been declared stable.](https://opentelemetry.io/blog/2023/http-conventions-declared-stable/#migration-plan) Opt-in by setting the environment variable OTEL_SEMCONV_STABILITY_OPT_IN to
- "http" - to use the stable conventions
- "http/dup" - to emit both the old and the stable conventions
Otherwise, the old conventions will be used. The stable conventions will replace the old conventions in the next major release of this library.
-}
module OpenTelemetry.Instrumentation.PostgresqlSimple (
staticConnectionAttributes,
-- * Queries that return results
query,
query_,
-- ** Queries taking parser as argument
queryWith,
queryWith_,
-- * Queries that stream results
fold,
foldWithOptions,
fold_,
foldWithOptions_,
forEach,
forEach_,
returning,
-- ** Queries that stream results taking a parser as an argument
foldWith,
foldWithOptionsAndParser,
foldWith_,
foldWithOptionsAndParser_,
forEachWith,
forEachWith_,
returningWith,
-- * Statements that do not return results
execute,
execute_,
executeMany,
-- * Reexported functions
module X,
-- * Utility functions
pgsSpan,
) where
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import qualified Data.ByteString.Char8 as C
import qualified Data.HashMap.Strict as H
import Data.IP
import Data.Int (Int64)
import Data.List
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Database.PostgreSQL.Simple as X hiding (
execute,
executeMany,
execute_,
fold,
foldWith,
foldWithOptions,
foldWithOptionsAndParser,
foldWithOptionsAndParser_,
foldWithOptions_,
foldWith_,
fold_,
forEach,
forEachWith,
forEachWith_,
forEach_,
query,
queryWith,
queryWith_,
query_,
returning,
returningWith,
)
import qualified Database.PostgreSQL.Simple as Simple
import qualified Database.PostgreSQL.Simple.FromRow as Simple
import Database.PostgreSQL.Simple.Internal (
Connection (Connection, connectionHandle),
withConnection,
)
import GHC.Stack
import OpenTelemetry.Resource ((.=), (.=?))
import OpenTelemetry.SemanticsConfig
import OpenTelemetry.Trace.Core as TC
import OpenTelemetry.Trace.Monad
import Text.Read (readMaybe)
import UnliftIO
-- | Get attributes that can be attached to a span denoting some database action
staticConnectionAttributes :: (HasCallStack, MonadIO m) => Connection -> m (H.HashMap T.Text Attribute)
staticConnectionAttributes Connection {connectionHandle} = liftIO $ do
(mDb, mUser, mHost, mPort) <- withMVar connectionHandle $ \pqConn -> do
(,,,)
<$> LibPQ.db pqConn
<*> LibPQ.user pqConn
<*> LibPQ.host pqConn
<*> LibPQ.port pqConn
let stableMaybeAttributes =
[ "db.system" .= toAttribute ("postgresql" :: T.Text)
, "db.user" .=? (TE.decodeUtf8 <$> mUser)
, "db.name" .=? (TE.decodeUtf8 <$> mDb)
, "server.port"
.=? ( do
port <- TE.decodeUtf8 <$> mPort
(readMaybe $ T.unpack port) :: Maybe Int
)
, case (readMaybe . C.unpack) =<< mHost of
Nothing -> "server.address" .=? (TE.decodeUtf8 <$> mHost)
Just (IPv4 ipv4) -> "server.address" .= T.pack (show ipv4)
Just (IPv6 ipv6) -> "server.address" .= T.pack (show ipv6)
]
oldMaybeAttributes =
[ "db.system" .= toAttribute ("postgresql" :: T.Text)
, "db.user" .=? (TE.decodeUtf8 <$> mUser)
, "db.name" .=? (TE.decodeUtf8 <$> mDb)
, "net.peer.port"
.=? ( do
port <- TE.decodeUtf8 <$> mPort
(readMaybe $ T.unpack port) :: Maybe Int
)
, case (readMaybe . C.unpack) =<< mHost of
Nothing -> "net.peer.name" .=? (TE.decodeUtf8 <$> mHost)
Just (IPv4 ipv4) -> "net.peer.ip" .= T.pack (show ipv4)
Just (IPv6 ipv6) -> "net.peer.ip" .= T.pack (show ipv6)
]
semanticsOptions <- getSemanticsOptions
pure $
H.fromList $
catMaybes $
case httpOption semanticsOptions of
Stable -> stableMaybeAttributes
StableAndOld -> stableMaybeAttributes `union` oldMaybeAttributes
Old -> oldMaybeAttributes
-- | Function to help with wrapping functions in postgresql-simple
pgsSpan :: HasCallStack => Connection -> C.ByteString -> IO a -> IO a
pgsSpan conn statement f = do
connAttr <- staticConnectionAttributes conn
dbName <- maybe "unknown db" TE.decodeUtf8 <$> withConnection conn LibPQ.db
let callAttr = H.fromList [("db.statement", toAttribute $ TE.decodeUtf8 statement)]
attrs = connAttr <> callAttr
spanArgs = SpanArguments Client attrs [] Nothing
tracerProvider <- getGlobalTracerProvider
let tracer = makeTracer tracerProvider $detectInstrumentationLibrary tracerOptions
TC.inSpan tracer dbName spanArgs f
-- | Instrumented version of 'Simple.query'
query :: (HasCallStack, MonadIO m, ToRow q, FromRow r) => Connection -> Query -> q -> m [r]
query = queryWith Simple.fromRow
-- | Instrumented version of 'Simple.query_'
query_ :: (HasCallStack, MonadIO m, FromRow r) => Connection -> Query -> m [r]
query_ = queryWith_ Simple.fromRow
-- | Instrumented version of 'Simple.queryWith'
queryWith :: (HasCallStack, MonadIO m, ToRow q) => Simple.RowParser r -> Connection -> Query -> q -> m [r]
queryWith parser conn template qs = liftIO $ do
statement <- formatQuery conn template qs
pgsSpan conn statement $ Simple.queryWith parser conn template qs
-- | Instrumented version of 'Simple.queryWith_'
queryWith_ :: MonadIO m => Simple.RowParser r -> Connection -> Query -> m [r]
queryWith_ parser conn query = liftIO $ do
statement <- formatQuery conn query ()
pgsSpan conn statement $ Simple.queryWith_ parser conn query
-- | Instrumented version of 'Simple.fold'
fold :: (HasCallStack, MonadUnliftIO m, FromRow row, ToRow params) => Connection -> Query -> params -> a -> (a -> row -> m a) -> m a
fold = foldWithOptionsAndParser Simple.defaultFoldOptions Simple.fromRow
-- | Instrumented version of 'Simple.foldWith'
foldWith :: (HasCallStack, MonadUnliftIO m, ToRow params) => Simple.RowParser row -> Connection -> Query -> params -> a -> (a -> row -> m a) -> m a
foldWith = foldWithOptionsAndParser Simple.defaultFoldOptions
-- | Instrumented version of 'Simple.foldWithOptions'
foldWithOptions :: (HasCallStack, MonadUnliftIO m, FromRow row, ToRow params) => FoldOptions -> Connection -> Query -> params -> a -> (a -> row -> m a) -> m a
foldWithOptions opts = foldWithOptionsAndParser opts Simple.fromRow
-- | Instrumented version of 'Simple.foldWithOptionsAndParser'
foldWithOptionsAndParser :: (HasCallStack, MonadUnliftIO m, ToRow params) => FoldOptions -> Simple.RowParser row -> Connection -> Query -> params -> a -> (a -> row -> m a) -> m a
foldWithOptionsAndParser opts parser conn template qs a f = withRunInIO $ \runInIO -> do
statement <- formatQuery conn template qs
pgsSpan conn statement $ Simple.foldWithOptionsAndParser opts parser conn template qs a (\a' r -> runInIO (f a' r))
-- | Instrumented version of 'Simple.fold_'
fold_ :: (HasCallStack, MonadUnliftIO m, FromRow r) => Connection -> Query -> a -> (a -> r -> m a) -> m a
fold_ = foldWithOptionsAndParser_ Simple.defaultFoldOptions Simple.fromRow
-- | Instrumented version of 'Simple.foldWith_'
foldWith_ :: MonadUnliftIO m => Simple.RowParser r -> Connection -> Query -> a -> (a -> r -> m a) -> m a
foldWith_ = foldWithOptionsAndParser_ Simple.defaultFoldOptions
-- | Instrumented version of 'Simple.foldWithOptions_'
foldWithOptions_ :: (HasCallStack, MonadUnliftIO m, FromRow r) => FoldOptions -> Connection -> Query -> a -> (a -> r -> m a) -> m a
foldWithOptions_ opts = foldWithOptionsAndParser_ opts Simple.fromRow
-- | Instrumented version of 'Simple.foldWithOptionsAndParser_'
foldWithOptionsAndParser_ :: MonadUnliftIO m => FoldOptions -> Simple.RowParser r -> Connection -> Query -> a -> (a -> r -> m a) -> m a
foldWithOptionsAndParser_ opts parser conn q a f = withRunInIO $ \runInIO -> do
statement <- formatQuery conn q ()
pgsSpan conn statement $ Simple.foldWithOptionsAndParser_ opts parser conn q a (\a' r -> runInIO (f a' r))
{- | Instrumented version of 'Simple.forEach'
forEach :: (HasCallStack, MonadUnliftIO m, ToRow q, FromRow r) => Connection -> Query -> q -> (r -> m ()) -> m ()
-}
forEach conn template qs f = forEachWith Simple.fromRow
{-# INLINE forEach #-}
-- | Instrumented version of 'Simple.forEachWith'
forEachWith :: (HasCallStack, MonadUnliftIO m, ToRow q) => Simple.RowParser r -> Connection -> Query -> q -> (r -> m ()) -> m ()
forEachWith parser conn template qs = foldWith parser conn template qs () . const
{-# INLINE forEachWith #-}
-- | Instrumented version of 'Simple.forEach_'
forEach_ :: (HasCallStack, MonadUnliftIO m, FromRow r) => Connection -> Query -> (r -> m ()) -> m ()
forEach_ = forEachWith_ Simple.fromRow
{-# INLINE forEach_ #-}
-- | Instrumented version of 'Simple.forEachWith_'
forEachWith_ :: MonadUnliftIO m => Simple.RowParser r -> Connection -> Query -> (r -> m ()) -> m ()
forEachWith_ parser conn template = foldWith_ parser conn template () . const
{-# INLINE forEachWith_ #-}
-- | Instrumented version of 'Simple.returning'
returning :: (HasCallStack, MonadIO m, ToRow q, FromRow r) => Connection -> Query -> [q] -> m [r]
returning = returningWith Simple.fromRow
-- | A version of 'returning' taking parser as argument
returningWith :: (HasCallStack, MonadIO m, ToRow q) => Simple.RowParser r -> Connection -> Query -> [q] -> m [r]
returningWith _parser _conn _q [] = pure []
returningWith parser conn q qs = liftIO $ do
statement <- formatMany conn q qs
pgsSpan conn statement $ Simple.returningWith parser conn q qs
-- | Instrumented version of 'Simple.execute'
execute :: (HasCallStack, MonadIO m, ToRow q) => Connection -> Query -> q -> m Int64
execute conn template qs = liftIO $ do
statement <- formatQuery conn template qs
pgsSpan conn statement $ Simple.execute conn template qs
-- | Instrumented version of 'Simple.execute_'
execute_ :: MonadIO m => Connection -> Query -> m Int64
execute_ conn q = liftIO $ do
statement <- formatQuery conn q ()
pgsSpan conn statement $ Simple.execute_ conn q
-- | Instrumented version of 'Simple.executeMany'
executeMany :: (HasCallStack, MonadIO m, ToRow q) => Connection -> Query -> [q] -> m Int64
executeMany _conn _q [] = pure 0
executeMany conn q qs = liftIO $ do
statement <- formatMany conn q qs
pgsSpan conn statement $ Simple.executeMany conn q qs