diff options
| -rw-r--r-- | Biz/Devalloc.hs | 54 |
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) |