summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2020-12-24 00:39:15 -0500
committerBen Sima <ben@bsima.me>2020-12-24 00:39:15 -0500
commit9acdd49be8c589cd766c81929599b00afb7a729d (patch)
tree44a810617e807dc7f5ab28736115081eb3a38423
parent9f2d8dbf6e0b5ee9153524601b4e7dec49f308df (diff)
devalloc: refactor to use servant-generic
-rw-r--r--Biz/Devalloc.hs99
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