From 751b725332fd0e9397b7cfd3f3a3bff14056c232 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Tue, 7 Apr 2020 22:07:07 -0700
Subject: Return the app state as a simple dashboard

---
 Run/Que/Server.hs | 28 +++++++++++++++++++---------
 1 file changed, 19 insertions(+), 9 deletions(-)

(limited to 'Run/Que')

diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs
index 4974498..146a16a 100644
--- a/Run/Que/Server.hs
+++ b/Run/Que/Server.hs
@@ -35,6 +35,7 @@ import qualified Data.Text.Encoding            as Encoding
 import           Data.Text.Lazy                 ( Text
                                                 , fromStrict
                                                 )
+import qualified Data.Text.Lazy.IO             as Text
 import qualified Network.HTTP.Types.Status     as Http
 import qualified Network.Wai                   as Wai
 import qualified Network.Wai.Handler.Warp      as Warp
@@ -84,6 +85,19 @@ routes = do
   Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index"
   Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index"
 
+  -- | GET /_/dash
+  Scotty.get (Scotty.literal "/_/dash") <| do
+    authkey  <- fromMaybe "" </ Scotty.header "Authorization"
+    adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
+    if authkey == adminkey
+      then do
+        d <- app <| gets ques
+        Scotty.json d
+      else do
+        Scotty.status Http.methodNotAllowed405
+        Scotty.text "not allowed"
+
+
   -- | Namespace management
   Scotty.matchAny (Scotty.regex namespace) <| do
     Scotty.status Http.notImplemented501
@@ -110,17 +124,13 @@ routes = do
   --
   -- Put a value on a que. Returns immediately.
   Scotty.post (Scotty.regex quepath) <| do
-    xFwdHost <- Scotty.header "X-Forwarded-Host"
-    xRealIP  <- Scotty.header "X-Real-IP"
-    host     <- Scotty.header "Host"
+    authkey  <- fromMaybe "" </ Scotty.header "Authorization"
+    adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
     (ns, qp) <- extract
     -- Only allow my IP or localhost to publish to '_' namespace
-    when ("_" == ns) <| case (xFwdHost, xRealIP, host) of
-      (Just "73.222.221.62", _, _) -> Scotty.status Http.ok200
-      (_, Just "73.222.221.62", _) -> Scotty.status Http.ok200
-      (_, _, Just ("localhost:3000")) -> Scotty.status Http.ok200
-      _ -> Scotty.status Http.methodNotAllowed405
-        >> Scotty.text "not allowed: _ is a reserved namespace"
+    when ("_" == ns && authkey /= adminkey)
+      <| Scotty.status Http.methodNotAllowed405
+      >> Scotty.text "not allowed: _ is a reserved namespace"
     guardNs ns ["pub", "_"]
     -- passed all auth checks
     app . modify <| upsertNamespace ns
-- 
cgit v1.2.3