hedis

herp-inc · May 8, 2023 · a03729b · a03729b
1 parent a95eaa2
commit a03729b
Show file tree

Hide file tree

Showing 12 changed files with 1,069 additions and 118 deletions.
diff --git a/api/src/OpenTelemetry/Trace/Monad.hs b/api/src/OpenTelemetry/Trace/Monad.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -34,20 +35,17 @@ module OpenTelemetry.Trace.Monad (
   -- , NewEvent (..)
   -- Fundamental monad instances
   MonadTracer (..),
+  TracerT (..),
+  runTracerT,
 ) where
 
-import Control.Monad.IO.Unlift
+import Control.Monad.IO.Unlift (MonadIO, MonadUnliftIO)
 import Control.Monad.Identity (IdentityT)
-import Control.Monad.Reader (ReaderT)
+import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT))
 import Control.Monad.Trans (MonadTrans (lift))
 import Data.Text (Text)
-import GHC.Stack
-import OpenTelemetry.Trace.Core (
-  Span,
-  SpanArguments (..),
-  Tracer,
-  inSpan'',
- )
+import GHC.Stack (CallStack, HasCallStack, callStack)
+import OpenTelemetry.Trace.Core (Span, SpanArguments, Tracer, inSpan'')
 
 
 -- | This is generally scoped by Monad stack to do different things
@@ -91,3 +89,18 @@ instance (MonadTracer m) => MonadTracer (IdentityT m) where
 
 instance {-# OVERLAPPABLE #-} (MonadTracer m) => MonadTracer (ReaderT r m) where
   getTracer = lift getTracer
+
+
+{- | Another 'MonadTracer' instance for 'ReaderT'.
+This @newtype@ data type is intended to be used with @DerivingVia@ language extension.
+-}
+newtype TracerT m a = TracerT (ReaderT Tracer m a)
+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadFail, MonadReader Tracer)
+
+
+runTracerT :: Tracer -> TracerT m a -> m a
+runTracerT tracer (TracerT m) = runReaderT m tracer
+
+
+instance (Monad m) => MonadTracer (TracerT m) where
+  getTracer = ask
diff --git a/cabal.project b/cabal.project
@@ -11,6 +11,7 @@ packages:
   , propagators/b3
   , instrumentation/conduit
   , instrumentation/cloudflare
+  , instrumentation/hedis
   , instrumentation/hspec
   , instrumentation/http-client
   , instrumentation/persistent

diff --git a/hie.yaml b/hie.yaml
@@ -1,127 +1,148 @@
 cradle:
-  stack:
-    - path: "api/src"
-      component: "hs-opentelemetry-api:lib"
+  multi:
+    - path: "instrumentation/hedis/Setup.hs"
+      config:
+        cradle:
+          direct:
+            arguments:
+              - "-package base"
+              - "-package Cabal"
+              - "-package filepath"
+    - path: .
+      config:
+        cradle:
+          stack:
+            - path: "api/src"
+              component: "hs-opentelemetry-api:lib"
 
-    - path: "api/test"
-      component: "hs-opentelemetry-api:test:hs-opentelemetry-api-test"
+            - path: "api/test"
+              component: "hs-opentelemetry-api:test:hs-opentelemetry-api-test"
 
-    - path: "examples/http-server/./main.hs"
-      component: "http-server:exe:http-server"
+            - path: "examples/http-server/./main.hs"
+              component: "http-server:exe:http-server"
 
-    - path: "examples/yesod-minimal/src"
-      component: "yesod-minimal:lib"
+            - path: "examples/yesod-minimal/src"
+              component: "yesod-minimal:lib"
 
-    - path: "examples/yesod-minimal/src/Minimal.hs"
-      component: "yesod-minimal:exe:yesod-minimal"
+            - path: "examples/yesod-minimal/src/Minimal.hs"
+              component: "yesod-minimal:exe:yesod-minimal"
 
-    - path: "examples/yesod-subsite/src/main.hs"
-      component: "yesod-subsite:exe:yesod-subsite"
+            - path: "examples/yesod-minimal/src/Paths_yesod_minimal.hs"
+              component: "yesod-minimal:exe:yesod-minimal"
 
-    - path: "exporters/handle/src"
-      component: "hs-opentelemetry-exporter-handle:lib"
+            - path: "examples/yesod-subsite/src/main.hs"
+              component: "yesod-subsite:exe:yesod-subsite"
 
-    - path: "exporters/handle/test"
-      component: "hs-opentelemetry-exporter-handle:test:hs-opentelemetry-exporter-handle-test"
+            - path: "exporters/handle/src"
+              component: "hs-opentelemetry-exporter-handle:lib"
 
-    - path: "exporters/in-memory/src"
-      component: "hs-opentelemetry-exporter-in-memory:lib"
+            - path: "exporters/handle/test"
+              component: "hs-opentelemetry-exporter-handle:test:hs-opentelemetry-exporter-handle-test"
 
-    - path: "exporters/in-memory/test"
-      component: "hs-opentelemetry-exporter-in-memory:test:hs-opentelemetry-exporter-in-memory-test"
+            - path: "exporters/in-memory/src"
+              component: "hs-opentelemetry-exporter-in-memory:lib"
 
-    - path: "exporters/otlp/src"
-      component: "hs-opentelemetry-exporter-otlp:lib"
+            - path: "exporters/in-memory/test"
+              component: "hs-opentelemetry-exporter-in-memory:test:hs-opentelemetry-exporter-in-memory-test"
 
-    - path: "exporters/otlp/test"
-      component: "hs-opentelemetry-exporter-otlp:test:hs-opentelemetry-exporter-otlp-test"
+            - path: "exporters/otlp/src"
+              component: "hs-opentelemetry-exporter-otlp:lib"
 
-    - path: "instrumentation/cloudflare/src"
-      component: "hs-opentelemetry-instrumentation-cloudflare:lib"
+            - path: "exporters/otlp/test"
+              component: "hs-opentelemetry-exporter-otlp:test:hs-opentelemetry-exporter-otlp-test"
 
-    - path: "instrumentation/cloudflare/test"
-      component: "hs-opentelemetry-instrumentation-cloudflare:test:cloudflare-test"
+            - path: "instrumentation/cloudflare/src"
+              component: "hs-opentelemetry-instrumentation-cloudflare:lib"
 
-    - path: "instrumentation/conduit/src"
-      component: "hs-opentelemetry-instrumentation-conduit:lib"
+            - path: "instrumentation/cloudflare/test"
+              component: "hs-opentelemetry-instrumentation-cloudflare:test:cloudflare-test"
 
-    - path: "instrumentation/conduit/test"
-      component: "hs-opentelemetry-instrumentation-conduit:test:hs-opentelemetry-instrumentation-conduit-test"
+            - path: "instrumentation/conduit/src"
+              component: "hs-opentelemetry-instrumentation-conduit:lib"
 
-    - path: "instrumentation/hspec/src"
-      component: "hs-opentelemetry-instrumentation-hspec:lib"
+            - path: "instrumentation/conduit/test"
+              component: "hs-opentelemetry-instrumentation-conduit:test:hs-opentelemetry-instrumentation-conduit-test"
 
-    - path: "instrumentation/hspec/test"
-      component: "hs-opentelemetry-instrumentation-hspec:test:hs-opentelemetry-hspec-test"
+            - path: "instrumentation/hedis/gen"
+              component: "hs-opentelemetry-instrumentation-hedis:lib"
 
-    - path: "instrumentation/http-client/src"
-      component: "hs-opentelemetry-instrumentation-http-client:lib"
+            - path: "instrumentation/hedis/src"
+              component: "hs-opentelemetry-instrumentation-hedis:lib"
 
-    - path: "instrumentation/http-client/test"
-      component: "hs-opentelemetry-instrumentation-http-client:test:hs-opentelemetry-instrumentation-http-client-test"
+            - path: "instrumentation/hspec/src"
+              component: "hs-opentelemetry-instrumentation-hspec:lib"
 
-    - path: "instrumentation/persistent/src"
-      component: "hs-opentelemetry-instrumentation-persistent:lib"
+            - path: "instrumentation/hspec/test"
+              component: "hs-opentelemetry-instrumentation-hspec:test:hs-opentelemetry-hspec-test"
 
-    - path: "instrumentation/persistent/test"
-      component: "hs-opentelemetry-instrumentation-persistent:test:hs-opentelemetry-persistent-test"
+            - path: "instrumentation/http-client/src"
+              component: "hs-opentelemetry-instrumentation-http-client:lib"
 
-    - path: "instrumentation/persistent-mysql/src"
-      component: "hs-opentelemetry-instrumentation-persistent-mysql:lib"
+            - path: "instrumentation/http-client/test"
+              component: "hs-opentelemetry-instrumentation-http-client:test:hs-opentelemetry-instrumentation-http-client-test"
 
-    - path: "instrumentation/postgresql-simple/src"
-      component: "hs-opentelemetry-instrumentation-postgresql-simple:lib"
+            - path: "instrumentation/persistent/src"
+              component: "hs-opentelemetry-instrumentation-persistent:lib"
 
-    - path: "instrumentation/postgresql-simple/test"
-      component: "hs-opentelemetry-instrumentation-postgresql-simple:test:hs-opentelemetry-instrumentation-postgresql-simple-test"
+            - path: "instrumentation/persistent/test"
+              component: "hs-opentelemetry-instrumentation-persistent:test:hs-opentelemetry-persistent-test"
 
-    - path: "instrumentation/wai/src"
-      component: "hs-opentelemetry-instrumentation-wai:lib"
+            - path: "instrumentation/persistent-mysql/src"
+              component: "hs-opentelemetry-instrumentation-persistent-mysql:lib"
 
-    - path: "instrumentation/wai/test"
-      component: "hs-opentelemetry-instrumentation-wai:test:hs-opentelemetry-instrumentation-wai-test"
+            - path: "instrumentation/postgresql-simple/src"
+              component: "hs-opentelemetry-instrumentation-postgresql-simple:lib"
 
-    - path: "instrumentation/yesod/src"
-      component: "hs-opentelemetry-instrumentation-yesod:lib"
+            - path: "instrumentation/postgresql-simple/test"
+              component: "hs-opentelemetry-instrumentation-postgresql-simple:test:hs-opentelemetry-instrumentation-postgresql-simple-test"
 
-    - path: "instrumentation/yesod/test"
-      component: "hs-opentelemetry-instrumentation-yesod:test:hs-opentelemetry-instrumentation-yesod-test"
+            - path: "instrumentation/wai/src"
+              component: "hs-opentelemetry-instrumentation-wai:lib"
 
-    - path: "otlp/src"
-      component: "hs-opentelemetry-otlp:lib"
+            - path: "instrumentation/wai/test"
+              component: "hs-opentelemetry-instrumentation-wai:test:hs-opentelemetry-instrumentation-wai-test"
 
-    - path: "propagators/b3/src"
-      component: "hs-opentelemetry-propagator-b3:lib"
+            - path: "instrumentation/yesod/src"
+              component: "hs-opentelemetry-instrumentation-yesod:lib"
 
-    - path: "propagators/b3/test/spec"
-      component: "hs-opentelemetry-propagator-b3:test:spec"
+            - path: "instrumentation/yesod/test"
+              component: "hs-opentelemetry-instrumentation-yesod:test:hs-opentelemetry-instrumentation-yesod-test"
 
-    - path: "propagators/datadog/src"
-      component: "hs-opentelemetry-propagator-datadog:lib"
+            - path: "otlp/src"
+              component: "hs-opentelemetry-otlp:lib"
 
-    - path: "propagators/datadog/test/spec"
-      component: "hs-opentelemetry-propagator-datadog:test:spec"
+            - path: "propagators/b3/src"
+              component: "hs-opentelemetry-propagator-b3:lib"
 
-    - path: "propagators/datadog/old-src"
-      component: "hs-opentelemetry-propagator-datadog:test:spec"
+            - path: "propagators/b3/test/spec"
+              component: "hs-opentelemetry-propagator-b3:test:spec"
 
-    - path: "propagators/datadog/benchmark/header-codec/main.hs"
-      component: "hs-opentelemetry-propagator-datadog:bench:header-codec"
+            - path: "propagators/datadog/src"
+              component: "hs-opentelemetry-propagator-datadog:lib"
 
-    - path: "propagators/w3c/src"
-      component: "hs-opentelemetry-propagator-w3c:lib"
+            - path: "propagators/datadog/test/spec"
+              component: "hs-opentelemetry-propagator-datadog:test:spec"
 
-    - path: "propagators/w3c/test"
-      component: "hs-opentelemetry-propagator-w3c:test:hs-opentelemetry-propagator-w3c-test"
+            - path: "propagators/datadog/old-src"
+              component: "hs-opentelemetry-propagator-datadog:test:spec"
 
-    - path: "sdk/src"
-      component: "hs-opentelemetry-sdk:lib"
+            - path: "propagators/datadog/benchmark/header-codec/main.hs"
+              component: "hs-opentelemetry-propagator-datadog:bench:header-codec"
 
-    - path: "sdk/test"
-      component: "hs-opentelemetry-sdk:test:hs-opentelemetry-sdk-test"
+            - path: "propagators/w3c/src"
+              component: "hs-opentelemetry-propagator-w3c:lib"
 
-    - path: "utils/exceptions/src"
-      component: "hs-opentelemetry-utils-exceptions:lib"
+            - path: "propagators/w3c/test"
+              component: "hs-opentelemetry-propagator-w3c:test:hs-opentelemetry-propagator-w3c-test"
 
-    - path: "utils/exceptions/test"
-      component: "hs-opentelemetry-utils-exceptions:test:exceptions-test"
+            - path: "sdk/src"
+              component: "hs-opentelemetry-sdk:lib"
+
+            - path: "sdk/test"
+              component: "hs-opentelemetry-sdk:test:hs-opentelemetry-sdk-test"
+
+            - path: "utils/exceptions/src"
+              component: "hs-opentelemetry-utils-exceptions:lib"
+
+            - path: "utils/exceptions/test"
+              component: "hs-opentelemetry-utils-exceptions:test:exceptions-test"
diff --git a/instrumentation/hedis/.gitignore b/instrumentation/hedis/.gitignore
@@ -0,0 +1 @@
+/gen/
diff --git a/instrumentation/hedis/Setup.hs b/instrumentation/hedis/Setup.hs
@@ -0,0 +1,101 @@
+import Data.Foldable (for_)
+import Data.List (intercalate, isPrefixOf, subsequences)
+import Data.Maybe (mapMaybe)
+import Debug.Trace (trace, traceIO)
+import Distribution.Simple (Args, defaultMainWithHooks, simpleUserHooks)
+import qualified Distribution.Simple
+import Distribution.Simple.Setup (BuildFlags)
+import Distribution.Types.HookedBuildInfo (HookedBuildInfo, emptyHookedBuildInfo)
+import GHC.Stack (HasCallStack)
+import System.Directory (copyFile, createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, removeFile)
+import System.FilePath (takeDirectory, (</>))
+import System.IO (IOMode (ReadMode), hClose, hGetContents, hPutStr, hSetNewlineMode, noNewlineTranslation, openTempFile, stdin, withFile)
+
+
+main :: IO ()
+main = defaultMainWithHooks simpleUserHooks {Distribution.Simple.preBuild = preBuild}
+
+
+{- | Create a wrapper module.
+
+@
+append :: (RedisCtx m f, Otel.MonadTracer m, MonadUnliftIO m, HasCallStack) => ByteString -> ByteString -> m (f Integer)
+append = wrap2 "append" Orig.append
+@
+-}
+preBuild :: (HasCallStack) => Args -> BuildFlags -> IO HookedBuildInfo
+preBuild _ _ = do
+  let
+    sourceTextPath = "functions.txt"
+    destinationCodePath = "gen/OpenTelemetry/Instrumentation/Hedis/Internal/Action.hs"
+    oldConstraintText = "RedisCtx m f"
+    newConstraintText = "(RedisCtx m f, Otel.MonadTracer m, MonadUnliftIO m, HasCallStack)"
+  temporaryFilePath <-
+    withFile sourceTextPath ReadMode $ \sourceTextHandle -> do
+      temporaryDirectoryPath <- getTemporaryDirectory
+      createDirectoryIfMissing True temporaryDirectoryPath
+      (temporaryFilePath, temporaryHandle) <- openTempFile temporaryDirectoryPath "generated.hs"
+      putStrLn $ "temporary file: " ++ temporaryFilePath
+      hSetNewlineMode sourceTextHandle noNewlineTranslation
+      hSetNewlineMode temporaryHandle noNewlineTranslation
+      lines <- Prelude.lines <$> hGetContents sourceTextHandle
+      let
+        actionInfos =
+          flip mapMaybe lines $ \line ->
+            if "--" `isPrefixOf` line
+              then Nothing
+              else
+                let
+                  name = takeWhile (/= ' ') line
+                  paramCount = length $ filter (== ('-', '>')) $ zip (init line) $ tail line
+                  typ = replace oldConstraintText newConstraintText line
+                  term = name ++ " = wrap" ++ show paramCount ++ " \"" ++ name ++ "\" " ++ "Orig." ++ name
+                 in
+                  if name == "command"
+                    then Nothing -- becuase `command` has an unexposed type
+                    else Just (name, typ, term)
+        names = (\(name, _, _) -> name) <$> actionInfos
+        declerations = (\(_, typ, term) -> typ ++ "\n" ++ term) <$> actionInfos
+      hPutStr temporaryHandle $
+        unlines $
+          [ "{-# LANGUAGE ConstraintKinds #-}"
+          , "{-# LANGUAGE OverloadedStrings #-}"
+          , "{-# OPTIONS_GHC -Wno-missing-export-lists #-}"
+          , "{-# OPTIONS_GHC -Wno-missing-import-lists #-}"
+          , ""
+          , "module OpenTelemetry.Instrumentation.Hedis.Internal.Action where"
+          , ""
+          , "import OpenTelemetry.Instrumentation.Hedis.Internal.Wrapper"
+          , "import qualified Database.Redis as Orig"
+          , "import Database.Redis hiding (" ++ intercalate ", " names ++ ")"
+          , ""
+          , "import Control.Monad.IO.Unlift (MonadUnliftIO)"
+          , "import Data.ByteString (ByteString)"
+          , "import GHC.Stack (HasCallStack)"
+          , "import qualified OpenTelemetry.Trace.Monad as Otel (MonadTracer)"
+          , ""
+          ]
+            ++ declerations
+      hClose temporaryHandle
+      pure temporaryFilePath
+  createDirectoryIfMissing True $ takeDirectory destinationCodePath
+  copyFile temporaryFilePath destinationCodePath
+  removeFile temporaryFilePath
+  pure emptyHookedBuildInfo
+
+
+replace :: (Eq a) => [a] -> [a] -> [a] -> [a]
+replace old new =
+  intercalate new . split old
+  where
+    split _ [] = []
+    split sep xs =
+      let (p, xs') = split1 [] xs
+       in p : split sep xs'
+      where
+        split1 acc [] = (reverse acc, [])
+        split1 acc xs@(y : ys) =
+          let (a, as) = splitAt (length sep) xs
+           in if a == sep
+                then (reverse acc, as)
+                else split1 (y : acc) ys