summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
Diffstat (limited to 'Biz')
-rw-r--r--Biz/Devalloc.hs129
1 files 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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 12:27:47 +0000