galley: Set request id correctly in Wai app

changelog.d/5-internal/galley-request-id

@@ -0,0 +1 @@
+Set request ID correctly in galley logs

services/galley/src/Galley/App.hs

@@ -37,7 +37,6 @@ module Galley.App
 
     -- * Running Galley effects
     GalleyEffects,
-    runGalley,
     evalGalley,
     ask,
     DeleteItem (..),
@@ -95,7 +94,6 @@ import Network.HTTP.Client.OpenSSL
 import Network.HTTP.Media.RenderHeader (RenderHeader (..))
 import Network.HTTP.Types (hContentType)
 import Network.HTTP.Types.Status (statusCode, statusMessage)
-import Network.Wai
 import qualified Network.Wai.Utilities as Wai
 import qualified Network.Wai.Utilities.Server as Server
 import OpenSSL.Session as Ssl
@@ -188,11 +186,6 @@ initHttpManager o = do
         managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize)
       }
 
-runGalley :: Env -> Request -> Sem GalleyEffects a -> IO a
-runGalley e r m =
-  let e' = reqId .~ lookupReqId r $ e
-   in evalGalley e' m
-
 interpretTinyLog ::
   Members '[Embed IO] r =>
   Env ->
@@ -201,9 +194,6 @@ interpretTinyLog ::
 interpretTinyLog e = interpret $ \case
   P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m)
 
-lookupReqId :: Request -> RequestId
-lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders
-
 toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a
 toServantHandler env galley = do
   eith <- liftIO $ Control.Exception.try (evalGalley env galley)

services/galley/src/Galley/Run.hs

@@ -21,13 +21,16 @@ module Galley.Run
   )
 where
 
+import Bilge.Request (requestIdName)
 import Cassandra (runClient, shutdown)
 import Cassandra.Schema (versionCheck)
 import qualified Control.Concurrent.Async as Async
 import Control.Exception (finally)
-import Control.Lens (view, (^.))
+import Control.Lens (view, (.~), (^.))
 import qualified Data.Aeson as Aeson
+import Data.Default
 import Data.Domain
+import Data.Id
 import qualified Data.Metrics.Middleware as M
 import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware)
 import Data.Misc (portNumber)
@@ -45,6 +48,7 @@ import qualified Galley.Queue as Q
 import Imports
 import qualified Network.HTTP.Media.RenderHeader as HTTPMedia
 import qualified Network.HTTP.Types as HTTP
+import Network.Wai
 import qualified Network.Wai.Middleware.Gunzip as GZip
 import qualified Network.Wai.Middleware.Gzip as GZip
 import Network.Wai.Utilities.Server
@@ -91,21 +95,25 @@ mkApp o = do
   return (middlewares $ servantApp e, e, finalizer)
   where
     rtree = compile API.sitemap
-    app e r k = runGalley e r (route rtree r k)
+    app e r k = evalGalley e (route rtree r k)
     -- the servant API wraps the one defined using wai-routing
-    servantApp e r =
-      Servant.serveWithContext
-        (Proxy @CombinedAPI)
-        ( view (options . optSettings . setFederationDomain) e
-            :. customFormatters
-            :. Servant.EmptyContext
-        )
-        ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap
-            :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap
-            :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap
-            :<|> Servant.Tagged (app e)
-        )
-        r
+    servantApp e0 r =
+      let e = reqId .~ lookupReqId r $ e0
+       in Servant.serveWithContext
+            (Proxy @CombinedAPI)
+            ( view (options . optSettings . setFederationDomain) e
+                :. customFormatters
+                :. Servant.EmptyContext
+            )
+            ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap
+                :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap
+                :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap
+                :<|> Servant.Tagged (app e)
+            )
+            r
+
+    lookupReqId :: Request -> RequestId
+    lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders
 
 -- Servant needs a context type argument here that contains *at least* the
 -- context types required by all the HasServer instances. In reality, this should