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
This commit is contained in:
Profpatsch
clbot
parent
3b882d7510
commit
23c811a2a0
1 changed files with 113 additions and 99 deletions
|
|
@ -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 catchAppException act =
|
||||
try act >>= \case
|
||||
Right a -> pure a
|
||||
Left (AppException err) -> do
|
||||
runInIO (logError err)
|
||||
respond (Wai.responseLBS Http.status500 [] "")
|
||||
let runApplication ::
|
||||
(MonadUnliftIO m, MonadLogger m) =>
|
||||
( Wai.Request ->
|
||||
(Wai.Response -> m Wai.ResponseReceived) ->
|
||||
m Wai.ResponseReceived
|
||||
) ->
|
||||
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 $
|
||||
runInIO $
|
||||
runHandlers
|
||||
[ Handler
|
||||
{ path = "",
|
||||
body =
|
||||
Body
|
||||
(pure ())
|
||||
(\((), _) -> pure $ h [] (renderHtml mainPage))
|
||||
},
|
||||
Handler
|
||||
{ path = "snips/table-opening-hours-last-week",
|
||||
body =
|
||||
Body
|
||||
((label @"ifModifiedSince" <$> parseIfModifiedSince))
|
||||
( \(req', cache) -> liftIO $ do
|
||||
now <- getCurrentTime <&> mkSecondTime
|
||||
new <- runInIO $ updateCacheIfNewer now cache heatmap
|
||||
let cacheToHeaders =
|
||||
[ ("Last-Modified", new.lastModified & formatHeaderTime),
|
||||
("Expires", new.until & formatHeaderTime),
|
||||
( "Cache-Control",
|
||||
let maxAge = new.until `diffSecondTime` now
|
||||
in [fmt|max-age={maxAge & floor @NominalDiffTime @Int & show}, immutable|]
|
||||
)
|
||||
]
|
||||
if
|
||||
-- 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,
|
||||
modifiedSince >= new.lastModified ->
|
||||
pure $ Wai.responseLBS Http.status304 cacheToHeaders ""
|
||||
| otherwise ->
|
||||
pure $ h cacheToHeaders (new.result & toLazyBytes)
|
||||
)
|
||||
}
|
||||
]
|
||||
req
|
||||
(\resp -> liftIO $ respond resp)
|
||||
runHandlers
|
||||
runApplication
|
||||
[ Handler
|
||||
{ path = "",
|
||||
body =
|
||||
Body
|
||||
(pure ())
|
||||
(\((), _) -> pure $ h [] (renderHtml mainPage))
|
||||
},
|
||||
Handler
|
||||
{ path = "snips/table-opening-hours-last-week",
|
||||
body =
|
||||
Body
|
||||
((label @"ifModifiedSince" <$> parseIfModifiedSince))
|
||||
( \(req', cache) -> do
|
||||
now <- liftIO getCurrentTime <&> mkSecondTime
|
||||
new <- updateCacheIfNewer now cache heatmap
|
||||
let cacheToHeaders =
|
||||
[ ("Last-Modified", new.lastModified & formatHeaderTime),
|
||||
("Expires", new.until & formatHeaderTime),
|
||||
( "Cache-Control",
|
||||
let maxAge = new.until `diffSecondTime` now
|
||||
in [fmt|max-age={maxAge & floor @NominalDiffTime @Int & show}, immutable|]
|
||||
)
|
||||
]
|
||||
if
|
||||
-- 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,
|
||||
modifiedSince >= new.lastModified ->
|
||||
pure $ Wai.responseLBS Http.status304 cacheToHeaders ""
|
||||
| otherwise ->
|
||||
pure $ h cacheToHeaders (new.result & toLazyBytes)
|
||||
)
|
||||
}
|
||||
]
|
||||
|
||||
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 result = do
|
||||
until <- getCurrentTime <&> mkSecondTime
|
||||
newCache :: Text -> a -> IO (TVar (Cache a))
|
||||
newCache name result = do
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue