diff options
| author | Profpatsch <mail@profpatsch.de> | 2023-10-20T11·40+0200 |
|---|---|---|
| committer | clbot <clbot@tvl.fyi> | 2023-10-20T11·43+0000 |
| commit | 17d0cc0473494d17531816812958f2f28d243658 (patch) | |
| tree | 2717af607a19f0f3679e303a67bf7ebcec11b6cd /users/Profpatsch/openlab-tools/src | |
| parent | efbffcd12dfcb1bff4a29b8e91b59428c9ad2dbe (diff) | |
feat(users/Profpatsch/openlab-tools): main page r/6859
Change-Id: I3e8b7ed9993268fab49050fb6894e3cc21e4a318 Reviewed-on: https://cl.tvl.fyi/c/depot/+/9804 Autosubmit: Profpatsch <mail@profpatsch.de> Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI
Diffstat (limited to 'users/Profpatsch/openlab-tools/src')
| -rw-r--r-- | users/Profpatsch/openlab-tools/src/OpenlabTools.hs | 86 |
1 files changed, 76 insertions, 10 deletions
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 <- |