From 13148a011bbfc96042fbe3965d9dc2bd93a9a047 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Mon, 28 Dec 2020 20:18:17 -0500 Subject: devalloc: initialize keep database --- Biz/Devalloc.hs | 129 ++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 103 insertions(+), 26 deletions(-) diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 7dbc4a5..38976c1 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -14,14 +16,17 @@ -- Developer allocation -- -- : out devalloc +-- : dep acid-state -- : dep clay -- dep cmark -- sys cmark -- : dep envy -- : dep github +-- : dep ixset -- : dep lucid -- : dep protolude -- : dep req +-- : dep safe-copy -- : dep servant -- : dep servant-lucid -- : dep servant-server @@ -39,9 +44,15 @@ import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Look import qualified Clay import qualified Control.Exception as Exception +import Data.Acid (makeAcidic) +import qualified Data.Acid as Acid import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LBS +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet, (@=)) +import qualified Data.IxSet as IxSet import qualified Data.List as List +import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding @@ -68,29 +79,84 @@ import System.FilePath ((<.>), ()) import qualified System.Process as Process import qualified Web.FormUrlEncoded +-- * persistent data + +-- this must go first because of template haskell splicing + +newtype UserEmail = UserEmail {unUserEmail :: Text} + deriving (Eq, Ord, Data, Typeable) + +$(deriveSafeCopy 0 'base ''UserEmail) + +data User = User + { userEmail :: UserEmail, + userGitHubToken :: Text + } + deriving (Eq, Data, Typeable, Ord) + +$(deriveSafeCopy 0 'base ''User) + +instance Indexable User where + empty = + ixSet + [ ixFun <| \u -> [userEmail u] + ] + +-- | The database. +newtype Keep = Keep {users :: IxSet User} + deriving (Data, Typeable) + +instance Semigroup Keep where + a <> b = Keep <| users a <> users b + +instance Monoid Keep where + mempty = Keep <| mempty [] + +$(deriveSafeCopy 0 'base ''Keep) + +newUser :: User -> Acid.Update Keep User +newUser u = do + keep <- get + put <| keep {users = IxSet.insert u (users keep)} + return u + +getUserByEmail :: Text -> Acid.Query Keep (Maybe User) +getUserByEmail email = do + Keep {..} <- ask + return <| IxSet.getOne <| users @= email + +$(makeAcidic ''Keep ['newUser, 'getUserByEmail]) + +-- * main and test + main :: IO () main = Exception.bracket startup shutdown run where startup = do cfg <- Envy.decodeWithDefaults Envy.defConfig oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig + kp <- Acid.openLocalStateFrom (keep cfg) mempty :: IO (Acid.AcidState Keep) putText "@" putText "devalloc" putText <| "port: " <> (show <| port cfg) putText <| "depo: " <> (Text.pack <| depo cfg) - return (cfg, serve paths (toServant <| htmlApp cfg oAuthArgs)) - shutdown :: (Config, Application) -> IO () - shutdown _ = pure () - run :: (Config, Wai.Application) -> IO () - run (cfg, app) = Warp.run (port cfg) (logStdout app) + putText <| "keep: " <> (Text.pack <| keep cfg) + return (cfg, serve paths (toServant <| htmlApp kp cfg oAuthArgs), kp) + shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () + shutdown (_, _, kp) = Acid.closeAcidState kp + run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO () + run (cfg, app, _) = Warp.run (port cfg) (logStdout app) test :: IO Analysis test = test_analyzeGitHub +-- * app configurations + data Config = Config { port :: Warp.Port, -- | The repo depo! Depository of repositories! - depo :: FilePath + depo :: FilePath, + keep :: FilePath } deriving (Generic, Show) @@ -98,7 +164,8 @@ instance Envy.DefConfig Config where defConfig = Config { port = 8005, - depo = "_/var/devalloc/depo" + depo = "_/var/devalloc/depo", + keep = "_/var/devalloc/keep" } instance Envy.FromEnv Config @@ -122,6 +189,8 @@ instance Envy.DefConfig OAuthArgs where instance Envy.FromEnv OAuthArgs +-- * paths and pages + -- | Wraps pages in default HTML instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where toHtmlRaw = Lucid.toHtml @@ -148,8 +217,7 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where Lucid.href_ _href ] --- * paths and pages - +-- | All of the routes in the app. data Paths path = Paths { home :: path :- Get '[HTML] (HtmlApp Home), githubAuth :: @@ -169,11 +237,11 @@ paths :: Proxy (ToServantApi Paths) paths = genericApi (Proxy :: Proxy Paths) -- | Main HTML handlers for all paths. -htmlApp :: Config -> OAuthArgs -> Paths AsServer -htmlApp cfg oAuthArgs = +htmlApp :: Acid.AcidState Keep -> Config -> OAuthArgs -> Paths AsServer +htmlApp kp cfg oAuthArgs = Paths { home = page (Home oAuthArgs), - githubAuth = auth oAuthArgs, + githubAuth = auth kp oAuthArgs, githubAnalysis = \user repo -> liftIO <| analyzeGitHub cfg user repo >>= HtmlApp .> pure, css = look @@ -229,25 +297,28 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) -auth :: OAuthArgs -> Maybe Text -> Handler (HtmlApp SelectRepo) -auth _ Nothing = panic "no code from github api" -auth OAuthArgs {..} (Just code) = - liftIO <| getAccessToken +-- | Login a user by authenticating with GitHub. +auth :: + Acid.AcidState Keep -> + OAuthArgs -> + Maybe Text -> + Handler (HtmlApp SelectRepo) +auth _ _ Nothing = panic "no code from github api" +auth _ oAuthArgs (Just code) = + liftIO <| getAccessToken oAuthArgs code >>= getRepos >>= \case Left err -> panic <| show err Right repos -> pure <. HtmlApp <| SelectRepo repos + +getAccessToken :: OAuthArgs -> Text -> IO Text +getAccessToken OAuthArgs {..} code = + accessTokenRequest + >>= Req.responseBody + /> access_token + /> return + |> Req.runReq Req.defaultHttpConfig where - getRepos oAuthToken = - GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken) - (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) - getAccessToken = - accessTokenRequest - >>= Req.responseBody - /> access_token - /> return - |> Req.runReq Req.defaultHttpConfig accessTokenRequest = Req.req Req.POST @@ -259,6 +330,12 @@ auth OAuthArgs {..} (Just code) = <> "code" =: code <> "state" =: githubState +getRepos :: Text -> IO (Either GitHub.Error (Vector GitHub.Repo)) +getRepos oAuthToken = + GitHub.github + (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + -- | This view presents a list of repos to select for analysis. newtype SelectRepo = SelectRepo (Vector GitHub.Repo) -- cgit v1.2.3