Add hs-opentelemetry

.github/workflows/haskell-ci.yml

@@ -178,6 +178,7 @@ jobs:
           touch cabal.project.local
           echo "packages: ${PKGDIR_hackage_server}" >> cabal.project
           cat >> cabal.project <<EOF
+          allow-newer: lens-family:containers, lens-family-core:containers
           EOF
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(Cabal|Cabal-syntax|hackage-server|parsec|process|text)$/; }' >> cabal.project.local
           cat cabal.project

cabal.haskell-ci

@@ -21,6 +21,13 @@ apt: libbrotli-dev libgd-dev
 haddock-components: all
   -- since haskell-ci 0.15.20220822
 
+
+-- On GHC 9.14.1 the boot library `containers-0.8` is used but `lens-family` 
+-- (pulled in transitively via `hs-opentelemetry-sdk`) constrains 
+-- `containers < 0.8`.
+raw-project
+  allow-newer: lens-family:containers, lens-family-core:containers
+
 -- tests: >= 9.4
 --   -- parallel-doctest uses the ghc package
 --   -- and thus does not build with Cabal-3.8.1.0 below GHC 9.4

exes/Main.hs

@@ -24,6 +24,8 @@ import System.Exit
          ( exitWith, ExitCode(..) )
 import Control.Exception
          ( bracket )
+import qualified OpenTelemetry.Trace as OTel
+         ( initializeGlobalTracerProvider, shutdownTracerProvider )
 import System.Posix.Signals as Signal
          ( Signal
          , installHandler
@@ -206,6 +208,7 @@ data RunFlags = RunFlags {
     flagRunTemp            :: Flag Bool,
     flagRunCacheDelay      :: Flag String,
     flagRunLiveTemplates   :: Flag Bool,
+    flagRunOpenTelemetry   :: Flag Bool,
     -- Online backup flags
     flagRunBackupOutputDir :: Flag FilePath,
     flagRunBackupLinkBlobs :: Flag Bool,
@@ -226,6 +229,7 @@ defaultRunFlags = RunFlags {
     flagRunTemp            = Flag False,
     flagRunCacheDelay      = NoFlag,
     flagRunLiveTemplates   = Flag False,
+    flagRunOpenTelemetry   = Flag False,
     flagRunBackupOutputDir = Flag "backups",
     flagRunBackupLinkBlobs = Flag False,
     flagRunBackupScrubbed  = Flag False
@@ -311,6 +315,10 @@ runCommand =
           "Do not cache templates, for quicker feedback during development."
           flagRunLiveTemplates (\v flags -> flags { flagRunLiveTemplates = v })
           (noArg (Flag True))
+      , option [] ["enable-opentelemetry"]
+          ("Initialize the OpenTelemetry SDK and export traces. Exporters and endpoints are configured via the standard OTEL_* environment variables.")
+          flagRunOpenTelemetry (\v flags -> flags { flagRunOpenTelemetry = v })
+          (noArg (Flag True))
       ]
 
 runAction :: RunFlags -> IO ()
@@ -369,7 +377,8 @@ runAction opts = do
           lognotice verbosity "Done"
 
     let useTempServer = fromFlag (flagRunTemp opts)
-    withServer config useTempServer $ \server ->
+    withOpenTelemetry (fromFlag $ flagRunOpenTelemetry opts) $
+      withServer config useTempServer $ \server ->
       withHandler sigUSR1 (checkpointHandler server) $
       withHandler sigUSR2 (backupHandler server) $
       withHandler sigHUP  (reloadHandler server) $ do
@@ -379,6 +388,24 @@ runAction opts = do
   where
     verbosity = fromFlag (flagRunVerbosity opts)
 
+    withOpenTelemetry
+        :: Bool  -- is telemetry enabled?
+        -> IO a
+        -> IO a
+    withOpenTelemetry = \case
+      False -> id
+      True ->
+        bracket
+          ( do
+              lognotice verbosity "Initializing OpenTelemetry SDK..."
+              OTel.initializeGlobalTracerProvider
+          )
+          (\tp -> do
+              lognotice verbosity "Shutting down OpenTelemetry SDK..."
+              void $ OTel.shutdownTracerProvider tp Nothing
+          )
+          . const
+
     -- Option handling:
     --
     checkPortOpt defaults Nothing    = return (loPortNum (confListenOn defaults))

hackage-server.cabal

@@ -466,6 +466,7 @@ library
     , happstack-server      ^>= 7.7.1     || ^>= 7.8.0  || ^>= 7.9.0
     , hashable               >= 1.3       && < 1.6
     , hs-captcha            ^>= 1.0
+    , hs-opentelemetry-api   >= 0.1        && < 1.1
     , hslogger              ^>= 1.3.1
     , lifted-base           ^>= 0.2.1
     , mime-mail             ^>= 0.5
@@ -519,6 +520,7 @@ executable hackage-server
     , Cabal
     , directory
     , filepath
+    , hs-opentelemetry-sdk   >= 1.0 && < 1.1
     , network-uri
     , parsec
     , unix

src/Distribution/Server/Framework/Resource.hs

@@ -43,16 +43,23 @@ import Distribution.Server.Framework.HappstackUtils (remainingPathString, uriEsc
 import Distribution.Server.Util.ContentType (parseContentAccept)
 import Distribution.Server.Framework.Error
 
+import qualified Control.Exception.Lifted as Lifted
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Function (on)
 import Data.List (intercalate, unionBy, elemIndices, find, isSuffixOf)
+import Data.String (fromString)
+import qualified Data.Text as T
 import qualified Text.ParserCombinators.Parsec as Parse
 
 import System.FilePath.Posix ((</>), (<.>))
 import qualified Data.Tree as Tree (Tree(..), drawTree)
 import qualified Data.ByteString.Char8 as BS -- Used for accept header only
 
+import qualified OpenTelemetry.Trace.Core as OTel
+import qualified OpenTelemetry.Context as OTelCtx
+import qualified OpenTelemetry.Context.ThreadLocal as OTelTL
+
 type Content = String
 
 type DynamicPath = [(String, String)]
@@ -378,21 +385,91 @@ parseFormatTrunkAt = do
     untilNext :: Parse.Parser String
     untilNext = Parse.many1 (Parse.noneOf "/")
 
+-- | Obtain the OpenTelemetry tracer used to record the handling of resources.
+getHackageTracer :: MonadIO m => m OTel.Tracer
+getHackageTracer = do
+    tp <- OTel.getGlobalTracerProvider
+    pure $ OTel.makeTracer tp (fromString "hackage-server") OTel.tracerOptions
+
+-- | Render a 'BranchPath' back into a human readable route template.
+renderBranchPathTemplate :: BranchPath -> String
+renderBranchPathTemplate loc = '/' : intercalate "/" (fmap comp $ reverse loc)
+  where
+    comp (StaticBranch  s) = s
+    comp (DynamicBranch s) = ':' : s
+    comp TrailingBranch    = "..."
+
+-- | Wrap the handling of a resource in a fresh OpenTelemetry span.
+withResourceSpan
+    :: BranchPath
+    -> ResourceFormat
+    -> DynamicPath
+    -> ServerPartE Response
+    -> ServerPartE Response
+withResourceSpan rloc rformat dpath act = do
+    rq     <- askRq
+    tracer <- getHackageTracer
+    ctx    <- OTelTL.getContext
+    let httpMethod  = show (rqMethod rq)
+        theUri      = rqUri rq
+        rawQuery    = dropWhile (== '?') (rqQuery rq)
+        scheme      = if rqSecure rq then "https" else "http"
+        route = renderBranchPathTemplate rloc
+        (peerHost, peerPort) = rqPeer rq
+        -- The span name follows the HTTP convention of "{method} {route}".
+        spanName    = httpMethod ++ " " ++ route
+        spanArgs    = OTel.defaultSpanArguments { OTel.kind = OTel.Server }
+    sp <- OTel.createSpan tracer ctx (T.pack spanName) spanArgs
+
+    -- Standard HTTP semantic-convention attributes.
+    OTel.addAttribute sp (T.pack "http.request.method")   $ T.pack httpMethod
+    OTel.addAttribute sp (T.pack "http.route")            $ T.pack route
+    OTel.addAttribute sp (T.pack "url.path")              $ T.pack theUri
+    OTel.addAttribute sp (T.pack "url.scheme")            $ T.pack scheme
+    OTel.addAttribute sp (T.pack "network.peer.address")  $ T.pack peerHost
+    OTel.addAttribute sp (T.pack "network.peer.port")     (fromIntegral peerPort :: Int)
+    unless (null rawQuery) $
+      OTel.addAttribute sp (T.pack "url.query")           $ T.pack rawQuery
+    forM_ (getHeader "Host" rq) $ \host ->
+      OTel.addAttribute sp (T.pack "server.address")      $ T.pack $ BS.unpack host
+    forM_ (getHeader "User-Agent" rq) $ \ua ->
+      OTel.addAttribute sp (T.pack "user_agent.original") $ T.pack $ BS.unpack ua
+
+    -- Hackage-specific attributes.
+    OTel.addAttribute sp (T.pack "hackage.resource")        $ T.pack route
+    OTel.addAttribute sp (T.pack "hackage.resource.format") $ T.pack $ show rformat
+    forM_ dpath $ \(k, v) -> OTel.addAttribute sp (T.pack $ "hackage.capture." <> k) $ T.pack v
+
+    _ <- OTelTL.attachContext $ OTelCtx.insertSpan sp ctx
+    Lifted.finally
+      ( do
+          resp <- act
+          OTel.addAttribute sp (T.pack "http.response.status_code") (rsCode resp :: Int)
+          pure resp
+      )
+      ( do
+          OTel.endSpan sp Nothing
+          void $ OTelTL.attachContext ctx
+      )
+
 -- serveResource does all the path format and HTTP method preprocessing for a Resource
 --
 -- For a small curl-based testing mini-suite of [Resource]:
 -- [res "/foo" ["json"], res "/foo/:bar.:format" ["html", "json"], res "/baz/test/.:format" ["html", "text", "json"], res "/package/:package/:tarball.tar.gz" ["tarball"], res "/a/:a/:b/" ["html", "json"], res "/mon/..." [""], res "/wiki/path.:format" [], res "/hi.:format" ["yaml", "blah"]]
 --     where res field formats = (resourceAt field) { resourceGet = map (\format -> (format, \_ -> return . toResponse . (++"\n") . ((show format++" - ")++) . show)) formats }
 serveResource :: [(Content, ServerErrorResponse)] -> Resource -> ServerResponse
-serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpath -> msum $
+serveResource errRes (Resource rloc rget rput rpost rdelete rformat rend _) = \dpath -> msum $
     map (\func -> func dpath) $ methodPart ++ [optionPart]
   where
     optionPart = makeOptions $ concat [ met | ((_:_), met) <- zip methods methodsList]
     methodPart = [ serveResources met res | (res@(_:_), met) <- zip methods methodsList]
     methods = [rget, rput, rpost, rdelete]
     methodsList = [[GET, HEAD], [PUT], [POST], [DELETE]]
     makeOptions :: [Method] -> ServerResponse
-    makeOptions methodList = \_ -> method OPTIONS >> nullDir >> do
+    makeOptions methodList = \dpath -> do
+      method OPTIONS
+      nullDir
+      withResourceSpan rloc rformat dpath $ do
         setHeaderM "Allow" (intercalate ", " . map show $ methodList)
         return $ toResponse ()
     -- some of the dpath lookup calls can be replaced by pattern matching the head/replacing
@@ -459,7 +536,7 @@ serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpat
           case lookup "format" dpath of
             Just format@(_:_) -> case lookup format res of
                                -- return a specific format if it is found
-                Just answer -> handleErrors (Just format) $ answer dpath
+                Just answer -> handleErrors (Just format) $ withResourceSpan rloc rformat dpath $ answer dpath
                 Nothing -> mzero -- return 404 if the specific format is not found
                   -- return default response when format is empty or non-existent
             _ -> do
@@ -469,7 +546,7 @@ serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpat
                     Just x -> x
                     Nothing -> head res
               (format,answer) <- negotiateContent contentResponsePair res
-              handleErrors (Just format) $ answer dpath
+              handleErrors (Just format) $ withResourceSpan rloc rformat dpath $ answer dpath
 
     handleErrors format =
       handleErrorResponse (serveErrorResponse errRes format)