[yesod] add subsite support

cabal.project

@@ -21,6 +21,8 @@ packages:
   , instrumentation/tasty
   , instrumentation/yesod
   , instrumentation/wai
+  , examples/yesod-minimal
+  , examples/yesod-subsite
   , utils/exceptions
   , vendors/honeycomb
 

docker-compose.yaml

@@ -0,0 +1,18 @@
+version: "3"
+
+services:
+  jaeger:
+    image: jaegertracing/all-in-one
+    environment:
+      - COLLECTOR_OTLP_ENABLED=true
+    ports:
+      - "4318:4318" # otelcol HTTP/JSON
+      - "16686:16686" # UI and API
+
+  postgres:
+    image: postgres
+    environment:
+      - POSTGRES_USER=otel
+      - POSTGRES_PASSWORD=password
+    ports:
+      - "5432:5432"

examples/yesod-minimal/src/Minimal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -45,6 +46,10 @@ data Minimal = Minimal
   }
 
 
+instance MonadTracer (HandlerFor Minimal) where
+  getTracer = getTracerWithGlobalTracerProvider
+
+
 $( do
     let routes =
           [parseRoutes|
@@ -53,8 +58,8 @@ $( do
         |]
     Prelude.concat
       <$> Prelude.sequence
-        [ mkRouteToRenderer ''Minimal routes
-        , mkRouteToPattern ''Minimal routes
+        [ mkRouteToRenderer ''Minimal mempty routes
+        , mkRouteToPattern ''Minimal mempty routes
         , mkYesod "Minimal" routes
         ]
  )

examples/yesod-subsite/.gitignore

@@ -0,0 +1 @@
+/bin/

examples/yesod-subsite/Makefile

@@ -0,0 +1,19 @@
+.PHONY: server.run
+server.run:
+	docker compose --file ../../docker-compose.yaml up $(DOCKER_COMPOSE_OPTS)
+
+.PHONY: server.stop
+server.stop:
+	docker compose --file ../../docker-compose.yaml down $(DOCKER_COMPOSE_OPTS)
+
+.PHONY: app.run
+app.run: bin/yesod-subsite
+	OTEL_SERVICE_NAME=yesod-subsite bin/yesod-subsite $(YESOD_MINIMAL_OPTS)
+
+bin/yesod-subsite:
+	stack install --local-bin-path ./bin $(CABAL_OPTS) yesod-subsite:exe:yesod-subsite
+
+.PHONY: clean
+clean:
+	stack clean
+	$(RM) bin/yesod-subsite

examples/yesod-subsite/README.md

@@ -0,0 +1,29 @@
+# yesod-subsite Example
+
+This example shows how to use hs-opentelemetry-instrumentation-wai and hs-opentelemetry-instrumentation-yesod with Yesod subsite.
+
+## How to Run
+
+Run a following command to start Jaeger.
+
+```
+$ make server.run
+```
+
+Build and run this example in another shell.
+
+```
+$ make app.run
+```
+
+You can access following end points.
+
+- http://localhost:16686/
+  - Jaeger UI
+- http://localhost:3000/
+  - target app
+
+When you access http://localhost:3000/, Open Telemetry's traces are sent to the Jaeger.
+And you can see the traces at http://localhost:16686.
+
+![Screenshot of Jaeger](./image/jaeger-trace-example.png)

examples/yesod-subsite/src/Subsite.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- an option for Template Haskell stage restriction
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Subsite (
+  module Subsite.Data,
+) where
+
+import Subsite.Data (
+  Route (FooR, SubHomeR),
+  Subsite (Subsite),
+  getFooR,
+  getSubHomeR,
+  resourcesSubsite,
+  routeToPattern,
+  routeToRenderer,
+ )
+import Yesod.Core (
+  YesodSubDispatch (yesodSubDispatch),
+  mkYesodSubDispatch,
+ )
+
+
+instance YesodSubDispatch Subsite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)

examples/yesod-subsite/src/Subsite/Data.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Subsite.Data (
+  Subsite (Subsite),
+  getSubHomeR,
+  getFooR,
+  routeToPattern,
+  routeToRenderer,
+  resourcesSubsite,
+  Route (FooR, SubHomeR),
+) where
+
+import Data.Text (Text)
+import OpenTelemetry.Instrumentation.Yesod (
+  mkRouteToPattern,
+  mkRouteToRenderer,
+ )
+import Yesod.Core (
+  RenderRoute (renderRoute),
+  SubHandlerFor,
+  mkYesodSubData,
+  parseRoutes,
+ )
+import Yesod.Core.Types (Route)
+
+
+data Subsite = Subsite
+
+
+$( do
+    let routes =
+          [parseRoutes|
+          / SubHomeR GET
+          /foo FooR GET
+        |]
+    concat
+      <$> sequence
+        [ mkRouteToRenderer ''Subsite mempty routes
+        , mkRouteToPattern ''Subsite mempty routes
+        , mkYesodSubData "Subsite" routes
+        ]
+ )
+
+
+getSubHomeR :: SubHandlerFor Subsite master Text
+getSubHomeR = pure "GET /subsite"
+
+
+getFooR :: SubHandlerFor Subsite master Text
+getFooR = pure "GET /subsite/foo"

examples/yesod-subsite/src/main.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+-- an option for Template Haskell
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+import qualified Data.Map as M
+import Data.Text (Text, pack)
+import Network.Wai.Handler.Warp (run)
+import OpenTelemetry.Instrumentation.Wai (newOpenTelemetryWaiMiddleware')
+import OpenTelemetry.Instrumentation.Yesod (
+  RouteRenderer (RouteRenderer),
+  YesodOpenTelemetryTrace (getTracerProvider),
+  mkRouteToPattern,
+  mkRouteToRenderer,
+  openTelemetryYesodMiddleware,
+ )
+import OpenTelemetry.Trace (
+  TracerProvider,
+  initializeTracerProvider,
+  shutdownTracerProvider,
+ )
+import Subsite (Subsite (Subsite))
+import qualified Subsite
+import UnliftIO (bracket)
+import Yesod.Core (
+  RenderRoute (renderRoute),
+  Yesod (errorHandler, yesodMiddleware),
+  defaultYesodMiddleware,
+  mkYesod,
+  parseRoutes,
+  toWaiApp,
+ )
+import Yesod.Core.Handler (provideRep, selectRep)
+import Yesod.Routes.TH.Types (ResourceTree)
+
+
+-- | This is my data type. There are many like it, but this one is mine.
+data Site = Site
+  { tracerProvider :: TracerProvider
+  , subsite :: Subsite
+  }
+
+
+$( do
+    let routes :: [ResourceTree String]
+        routes =
+          [parseRoutes|
+          / RootR GET
+          /subsite SubsiteR Subsite subsite
+        |]
+    concat
+      <$> sequence
+        [ mkRouteToRenderer ''Site (M.fromList [("Subsite", [|Subsite.routeToRenderer|])]) routes
+        , mkRouteToPattern ''Site (M.fromList [("Subsite", [|Subsite.routeToPattern|])]) routes
+        , mkYesod "Site" routes
+        ]
+ )
+
+
+instance Yesod Site where
+  yesodMiddleware m = openTelemetryYesodMiddleware (RouteRenderer routeToRenderer routeToPattern) $ defaultYesodMiddleware m
+  errorHandler err = selectRep $ provideRep $ pure $ pack $ show err
+
+
+instance YesodOpenTelemetryTrace Site where
+  getTracerProvider = tracerProvider
+
+
+getRootR :: Handler Text
+getRootR = pure "GET /"
+
+
+main :: IO ()
+main = do
+  bracket
+    initializeTracerProvider
+    shutdownTracerProvider
+    $ \tp -> do
+      waiApp <- toWaiApp $ Site tp Subsite
+      let openTelemetryWaiMiddleware = newOpenTelemetryWaiMiddleware' tp
+      run 3000 $ openTelemetryWaiMiddleware waiApp

examples/yesod-subsite/yesod-subsite.cabal

@@ -0,0 +1,45 @@
+cabal-version: 1.12
+
+name: yesod-subsite
+version: 0.0.0
+build-type: Simple
+
+executable yesod-subsite
+  main-is: main.hs
+  other-modules: Subsite
+                 Subsite.Data
+  hs-source-dirs: src
+  build-depends: base,
+                 containers,
+                 hs-opentelemetry-instrumentation-wai,
+                 hs-opentelemetry-instrumentation-yesod,
+                 hs-opentelemetry-sdk,
+                 text,
+                 unliftio,
+                 warp,
+                 yesod-core
+  ghc-options: -threaded
+               -with-rtsopts=-N
+               -Wall
+               -Wcompat
+               -Widentities
+               -Wincomplete-record-updates
+               -Wincomplete-uni-patterns
+               -Wmissing-export-lists
+               -Wmissing-exported-signatures
+               -Wmissing-home-modules
+               -Wmissing-import-lists
+               -Wmissing-export-lists
+               -Wmonomorphism-restriction
+               -Wno-name-shadowing
+               -Wpartial-fields
+               -Wredundant-constraints
+               -Wunused-packages
+  if impl(ghc >= 9.0)
+    ghc-options: -Winvalid-haddock
+  if impl(ghc >= 9.2)
+    ghc-options: -Wmissing-kind-signatures
+                 -Woperator-whitespace
+                 -Wredundant-bang-patterns
+
+  default-language: Haskell2010

hie.yaml

@@ -18,8 +18,8 @@ cradle:
     - path: "examples/yesod-minimal/src/Minimal.hs"
       component: "yesod-minimal:exe:yesod-minimal"
 
-    - path: "examples/yesod-minimal/src/Paths_yesod_minimal.hs"
-      component: "yesod-minimal:exe:yesod-minimal"
+    - path: "examples/yesod-subsite/src/main.hs"
+      component: "yesod-subsite:exe:yesod-subsite"
 
     - path: "exporters/handle/src"
       component: "hs-opentelemetry-exporter-handle:lib"

instrumentation/yesod/hs-opentelemetry-instrumentation-yesod.cabal

@@ -35,13 +35,15 @@ library
   ghc-options: -Wall
   build-depends:
       base >=4.7 && <5
+    , containers
     , hs-opentelemetry-api ==0.2.*
     , hs-opentelemetry-instrumentation-wai >=0.0.1 && <0.2
     , microlens
     , template-haskell
     , text
     , unliftio
     , unordered-containers
+    , vault
     , wai
     , yesod-core
   default-language: Haskell2010

instrumentation/yesod/package.yaml

@@ -27,11 +27,13 @@ library:
   dependencies:
   - hs-opentelemetry-api ^>= 0.2
   - hs-opentelemetry-instrumentation-wai >= 0.0.1 && < 0.2
+  - containers
   - microlens
   - template-haskell
   - text
   - unliftio
   - unordered-containers
+  - vault
   - wai
   - yesod-core