devalloc: refactor to use servant-generic

1 files changed, 51 insertions, 48 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index ec8f870..783c9cd 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -1,11 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -56,7 +58,9 @@ import qualified Network.Wai as Wai
 import qualified Network.Wai.Handler.Warp as Warp
 import Network.Wai.Middleware.RequestLogger (logStdout)
 import Servant
+import Servant.API.Generic (ToServantApi, genericApi, toServant, (:-))
 import Servant.HTML.Lucid
+import Servant.Server.Generic (AsServer)
 import qualified System.Directory as Directory
 import qualified System.Envy as Envy
 import System.FilePath ((<.>), (</>))
@@ -73,7 +77,7 @@ main = Exception.bracket startup shutdown run
       putText "devalloc"
       putText <| "port: " <> (show <| port cfg)
       putText <| "depo: " <> (Text.pack <| depo cfg)
-      return (cfg, serve (Proxy @AllPaths) <| paths cfg oAuthArgs)
+      return (cfg, serve paths (toServant <| htmlApp cfg oAuthArgs))
     shutdown :: (Config, Application) -> IO ()
     shutdown _ = pure ()
     run :: (Config, Wai.Application) -> IO ()
@@ -145,29 +149,33 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
 
 -- * paths and pages
 
-type AllPaths =
-  Get '[HTML] (HtmlApp Home)
-    :<|> "auth" :> "github" :> "callback"
-      :> QueryParam "code" Text
-      :> Get '[HTML] (HtmlApp SelectRepo)
-    :<|> GitHubAnalysis
-    :<|> "css" :> "main.css" :> Get '[CSS] Text
-
-allPaths :: Proxy AllPaths
-allPaths = Proxy :: Proxy AllPaths
-
-type GitHubAnalysis =
-  "analysis" :> "github"
-    :> Capture "user" Text
-    :> Capture "repo" Text
-    :> Get '[HTML] (HtmlApp Analysis)
-
-paths :: Config -> OAuthArgs -> Server AllPaths
-paths cfg oAuthArgs =
-  page (Home oAuthArgs)
-    :<|> auth oAuthArgs
-    :<|> (\user repo -> liftIO <| analyzeGitHub cfg user repo >>= pure . HtmlApp)
-    :<|> look
+data Paths path = Paths
+  { home :: path :- Get '[HTML] (HtmlApp Home),
+    githubAuth ::
+      path :- "auth" :> "github" :> "callback"
+        :> QueryParam "code" Text
+        :> Get '[HTML] (HtmlApp SelectRepo),
+    githubAnalysis ::
+      path :- "analysis" :> "github"
+        :> Capture "user" Text
+        :> Capture "repo" Text
+        :> Get '[HTML] (HtmlApp Analysis),
+    css :: path :- "css" :> "main.css" :> Get '[CSS] Text
+  }
+  deriving (Generic)
+
+paths :: Proxy (ToServantApi Paths)
+paths = genericApi (Proxy :: Proxy Paths)
+
+-- | Main HTML handlers for all paths.
+htmlApp :: Config -> OAuthArgs -> Paths AsServer
+htmlApp cfg oAuthArgs =
+  Paths
+    { home = page (Home oAuthArgs),
+      githubAuth = auth oAuthArgs,
+      githubAnalysis = (\user repo -> liftIO <| analyzeGitHub cfg user repo >>= pure . HtmlApp),
+      css = look
+    }
   where
     page = pure . HtmlApp
     look =
@@ -175,15 +183,6 @@ paths cfg oAuthArgs =
         Biz.Look.fuckingStyle
         "body" Clay.? Biz.Look.fontStack
 
--- | Create an href attribute to a path in 'AllPaths'.
-linkTo ::
-  (HasLink path, IsElem path AllPaths) =>
-  -- | Proxy to the path
-  Proxy path ->
-  -- | Return value @x@ is to be used like @Lucid.a_ [ x ] ...@
-  MkLink path Lucid.Attribute
-linkTo = Lucid.safeHref_ "/" allPaths
-
 newtype Home = Home OAuthArgs
 
 instance Lucid.ToHtml Home where
@@ -198,15 +197,6 @@ data OAuthResponse = OAuthResponse
   }
   deriving (Generic, Aeson.FromJSON)
 
-newtype SelectRepo = SelectRepo (Vector GitHub.Repo)
-
-instance Lucid.ToHtml SelectRepo where
-  toHtmlRaw = Lucid.toHtml
-  toHtml (SelectRepo repos) =
-    Lucid.toHtml <| do
-      Lucid.h1_ "Select a repo to analyze"
-      selectRepo repos
-
 auth :: OAuthArgs -> Maybe Text -> Handler (HtmlApp SelectRepo)
 auth _ Nothing = panic "no code from github api"
 auth OAuthArgs {..} (Just code) =
@@ -237,6 +227,8 @@ auth OAuthArgs {..} (Just code) =
         <> "code" =: code
         <> "state" =: githubState
 
+-- * analysis
+
 data Analysis = Analysis
   { bareRepo :: FilePath,
     -- | A path with no active contributors
@@ -378,8 +370,8 @@ analyzeGitHub cfg o r = do
 test_analyzeGitHub :: IO Analysis
 test_analyzeGitHub = analyzeGitHub Envy.defConfig "bsima" "bin"
 
--- | Clone the repo to /var/devalloc/repos/<url>, return the full path to the
--- local repo.
+-- | Clone the repo to @<Config.depo>/<url>@. Return the full path to the local
+-- repo.
 gitBareClone :: Config -> Text -> IO FilePath
 gitBareClone Config {depo} url = do
   worktreeExists <- Directory.doesPathExist worktree
@@ -402,6 +394,16 @@ encodeParams =
     . LBS.toStrict
     . Web.FormUrlEncoded.urlEncodeParams
 
+newtype SelectRepo = SelectRepo (Vector GitHub.Repo)
+
+instance Lucid.ToHtml SelectRepo where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (SelectRepo repos) =
+    Lucid.toHtml <| do
+      Lucid.h1_ "Select a repo to analyze"
+      selectRepo repos
+
+
 selectRepo :: Vector GitHub.Repo -> Lucid.Html ()
 selectRepo = Lucid.ul_ . mapM_ render . Vector.toList
   where
@@ -409,10 +411,11 @@ selectRepo = Lucid.ul_ . mapM_ render . Vector.toList
     render repo =
       Lucid.li_
         . Lucid.a_
-          [ linkTo
-              (Proxy :: Proxy GitHubAnalysis)
-              (GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo)
-              (GitHub.untagName <| GitHub.repoName repo)
+          [ Lucid.linkHref_ "/"
+              <| fieldLink
+                githubAnalysis
+                (GitHub.untagName <| GitHub.simpleOwnerLogin <| GitHub.repoOwner repo)
+                (GitHub.untagName <| GitHub.repoName repo)
           ]
         . Lucid.toHtml
         . GitHub.untagName