acms serve serves `APPROOT`

2 files changed, 27 insertions, 2 deletions

diff --git a/acms/acms.cabal b/acms/acms.cabal
index 0c43b1a..96e3f99 100644
--- a/acms/acms.cabal
+++ b/acms/acms.cabal
@@ -88,8 +88,9 @@ library
           uuid,
           vector,
           wai,
+          wai-app-static,
           wai-cors,
-          warp
+          warp,
 
 
 executable acms
@@ -106,7 +107,7 @@ executable acms
         optparse-applicative,
         sh,
         text,
-        utf8-string
+        utf8-string,
 
     if arch(javascript)
         buildable: False
diff --git a/acms/src/ACMS/ACMS.hs b/acms/src/ACMS/ACMS.hs
index e09132d..c0046f4 100644
--- a/acms/src/ACMS/ACMS.hs
+++ b/acms/src/ACMS/ACMS.hs
@@ -34,6 +34,7 @@ import Git qualified as G
 import Git.Libgit2 qualified as GB
 import Network.HTTP.Types.Status qualified as W
 import Network.Wai qualified as W
+import Network.Wai.Application.Static
 import Network.Wai.Handler.Warp qualified as W
 import Network.Wai.Middleware.Cors (simpleCors)
 import Safe
@@ -44,9 +45,11 @@ import System.Exit
 import System.FilePath
 import System.INotify
 import System.IO qualified as IO
+import System.IO.Unsafe (unsafePerformIO)
 import System.Random
 import Text.Printf (printf)
 import Version
+import WaiAppStatic.Types (unsafeToPiece)
 
 getUUID :: IO U.UUID
 getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED"
@@ -309,6 +312,7 @@ run (Config {serverPort, contentRepositoryPath}) = do
               & W.setHost hostPref
           )
           . simpleCors
+          . adminPanel
           . restApi root ref repoT
           . queryApi root ref repoT
           $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found"))
@@ -317,6 +321,26 @@ run (Config {serverPort, contentRepositoryPath}) = do
   logStderr ("Serving " ++ contentRepositoryPath ++ " on port " ++ show serverPort ++ ".")
   either throwIO pure =<< takeMVar stopM
 
+adminPanel :: W.Middleware
+adminPanel app req resp =
+  maybe
+    (app req resp)
+    ( \root -> case W.pathInfo req of
+        ("admin" : pathInfo) ->
+          staticApp
+            ( (defaultWebAppSettings root)
+                { ssAddTrailingSlash = True,
+                  ssIndices = [unsafeToPiece "index.html"]
+                }
+            )
+            req
+              { W.pathInfo = pathInfo
+              }
+            resp
+        _ -> app req resp
+    )
+    (unsafePerformIO (lookupEnv "APPROOT"))
+
 data InvalidSchemaVersion = InvalidSchemaVersion String
   deriving (Show)