summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2021-03-24 21:10:04 -0400
committerBen Sima <ben@bsima.me>2021-03-24 21:10:04 -0400
commit82e8dc3d0f747a5737359228eebb02f7a5ab7912 (patch)
treea76321cc786f6c1dcb375407d4bb97afa9126516
parentf126ce71dd858a855ddaf3ed885415bec60bd188 (diff)
Add a simple admin page
-rw-r--r--Biz/Devalloc.hs54
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)