feat(users/Profpatsch/openlab-tools): main page
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
This commit is contained in:
Profpatsch
clbot
parent
efbffcd12d
commit
17d0cc0473
3 changed files with 78 additions and 10 deletions
|
|
@ -28,6 +28,7 @@ let
|
||||||
pkgs.haskellPackages.hs-opentelemetry-sdk
|
pkgs.haskellPackages.hs-opentelemetry-sdk
|
||||||
pkgs.haskellPackages.http-conduit
|
pkgs.haskellPackages.http-conduit
|
||||||
pkgs.haskellPackages.http-types
|
pkgs.haskellPackages.http-types
|
||||||
|
pkgs.haskellPackages.ihp-hsx
|
||||||
pkgs.haskellPackages.monad-logger
|
pkgs.haskellPackages.monad-logger
|
||||||
pkgs.haskellPackages.selective
|
pkgs.haskellPackages.selective
|
||||||
pkgs.haskellPackages.unliftio
|
pkgs.haskellPackages.unliftio
|
||||||
|
|
|
||||||
|
|
@ -83,6 +83,7 @@ library
|
||||||
hs-opentelemetry-api,
|
hs-opentelemetry-api,
|
||||||
http-conduit,
|
http-conduit,
|
||||||
http-types,
|
http-types,
|
||||||
|
ihp-hsx,
|
||||||
monad-logger,
|
monad-logger,
|
||||||
mtl,
|
mtl,
|
||||||
network-uri,
|
network-uri,
|
||||||
|
|
|
||||||
|
|
@ -19,6 +19,7 @@ import Data.Time.Clock (addUTCTime)
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import GHC.Records (HasField (..))
|
import GHC.Records (HasField (..))
|
||||||
import GHC.Stack qualified
|
import GHC.Stack qualified
|
||||||
|
import IHP.HSX.QQ (hsx)
|
||||||
import Json qualified
|
import Json qualified
|
||||||
import Label
|
import Label
|
||||||
import Network.HTTP.Client.Conduit qualified as Http
|
import Network.HTTP.Client.Conduit qualified as Http
|
||||||
|
|
@ -35,10 +36,83 @@ import PossehlAnalyticsPrelude
|
||||||
import Pretty
|
import Pretty
|
||||||
import System.Environment qualified as Env
|
import System.Environment qualified as Env
|
||||||
import System.IO qualified as IO
|
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 Text.HTML.TagSoup qualified as Soup
|
||||||
import UnliftIO
|
import UnliftIO
|
||||||
import Prelude hiding (span, until)
|
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 :: AppT IO ByteString
|
||||||
heatmap = do
|
heatmap = do
|
||||||
Http.httpBS [fmt|GET https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg|]
|
Http.httpBS [fmt|GET https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg|]
|
||||||
|
|
@ -178,10 +252,12 @@ data Cache a = Cache
|
||||||
result :: a
|
result :: a
|
||||||
}
|
}
|
||||||
|
|
||||||
|
newCache :: a -> IO (IORef (Cache a))
|
||||||
newCache result = do
|
newCache result = do
|
||||||
until <- getCurrentTime
|
until <- getCurrentTime
|
||||||
newIORef Cache {..}
|
newIORef Cache {..}
|
||||||
|
|
||||||
|
updateCache :: IORef (Cache a) -> a -> IO ()
|
||||||
updateCache cache result = do
|
updateCache cache result = do
|
||||||
until <- getCurrentTime <&> ((5 * 60) `addUTCTime`)
|
until <- getCurrentTime <&> ((5 * 60) `addUTCTime`)
|
||||||
_ <- writeIORef cache Cache {..}
|
_ <- writeIORef cache Cache {..}
|
||||||
|
|
@ -198,16 +274,6 @@ updateCacheIfNewer cache act = withRunInIO $ \runInIO -> do
|
||||||
pure res
|
pure res
|
||||||
else pure old.result
|
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")
|
-- pgFormat <- readTools (label @"toolsEnvVar" "OPENLAB_TOOLS_TOOLS") (readTool "pg_format")
|
||||||
-- let config = label @"logDatabaseQueries" LogDatabaseQueries
|
-- let config = label @"logDatabaseQueries" LogDatabaseQueries
|
||||||
-- pgConnPool <-
|
-- pgConnPool <-
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue