Put an example analysis on the homepage

The design kinda sucks, but I will refresh it later. I just want to get this
shipped right now.

1 files changed, 203 insertions, 58 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index d7a43ea..04ee90e 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -109,7 +110,6 @@ import qualified Servant.Auth.Server as Auth
 import qualified Servant.HTML.Lucid as Lucid
 import Servant.Server.Generic (AsServer)
 import qualified System.Directory as Directory
-import qualified System.Environment as Env
 import qualified System.Envy as Envy
 import System.FilePath ((<.>), (</>))
 import qualified System.Process as Process
@@ -219,6 +219,10 @@ $(deriveSafeCopy 0 'base ''Commit)
 newtype URL = URL Text
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
+instance Envy.Var URL where
+  toVar (URL txt) = str txt
+  fromVar = Just <. URL <. str
+
 instance Lucid.ToHtml URL where
   toHtmlRaw = Lucid.toHtml
   toHtml (URL txt) = Lucid.toHtml txt
@@ -295,7 +299,8 @@ instance Indexable Analysis where
       [ ixFun <| \Analysis {..} -> [analysisId],
         ixFun <| \Analysis {..} -> [askedBy],
         ixFun <| \Analysis {..} -> [url],
-        ixFun <| \Analysis {..} -> [commit]
+        ixFun <| \Analysis {..} -> [commit],
+        ixFun <| \Analysis {..} -> [repoVisibility]
       ]
 
 -- | The database.
@@ -367,6 +372,11 @@ getAnalysesByAsker user = do
   Keep {..} <- ask
   pure <| IxSet.toList <| analyses @= userId user
 
+getAnalysesByUrl :: URL -> Acid.Query Keep [Analysis]
+getAnalysesByUrl url = do
+  Keep {..} <- ask
+  pure <| IxSet.toList <| analyses @= url
+
 getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis)
 getAnalysisByUrlAndCommit url sha = do
   Keep {..} <- ask
@@ -383,6 +393,7 @@ $( makeAcidic
        'getAnalysisById,
        'getAllAnalyses,
        'getAnalysesByAsker,
+       'getAnalysesByUrl,
        'getAnalysisByUrlAndCommit
      ]
  )
@@ -490,18 +501,21 @@ startup quiet = do
   oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
   kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep)
   jwk <- Auth.generateKey
+  let URL url = homeExample cfg
   unless quiet <| do
-    Log.info ["@", "devalloc"] >> Log.br
-    Log.info ["area", show <| area cfg] >> Log.br
-    Log.info ["port", show <| port cfg] >> Log.br
-    Log.info ["depo", Text.pack <| depo cfg] >> Log.br
-    Log.info ["keep", Text.pack <| keep cfg] >> Log.br
+    Log.info ["boot", "devalloc"] >> Log.br
+    Log.info ["boot", "area", show <| area cfg] >> Log.br
+    Log.info ["boot", "port", show <| port cfg] >> Log.br
+    Log.info ["boot", "depo", Text.pack <| depo cfg] >> Log.br
+    Log.info ["boot", "keep", Text.pack <| keep cfg] >> Log.br
+    Log.info ["boot", "home", "example", url] >> Log.br
   let jwtCfg = Auth.defaultJWTSettings jwk
   let cooks = case area cfg of
         Test -> testCookieSettings
         Live -> liveCookieSettings
   let ctx = cooks :. jwtCfg :. EmptyContext
   let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs)
+  unless quiet <| do Log.info ["boot", "ready"] >> Log.br
   pure (cfg, app, kp)
 
 shutdown :: (Config, Application, Acid.AcidState Keep) -> IO ()
@@ -570,7 +584,13 @@ data Config = Config
     -- | The repo depo! Depository of repositories!
     depo :: FilePath,
     keep :: FilePath,
-    area :: Area
+    area :: Area,
+    -- | A user token for the GitHub API to be used in testing and when getting
+    -- the homepage/example analyses. Get a token with 'repo' scope from GitHub
+    -- and set in .envrc.local
+    -- https://docs.github.com/en/github/authenticating-to-github/creating-a-personal-access-token
+    tokn :: Text,
+    homeExample :: URL
   }
   deriving (Generic, Show)
 
@@ -580,7 +600,9 @@ instance Envy.DefConfig Config where
       { port = 8005,
         depo = "_/var/devalloc/depo",
         keep = "_/var/devalloc/keep",
-        area = Test
+        area = Test,
+        tokn = mempty,
+        homeExample = URL "https://github.com/github/training-kit"
       }
 
 instance Envy.FromEnv Config
@@ -740,7 +762,12 @@ htmlApp ::
 htmlApp cooks kp cfg jwk oAuthArgs =
   Paths
     { home =
-        pure <. HtmlApp <| Home oAuthArgs,
+        homeExample cfg
+          |> GetAnalysesByUrl
+          |> Acid.query' kp
+          /> head
+          /> Home oAuthArgs
+          /> HtmlApp,
       login =
         pure <| addHeader (githubLoginUrl oAuthArgs) NoContent,
       githubAuth = \case
@@ -748,7 +775,6 @@ htmlApp cooks kp cfg jwk oAuthArgs =
         Just code -> do
           OAuthResponse {..} <- githubOauth oAuthArgs code |> liftIO
           guardScope scope
-          let token = Encoding.encodeUtf8 access_token
           let warn :: Text -> Handler a
               warn msg =
                 Log.warn [msg]
@@ -757,10 +783,10 @@ htmlApp cooks kp cfg jwk oAuthArgs =
                   >> throwError err502 {errBody = str msg}
           user <-
             GitHub.userInfoCurrentR
-              |> GitHub.github (GitHub.OAuth token)
+              |> GitHub.github (userGitHubAuth access_token)
               |> liftIO
               +> either (show .> warn) pure
-              +> upsertGitHubUser kp token
+              +> upsertGitHubUser kp (Encoding.encodeUtf8 access_token)
               .> liftIO
               +> either warn pure
           Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user
@@ -787,7 +813,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
         guardAuth
           >=> \user@User {..} ->
             GitHub.github
-              (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken)
+              (userGitHubAuth userGitHubToken)
               (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
               |> liftIO
               +> \case
@@ -811,8 +837,14 @@ htmlApp cooks kp cfg jwk oAuthArgs =
                 Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis,
       githubAnalysis = \a owner repo ->
         guardAuth a
-          +> \user ->
-            analyzeGitHub kp user (depo cfg) owner repo
+          +> \user@User {..} ->
+            analyzeGitHub
+              kp
+              userId
+              (userGitHubAuth userGitHubToken)
+              (depo cfg)
+              owner
+              repo
               |> liftIO
               +> AnalysisDisplay user
               .> HtmlApp
@@ -895,12 +927,25 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               "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
-            Clay.textAlign Clay.center
+            "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
@@ -928,6 +973,41 @@ htmlApp cooks kp cfg jwk oAuthArgs =
               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
@@ -942,11 +1022,11 @@ htmlApp cooks kp cfg jwk oAuthArgs =
 
 -- | 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.
-newtype Home = Home OAuthArgs
+data Home = Home OAuthArgs (Maybe Analysis)
 
 instance Lucid.ToHtml Home where
   toHtmlRaw = Lucid.toHtml
-  toHtml (Home oAuthArgs) = do
+  toHtml (Home oAuthArgs analysis) = do
     header Nothing
     Lucid.main_ [Lucid.id_ "home"] <| do
       section <| do
@@ -954,7 +1034,7 @@ instance Lucid.ToHtml Home where
         h1 "Know your team."
         p "Devalloc analyzes your codebase trends, finds patterns in how your developers work, and protects against tech debt."
         p "Just hook it up to your CI system - Devalloc warns you when it finds a problem."
-        Lucid.toHtml <| tryButton oAuthArgs
+        Lucid.toHtml <| tryButton oAuthArgs "Give it a try with GitHub" mempty
       section <| do
         h2 "Identify blackholes in your codebase"
         p
@@ -967,6 +1047,14 @@ instance Lucid.ToHtml Home where
           "Which pieces of code get continually rewritten, taking up valuable dev time? \
           \ Find these module hot spots before they become a costly time-sink."
       section <| do
+        h2 "See an example analysis"
+        maybe
+          ( Lucid.toHtml
+              <| tryButton oAuthArgs "Run a free complimentary analysis" mempty
+          )
+          (exampleWrapper <. Lucid.toHtml)
+          analysis
+      section <| do
         h2 "Protect against lost knowledge"
         p "Not everyone can know every part of a codebase. By finding pieces of code that only 1 or 2 people have touched, devalloc identifes siloed knowledge. This allows you to protect against the risk of this knowledge leaving the company if an employee leaves."
       section <| do
@@ -978,7 +1066,11 @@ instance Lucid.ToHtml Home where
         p "Does your team feel splintered or not cohesive? Which developers work best together? Devalloc analyzes the collaboration patterns between devs and helps you form optimal pairings and teams based on shared code and mindspace."
       section <| do
         h1 <| "Ready to get going?"
-        Lucid.toHtml <| tryButton oAuthArgs
+        Lucid.toHtml
+          <| tryButton
+            oAuthArgs
+            "Give it a try with GitHub"
+            "It's free for a limited time!"
     footer
     where
       section = Lucid.section_
@@ -986,6 +1078,7 @@ instance Lucid.ToHtml Home where
       p = Lucid.p_ <. markdown
       h1 = Lucid.h1_
       h2 = Lucid.h2_ <. markdown
+      exampleWrapper = Lucid.div_ [Lucid.class_ "example"]
 
 data Analyses = Analyses User [Analysis]
 
@@ -1066,6 +1159,12 @@ data OAuthResponse = OAuthResponse
   }
   deriving (Generic, Aeson.FromJSON)
 
+userGitHubAuth ::
+  -- | Token from `User.userGitHubToken` or `Config.tokn`
+  Text ->
+  GitHub.Auth
+userGitHubAuth = GitHub.OAuth <. Encoding.encodeUtf8
+
 -- | POST to GitHub's OAuth service and get the user's oAuth token.
 githubOauth ::
   OAuthArgs ->
@@ -1138,13 +1237,13 @@ encodeParams =
     <. Web.urlEncodeParams
 
 -- | Login button for GitHub.
-tryButton :: OAuthArgs -> Lucid.Html ()
-tryButton oAuthArgs =
+tryButton :: OAuthArgs -> Text -> Text -> Lucid.Html ()
+tryButton oAuthArgs title subtitle =
   Lucid.a_
     [Lucid.id_ "try-button", Lucid.href_ <| githubLoginUrl oAuthArgs]
     <| do
-      "Give it a try with GitHub"
-      Lucid.small_ "Free for a limited time, then $99 per month"
+      Lucid.toHtml title
+      Lucid.small_ <| Lucid.toHtml subtitle
 
 -- | Universal header
 header :: Monad m => Maybe User -> Lucid.HtmlT m ()
@@ -1181,33 +1280,71 @@ instance Lucid.ToHtml AnalysisDisplay where
   toHtmlRaw = Lucid.toHtml
   toHtml (AnalysisDisplay user anal) = do
     header <| Just user
-    Lucid.main_ <| Lucid.toHtml anal
+    Lucid.main_ <| do
+      Lucid.h1_ "Analysis Results"
+      Lucid.toHtml anal
     footer
 
 instance Lucid.ToHtml Analysis where
   toHtmlRaw = Lucid.toHtml
-  toHtml = render .> Lucid.toHtml
+  toHtml Analysis {..} =
+    Lucid.div_ [Lucid.id_ "analysis"] <| do
+      Lucid.p_ [Lucid.class_ ".analysisFor"] <| do
+        "Analysis for "
+        Lucid.a_ [Lucid.href_ <| (\(URL txt) -> txt) <| url] <| do
+          Lucid.toHtml url
+
+      Lucid.div_ [Lucid.class_ "metrics"] <| do
+        score_ <| do
+          title_ "Total Score"
+          percentage_ <| do
+            quantity_ <| Lucid.toHtml <| tshow score
+            centum_ "/100"
+
+        score_ <| do
+          title_ "Total Files"
+          quantity_ <| Lucid.toHtml <| tshow totalFiles
+
+        score_ <| do
+          title_ "Active authors"
+          quantity_ <| Lucid.toHtml <| slen activeAuthors
+          Lucid.details_ <| do
+            Lucid.summary_ "Details"
+            Lucid.ul_ <| forM_ activeAuthors <| \author -> do
+              Lucid.li_ <| Lucid.toHtml author
+
+        score_ <| do
+          title_ "Blackholes"
+          quantity_ <| Lucid.toHtml <| slen blackholes
+          Lucid.details_ <| do
+            Lucid.summary_ "Details"
+            Lucid.ul_ <| do
+              traverse_ (Lucid.toHtml .> Lucid.li_) blackholes
+
+        score_ <| do
+          title_ "Liabilities"
+          quantity_ <| Lucid.toHtml <| slen liabilities
+          Lucid.details_ <| do
+            Lucid.summary_ "Details"
+            Lucid.ul_ <| do
+              traverse_ (Lucid.toHtml .> Lucid.li_) liabilities
+
+        score_ <| do
+          title_ "Stale files"
+          quantity_ <| Lucid.toHtml <| slen stale
+          Lucid.details_ <| do
+            Lucid.summary_ "Details"
+            Lucid.ul_ <| do
+              forM_ stale <| \(path, days) ->
+                Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)"
     where
-      render :: Analysis -> Lucid.Html ()
-      render Analysis {..} = do
-        Lucid.h1_ "Analysis Results"
-        Lucid.h3_ "Total score:"
-        Lucid.p_ <| Lucid.toHtml <| Text.pack <| show score
-        Lucid.h3_ "Active authors:"
-        Lucid.ul_ <| forM_ activeAuthors <| \author -> do
-          Lucid.li_ <| Lucid.toHtml author
-        Lucid.h3_ <| Lucid.toHtml <| "Total files: " <> tshow totalFiles
-        Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen blackholes <> " blackholes:"
-        Lucid.ul_ <| do
-          traverse_ (Lucid.toHtml .> Lucid.li_) blackholes
-        Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen liabilities <> " liabilities:"
-        Lucid.ul_ <| do
-          traverse_ (Lucid.toHtml .> Lucid.li_) liabilities
-        Lucid.h3_ <| Lucid.toHtml <| "Found " <> slen stale <> " stale files:"
-        Lucid.ul_ <| do
-          forM_ stale <| \(path, days) ->
-            Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)"
       slen = tshow <. length
+      div_ c = Lucid.with Lucid.div_ [Lucid.class_ c]
+      score_ = div_ "score"
+      title_ = div_ "title"
+      quantity_ = div_ "quantity"
+      centum_ = div_ "centum"
+      percentage_ = div_ "percentage"
 
 -- | Run a full analysis on a git repo
 analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> Bool -> IO Analysis
@@ -1350,9 +1487,12 @@ authorsFor gitDir path =
 
 -- | Clones a repo from GitHub and does the analysis.
 analyzeGitHub ::
+  GitHub.AuthMethod ghAuth =>
   Acid.AcidState Keep ->
   -- | The User asking for the analysis, we auth as them
-  User ->
+  Id.Id User ->
+  -- | How to auth with GitHub API
+  ghAuth ->
   -- | The repo depo
   FilePath ->
   -- | GitHub owner
@@ -1360,7 +1500,7 @@ analyzeGitHub ::
   -- | GitHub repo
   Text ->
   IO Analysis
-analyzeGitHub keep User {..} depo o r = do
+analyzeGitHub keep userId ghAuth depo o r = do
   activeAuthors <-
     getPeople
       /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR)
@@ -1375,7 +1515,6 @@ analyzeGitHub keep User {..} depo o r = do
       bareRepo <- fetchBareRepo depo <. GitHub.getUrl <| GitHub.repoHtmlUrl repo
       analyze keep userId activeAuthors (URL url) bareRepo (GitHub.repoPrivate repo)
   where
-    ghAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken
     ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o
     ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r
 
@@ -1412,20 +1551,22 @@ test_analyzeGitHub load =
     "analyzeGitHub"
     [ Test.unit "can analyze a public repo (octocat/hello-world)" <| do
         (c, _, k) <- load
-        -- get a token with 'repo' scope from GitHub and set in .envrc.local
-        -- https://docs.github.com/en/github/authenticating-to-github/creating-a-personal-access-token
-        tok <-
-          Env.lookupEnv "GITHUB_USER_TOKEN"
-            /> maybe (panic "need GITHUB_USER_TOKEN") Text.pack
         let user =
               User
                 { userEmail = UserEmail <| Just "user@example.com",
                   userGitHubId = GitHubId 0,
-                  userGitHubToken = tok,
+                  userGitHubToken = tokn c,
                   userSubscription = Free,
                   userId = mempty
                 }
-        Analysis {..} <- analyzeGitHub k user (depo c) "octocat" "hello-world"
+        Analysis {..} <-
+          analyzeGitHub
+            k
+            (userId user)
+            (userGitHubAuth <| userGitHubToken user)
+            (depo c)
+            "octocat"
+            "hello-world"
         url @?= URL "https://github.com/octocat/Hello-World"
         bareRepo @?= depo c <> "/github.com/octocat/Hello-World.git"
         length activeAuthors @?= 2
@@ -1447,9 +1588,13 @@ fetchBareRepo depo url =
     >> pure worktree
   where
     fetchOrClone True =
-      Process.callProcess "git" ["--git-dir", worktree, "fetch", "--quiet", "origin"]
+      Log.info ["git", "fetch", url]
+        >> Log.br
+        >> Process.callProcess "git" ["--git-dir", worktree, "fetch", "--quiet", "origin"]
     fetchOrClone False =
-      Process.callProcess "git" ["clone", "--quiet", "--bare", "--", Text.unpack url, worktree]
+      Log.info ["git", "clone", url]
+        >> Log.br
+        >> Process.callProcess "git" ["clone", "--bare", "--quiet", "--", Text.unpack url, worktree]
     removeScheme :: Text -> FilePath
     removeScheme u = Text.unpack <. Text.dropWhile (== '/') <. snd <| Text.breakOn "//" u
     worktree = depo </> removeScheme url <.> "git"