From 485af1d460be0979b7093da307f379ef088a98db Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 10 Feb 2022 00:14:43 +0100
Subject: server: simple servant-lucid stuff

---
 server/Main.hs | 25 ++++++++++++++++++-------
 1 file changed, 18 insertions(+), 7 deletions(-)

(limited to 'server/Main.hs')

diff --git a/server/Main.hs b/server/Main.hs
index 0fbc4b4..00b4689 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -22,14 +22,15 @@ import           Network.Wai.Handler.Warp   (run)
 import           Servant                    (Application, Capture, Get, Handler,
                                              HasServer (ServerT), JSON,
                                              NoContent, Post, Proxy (Proxy),
-                                             ReqBody, ServerError (errBody),
-                                             err500, hoistServer, serve,
-                                             throwError, type (:<|>) (..),
-                                             type (:>))
+                                             Raw, ReqBody,
+                                             ServerError (errBody), err500,
+                                             hoistServer, serve, throwError,
+                                             type (:<|>) (..), type (:>))
+import           Servant.HTML.Lucid         (HTML)
+import           Servant.Server.StaticFiles (serveDirectoryWebApp)
 import           Server                     (Config (..), JobStatus,
                                              RemoteRef (..), State,
                                              defaultState, loadConfig)
-
 {-
 Needed:
  - admin overview (perhaps on seperate port?)
@@ -48,6 +49,10 @@ type API format =
   :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus
   :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
 
+type Routes =
+   "api" :> API JSON
+  :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus
+  :<|> Raw
 
 -- | API's implementation
 jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App
@@ -56,11 +61,17 @@ jsonAPI config state =
   :<|> statusImpl state
   :<|> relintImpl config state
 
+server :: Config True -> MVar State -> ServerT Routes App
+server config state =
+  jsonAPI config state
+  :<|> statusImpl state
+  :<|> serveDirectoryWebApp "./static"
+
 -- | make an application; convert any cli errors into a 500
 app :: Config True -> MVar State -> Application
 app config =
-  serve api . hoistServer api conv . jsonAPI config
-  where api = Proxy @(API JSON)
+  serve api . hoistServer api conv . server config
+  where api = Proxy @Routes
         conv :: App a -> Handler a
         conv m = do
           config <- liftIO $ mkDefaultCliConfig []
-- 
cgit v1.2.3