Add navbar mostly everywhere

This necessitated adding a few more paths for clarity and such, and a type for
the analysis page. There seem to be some bugs with session handling I think, but
I'll suss those out later. Also I'm running into many uncaught exceptions so
eventually I will need to tackle those as well.

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