diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 355ebbe59..3d7cf89af 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -178,6 +178,7 @@ jobs: touch cabal.project.local echo "packages: ${PKGDIR_hackage_server}" >> cabal.project cat >> cabal.project <> cabal.project.local cat cabal.project diff --git a/cabal.haskell-ci b/cabal.haskell-ci index e09dd3590..154926984 100644 --- a/cabal.haskell-ci +++ b/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 diff --git a/exes/Main.hs b/exes/Main.hs index 2e4723f11..6344f139d 100644 --- a/exes/Main.hs +++ b/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)) diff --git a/hackage-server.cabal b/hackage-server.cabal index bd88d1455..5affdc634 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/src/Distribution/Server/Framework/Resource.hs b/src/Distribution/Server/Framework/Resource.hs index 6080844e5..a2c7abcbe 100644 --- a/src/Distribution/Server/Framework/Resource.hs +++ b/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,13 +385,80 @@ 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] @@ -392,7 +466,10 @@ serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpat 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)