Add a simple admin page

1 files changed, 52 insertions, 2 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 0b4a88e..3f7afe5 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -765,7 +765,12 @@ data Paths path = Paths
         :> "analysis"
         :> QueryParam "user" Text
         :> QueryParam "repo" Text
-        :> Post '[Lucid.HTML] (App.Html AnalysisDisplay)
+        :> Post '[Lucid.HTML] (App.Html AnalysisDisplay),
+    admin ::
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "admin"
+        :> Get '[Lucid.HTML] (App.Html AdminDashboard)
   }
   deriving (Generic)
 
@@ -785,6 +790,18 @@ guardAuth = \case
   Auth.Indefinite -> throwError err401 {errBody = "No authentication found"}
   Auth.Authenticated user -> pure user
 
+guardAdmin ::
+  MonadError ServerError m =>
+  Auth.AuthResult User ->
+  m User
+guardAdmin = \case
+  Auth.NoSuchUser -> throwError err401 {errBody = "No such user"}
+  Auth.BadPassword -> throwError err401 {errBody = "Bad password"}
+  Auth.Indefinite -> throwError err401 {errBody = "No authentication found"}
+  Auth.Authenticated user@User {..}
+    | userGitHubId == GitHubId 200617 -> pure user
+    | otherwise -> throwError err401 {errBody = "You're not admin..."}
+
 requiredScopes :: Set Text
 requiredScopes = Set.fromList ["repo"]
 
@@ -903,7 +920,15 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               |> liftIO
               +> AnalysisDisplay user
               .> App.Html
-              .> pure
+              .> pure,
+      admin =
+        guardAdmin
+          >=> \user -> do
+            allUsers <- Acid.query' kp GetUsers
+            totalAnalyses <- length </ Acid.query' kp GetAllAnalyses
+            AdminDashboard {..}
+              |> App.Html
+              |> pure
     }
 
 baseStyle :: Clay.Css
@@ -1011,6 +1036,31 @@ yellow, black :: Clay.Color
 yellow = "#ffe000"
 black = "#121212"
 
+data AdminDashboard = AdminDashboard
+  { user :: User,
+    allUsers :: [User],
+    totalAnalyses :: Int
+  }
+
+instance App.HasCss AdminDashboard where
+  cssFor _ = mempty
+
+instance Lucid.ToHtml AdminDashboard where
+  toHtmlRaw = Lucid.toHtml
+  toHtml AdminDashboard {..} = do
+    header <| Just user
+    Lucid.main_ <| do
+      Lucid.section_ <| do
+        Lucid.h2_ <| Lucid.toHtml <| "Total Analyses: " <> tshow totalAnalyses
+        Lucid.h2_ "All Users"
+        Lucid.ul_
+          <| forM_ allUsers
+          <| \User {..} -> do
+            Lucid.li_ <| do
+              Lucid.toHtml <| unGitHubHandle userGitHubHandle
+
+    footer
+
 -- | The front page pitch. Eventually I'd like to load the content from markdown
 -- files or some other store of data so I can A/B test.
 data Home = Home OAuthArgs (Maybe Analysis)