From 6e09e304169d7aaeae914d52ee9bca2ef02f1f01 Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Fri, 15 Mar 2024 14:19:14 +0900 Subject: [PATCH] Hook version of hedis instrumentation --- api/src/OpenTelemetry/Attributes/Key.hs | 4 +- cabal.project | 6 + docker-compose.yaml | 5 + hie.yaml | 3 + ...-opentelemetry-instrumentation-hedis.cabal | 25 +- .../OpenTelemetry/Instrumentation/Hedis.hs | 721 ++++-------------- .../Instrumentation/Hedis/Internal/Wrapper.hs | 45 -- stack-ghc-9.2.yaml | 2 + stack-ghc-9.2.yaml.lock | 11 + stack.yaml | 3 + stack.yaml.lock | 11 + 11 files changed, 202 insertions(+), 634 deletions(-) delete mode 100644 instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis/Internal/Wrapper.hs diff --git a/api/src/OpenTelemetry/Attributes/Key.hs b/api/src/OpenTelemetry/Attributes/Key.hs index 6f2c7f25..061540b6 100644 --- a/api/src/OpenTelemetry/Attributes/Key.hs +++ b/api/src/OpenTelemetry/Attributes/Key.hs @@ -5,10 +5,12 @@ Module : OpenTelemetry.Attributes.Key Copyright : (c) Kazuki Okamoto (岡本和樹), 2023 License : BSD-3 -Description : Key-value pair metadata used in 'OpenTelemetry.Trace.Span's, 'OpenTelemetry.Trace.Link's, and 'OpenTelemetry.Trace.Event's +Description : Key-value pair keys used in 'OpenTelemetry.Trace.Span's, 'OpenTelemetry.Trace.Link's, and 'OpenTelemetry.Trace.Event's Maintainer : Kazuki Okamoto (岡本和樹) Stability : experimental Portability : non-portable (GHC extensions) + +This module is based on OpenTelemetry Semantic Conventions 1.24.0. -} module OpenTelemetry.Attributes.Key ( Key (..), diff --git a/cabal.project b/cabal.project index 93e01593..dd3cb86e 100644 --- a/cabal.project +++ b/cabal.project @@ -6,6 +6,7 @@ packages: , examples/aws-s3 , examples/grpc-echo , examples/hdbc-mysql + , examples/hedis , examples/http-server , examples/yesod-minimal , examples/yesod-subsite @@ -74,6 +75,11 @@ source-repository-package location: https://github.com/herp-inc/herp-logger tag: v0.3 +source-repository-package + type: git + location: https://github.com/kakkun61/hedis + tag: 60313d0c76392f7a00467d40c40fa5e851e0ce11 + allow-newer: http-api-data:base , postgresql-simple:base diff --git a/docker-compose.yaml b/docker-compose.yaml index e4d50b63..c641ea0c 100644 --- a/docker-compose.yaml +++ b/docker-compose.yaml @@ -25,6 +25,11 @@ services: ports: - "3306:3306" + redis: + image: redis + ports: + - "6379:6379" + localstack: image: localstack/localstack:s3-latest ports: diff --git a/hie.yaml b/hie.yaml index 9681f3ec..2722f033 100644 --- a/hie.yaml +++ b/hie.yaml @@ -55,6 +55,9 @@ cradle: - path: "examples/hdbc-mysql/main.hs" component: "hdbc-mysql-example:exe:hdbc-mysql-example" + - path: "examples/hedis/client.hs" + component: "hedis-example:exe:hedis-client" + - path: "examples/http-server/main.hs" component: "http-server:exe:http-server" diff --git a/instrumentation/hedis/hs-opentelemetry-instrumentation-hedis.cabal b/instrumentation/hedis/hs-opentelemetry-instrumentation-hedis.cabal index bb169e01..59286920 100644 --- a/instrumentation/hedis/hs-opentelemetry-instrumentation-hedis.cabal +++ b/instrumentation/hedis/hs-opentelemetry-instrumentation-hedis.cabal @@ -4,7 +4,6 @@ name: hs-opentelemetry-instrumentation-hedis version: 0.0.0.0 author: Kazuki Okamoto (岡本和樹) maintainer: kazuki.okamoto@herp.co.jp -extra-source-files: functions.txt common common build-depends: base >= 4 && < 5 @@ -13,29 +12,19 @@ common common ghc-options: -Wcompat default-language: Haskell2010 -custom-setup - setup-depends: - base, - Cabal, - directory, - filepath - library import: common - hs-source-dirs: src, gen + hs-source-dirs: src exposed-modules: OpenTelemetry.Instrumentation.Hedis - other-modules: OpenTelemetry.Instrumentation.Hedis.Internal.Action - OpenTelemetry.Instrumentation.Hedis.Internal.Wrapper - autogen-modules: OpenTelemetry.Instrumentation.Hedis.Internal.Action + other-modules: + Paths_hs_opentelemetry_instrumentation_hedis + autogen-modules: + Paths_hs_opentelemetry_instrumentation_hedis build-depends: hs-opentelemetry-api, + hs-opentelemetry-semantic-conventions, hedis >= 0.14, bytestring, - iproute, - mtl, - safe-exceptions, - text, - unliftio-core, - unordered-containers + text ghc-options: -Wcompat -Wno-name-shadowing if impl(ghc >= 6.4) diff --git a/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis.hs b/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis.hs index d66c4cc0..a996c978 100644 --- a/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis.hs +++ b/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis.hs @@ -1,586 +1,167 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-missing-import-lists #-} module OpenTelemetry.Instrumentation.Hedis ( - -- * The Redis Monad - Redis (Redis), - runRedis, - runRedis', - - -- * Connection - Connection (..), - Orig.ConnectError (..), - connect, - connect', - checkedConnect, - checkedConnect', - disconnect, - disconnect', - withConnect, - withConnect', - withCheckedConnect, - withCheckedConnect', - Orig.ConnectInfo (..), - Orig.defaultConnectInfo, - Orig.parseConnectInfo, - Orig.connectCluster, - Orig.PortID (..), - - -- * Commands - - -- ** Connection - auth, - echo, - ping, - quit, - select, - - -- ** Keys - del, - dump, - exists, - expire, - expireat, - keys, - Orig.MigrateOpts (..), - Orig.defaultMigrateOpts, - migrate, - migrateMultiple, - move, - objectRefcount, - objectEncoding, - objectIdletime, - persist, - pexpire, - pexpireat, - pttl, - randomkey, - rename, - renamenx, - restore, - restoreReplace, - Orig.Cursor, - Orig.cursor0, - Orig.ScanOpts (..), - Orig.defaultScanOpts, - scan, - scanOpts, - Orig.SortOpts (..), - Orig.defaultSortOpts, - Orig.SortOrder (..), - sort, - sortStore, - ttl, - Orig.RedisType (..), - getType, - wait, - - -- ** Hashes - hdel, - hexists, - hget, - hgetall, - hincrby, - hincrbyfloat, - hkeys, - hlen, - hmget, - hmset, - hscan, - hscanOpts, - hset, - hsetnx, - hstrlen, - hvals, - - -- ** HyperLogLogs - pfadd, - pfcount, - pfmerge, - - -- ** Lists - blpop, - brpop, - brpoplpush, - lindex, - linsertBefore, - linsertAfter, - llen, - lpop, - lpush, - lpushx, - lrange, - lrem, - lset, - ltrim, - rpop, - rpoplpush, - rpush, - rpushx, - - -- ** Scripting - eval, - evalsha, - Orig.DebugMode, - scriptDebug, - scriptExists, - scriptFlush, - scriptKill, - scriptLoad, - - -- ** Server - bgrewriteaof, - bgsave, - clientGetname, - clientList, - clientPause, - Orig.ReplyMode, - clientReply, - clientSetname, - commandCount, - commandInfo, - configGet, - configResetstat, - configRewrite, - configSet, - dbsize, - debugObject, - flushall, - flushdb, - info, - infoSection, - lastsave, - save, - slaveof, - Orig.Slowlog (..), - slowlogGet, - slowlogLen, - slowlogReset, - time, - - -- ** Sets - sadd, - scard, - sdiff, - sdiffstore, - sinter, - sinterstore, - sismember, - smembers, - smove, - spop, - spopN, - srandmember, - srandmemberN, - srem, - sscan, - sscanOpts, - sunion, - sunionstore, - - -- ** Sorted Sets - Orig.ZaddOpts (..), - Orig.defaultZaddOpts, - zadd, - zaddOpts, - zcard, - zcount, - zincrby, - Orig.Aggregate (..), - zinterstore, - zinterstoreWeights, - zlexcount, - zrange, - zrangeWithscores, - Orig.RangeLex (..), - zrangebylex, - zrangebylexLimit, - zrangebyscore, - zrangebyscoreWithscores, - zrangebyscoreLimit, - zrangebyscoreWithscoresLimit, - zrank, - zrem, - zremrangebylex, - zremrangebyrank, - zremrangebyscore, - zrevrange, - zrevrangeWithscores, - zrevrangebyscore, - zrevrangebyscoreWithscores, - zrevrangebyscoreLimit, - zrevrangebyscoreWithscoresLimit, - zrevrank, - zscan, - zscanOpts, - zscore, - zunionstore, - zunionstoreWeights, - - -- ** Strings - append, - bitcount, - bitcountRange, - bitopAnd, - bitopOr, - bitopXor, - bitopNot, - bitpos, - decr, - decrby, - get, - getbit, - getrange, - getset, - incr, - incrby, - incrbyfloat, - mget, - mset, - msetnx, - psetex, - Orig.Condition (..), - Orig.SetOpts (..), - set, - setOpts, - setbit, - setex, - setnx, - setrange, - strlen, - - -- ** Streams - Orig.XReadOpts (..), - Orig.defaultXreadOpts, - Orig.XReadResponse (..), - Orig.StreamsRecord (..), - Orig.TrimOpts (..), - xadd, - xaddOpts, - xread, - xreadOpts, - xreadGroup, - xreadGroupOpts, - xack, - xgroupCreate, - xgroupSetId, - xgroupDestroy, - xgroupDelConsumer, - xrange, - xrevRange, - xlen, - Orig.XPendingSummaryResponse (..), - xpendingSummary, - Orig.XPendingDetailRecord (..), - xpendingDetail, - Orig.XClaimOpts (..), - Orig.defaultXClaimOpts, - xclaim, - xclaimJustIds, - Orig.XInfoConsumersResponse (..), - xinfoConsumers, - Orig.XInfoGroupsResponse (..), - xinfoGroups, - Orig.XInfoStreamResponse (..), - xinfoStream, - xdel, - xtrim, - Orig.inf, - Orig.ClusterNodesResponse (..), - Orig.ClusterNodesResponseEntry (..), - Orig.ClusterNodesResponseSlotSpec (..), - clusterNodes, - Orig.ClusterSlotsResponse (..), - Orig.ClusterSlotsResponseEntry (..), - Orig.ClusterSlotsNode (..), - clusterSlots, - clusterSetSlotNode, - clusterSetSlotStable, - clusterSetSlotImporting, - clusterSetSlotMigrating, - clusterGetKeysInSlot, - - -- * Transactions - watch, - unwatch, - multiExec, - Orig.Queued (), - Orig.TxResult (..), - Orig.RedisTx (), - - -- * Pub\/Sub - publish, - - -- ** Subscribing to channels - -- $pubsubexpl - - -- *** Single-thread Pub/Sub - pubSub, - Orig.Message (..), - Orig.PubSub (), - Orig.subscribe, - Orig.unsubscribe, - Orig.psubscribe, - Orig.punsubscribe, - - -- *** Continuous Pub/Sub message controller - pubSubForever, - pubSubForever', - Orig.RedisChannel, - Orig.RedisPChannel, - Orig.MessageCallback, - Orig.PMessageCallback, - Orig.PubSubController, - Orig.newPubSubController, - Orig.currentChannels, - Orig.currentPChannels, - Orig.addChannels, - Orig.addChannelsAndWait, - Orig.removeChannels, - Orig.removeChannelsAndWait, - Orig.UnregisterCallbacksAction, - - -- * Low-Level Command API - sendRequest, - Orig.Reply (..), - Orig.Status (..), - Orig.RedisResult (..), - Orig.ConnectionLostException (..), - Orig.ConnectTimeout (..), - Orig.HashSlot, - Orig.keyToSlot, + appendHooksToConnectionInfo, ) where -import qualified Control.Exception.Safe as E import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (MonadReader (), ReaderT (ReaderT, runReaderT)) import Data.ByteString (ByteString) -import qualified Data.HashMap.Strict as H -import Data.IP (IP) -import Data.String (IsString (fromString)) +import Data.Function ((&)) +import Data.Int (Int64) import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Version (showVersion) import qualified Database.Redis as Orig -import GHC.Stack (HasCallStack) -import OpenTelemetry.Instrumentation.Hedis.Internal.Action -import OpenTelemetry.Instrumentation.Hedis.Internal.Wrapper (wrap0, wrap1, wrap2) -import qualified OpenTelemetry.Trace.Core as Otel (Attribute, SpanArguments (attributes, kind), SpanKind (Client), Tracer, TracerProvider, defaultSpanArguments, getGlobalTracerProvider, inSpan, makeTracer, tracerOptions) -import qualified OpenTelemetry.Trace.Monad as Otel (MonadTracer, TracerT (TracerT)) -import Text.Read (readMaybe) - - -#if MIN_VERSION_hedis(0, 15, 1) -import Control.Monad.IO.Unlift (MonadUnliftIO) -#else -import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) -import qualified Database.Redis.Core.Internal as Orig -#endif - - -data Connection = Connection {connectInfo :: Orig.ConnectInfo, originalConnection :: Orig.Connection} - - -{- | A wrapper data type with 'Otel.Tracer'. -@m@ is expected to be 'Orig.Redis' or 'Orig.RedisTx'. --} -newtype Redis m a - = Redis (ReaderT Otel.Tracer m a) - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadFail, MonadReader Otel.Tracer) - deriving (Otel.MonadTracer) via (Otel.TracerT Otel.Tracer m) - -#if !MIN_VERSION_hedis(0, 15, 1) -instance {-# OVERLAPPING #-} MonadUnliftIO (Redis Orig.Redis) where - withRunInIO inner = - Redis $ ReaderT $ \tracer -> Orig.Redis $ ReaderT $ \env -> - inner $ flip runReaderT env . (\(Orig.Redis m) -> m) . flip runReaderT tracer . (\(Redis m) -> m) -#endif - - -{- | Note: @'Redis' 'Orig.RedisTx'@ cannot be an instance of 'Orig.MonadRedis' - because 'Orig.RedisTx' is not an instance of 'MonadUnliftIO'. --} -instance Orig.MonadRedis (Redis Orig.Redis) where - liftRedis = lift - - -instance Orig.RedisCtx (Redis Orig.Redis) (Either Orig.Reply) where - returnDecode = lift . Orig.returnDecode - - -lift :: m a -> Redis m a -lift r = Redis $ ReaderT $ const r - - --- | A function wrapping 'Orig.runRedis' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -runRedis :: (MonadUnliftIO m, HasCallStack) => Connection -> Redis Orig.Redis a -> m a -runRedis conn m = do - tp <- Otel.getGlobalTracerProvider - runRedis' tp conn m - - --- | A version of an explicit parameter for 'runRedis'. -runRedis' :: (MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Connection -> Redis Orig.Redis a -> m a -runRedis' tp Connection {originalConnection, connectInfo} (Redis m) = do - let tracer = makeTracer tp - inSpan tracer "runRedis'" connectInfo $ liftIO $ Orig.runRedis originalConnection $ runReaderT m tracer - - --- | A function wrapping 'Orig.connect' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -connect :: (MonadUnliftIO m, HasCallStack) => Orig.ConnectInfo -> m Connection -connect info = do - tp <- Otel.getGlobalTracerProvider - connect' tp info - - --- | A version of an explicit parameter for 'connect'. -connect' :: (MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Orig.ConnectInfo -> m Connection -connect' tp info = do - let tracer = makeTracer tp - doConnect tracer info - - -doConnect :: (MonadUnliftIO m, HasCallStack) => Otel.Tracer -> Orig.ConnectInfo -> m Connection -doConnect tracer info = inSpan tracer "doConnect" info $ liftIO $ Connection info <$> Orig.connect info +import GHC.Stack (HasCallStack, withFrozenCallStack) +import qualified OpenTelemetry.Attributes.Map as Otel +import qualified OpenTelemetry.SemanticConventions as Otel +import qualified OpenTelemetry.Trace.Core as Otel +import Paths_hs_opentelemetry_instrumentation_hedis (version) --- | A function wrapping 'Orig.checkedConnect' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -checkedConnect :: (MonadUnliftIO m, HasCallStack) => Orig.ConnectInfo -> m Connection -checkedConnect info = do - tp <- Otel.getGlobalTracerProvider - checkedConnect' tp info - - --- | A version of an explicit parameter for 'checkedConnect'. -checkedConnect' :: (MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Orig.ConnectInfo -> m Connection -checkedConnect' tp info = do - let tracer = makeTracer tp - doCheckedConnect tracer info - - -doCheckedConnect :: (MonadUnliftIO m, HasCallStack) => Otel.Tracer -> Orig.ConnectInfo -> m Connection -doCheckedConnect tracer info = inSpan tracer "doCheckedConnect" info $ liftIO $ Connection info <$> Orig.checkedConnect info - - --- | A function wrapping 'Orig.disconnect' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -disconnect :: (MonadUnliftIO m, HasCallStack) => Connection -> m () -disconnect conn = do - tp <- Otel.getGlobalTracerProvider - disconnect' tp conn - - --- | A version of an explicit parameter for 'disconnect'. -disconnect' :: (MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Connection -> m () -disconnect' tp conn = do - let tracer = makeTracer tp - doDisconnect tracer conn - - -doDisconnect :: (MonadUnliftIO m, HasCallStack) => Otel.Tracer -> Connection -> m () -doDisconnect tracer Connection {originalConnection, connectInfo} = inSpan tracer "doDisconnect" connectInfo $ liftIO $ Orig.disconnect originalConnection - - --- | A function wrapping 'Orig.withConnect' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -withConnect :: (E.MonadMask m, MonadUnliftIO m, HasCallStack) => Orig.ConnectInfo -> (Orig.Connection -> m c) -> m c -withConnect info action = do - tp <- Otel.getGlobalTracerProvider - withConnect' tp info action - - --- | A version of an explicit parameter for 'withConnect'. -withConnect' :: (E.MonadMask m, MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Orig.ConnectInfo -> (Orig.Connection -> m c) -> m c -withConnect' tp info action = do - let tracer = makeTracer tp - inSpan tracer "withConnect'" info $ E.bracket (doConnect tracer info) (doDisconnect tracer) $ \(Connection {originalConnection}) -> action originalConnection - - --- | A function wrapping 'Orig.withCheckedConnect' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -withCheckedConnect :: (E.MonadMask m, MonadUnliftIO m, HasCallStack) => Orig.ConnectInfo -> (Orig.Connection -> m c) -> m c -withCheckedConnect info action = do - tp <- Otel.getGlobalTracerProvider - withCheckedConnect' tp info action - - --- | A version of an explicit parameter for 'withCheckedConnect'. -withCheckedConnect' :: (E.MonadMask m, MonadUnliftIO m, HasCallStack) => Otel.TracerProvider -> Orig.ConnectInfo -> (Orig.Connection -> m c) -> m c -withCheckedConnect' tp info action = do - let tracer = makeTracer tp - inSpan tracer "withConnect'" info $ E.bracket (doCheckedConnect tracer info) (doDisconnect tracer) $ \(Connection {originalConnection}) -> action originalConnection - - -watch :: [ByteString] -> Redis Orig.Redis (Either Orig.Reply Orig.Status) -watch = wrap1 "watch" $ lift . Orig.watch - - -unwatch :: Redis Orig.Redis (Either Orig.Reply Orig.Status) -unwatch = wrap0 "unwatch" $ lift Orig.unwatch - - -multiExec :: Redis Orig.RedisTx (Orig.Queued a) -> Redis Orig.Redis (Orig.TxResult a) -multiExec (Redis m) = wrap0 "multiExec" $ Redis $ ReaderT $ Orig.multiExec . runReaderT m - - -pubSub :: Orig.PubSub -> (Orig.Message -> IO Orig.PubSub) -> Redis Orig.Redis () -pubSub = wrap2 "pubSub" $ \sub f -> lift $ Orig.pubSub sub f - - --- | A function wrapping 'Orig.pubSubForever' with 'Otel.Tracer' using 'Otel.getGlobalTracerProvider'. -pubSubForever :: Connection -> Orig.PubSubController -> IO () -> IO () -pubSubForever connection controller action = do - tp <- Otel.getGlobalTracerProvider - pubSubForever' tp connection controller action - - --- | A version of an explicit parameter for 'pubSubForever'. -pubSubForever' :: Otel.TracerProvider -> Connection -> Orig.PubSubController -> IO () -> IO () -pubSubForever' tp Connection {originalConnection, connectInfo} controller action = do - let tracer = makeTracer tp - inSpan tracer "pubSubForever'" connectInfo $ Orig.pubSubForever originalConnection controller action - - -makeTracer :: Otel.TracerProvider -> Otel.Tracer -makeTracer tp = Otel.makeTracer tp "hs-opentelemetry-instrumentation-hedis" Otel.tracerOptions - - -inSpan :: (MonadUnliftIO m, HasCallStack) => Otel.Tracer -> Text -> Orig.ConnectInfo -> m a -> m a -inSpan tracer name info f = do - let args = Otel.defaultSpanArguments {Otel.kind = Otel.Client, Otel.attributes = makeAttributes info} - Otel.inSpan tracer name args f - - -makeAttributes :: Orig.ConnectInfo -> H.HashMap Text Otel.Attribute -makeAttributes info@Orig.ConnInfo {Orig.connectHost, Orig.connectPort} = +appendHooksToConnectionInfo :: (MonadIO m, HasCallStack) => Otel.TracerProvider -> Orig.ConnectInfo -> m Orig.ConnectInfo +appendHooksToConnectionInfo tracerProvider connectInfo@Orig.ConnInfo {Orig.connectHooks} = withFrozenCallStack $ liftIO $ do let - transportAttr :: Otel.Attribute - portAttr :: (Text, Otel.Attribute) - (transportAttr, portAttr) = + tracer = + Otel.makeTracer + tracerProvider + (Otel.InstrumentationLibrary "hs-opentelemetry-instrumentation-hedis" $ Text.pack $ showVersion version) + Otel.tracerOptions + pure + connectInfo + { Orig.connectHooks = + connectHooks + { Orig.sendRequestHook = sendDatabaseOrPubSubHook tracer connectInfo . Orig.sendRequestHook connectHooks + , Orig.sendPubSubHook = sendDatabaseOrPubSubHook tracer connectInfo . Orig.sendPubSubHook connectHooks + , Orig.callbackHook = callbackHook tracer connectInfo . Orig.callbackHook connectHooks + } + } + + +sendDatabaseOrPubSubHook :: HasCallStack => Otel.Tracer -> Orig.ConnectInfo -> ([ByteString] -> IO a) -> [ByteString] -> IO a +sendDatabaseOrPubSubHook tracer connectInfo send message@[command, channel, _] | elem command ["PUBLISH", "SPUBLISH"] = do + let spanName = decodeBs channel <> " publish" + kind = Otel.Producer + attributes = makePubSubAttributes connectInfo $ Right message + Otel.inSpan tracer spanName Otel.defaultSpanArguments {Otel.kind, Otel.attributes} $ send message +sendDatabaseOrPubSubHook _ _ send message@(command : _) | elem command pubSubCommands = send message +sendDatabaseOrPubSubHook tracer connectInfo send message = do + let spanName = makeDatabaseSpanName message + attributes = makeDatabaseAttributes connectInfo message + kind = Otel.Client + Otel.inSpan tracer spanName Otel.defaultSpanArguments {Otel.kind, Otel.attributes} $ send message + + +callbackHook :: HasCallStack => Otel.Tracer -> Orig.ConnectInfo -> (Orig.Message -> IO Orig.PubSub) -> Orig.Message -> IO Orig.PubSub +callbackHook tracer connectInfo callback message = do + let spanName = decodeBs (Orig.msgChannel message) <> " deliver" + kind = Otel.Consumer + attributes = makePubSubAttributes connectInfo $ Left message + Otel.inSpan tracer spanName Otel.defaultSpanArguments {Otel.kind, Otel.attributes} $ callback message + + +makeDatabaseSpanName :: HasCallStack => [ByteString] -> Text +makeDatabaseSpanName (command : _) = decodeBs command +makeDatabaseSpanName _ = error "unexpected" + + +makeDatabaseAttributes :: Orig.ConnectInfo -> [ByteString] -> Otel.AttributeMap +makeDatabaseAttributes Orig.ConnInfo {Orig.connectHost, Orig.connectPort, Orig.connectUsername, Orig.connectDatabase} request = + let + host :: Text + maybePort :: Maybe Int64 + transport :: Text + (host, maybePort, transport) = case connectPort of - Orig.PortNumber n -> ("ip_tcp", ("net.peer.port", fromString $ show n)) - Orig.UnixSocket p -> ("other", ("net.sock.peer.port", fromString p)) + Orig.PortNumber n -> (Text.pack connectHost, Just $ fromInteger $ toInteger n, "tcp") + Orig.UnixSocket s -> (Text.pack s, Nothing, "unix") + statement = Text.unwords $ (\s -> "'" <> s <> "'") . decodeBs <$> request in - [ ("db.connection_string", fromString $ showsPrecConnectInfoMasked 0 info "") - , portAttr - , (("net.transport", transportAttr)) - , ((maybe "net.peer.name" (const "net.sock.peer.addr") (readMaybe connectHost :: Maybe IP), fromString connectHost)) - ] - - -showsPrecConnectInfoMasked :: Int -> Orig.ConnectInfo -> ShowS -showsPrecConnectInfoMasked d Orig.ConnInfo {Orig.connectHost, Orig.connectPort, Orig.connectAuth, Orig.connectDatabase, Orig.connectMaxConnections, Orig.connectMaxIdleTime, Orig.connectTimeout, Orig.connectTLSParams} = - showParen (d > 10) $ - showString "ConnInfo {" - . (showString "connectHost = " . shows connectHost . showString ", ") - . (showString "connectPort = " . shows connectPort . showString ", ") - . (showString "connectAuth = " . maybe (shows (Nothing :: Maybe ())) (const $ showString "Just \"****\"") connectAuth . showString ", ") - . (showString "connectDatabase = " . shows connectDatabase . showString ", ") - . (showString "connectMaxConnections = " . shows connectMaxConnections . showString ", ") - . (showString "connectMaxIdleTime = " . shows connectMaxIdleTime . showString ", ") - . (showString "connectTimeout = " . shows connectTimeout . showString ", ") - . (showString "connectTLSParams = " . shows connectTLSParams) - . showString "}" + mempty + -- Database Client attributes + -- attributes to dissmiss: db.connection_string, network.type + & Otel.insertByKey Otel.db_instance_id host + & Otel.insertByKey Otel.db_system "redis" + & maybe id (Otel.insertByKey Otel.db_user . decodeBs) connectUsername + & Otel.insertByKey Otel.network_peer_address host + & maybe id (Otel.insertByKey Otel.network_peer_port) maybePort + & Otel.insertByKey Otel.network_transport transport + & Otel.insertByKey Otel.server_address host + & maybe id (Otel.insertByKey Otel.server_port) maybePort + -- Database Client Call-level attributes + -- attributes to dissmiss: db.name, db.operation + & Otel.insertByKey Otel.db_statement statement + -- Redis Call-level attributes + & Otel.insertByKey Otel.db_redis_databaseIndex (fromInteger connectDatabase) + + +makePubSubAttributes :: Orig.ConnectInfo -> Either Orig.Message [ByteString] -> Otel.AttributeMap +makePubSubAttributes Orig.ConnInfo {Orig.connectHost, Orig.connectPort} message = + let + destination :: Text + operation :: Text + message' :: Text + maybePattern :: Maybe Text + (destination, operation, message', maybePattern) = + case message of + Right ["PUBLISH", channel, message''] -> (decodeBs channel, "publish", "'" <> decodeBs message'' <> "'", Nothing) + Right (command : _) -> error $ "unexpected command: " <> show command + Right [] -> error "unexpected" + Left Orig.Message {Orig.msgChannel, Orig.msgMessage} -> (decodeBs msgChannel, "deliver", "'" <> decodeBs msgMessage <> "'", Nothing) + Left Orig.PMessage {Orig.msgPattern, Orig.msgChannel, Orig.msgMessage} -> (decodeBs msgChannel, "deliver", "'" <> decodeBs msgMessage <> "'", Just $ decodeBs msgPattern) + host :: Text + maybePort :: Maybe Int64 + transport :: Text + (host, maybePort, transport) = + case connectPort of + Orig.PortNumber n -> (Text.pack connectHost, Just $ fromInteger $ toInteger n, "tcp") + Orig.UnixSocket s -> (Text.pack s, Nothing, "unix") + in + mempty + -- Messaging attributes + -- attributes to dissmiss: + -- - messaging.batch.message_count + -- - messaging.client_id + -- - messaging.destination.template + -- - messaging.message.body.size + -- - messaging.message.conversation_id + -- - messaging.message.envelope.size + -- - messaging.message.id + -- - network.protocol.version + -- - network.type + & Otel.insertByKey Otel.messaging_destination_anonymous False + & Otel.insertByKey Otel.messaging_destination_name destination + & Otel.insertByKey Otel.messaging_destination_temporary False + & Otel.insertByKey Otel.messaging_operation operation + & Otel.insertByKey Otel.messaging_system "redis" + & Otel.insertByKey Otel.network_peer_address host + & maybe id (Otel.insertByKey Otel.network_peer_port) maybePort + & Otel.insertByKey Otel.network_protocol_name "redis" + & Otel.insertByKey Otel.network_transport transport + & Otel.insertByKey Otel.server_address host + & maybe id (Otel.insertByKey Otel.server_port) maybePort + -- Per-message attributes + & Otel.insert "messaging.message" (Otel.AttributeValue $ Otel.TextAttribute message') + & maybe id (Otel.insertByKey "messaging.redis.pattern" . Otel.AttributeValue . Otel.TextAttribute) maybePattern + + +pubSubCommands :: [ByteString] +pubSubCommands = + [ "SUBSCRIBE" + , "SSUBSCRIBE" + , "PSUBSCRIBE" + , "UNSUBSCRIBE" + , "SUNSUBSCRIBE" + , "PUNSUBSCRIBE" + ] + + +decodeBs :: ByteString -> Text +#if MIN_VERSION_text(2,0,0) +decodeBs = Text.decodeUtf8Lenient +#else +decodeBs = Text.decodeLatin1 +#endif diff --git a/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis/Internal/Wrapper.hs b/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis/Internal/Wrapper.hs deleted file mode 100644 index 8f726204..00000000 --- a/instrumentation/hedis/src/OpenTelemetry/Instrumentation/Hedis/Internal/Wrapper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module OpenTelemetry.Instrumentation.Hedis.Internal.Wrapper ( - wrap0, - wrap1, - wrap2, - wrap3, - wrap4, - wrap5, - wrap6, -) where - -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Data.Text (Text) -import GHC.Stack (HasCallStack) -import qualified OpenTelemetry.Trace.Core as Otel (defaultSpanArguments, inSpan) -import qualified OpenTelemetry.Trace.Monad as Otel (MonadTracer, getTracer) - - -wrap0 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> m z -> m z -wrap0 n m = do - tracer <- Otel.getTracer - Otel.inSpan tracer n Otel.defaultSpanArguments m - - -wrap1 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> m z) -> a -> m z -wrap1 n z a = wrap0 n $ z a - - -wrap2 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> b -> m z) -> a -> b -> m z -wrap2 n z a b = wrap0 n $ z a b - - -wrap3 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> b -> c -> m z) -> a -> b -> c -> m z -wrap3 n z a b c = wrap0 n $ z a b c - - -wrap4 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> b -> c -> d -> m z) -> a -> b -> c -> d -> m z -wrap4 n z a b c d = wrap0 n $ z a b c d - - -wrap5 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> b -> c -> d -> e -> m z) -> a -> b -> c -> d -> e -> m z -wrap5 n z a b c d e = wrap0 n $ z a b c d e - - -wrap6 :: (Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => Text -> (a -> b -> c -> d -> e -> f -> m z) -> a -> b -> c -> d -> e -> f -> m z -wrap6 n z a b c d e f = wrap0 n $ z a b c d e f diff --git a/stack-ghc-9.2.yaml b/stack-ghc-9.2.yaml index 520d7390..0f0aeb8a 100644 --- a/stack-ghc-9.2.yaml +++ b/stack-ghc-9.2.yaml @@ -53,6 +53,8 @@ extra-deps: - amazonka-sso-2.0@sha256:902be13b604e4a3b51a9b8e1adc6a32f42322ae11f738a72a8c737b2d0a91a5e,2995 - amazonka-sts-2.0@sha256:5c721083e8d80883a893176de6105c27bbbd8176f467c27ac5f8d548a5e726d8,3209 - crypton-0.34@sha256:9e4b50d79d1fba681befa08151db7223d2b4bb72564853e8530e614105d53a1a,14577 +- github: kakkun61/hedis + commit: 60313d0c76392f7a00467d40c40fa5e851e0ce11 nix: enable: true diff --git a/stack-ghc-9.2.yaml.lock b/stack-ghc-9.2.yaml.lock index 78c31d07..9ee88c63 100644 --- a/stack-ghc-9.2.yaml.lock +++ b/stack-ghc-9.2.yaml.lock @@ -99,6 +99,17 @@ packages: size: 23275 original: hackage: crypton-0.34@sha256:9e4b50d79d1fba681befa08151db7223d2b4bb72564853e8530e614105d53a1a,14577 +- completed: + name: hedis + pantry-tree: + sha256: 31961196203986bdf5b4b271923ad8f4f36771de9796778f5196cc518b689366 + size: 2678 + sha256: 867afb4d2564e0fd5d04a28166113a00ab033f6a1aaa7de5d9b3bb67c1be3baf + size: 79738 + url: https://github.com/kakkun61/hedis/archive/c523b1c2de5cd9ee4f6652f37daca01a1527c2ba.tar.gz + version: 0.15.2 + original: + url: https://github.com/kakkun61/hedis/archive/c523b1c2de5cd9ee4f6652f37daca01a1527c2ba.tar.gz snapshots: - completed: sha256: a684cdbdf9304b325a503e0fe1d9648e9c18155ce4c7cfebbe8a7f93674e6295 diff --git a/stack.yaml b/stack.yaml index 6013b804..fe527141 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,6 +8,7 @@ packages: - examples/aws-s3 # - examples/grpc-echo # only able to be built with cabal - examples/hdbc-mysql +- examples/hedis - examples/http-server - examples/yesod-minimal - examples/yesod-subsite @@ -53,6 +54,8 @@ extra-deps: - amazonka-sso-2.0@sha256:902be13b604e4a3b51a9b8e1adc6a32f42322ae11f738a72a8c737b2d0a91a5e,2995 - amazonka-sts-2.0@sha256:5c721083e8d80883a893176de6105c27bbbd8176f467c27ac5f8d548a5e726d8,3209 - crypton-0.34@sha256:9e4b50d79d1fba681befa08151db7223d2b4bb72564853e8530e614105d53a1a,14577 +- github: kakkun61/hedis + commit: 60313d0c76392f7a00467d40c40fa5e851e0ce11 nix: enable: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 0c816205..793192cb 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -99,6 +99,17 @@ packages: size: 23275 original: hackage: crypton-0.34@sha256:9e4b50d79d1fba681befa08151db7223d2b4bb72564853e8530e614105d53a1a,14577 +- completed: + name: hedis + pantry-tree: + sha256: 31961196203986bdf5b4b271923ad8f4f36771de9796778f5196cc518b689366 + size: 2678 + sha256: 867afb4d2564e0fd5d04a28166113a00ab033f6a1aaa7de5d9b3bb67c1be3baf + size: 79738 + url: https://github.com/kakkun61/hedis/archive/c523b1c2de5cd9ee4f6652f37daca01a1527c2ba.tar.gz + version: 0.15.2 + original: + url: https://github.com/kakkun61/hedis/archive/c523b1c2de5cd9ee4f6652f37daca01a1527c2ba.tar.gz snapshots: - completed: sha256: e7e57649a12f6178d1158e4b6f1f1885ed56d210ae6174385271cecc9b1ea974