fix(users/Profpatsch/openlab-tools): fix cache again

And of course I managed to move the cache creation into the handlers,
instead of doing it before starting the webserver.

And now I managed to create a hopeless mess of callbacks, but oh well.

Change-Id: I73c3aeced71923c7372496286a279e326b20c388
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9813
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

users/Profpatsch/openlab-tools/src/OpenlabTools.hs

@@ -106,53 +106,60 @@ runApp = withTracer $ \tracer -> do
           then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes
           else Html.renderHtml
 
-  let appT = withRunInIO $ \runInIO -> Warp.run 9099 $ \req respond -> do
+  let runApplication ::
-        let catchAppException act =
+        (MonadUnliftIO m, MonadLogger m) =>
-              try act >>= \case
+        ( Wai.Request ->
-                Right a -> pure a
+          (Wai.Response -> m Wai.ResponseReceived) ->
-                Left (AppException err) -> do
+          m Wai.ResponseReceived
-                  runInIO (logError err)
+        ) ->
-                  respond (Wai.responseLBS Http.status500 [] "")
+        m ()
+      runApplication app = do
+        withRunInIO $ \runInIO -> Warp.run 9099 $ \req respond -> do
+          let catchAppException act =
+                try act >>= \case
+                  Right a -> pure a
+                  Left (AppException err) -> do
+                    runInIO (logError err)
+                    respond (Wai.responseLBS Http.status500 [] "")
+          liftIO $ catchAppException (runInIO $ app req (\resp -> liftIO $ respond resp))
 
+  let appT :: AppT IO () = do
         let h extra res = Wai.responseLBS Http.ok200 (("Content-Type", "text/html") : extra) res
-        catchAppException $
+        runHandlers
-          runInIO $
+          runApplication
-            runHandlers
+          [ Handler
-              [ Handler
+              { path = "",
-                  { path = "",
+                body =
-                    body =
+                  Body
-                      Body
+                    (pure ())
-                        (pure ())
+                    (\((), _) -> pure $ h [] (renderHtml mainPage))
-                        (\((), _) -> pure $ h [] (renderHtml mainPage))
+              },
-                  },
+            Handler
-                Handler
+              { path = "snips/table-opening-hours-last-week",
-                  { path = "snips/table-opening-hours-last-week",
+                body =
-                    body =
+                  Body
-                      Body
+                    ((label @"ifModifiedSince" <$> parseIfModifiedSince))
-                        ((label @"ifModifiedSince" <$> parseIfModifiedSince))
+                    ( \(req', cache) -> do
-                        ( \(req', cache) -> liftIO $ do
+                        now <- liftIO getCurrentTime <&> mkSecondTime
-                            now <- getCurrentTime <&> mkSecondTime
+                        new <- updateCacheIfNewer now cache heatmap
-                            new <- runInIO $ updateCacheIfNewer now cache heatmap
+                        let cacheToHeaders =
-                            let cacheToHeaders =
+                              [ ("Last-Modified", new.lastModified & formatHeaderTime),
-                                  [ ("Last-Modified", new.lastModified & formatHeaderTime),
+                                ("Expires", new.until & formatHeaderTime),
-                                    ("Expires", new.until & formatHeaderTime),
+                                ( "Cache-Control",
-                                    ( "Cache-Control",
+                                  let maxAge = new.until `diffSecondTime` now
-                                      let maxAge = new.until `diffSecondTime` now
+                                   in [fmt|max-age={maxAge & floor @NominalDiffTime @Int  & show}, immutable|]
-                                       in [fmt|max-age={maxAge & floor @NominalDiffTime @Int  & show}, immutable|]
+                                )
-                                    )
+                              ]
-                                  ]
+                        if
-                            if
+                            -- If the last cache update is newer or equal to the requested version, we can tell the browser it’s fine
-                                -- If the last cache update is newer or equal to the requested version, we can tell the browser it’s fine
+                            | Just modifiedSince <- req'.ifModifiedSince,
-                                | Just modifiedSince <- req'.ifModifiedSince,
+                              modifiedSince >= new.lastModified ->
-                                  modifiedSince >= new.lastModified ->
+                                pure $ Wai.responseLBS Http.status304 cacheToHeaders ""
-                                    pure $ Wai.responseLBS Http.status304 cacheToHeaders ""
+                            | otherwise ->
-                                | otherwise ->
+                                pure $ h cacheToHeaders (new.result & toLazyBytes)
-                                    pure $ h cacheToHeaders (new.result & toLazyBytes)
+                    )
-                        )
+              }
-                  }
+          ]
-              ]
-              req
-              (\resp -> liftIO $ respond resp)
 
   runReaderT (appT :: AppT IO ()).unAppT Context {..}
   where
@@ -196,55 +203,6 @@ parseRequest span parser req =
   Parse.runParse "Unable to parse the HTTP request" parser req
     & assertM span id
 
-data Handler m = Handler
-  { path :: Text,
-    body :: Body m
-  }
-
-data Body m
-  = forall a.
-    Body
-      (Parse Wai.Request a)
-      ((a, TVar (Cache ByteString)) -> m Wai.Response)
-
-runHandlers ::
-  (Otel.MonadTracer m, MonadUnliftIO m, MonadThrow m) =>
-  [Handler m] ->
-  Wai.Request ->
-  (Wai.Response -> m Wai.ResponseReceived) ->
-  m Wai.ResponseReceived
-runHandlers handlers req respond = do
-  withCaches ::
-    [ T2
-        "handler"
-        (Handler m)
-        "cache"
-        (TVar (Cache ByteString))
-    ] <-
-    handlers
-      & traverse
-        ( \h -> do
-            cache <- liftIO $ newCache "nothing yet"
-            pure $ T2 (label @"handler" h) (label @"cache" cache)
-        )
-  let mHandler =
-        withCaches
-          & List.find
-            ( \h ->
-                (h.handler.path)
-                  == (req & Wai.pathInfo & Text.intercalate "/")
-            )
-  case mHandler of
-    Nothing -> respond $ Wai.responseLBS Http.status404 [] "nothing here (yet)"
-    Just handler -> do
-      inSpan' "TODO" $ \span -> do
-        let h :: Handler m = handler.handler
-        case h.body of
-          Body parse runHandler -> do
-            req' <- req & parseRequest span parse
-            resp <- runHandler (req', handler.cache)
-            respond resp
-
 heatmap :: AppT IO ByteString
 heatmap = do
   Http.httpBS [fmt|GET {mapallSpaceOla}|]
@@ -296,6 +254,59 @@ main =
 --       htmlUi
 -- )
 
+data Handler m = Handler
+  { path :: Text,
+    body :: Body m
+  }
+
+data Body m
+  = forall a.
+    Body
+      (Parse Wai.Request a)
+      ((a, TVar (Cache ByteString)) -> m Wai.Response)
+
+runHandlers ::
+  (Otel.MonadTracer m, MonadUnliftIO m, MonadThrow m) =>
+  -- ( (Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived) ->
+  --   m ()
+  -- ) ->
+  ( (Wai.Request -> (Wai.Response -> m a) -> m a) ->
+    m ()
+  ) ->
+  [Handler m] ->
+  m ()
+runHandlers runApplication handlers = do
+  withCaches ::
+    [ T2
+        "handler"
+        (Handler m)
+        "cache"
+        (TVar (Cache ByteString))
+    ] <-
+    handlers
+      & traverse
+        ( \h -> do
+            cache <- liftIO $ newCache h.path "nothing yet"
+            pure $ T2 (label @"handler" h) (label @"cache" cache)
+        )
+  runApplication $ \req respond -> do
+    let mHandler =
+          withCaches
+            & List.find
+              ( \h ->
+                  (h.handler.path)
+                    == (req & Wai.pathInfo & Text.intercalate "/")
+              )
+    case mHandler of
+      Nothing -> respond $ Wai.responseLBS Http.status404 [] "nothing here (yet)"
+      Just handler -> do
+        inSpan' "TODO" $ \span -> do
+          case handler.handler.body of
+            Body parse runHandler -> do
+              req' <- req & parseRequest span parse
+              resp <- runHandler (req', handler.cache)
+              respond resp
+
 inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
 inSpan name = Otel.inSpan name Otel.defaultSpanArguments
 
@@ -403,14 +414,16 @@ diffSecondTime :: SecondTime -> SecondTime -> NominalDiffTime
 diffSecondTime (SecondTime a) (SecondTime b) = diffUTCTime a b
 
 data Cache a = Cache
-  { until :: !SecondTime,
+  { name :: !Text,
+    until :: !SecondTime,
     lastModified :: !SecondTime,
     result :: !a
   }
+  deriving (Show)
 
-newCache :: a -> IO (TVar (Cache a))
+newCache :: Text -> a -> IO (TVar (Cache a))
-newCache result = do
+newCache name result = do
-  until <- getCurrentTime <&> mkSecondTime
+  let until = mkSecondTime $ Time.UTCTime {utctDay = Time.ModifiedJulianDay 1, utctDayTime = 1}
   let lastModified = until
   newTVarIO $ Cache {..}
 
@@ -421,6 +434,7 @@ updateCache now cache result' = do
   let until = mkSecondTime $ (5 * 60) `addUTCTime` now.unSecondTime
   !toWrite <- do
     old <- readTVar cache
+    let name = old.name
     -- only update the lastModified time iff the content changed (this is helpful for HTTP caching with If-Modified-Since)
     if old.result == result
       then do
@@ -436,7 +450,7 @@ updateCache now cache result' = do
 updateCacheIfNewer :: (MonadUnliftIO m, NFData b, Eq b) => SecondTime -> TVar (Cache b) -> m b -> m (Cache b)
 updateCacheIfNewer now cache act = withRunInIO $ \runInIO -> do
   old <- readTVarIO cache
-  if old.until <= now
+  if old.until < now
     then do
       res <- runInIO act
       atomically $ updateCache now cache res