wip

cabal.project

@@ -71,7 +71,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kleidukos/servant-effectful
-    tag: 22af09642078d5296b524495ad8213bf2ace62d2
+    tag: 02e7fe0ab9fa0af06b1e2ec21cecfae405d39fc5
 
 source-repository-package
     type: git

flora.cabal

@@ -428,6 +428,7 @@ library flora-web
     , servant
     , servant-client
     , servant-client-core
+    , servant-effectful
     , servant-openapi3
     , servant-prometheus
     , servant-server

src/web/FloraWeb/Server.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 module FloraWeb.Server where
 
 import Colourista.IO (blueMessage)
@@ -13,10 +14,11 @@ import Data.Text.Display (display)
 import Effectful
 import Effectful.Concurrent
 import Effectful.Dispatch.Static
-import Effectful.Error.Static (runErrorNoCallStack, runErrorWith)
+import Effectful.Error.Static (Error, runErrorNoCallStack, runErrorWith)
 import Effectful.Fail (runFailIO)
 import Effectful.PostgreSQL.Transact.Effect (runDB)
 import Effectful.Reader.Static (runReader)
+import Effectful.Servant
 import Effectful.Time (runTime)
 import Effectful.Trace qualified as Trace
 import Log (Logger)
@@ -27,7 +29,6 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Network.HTTP.Types (notFound404)
 import Network.Wai.Handler.Warp
   ( defaultSettings
-  , runSettings
   , setOnException
   , setPort
   )
@@ -48,6 +49,7 @@ import Servant
   , Context (..)
   , ErrorFormatters
   , Handler
+  , HasServer (ServerT)
   , NotFoundErrorFormatter
   , Proxy (Proxy)
   , defaultErrorFormatters
@@ -91,6 +93,7 @@ import FloraWeb.Pages.Templates (defaultTemplateEnv, defaultsToEnv)
 import FloraWeb.Pages.Templates.Error (renderError)
 import FloraWeb.Routes
 import FloraWeb.Types
+import Servant.Server (ServerError, ServerContext)
 
 type FloraAuthContext =
   '[ OptionalAuthContext
@@ -164,10 +167,18 @@ runServer appLogger floraEnv = do
           then WaiMetrics.prometheus WaiMetrics.def
           else id
   oddJobsEnv <- OddJobs.mkEnv oddjobsUiCfg ("/admin/odd-jobs/" <>)
+  jobsRunnerEnv <- OddJobs.mkEnv oddjobsUiCfg ("/admin/odd-jobs/" <>)
   let webEnv = WebEnv floraEnv
   webEnvStore <- liftIO $ newWebEnvStore webEnv
   ioref <- liftIO $ newIORef True
-  let server = mkServer appLogger webEnvStore floraEnv oddjobsUiCfg oddJobsEnv zipkin ioref
+  -- let server = mkServer appLogger webEnvStore floraEnv oddjobsUiCfg oddJobsEnv zipkin ioref
+  let middleware =
+        heartbeatMiddleware
+          . loggingMiddleware
+          . const
+        $ P.prometheusMiddleware P.defaultMetrics (Proxy @ServerRoutes)
+        $ prometheusMiddleware server
+
   let warpSettings =
         setPort (fromIntegral floraEnv.httpPort) $
           setOnException
@@ -177,29 +188,15 @@ runServer appLogger floraEnv = do
                 floraEnv.mltp
             )
             defaultSettings
-  liftIO
-    $ runSettings warpSettings
-    $ heartbeatMiddleware
-      . loggingMiddleware
-      . const
-    $ P.prometheusMiddleware P.defaultMetrics (Proxy @ServerRoutes)
-    $ prometheusMiddleware server
 
-mkServer
-  :: Logger
-  -> WebEnvStore
-  -> FloraEnv
-  -> OddJobs.UIConfig
-  -> OddJobs.Env
-  -> Zipkin
-  -> IORef Bool
-  -> Application
-mkServer logger webEnvStore floraEnv cfg jobsRunnerEnv zipkin ioref =
-  serveWithContextT
-    (Proxy @ServerRoutes)
-    (genAuthServerContext logger floraEnv)
-    (naturalTransform floraEnv logger webEnvStore zipkin)
-    (floraServer cfg jobsRunnerEnv floraEnv.environment ioref)
+  runWarpServerSettingsContext @ServerRoutes
+      warpSettings
+      (genAuthServerContext appLogger floraEnv)
+      middleware
+      ( naturalTransform floraEnv appLogger webEnvStore zipkin $
+          floraServer oddjobsUiCfg jobsRunnerEnv floraEnv.environment ioref
+      )
+  pure ()
 
 floraServer
   :: OddJobs.UIConfig
@@ -218,29 +215,29 @@ floraServer cfg jobsRunnerEnv environment ioref =
     , livereload = LiveReload.livereloadHandler environment ioref
     }
 
-naturalTransform :: FloraEnv -> Logger -> WebEnvStore -> Zipkin -> FloraEff a -> Handler a
-naturalTransform floraEnv logger _webEnvStore zipkin app = do
+naturalTransform
+  :: (HasServer api context, ServerContext context)
+  => FloraEnv
+  -> Logger
+  -> Zipkin
+  -> FloraEff a
+  -> ServerT api (Eff (Error ServerError : es))
+naturalTransform floraEnv logger zipkin app = do
   let runTrace =
         if floraEnv.environment == Production
           then Trace.runTrace zipkin.zipkinTracer
           else Trace.runNoTrace
-  result <-
-    liftIO $
-      Right
-        <$> app
-          & runTrace
-          & runDB floraEnv.pool
-          & runTime
-          & runReader floraEnv.features
-          & ( case floraEnv.features.blobStoreImpl of
-                Just (BlobStoreFS fp) -> runBlobStoreFS fp
-                _ -> runBlobStorePure
-            )
-          & Logging.runLog floraEnv.environment logger
-          & runErrorWith (\_callstack err -> pure $ Left err)
-          & runConcurrent
-          & runEff
-  either Except.throwError pure result
+  liftIO $ app
+    & runTrace
+    & runDB floraEnv.pool
+    & runTime
+    & runReader floraEnv.features
+    & ( case floraEnv.features.blobStoreImpl of
+          Just (BlobStoreFS fp) -> runBlobStoreFS fp
+          _ -> runBlobStorePure
+      )
+    & Logging.runLog floraEnv.environment logger
+    & runConcurrent
 
 genAuthServerContext :: Logger -> FloraEnv -> Context FloraAuthContext
 genAuthServerContext logger floraEnv =

src/web/FloraWeb/Types.hs

@@ -44,8 +44,8 @@ type RouteEffects =
    , Reader FeatureEnv
    , BlobStoreAPI
    , Log
-   , Error ServerError
    , Concurrent
+   , Error ServerError
    , IOE
    ]