Add footer and adjust widths

The footer is just a copyright for now. The header is full width, main and
footer max out at 900px. This seems like a reasonable default, so I put it in
the base Biz/Look.hs.

2 files changed, 65 insertions, 35 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
diff --git a/Biz/Look.hs b/Biz/Look.hs
index e7bcb82..27bc8c5 100644
--- a/Biz/Look.hs
+++ b/Biz/Look.hs
@@ -25,6 +25,7 @@ where
 
 import Alpha
 import Clay
+import qualified Clay.Flexbox as Flexbox
 import qualified Clay.Stylesheet as Clay
 
 fontStack :: Css
@@ -71,14 +72,21 @@ whenLight :: Css -> Css
 whenLight = query Clay.all [prefersLight]
 
 -- | The stylesheet from <https://perfectmotherfuckingwebsite.com> ported to
--- Clay.
+-- Clay, to be used as the base for other styles.
+--
+-- Differences from the original:
+--   - expects use of header/main/footer
+--   - has a sticky footer
+--   - wider, with a bit of body padding
 fuckingStyle :: Css
 fuckingStyle = do
   "body" ? do
-    maxWidth (px 650)
-    margin (px 40) auto (px 40) auto
-    padding 0 (px 10) 0 (px 10)
+    display flex
+    minHeight (vh 100)
+    flexDirection column
     color "#444"
+    margin (px 0) 0 0 0
+    padding (em 0.5) (em 0.5) (em 0.5) (em 0.5)
     fontSize (px 18)
     lineHeight (em 1.5)
     fontFamily
@@ -93,6 +101,12 @@ fuckingStyle = do
         "Noto Color Emoji"
       ]
       [sansSerif]
+  "main" ? Flexbox.flex 1 0 auto
+  "main" <> "header" <> "footer" ? do
+    maxWidth (px 900)
+    width (pct 100)
+    margin (em 1) auto 1 auto
+    padding (em 0) 0 0 0
   "h1" <> "h2" <> "h3" ? lineHeight (em 1.2)
   query Clay.all [prefersDark] <| do
     "body" ? do