diff options
| -rw-r--r-- | Biz/Devalloc.hs | 99 |
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 |