diff options
| -rw-r--r-- | users/Profpatsch/openlab-tools/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/openlab-tools/openlab-tools.cabal | 1 | ||||
| -rw-r--r-- | users/Profpatsch/openlab-tools/src/OpenlabTools.hs | 86 |
3 files changed, 78 insertions, 10 deletions
diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix index 168917f1b491..1966c62a7c16 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 590f2deb2aaa..369a1cabb82a 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 e6a9dd1feff1..00cf40f678e8 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| + <head> + <title>Openlab Augsburg Tools</title> + <meta charset="utf-8"> + <meta name="viewport" content="width=device-width, initial-scale=1"> + </head> + + <body> + <p>Welcome to the OpenLab Augsburg tools thingy. The idea is to provide some services that can be embedded into our other pages.</p> + + <h2>What’s there</h2> + <ul> + <li> + A <a href="snips/table-opening-hours-last-week">table displaying the opening hours last week</a>, courtesy of <a href="https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg">mapall.space</a>. + </li> + </ul> + + + <h2>Show me the code/how to contribute</h2> + + <p>The source code can be found <a href="https://code.tvl.fyi/tree/users/Profpatsch/openlab-tools">in my user dir in the tvl repo</a>.</p> + + <p>To build the server, clone the repository from <a href="https://code.tvl.fyi/depot.git">https://code.tvl.fyi/depot.git</a>. + Then <code>cd</code> into <code>users/Profpatsch</code>, run <code>nix-shell</code>. + </p> + + <p>You can now run the server with <code>cabal repl openlab-tools/`</code> by executing the <code>main</code> function inside the GHC repl. It starts on port <code>9099</code>. + <br> + To try out changes to the code, stop the server with <kbd><kbd>Ctrl</kbd>+<kbd>z</kbd></kbd> and type <code>:reload</code>, then <code>main</code> again. + <br> + Finally, from within <code>users/Profpatsch</code> you can start a working development environment by installing <var>vscode</var> or <var>vscodium</var> and the <var>Haskell</var> extension. Then run <code>code .</code> from within the directory. + </p> + + </body> + |] + +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 <- |