diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 441 |
1 files changed, 223 insertions, 218 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index bc1b83f..ce70f07 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -56,7 +56,7 @@ module Biz.Devalloc where import Alpha hiding (rem, (<.>)) -import Biz.App (CSS (..), HtmlApp (..)) +import qualified Biz.App as App import qualified Biz.Cli as Cli import qualified Biz.Id as Id import qualified Biz.Log as Log @@ -629,9 +629,9 @@ instance Envy.FromEnv OAuthArgs -- * paths and pages -- | Wraps pages in default HTML -instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where +instance (Lucid.ToHtml a, App.HasCss a) => Lucid.ToHtml (App.Html a) where toHtmlRaw = Lucid.toHtml - toHtml (HtmlApp x) = + toHtml (App.Html x) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Devalloc.io :: Know your codebase, know your team." @@ -645,9 +645,13 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where ] Lucid.meta_ [Lucid.charset_ "utf-8"] jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js" - cssRef "/css/main.css" + -- base styles + style baseStyle + -- page styles + style <| App.cssFor x Lucid.body_ (Lucid.toHtml x) where + style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.compact [] jsRef _href = Lucid.with (Lucid.script_ mempty) @@ -655,19 +659,12 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where Lucid.makeAttribute "async" mempty, Lucid.makeAttribute "defer" mempty ] - cssRef _href = - Lucid.with - (Lucid.link_ mempty) - [ Lucid.rel_ "stylesheet", - Lucid.type_ "text/css", - Lucid.href_ _href - ] -- | All of the routes in the app. data Paths path = Paths { home :: path - :- Get '[Lucid.HTML] (HtmlApp Home), + :- Get '[Lucid.HTML] (App.Html Home), login :: path :- "login" @@ -678,46 +675,41 @@ data Paths path = Paths :> "github" :> "callback" :> QueryParam "code" Text - :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserAccount)), + :> Get '[Lucid.HTML] (SetCookies (App.Html UserAccount)), getAccount :: path :- Auth.Auth '[Auth.Cookie] User :> "account" - :> Get '[Lucid.HTML] (HtmlApp UserAccount), + :> Get '[Lucid.HTML] (App.Html UserAccount), postAccount :: path :- Auth.Auth '[Auth.Cookie] User :> "account" :> ReqBody '[FormUrlEncoded] Subscription - :> Post '[Lucid.HTML] (HtmlApp UserAccount), + :> Post '[Lucid.HTML] (App.Html UserAccount), selectRepo :: path :- Auth.Auth '[Auth.Cookie] User :> "select-repo" - :> Get '[Lucid.HTML] (HtmlApp SelectRepo), + :> Get '[Lucid.HTML] (App.Html SelectRepo), getAnalyses :: path :- Auth.Auth '[Auth.Cookie] User :> "analysis" - :> Get '[Lucid.HTML] (HtmlApp Analyses), + :> Get '[Lucid.HTML] (App.Html Analyses), getAnalysis :: path :- Auth.Auth '[Auth.Cookie] User :> "analysis" :> Capture "analysisId" (Id.Id Analysis) - :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay), + :> Get '[Lucid.HTML] (App.Html AnalysisDisplay), postAnalysis :: path :- Auth.Auth '[Auth.Cookie] User :> "analysis" :> QueryParam "user" Text :> QueryParam "repo" Text - :> Post '[Lucid.HTML] (HtmlApp AnalysisDisplay), - css :: - path - :- "css" - :> "main.css" - :> Get '[CSS] Text + :> Post '[Lucid.HTML] (App.Html AnalysisDisplay) } deriving (Generic) @@ -771,7 +763,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = |> Acid.query' kp /> head /> Home oAuthArgs - /> HtmlApp, + /> App.Html, login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, githubAuth = \case @@ -800,18 +792,18 @@ htmlApp cooks kp cfg jwk oAuthArgs = -- I think this should redirect to instead of rendering UserAccount Just applyCookies -> UserAccount user - |> HtmlApp + |> App.Html |> applyCookies |> pure, getAccount = - guardAuth >=> UserAccount .> HtmlApp .> pure, + guardAuth >=> UserAccount .> App.Html .> pure, postAccount = \a subscription -> guardAuth a +> \user -> UpdateUser user {userSubscription = subscription} |> Acid.update' kp +> UserAccount - .> HtmlApp + .> App.Html .> pure, selectRepo = guardAuth @@ -822,14 +814,14 @@ htmlApp cooks kp cfg jwk oAuthArgs = |> liftIO +> \case Left err -> throwError err502 {errBody = show err} - Right repos -> pure <. HtmlApp <| SelectRepo user repos, + Right repos -> pure <. App.Html <| SelectRepo user repos, getAnalyses = guardAuth >=> \user@User {..} -> GetAnalysesByAsker user |> Acid.query' kp +> Analyses user - .> HtmlApp + .> App.Html .> pure, getAnalysis = \a analysisId -> guardAuth a @@ -838,7 +830,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = |> Acid.query' kp +> \case Nothing -> throwError err404 - Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, + Just analysis -> pure <| App.Html <| AnalysisDisplay user analysis, postAnalysis = \a mOwner mRepo -> guardAuth a +> \user@User {..} -> do @@ -854,197 +846,155 @@ htmlApp cooks kp cfg jwk oAuthArgs = repo |> liftIO +> AnalysisDisplay user - .> HtmlApp - .> pure, - css = - pure <. toStrict <. Clay.render <| do - let yellow = "#ffe000" - let black = "#121212" - Biz.Look.fuckingStyle - - Biz.Look.whenDark <| do - "body" ? do - Clay.backgroundColor black - "a:link" <> "a:visited" ? do - Clay.textDecorationColor Clay.white - Clay.color Clay.white - "a:hover" ? do - Clay.textDecorationColor yellow - "select" <> "button" <> "input" ? do - Clay.backgroundColor black - Clay.color Clay.white - - Biz.Look.whenLight <| do - "body" ? do - Clay.color black - "a:link" <> "a:visited" ? do - Clay.textDecorationColor black - Clay.color black - "a:hover" ? do - Clay.textDecorationColor yellow - "select" <> "button" <> "input" ? do - Clay.backgroundColor Clay.white - Clay.color black - - "body" ? Biz.Look.fontStack - "header" ? do - Clay.maxWidth (pct 100) - "footer" ? do - Clay.fontStyle Clay.italic - Clay.fontSize (rem 0.8) - Clay.marginTop (em 6) - Clay.marginBottom (em 6) - "a" ? do - Clay.transition "all" (sec 0.2) Clay.ease 0 - Clay.transitionProperties - [ "text-decoration-color", - "text-decoration-thickness", - "text-decoration-width" - ] - Clay.textDecoration Clay.underline - Biz.Look.textDecorationThickness (em 0.1) - Biz.Look.textDecorationWidth (em 0.1) - "a:hover" ? do - Clay.textDecorationColor yellow - Clay.textDecoration Clay.underline - Biz.Look.textDecorationThickness (em 0.2) - Biz.Look.textDecorationWidth (em 0.2) - - "select" <> "button" <> "input" ? do - Biz.Look.paddingAll (em 0.5) - Biz.Look.marginX (em 0.5) - Clay.borderColor yellow - Clay.borderStyle Clay.solid - - -- for making POST requests with a form disguised as a link - "input.link" ? do - Clay.borderWidth 0 - Clay.fontSize (rem 1) - Biz.Look.marginAll (px 0) - Biz.Look.paddingAll (px 0) - - "label" ? do - Clay.display Clay.inlineBlock - Clay.width (px 100) - - "nav" ? do - Clay.display Clay.flex - Clay.justifyContent Clay.spaceBetween - "a" ? do - Clay.padding (em 1) (em 1) (em 1) (em 1) - Clay.display Clay.block - "ul" ? do - Clay.display Clay.flex - Clay.justifyContent Clay.flexEnd - Clay.listStyleType Clay.none - Clay.margin (Clay.px 0) 0 0 0 - "li" ? do - Clay.padding 0 (px 5) 0 (px 5) - - "details" ? do - Clay.display Clay.inline - "summary" ? do - Clay.color "#6c757d" - Clay.display Clay.listItem - Clay.cursor Clay.pointer - "#home" ? do - "p" ? Clay.textAlign Clay.center - "h1" ? do - Clay.fontSize (Clay.rem 3) - "h1" <> "h2" ? do - Clay.textAlign Clay.center - ".example" ? do - Clay.borderStyle Clay.solid - Clay.borderWidth (px 2) - Clay.borderColor "#aaa" - Biz.Look.borderRadiusAll (px 10) - Biz.Look.paddingX (em 2) - Biz.Look.paddingY (em 1) - "section" ? do - Clay.padding (rem 3) 0 (rem 3) 0 - "a#try-button" <> "a#try-button:visited" ? do - Clay.transition "all" (sec 0.2) Clay.ease 0 - Clay.transitionProperties - ["color", "background-color", "border-color"] - Clay.padding (em 0.5) (em 1) (em 0.5) (em 1) - Clay.display Clay.flex - Clay.flexDirection Clay.column - Clay.margin (em 3) Clay.auto 0 Clay.auto - Clay.width (px 250) - Clay.borderWidth (px 1) - Clay.borderStyle Clay.solid - Clay.borderColor black - Clay.backgroundColor yellow - Clay.color black - Clay.textDecoration Clay.none - Clay.justifyContent Clay.center - Clay.alignItems Clay.center - Clay.fontWeight Clay.bold - "small" ? do - Clay.fontSize (px 10) - "a#try-button:hover" ? do - Clay.borderColor yellow - Clay.color yellow - Clay.backgroundColor black - - "#analysis" ? do - Clay.display Clay.grid - Clay.justifyContent Clay.spaceAround - Biz.Look.rowGap (rem 2) - Biz.Look.marginY (rem 1) - Biz.Look.gridTemplateAreas - [ "analysisFor", - "metrics" - ] - - ".metrics" ? do - Clay.gridTemplateColumns [pct 50, pct 50] - Clay.display Clay.grid - Biz.Look.columnGap (em 2) - Biz.Look.rowGap (em 2) - ".score" ? do - Clay.display Clay.flex - Clay.flexDirection Clay.column - ".title" ? do - Clay.fontSize (rem 1.4) - Clay.lineHeight (rem 2.4) - ".percentage" ? do - Clay.display Clay.flex - Clay.alignItems Clay.baseline - ".centum" ? do - Clay.fontSize (rem 1.2) - Clay.lineHeight (rem 1.2) - ".quantity" ? do - Clay.fontSize (rem 3) - Clay.lineHeight (rem 3) - "details" ? do - Biz.Look.gridArea "details-collapsed" - "details[open]" ? do - Biz.Look.gridArea "details" - - "#selectRepo" ? do - "ul" ? do - Clay.listStyleType Clay.none - Clay.margin (px 0) 0 0 0 - Clay.padding (px 0) 0 0 0 - "li" ? do - Clay.borderBottomWidth (px 1) - Clay.borderBottomColor "#999" - Clay.borderBottomStyle Clay.solid - Clay.padding (em 1.5) 0 (em 1.5) 0 - ".link" ? do - Clay.fontSize (em 1.17) + .> App.Html + .> pure } +baseStyle :: Clay.Css +baseStyle = do + Biz.Look.fuckingStyle + + Biz.Look.whenDark <| do + "body" ? do + Clay.backgroundColor black + "a:link" <> "a:visited" ? do + Clay.textDecorationColor Clay.white + Clay.color Clay.white + "a:hover" ? do + Clay.textDecorationColor yellow + "select" <> "button" <> "input" ? do + Clay.backgroundColor black + Clay.color Clay.white + + Biz.Look.whenLight <| do + "body" ? do + Clay.color black + "a:link" <> "a:visited" ? do + Clay.textDecorationColor black + Clay.color black + "a:hover" ? do + Clay.textDecorationColor yellow + "select" <> "button" <> "input" ? do + Clay.backgroundColor Clay.white + Clay.color black + + "body" ? Biz.Look.fontStack + "header" ? do + Clay.maxWidth (pct 100) + "footer" ? do + Clay.fontStyle Clay.italic + Clay.fontSize (rem 0.8) + Clay.marginTop (em 6) + Clay.marginBottom (em 6) + "a" <> "input.link" ? do + Clay.transition "all" (sec 0.2) Clay.ease 0 + Clay.transitionProperties + [ "text-decoration-color", + "text-decoration-thickness", + "text-decoration-width" + ] + Clay.textDecoration Clay.underline + Biz.Look.textDecorationThickness (em 0.1) + Biz.Look.textDecorationWidth (em 0.1) + "a:hover" <> "input.link" ? do + Clay.textDecorationColor yellow + Clay.textDecoration Clay.underline + Biz.Look.textDecorationThickness (em 0.2) + Biz.Look.textDecorationWidth (em 0.2) + + "select" <> "button" <> "input" ? do + Biz.Look.paddingAll (em 0.5) + Biz.Look.marginX (em 0.5) + Clay.borderColor yellow + Clay.borderStyle Clay.solid + + -- for making POST requests with a form disguised as a link + "input.link" ? do + Clay.cursor Clay.pointer + Clay.borderWidth 0 + Clay.fontSize (rem 1) + Biz.Look.marginAll (px 0) + Biz.Look.paddingAll (px 0) + + "label" ? do + Clay.display Clay.inlineBlock + Clay.width (px 100) + + "nav" ? do + Clay.display Clay.flex + Clay.justifyContent Clay.spaceBetween + "a" ? do + Clay.padding (em 1) (em 1) (em 1) (em 1) + Clay.display Clay.block + "ul" ? do + Clay.display Clay.flex + Clay.justifyContent Clay.flexEnd + Clay.listStyleType Clay.none + Clay.margin (Clay.px 0) 0 0 0 + "li" ? do + Clay.padding 0 (px 5) 0 (px 5) + + "details" ? do + Clay.display Clay.inline + "summary" ? do + Clay.color "#6c757d" + Clay.display Clay.listItem + Clay.cursor Clay.pointer + +yellow, black :: Clay.Color +yellow = "#ffe000" +black = "#121212" + -- | 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) +instance App.HasCss Home where + cssFor (Home _ _) = do + "p" ? Clay.textAlign Clay.center + "h1" ? do + Clay.fontSize (Clay.rem 3) + "h1" <> "h2" ? do + Clay.textAlign Clay.center + ".example" ? do + Clay.borderStyle Clay.solid + Clay.borderWidth (px 2) + Clay.borderColor "#aaa" + Biz.Look.borderRadiusAll (px 10) + Biz.Look.paddingX (em 2) + Biz.Look.paddingY (em 1) + "section" ? do + Clay.padding (rem 3) 0 (rem 3) 0 + "a#try-button" <> "a#try-button:visited" ? do + Clay.transition "all" (sec 0.2) Clay.ease 0 + Clay.transitionProperties + ["color", "background-color", "border-color"] + Clay.padding (em 0.5) (em 1) (em 0.5) (em 1) + Clay.display Clay.flex + Clay.flexDirection Clay.column + Clay.margin (em 3) Clay.auto 0 Clay.auto + Clay.width (px 250) + Clay.borderWidth (px 1) + Clay.borderStyle Clay.solid + Clay.borderColor black + Clay.backgroundColor yellow + Clay.color black + Clay.textDecoration Clay.none + Clay.justifyContent Clay.center + Clay.alignItems Clay.center + Clay.fontWeight Clay.bold + "small" ? do + Clay.fontSize (px 10) + "a#try-button:hover" ? do + Clay.borderColor yellow + Clay.color yellow + Clay.backgroundColor black + instance Lucid.ToHtml Home where toHtmlRaw = Lucid.toHtml toHtml (Home oAuthArgs analysis) = do header Nothing - Lucid.main_ [Lucid.id_ "home"] <| do + Lucid.main_ <| do section <| do h1 "Know your codebase." h1 "Know your team." @@ -1098,6 +1048,9 @@ instance Lucid.ToHtml Home where data Analyses = Analyses User [Analysis] +instance App.HasCss Analyses where + cssFor _ = mempty + instance Lucid.ToHtml Analyses where toHtmlRaw = Lucid.toHtml toHtml (Analyses user@User {..} analyses) = do @@ -1113,12 +1066,12 @@ instance Lucid.ToHtml Analyses where forM_ analyses <| \Analysis {..} -> Lucid.a_ [ href analysisId, - style <| Biz.Look.marginAll (em 1) + css <| Biz.Look.marginAll (em 1) <> Clay.textDecoration Clay.none ] <| do Lucid.div_ <| Lucid.toHtml url - Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small] + Lucid.div_ [css <| Clay.fontSizeCustom Clay.Font.small] <| Lucid.toHtml commit footer where @@ -1126,6 +1079,9 @@ instance Lucid.ToHtml Analyses where newtype UserAccount = UserAccount User +instance App.HasCss UserAccount where + cssFor (UserAccount _) = mempty + instance Lucid.ToHtml Subscription where toHtmlRaw = Lucid.toHtml toHtml Free = "Free" @@ -1163,8 +1119,8 @@ instance Lucid.ToHtml UserAccount where then [Lucid.selected_ <| tshow sel] else mempty -style :: Clay.Css -> Lucid.Attribute -style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] +css :: Clay.Css -> Lucid.Attribute +css = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] -- | A type for parsing JSON auth responses, used in 'githubOauth' below. -- Should be moved to Biz.Auth with others. @@ -1218,11 +1174,25 @@ githubLoginUrl OAuthArgs {..} = -- | This view presents a list of repos to select for analysis. data SelectRepo = SelectRepo User (Vector GitHub.Repo) +instance App.HasCss SelectRepo where + cssFor (SelectRepo _ _) = do + "ul" ? do + Clay.listStyleType Clay.none + Clay.margin (px 0) 0 0 0 + Clay.padding (px 0) 0 0 0 + "li" ? do + Clay.borderBottomWidth (px 1) + Clay.borderBottomColor "#999" + Clay.borderBottomStyle Clay.solid + Clay.padding (em 1.5) 0 (em 1.5) 0 + ".link" ? do + Clay.fontSize (em 1.17) + instance Lucid.ToHtml SelectRepo where toHtmlRaw = Lucid.toHtml toHtml (SelectRepo user repos) = do header <| Just user - Lucid.main_ [Lucid.id_ "selectRepo"] <| do + Lucid.main_ <| do Lucid.h2_ "Select a repo to analyze" Lucid.ul_ <| Lucid.toHtml <| traverse_ displayRepo (Vector.toList repos) footer @@ -1294,6 +1264,41 @@ footer = -- web page, hence this type. data AnalysisDisplay = AnalysisDisplay User Analysis +instance App.HasCss AnalysisDisplay where + cssFor (AnalysisDisplay _ _) = do + Clay.display Clay.grid + Clay.justifyContent Clay.spaceAround + Biz.Look.rowGap (rem 2) + Biz.Look.marginY (rem 1) + Biz.Look.gridTemplateAreas + [ "analysisFor", + "metrics" + ] + ".metrics" ? do + Clay.gridTemplateColumns [pct 50, pct 50] + Clay.display Clay.grid + Biz.Look.columnGap (em 2) + Biz.Look.rowGap (em 2) + ".score" ? do + Clay.display Clay.flex + Clay.flexDirection Clay.column + ".title" ? do + Clay.fontSize (rem 1.4) + Clay.lineHeight (rem 2.4) + ".percentage" ? do + Clay.display Clay.flex + Clay.alignItems Clay.baseline + ".centum" ? do + Clay.fontSize (rem 1.2) + Clay.lineHeight (rem 1.2) + ".quantity" ? do + Clay.fontSize (rem 3) + Clay.lineHeight (rem 3) + "details" ? do + Biz.Look.gridArea "details-collapsed" + "details[open]" ? do + Biz.Look.gridArea "details" + instance Lucid.ToHtml AnalysisDisplay where toHtmlRaw = Lucid.toHtml toHtml (AnalysisDisplay user anal) = do @@ -1306,7 +1311,7 @@ instance Lucid.ToHtml AnalysisDisplay where instance Lucid.ToHtml Analysis where toHtmlRaw = Lucid.toHtml toHtml Analysis {..} = - Lucid.div_ [Lucid.id_ "analysis"] <| do + Lucid.div_ <| do Lucid.p_ [Lucid.class_ ".analysisFor"] <| do "Analysis for " Lucid.a_ [Lucid.href_ <| (\(URL txt) -> txt) <| url] <| do |