From 17d0cc0473494d17531816812958f2f28d243658 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Fri, 20 Oct 2023 13:40:10 +0200 Subject: feat(users/Profpatsch/openlab-tools): main page Change-Id: I3e8b7ed9993268fab49050fb6894e3cc21e4a318 Reviewed-on: https://cl.tvl.fyi/c/depot/+/9804 Autosubmit: Profpatsch Reviewed-by: Profpatsch Tested-by: BuildkiteCI --- users/Profpatsch/openlab-tools/default.nix | 1 + users/Profpatsch/openlab-tools/openlab-tools.cabal | 1 + users/Profpatsch/openlab-tools/src/OpenlabTools.hs | 86 +++++++++++++++++++--- 3 files changed, 78 insertions(+), 10 deletions(-) (limited to 'users') diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix index 168917f1b4..1966c62a7c 100644 --- a/users/Profpatsch/openlab-tools/default.nix +++ b/users/Profpatsch/openlab-tools/default.nix @@ -28,6 +28,7 @@ let pkgs.haskellPackages.hs-opentelemetry-sdk pkgs.haskellPackages.http-conduit pkgs.haskellPackages.http-types + pkgs.haskellPackages.ihp-hsx pkgs.haskellPackages.monad-logger pkgs.haskellPackages.selective pkgs.haskellPackages.unliftio diff --git a/users/Profpatsch/openlab-tools/openlab-tools.cabal b/users/Profpatsch/openlab-tools/openlab-tools.cabal index 590f2deb2a..369a1cabb8 100644 --- a/users/Profpatsch/openlab-tools/openlab-tools.cabal +++ b/users/Profpatsch/openlab-tools/openlab-tools.cabal @@ -83,6 +83,7 @@ library hs-opentelemetry-api, http-conduit, http-types, + ihp-hsx, monad-logger, mtl, network-uri, diff --git a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs index e6a9dd1fef..00cf40f678 100644 --- a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs +++ b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs @@ -19,6 +19,7 @@ import Data.Time.Clock (addUTCTime) import Debug.Trace import GHC.Records (HasField (..)) import GHC.Stack qualified +import IHP.HSX.QQ (hsx) import Json qualified import Label import Network.HTTP.Client.Conduit qualified as Http @@ -35,10 +36,83 @@ import PossehlAnalyticsPrelude import Pretty import System.Environment qualified as Env import System.IO qualified as IO +import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty +import Text.Blaze.Html.Renderer.Utf8 qualified as Html +import Text.Blaze.Html5 qualified as Html import Text.HTML.TagSoup qualified as Soup import UnliftIO import Prelude hiding (span, until) +mainPage :: Html.Html +mainPage = + Html.docTypeHtml + [hsx| + + Openlab Augsburg Tools + + + + + +

Welcome to the OpenLab Augsburg tools thingy. The idea is to provide some services that can be embedded into our other pages.

+ +

What’s there

+ + + +

Show me the code/how to contribute

+ +

The source code can be found in my user dir in the tvl repo.

+ +

To build the server, clone the repository from https://code.tvl.fyi/depot.git. + Then cd into users/Profpatsch, run nix-shell. +

+ +

You can now run the server with cabal repl openlab-tools/` by executing the main function inside the GHC repl. It starts on port 9099. +
+ To try out changes to the code, stop the server with Ctrl+z and type :reload, then main again. +
+ Finally, from within users/Profpatsch you can start a working development environment by installing vscode or vscodium and the Haskell extension. Then run code . from within the directory. +

+ + + |] + +debug :: Bool +debug = False + +runApp :: IO () +runApp = withTracer $ \tracer -> do + cache <- newCache "" + let renderHtml = + if debug + 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 [] "") + + catchAppException $ do + case req & Wai.pathInfo & Text.intercalate "/" of + "" -> do + respond $ Wai.responseLBS Http.status200 [] (renderHtml mainPage) + "snips/table-opening-hours-last-week" -> do + new <- runInIO $ updateCacheIfNewer cache heatmap + + respond $ Wai.responseLBS Http.status200 [] (new & toLazyBytes) + _ -> do respond $ Wai.responseLBS Http.status404 [] "nothing here (yet)" + + runReaderT appT.unAppT Context {..} + heatmap :: AppT IO ByteString heatmap = do Http.httpBS [fmt|GET https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg|] @@ -178,10 +252,12 @@ data Cache a = Cache result :: a } +newCache :: a -> IO (IORef (Cache a)) newCache result = do until <- getCurrentTime newIORef Cache {..} +updateCache :: IORef (Cache a) -> a -> IO () updateCache cache result = do until <- getCurrentTime <&> ((5 * 60) `addUTCTime`) _ <- writeIORef cache Cache {..} @@ -198,16 +274,6 @@ updateCacheIfNewer cache act = withRunInIO $ \runInIO -> do pure res else pure old.result -runApp :: IO () -runApp = withTracer $ \tracer -> do - cache <- newCache "" - let appT = withRunInIO $ \runInIO -> Warp.run 9099 $ \req respond -> do - new <- runInIO $ updateCacheIfNewer cache heatmap - - respond $ Wai.responseLBS Http.status200 [] (new & toLazyBytes) - - runReaderT appT.unAppT Context {..} - -- pgFormat <- readTools (label @"toolsEnvVar" "OPENLAB_TOOLS_TOOLS") (readTool "pg_format") -- let config = label @"logDatabaseQueries" LogDatabaseQueries -- pgConnPool <- -- cgit 1.4.1