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

---
 Com/Simatime/Alpha.hs | 13 +++++++++++++
 Com/Simatime/Go.hs    |  5 +++++
 Run/Que/Server.hs     | 28 +++++++++++++++++++---------
 3 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/Com/Simatime/Alpha.hs b/Com/Simatime/Alpha.hs
index 8f5a506..cc3d23c 100644
--- a/Com/Simatime/Alpha.hs
+++ b/Com/Simatime/Alpha.hs
@@ -11,6 +11,9 @@ module Com.Simatime.Alpha
   , (/>)
   , (</)
   , (<//)
+  -- * Text
+  , chomp
+  , lchomp
   -- * Debugging tools
   , say
   -- * TODO: remove this
@@ -22,6 +25,8 @@ import           Data.Function                  ( (&) )
 import           Data.Functor                   ( (<&>) )
 import           Data.String
 import           Data.Text                      ( Text )
+import qualified Data.Text                     as Text
+import qualified Data.Text.Lazy                as LazyText
 import qualified Prelude
 import           Protolude                     as X
 
@@ -63,3 +68,11 @@ infixr 0 <|
 -- functor. Could also be defined as `f >>= return . g`
 (/>) :: Functor f => f a -> (a -> b) -> f b
 (/>) = (<&>)
+
+-- | Removes newlines from text.
+chomp :: Text -> Text
+chomp = Text.filter (/= '\n')
+
+-- | Removes newlines from lazy text.
+lchomp :: LazyText.Text -> LazyText.Text
+lchomp = LazyText.filter (/= '\n')
diff --git a/Com/Simatime/Go.hs b/Com/Simatime/Go.hs
index bd9296a..e622539 100644
--- a/Com/Simatime/Go.hs
+++ b/Com/Simatime/Go.hs
@@ -7,6 +7,7 @@ Golang and Clojure's core.async.
 $example
 -}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Com.Simatime.Go
   (
   -- * Running and forking
@@ -25,6 +26,7 @@ import           Com.Simatime.Alpha      hiding ( read )
 import qualified Control.Concurrent            as Concurrent
 import qualified Control.Concurrent.Chan.Unagi.Bounded
                                                as Chan
+import qualified Data.Aeson                    as Aeson
 
 -- | A standard channel.
 data Channel a = Channel
@@ -33,6 +35,9 @@ data Channel a = Channel
   , _size :: Int
   }
 
+instance Aeson.ToJSON (Channel a) where
+  toJSON _ = Aeson.String ("#<channel>" :: Text)
+
 -- | Starts a background process.
 fork :: IO () -> IO Concurrent.ThreadId
 fork = Concurrent.forkIO
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