diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 78 |
1 files changed, 47 insertions, 31 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 3584104..a33b167 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -54,7 +55,7 @@ import Biz.Test ((@=?)) import qualified Biz.Test as Test import qualified CMark as Cmark import qualified CMark.Lucid as Cmark -import Clay (em, px, rem, sec, (?)) +import Clay (em, pct, px, rem, sec, (?)) import qualified Clay import qualified Control.Exception as Exception import Crypto.JOSE.JWK (JWK) @@ -457,7 +458,6 @@ htmlApp cooks kp cfg jwk oAuthArgs = Biz.Look.whenDark <| do "body" ? do Clay.backgroundColor black - "a:link" <> "a:visited" ? do Clay.textDecorationColor Clay.white Clay.color Clay.white @@ -474,7 +474,13 @@ htmlApp cooks kp cfg jwk oAuthArgs = Clay.textDecorationColor yellow "body" ? Biz.Look.fontStack - -- "a:link" <> "a:visited" <> "a:hover" + "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 @@ -493,13 +499,16 @@ htmlApp cooks kp cfg jwk oAuthArgs = "nav" ? do Clay.display Clay.flex Clay.justifyContent Clay.spaceBetween - "nav > ul" ? do - Clay.display Clay.flex - Clay.justifyContent Clay.flexEnd - Clay.listStyleType Clay.none - Clay.margin (Clay.px 0) 0 0 0 - "nav > ul > li" ? do - Clay.padding 0 (px 5) 0 (px 5) + "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) "#home" ? do Clay.textAlign Clay.center @@ -537,6 +546,8 @@ htmlApp cooks kp cfg jwk oAuthArgs = "#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" -- TODO: more subtle gradient? @@ -551,7 +562,7 @@ newtype Home = Home OAuthArgs instance Lucid.ToHtml Home where toHtmlRaw = Lucid.toHtml toHtml (Home oAuthArgs) = do - Lucid.header_ <| Lucid.toHtml <| nav Nothing + header Nothing Lucid.main_ [Lucid.id_ "home"] <| do section <| do h1 "Know your codebase." @@ -580,6 +591,7 @@ instance Lucid.ToHtml Home where section <| do h1 <| "Ready to get going?" Lucid.toHtml <| tryButton oAuthArgs + footer where section = Lucid.section_ markdown = Cmark.renderNode [] <. Cmark.commonmarkToNode [] @@ -592,13 +604,14 @@ newtype UserHome = UserHome User instance Lucid.ToHtml UserHome where toHtmlRaw = Lucid.toHtml toHtml (UserHome user) = do - Lucid.header_ <| Lucid.toHtml <| nav <| Just user + header <| Just user Lucid.main_ <| do Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" Lucid.p_ <| Lucid.a_ [Lucid.linkHref_ "/" <| fieldLink selectRepo] "Analyze one of your repos" + footer where UserEmail email = userEmail user @@ -672,10 +685,11 @@ data SelectRepo = SelectRepo User (Vector GitHub.Repo) instance Lucid.ToHtml SelectRepo where toHtmlRaw = Lucid.toHtml toHtml (SelectRepo user repos) = do - Lucid.header_ <| Lucid.toHtml <. nav <| Just user + header <| Just user Lucid.main_ [Lucid.id_ "selectRepo"] <| do Lucid.h2_ "Select a repo to analyze" Lucid.ul_ <| Lucid.toHtml <| mapM_ displayRepo (Vector.toList repos) + footer where displayRepo :: GitHub.Repo -> Lucid.Html () displayRepo repo = @@ -711,29 +725,30 @@ tryButton oAuthArgs = "Give it a try with GitHub" Lucid.small_ "Free for a limited time" --- | 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 _ -> +-- | Universal header +header :: Monad m => Maybe User -> Lucid.HtmlT m () +header muser = + Lucid.header_ <| do Lucid.nav_ <| do a "Devalloc" <| fieldLink home - Lucid.ul_ - <| li "My Account" - <| fieldLink account + case muser of + Nothing -> + Lucid.ul_ <| do + li "Login" <| fieldLink login + li "Pricing" <| fieldLink home + Just _ -> + 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 () + Lucid.a_ [Lucid.linkHref_ "/" href] txt li txt href = Lucid.li_ <| a txt href +-- | Universal footer +footer :: Monad m => Lucid.HtmlT m () +footer = + Lucid.footer_ <| do + Lucid.p_ <| Lucid.i_ "Copyright ©2020-2021 Devalloc.io" + -- * analysis -- | I need more information than just 'Analysis' has to render a full, useful @@ -743,8 +758,9 @@ data AnalysisDisplay = AnalysisDisplay User Analysis instance Lucid.ToHtml AnalysisDisplay where toHtmlRaw = Lucid.toHtml toHtml (AnalysisDisplay user anal) = do - Lucid.header_ <| Lucid.toHtml <. nav <| Just user + header <| Just user Lucid.main_ <| Lucid.toHtml anal + footer -- | The result of analyzing a git repo. data Analysis = Analysis |