diff options
| -rw-r--r-- | Biz/Devalloc.hs | 106 |
1 files changed, 92 insertions, 14 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 667b6fe..91668c3 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -327,6 +327,10 @@ data Paths path = Paths { home :: path :- Get '[Lucid.HTML] (HtmlApp Home), + login :: + path + :- "login" + :> Verb 'GET 301 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent), githubAuth :: path :- "auth" @@ -334,6 +338,11 @@ data Paths path = Paths :> "callback" :> QueryParam "code" Text :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)), + account :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "account" + :> Get '[Lucid.HTML] (HtmlApp UserHome), selectRepo :: path :- Auth.Auth '[Auth.Cookie] User @@ -346,7 +355,7 @@ data Paths path = Paths :> "github" :> Capture "user" Text :> Capture "repo" Text - :> Get '[Lucid.HTML] (HtmlApp Analysis), + :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay), css :: path :- "css" @@ -373,8 +382,14 @@ htmlApp cooks kp cfg jwk oAuthArgs = Paths { home = pure <. HtmlApp <| Home oAuthArgs, + login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, githubAuth = auth kp cooks jwk oAuthArgs, + account = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user -> pure <| HtmlApp <| UserHome user, selectRepo = \case Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} Auth.BadPassword -> throwError err401 {errBody = "Bad password"} @@ -399,12 +414,34 @@ htmlApp cooks kp cfg jwk oAuthArgs = cfg owner repo - >>= HtmlApp + >>= AnalysisDisplay user + .> HtmlApp .> pure, css = return <. toStrict <. Clay.render <| do Biz.Look.fuckingStyle "body" Clay.? Biz.Look.fontStack + "nav" Clay.? do + Clay.display Clay.flex + Clay.justifyContent Clay.spaceBetween + "nav > ul" Clay.? do + Clay.display Clay.flex + Clay.justifyContent Clay.flexEnd + Clay.listStyleType <| Clay.none + Clay.margin (Clay.px 0) 0 0 0 + "nav > ul > li" Clay.? do + Clay.padding 0 (Clay.px 5) 0 (Clay.px 5) + {- + - nav > ul { + display: flex; + justify-content: flex-end; + list-style: none; + } + + nav > ul > li { + padding: 0 5px; + } + - -} } -- | The front page pitch. Eventually I'd like to load the content from markdown @@ -414,7 +451,7 @@ newtype Home = Home OAuthArgs instance Lucid.ToHtml Home where toHtmlRaw = Lucid.toHtml toHtml (Home oAuthArgs) = do - Lucid.h1_ "Devalloc" + Lucid.toHtml <| nav Nothing Lucid.p_ "Devalloc analyzes your codebase trends, finds patterns \ \ in how your developers work, and protects against tech debt." @@ -447,6 +484,7 @@ newtype UserHome = UserHome User instance Lucid.ToHtml UserHome where toHtmlRaw = Lucid.toHtml toHtml (UserHome user) = do + Lucid.toHtml <| nav <| Just user Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" Lucid.p_ <| Lucid.a_ @@ -511,12 +549,21 @@ getAccessToken OAuthArgs {..} code = <> "code" =: code <> "state" =: githubState +githubLoginUrl :: OAuthArgs -> Text +githubLoginUrl OAuthArgs {..} = + "https://github.com/login/oauth/authorize?" + <> encodeParams + [ ("client_id", githubClientId), + ("state", githubState) + ] + -- | This view presents a list of repos to select for analysis. data SelectRepo = SelectRepo User (Vector GitHub.Repo) instance Lucid.ToHtml SelectRepo where toHtmlRaw = Lucid.toHtml toHtml (SelectRepo user repos) = do + Lucid.toHtml <. nav <| Just user Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" Lucid.h2_ "Select a repo to analyze" Lucid.ul_ <| forM_ (Vector.toList repos) <| \repo -> @@ -545,19 +592,46 @@ encodeParams = -- | Login button for GitHub. loginButton :: OAuthArgs -> Lucid.Html () -loginButton OAuthArgs {..} = +loginButton oAuthArgs = Lucid.a_ - [ Lucid.href_ - <| "https://github.com/login/oauth/authorize?" - <> encodeParams - [ ("client_id", githubClientId), - ("state", githubState) - ] - ] + [Lucid.href_ <| githubLoginUrl oAuthArgs] "Get Started with GitHub" +-- | Universal top navbar +-- nav :: (Applicative m, Monad m) => Maybe User -> Lucid.HtmlT m () +nav :: Maybe User -> Lucid.Html () +nav = \case + Nothing -> + Lucid.nav_ <| do + a "Devalloc" <| fieldLink home + Lucid.ul_ <| do + li "Login" <| fieldLink login + li "Pricing" <| fieldLink home + Just u -> + Lucid.nav_ <| do + a "Devalloc" <| fieldLink home + Lucid.ul_ + <| li "My Account" + <| fieldLink account + where + a :: Text -> Link -> Lucid.Html () + a txt href = + Lucid.a_ [Lucid.linkHref_ "/" href] <| Lucid.toHtml txt + li :: Text -> Link -> Lucid.Html () + li txt href = Lucid.li_ <| a txt href + -- * analysis +-- | I need more information than just 'Analysis' has to render a full, useful +-- web page, hence this type. +data AnalysisDisplay = AnalysisDisplay User Analysis + +instance Lucid.ToHtml AnalysisDisplay where + toHtmlRaw = Lucid.toHtml + toHtml (AnalysisDisplay user anal) = do + Lucid.toHtml <. nav <| Just user + Lucid.toHtml anal + -- | The result of analyzing a git repo. data Analysis = Analysis { -- | Where the repo is stored on the local disk. @@ -671,6 +745,7 @@ lastTouched bareRepo path = do ] "" /> filter (/= '\n') + -- TODO: this fails if time is empty? /> Time.parseTimeOrError True Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" let days = round <| Clock.diffUTCTime now timestamp / Clock.nominalDay return (path, days) @@ -743,9 +818,12 @@ analyzeGitHub githubAuth cfg o r = do -- assume the only active author is the owner, for now -- TODO: should be userEmail but that requires authentication? let activeAuthors = [require "user email" <| GitHub.userName user] - Right repo <- GitHub.github () (GitHub.repositoryR ghOwner ghRepo) - bareRepo <- fetchBareRepo cfg <. GitHub.getUrl <| GitHub.repoHtmlUrl repo - analyze activeAuthors bareRepo + eRepo <- GitHub.github githubAuth (GitHub.repositoryR ghOwner ghRepo) + case eRepo of + Left err -> throwIO <| toException err + Right repo -> do + bareRepo <- fetchBareRepo cfg <. GitHub.getUrl <| GitHub.repoHtmlUrl repo + analyze activeAuthors bareRepo where ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r |