diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix
index 168917f1b..1966c62a7 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 590f2deb2..369a1cabb 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 e6a9dd1fe..00cf40f67 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 <-