summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Biz/Devalloc.hs276
-rw-r--r--Biz/Devalloc.nix1
2 files changed, 225 insertions, 52 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index a4bfb8d..5e23e67 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -18,8 +18,6 @@
-- : out devalloc
-- : dep acid-state
-- : dep clay
--- dep cmark
--- sys cmark
-- : dep envy
-- : dep github
-- : dep ixset
@@ -28,6 +26,8 @@
-- : dep req
-- : dep safecopy
-- : dep servant
+-- : dep servant-auth
+-- : dep servant-auth-server
-- : dep servant-lucid
-- : dep servant-server
-- : dep uuid
@@ -44,6 +44,7 @@ import Biz.App (CSS (..), HtmlApp (..))
import qualified Biz.Look
import qualified Clay
import qualified Control.Exception as Exception
+import Crypto.JOSE.JWK (JWK)
import Data.Acid (makeAcidic)
import qualified Data.Acid as Acid
import qualified Data.Aeson as Aeson
@@ -71,7 +72,9 @@ 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 qualified Servant.Auth as Auth
+import qualified Servant.Auth.Server as Auth
+import qualified Servant.HTML.Lucid as Lucid
import Servant.Server.Generic (AsServer)
import qualified System.Directory as Directory
import qualified System.Envy as Envy
@@ -84,22 +87,57 @@ import qualified Web.FormUrlEncoded
-- this must go first because of template haskell splicing
newtype UserEmail = UserEmail {unUserEmail :: Text}
- deriving (Eq, Ord, Data, Typeable)
+ deriving (Eq, Ord, Data, Typeable, Generic, Show)
+
+instance Aeson.ToJSON UserEmail
+
+instance Aeson.FromJSON UserEmail
+
+instance Auth.ToJWT UserEmail
+
+instance Auth.FromJWT UserEmail
$(deriveSafeCopy 0 'base ''UserEmail)
+-- | In 'GitHub.Data.Definitions' this is '(Id User)', but I don't want the
+-- extra complexity of 'Id', so just store the underlying Int
+newtype GitHubId = GitHubId {unGitHubId :: Int}
+ deriving (Eq, Ord, Data, Typeable, Generic, Show)
+
+instance Aeson.ToJSON GitHubId
+
+instance Aeson.FromJSON GitHubId
+
+instance Auth.ToJWT GitHubId
+
+instance Auth.FromJWT GitHubId
+
+$(deriveSafeCopy 0 'base ''GitHubId)
+
+-- | The main representation of a user.
data User = User
{ userEmail :: UserEmail,
+ userGitHubId :: GitHubId,
+ -- | So we can make GitHub API calls on their behalf.
userGitHubToken :: Text
}
- deriving (Eq, Data, Typeable, Ord)
+ deriving (Eq, Data, Typeable, Ord, Generic, Show)
+
+instance Aeson.ToJSON User
+
+instance Aeson.FromJSON User
+
+instance Auth.ToJWT User
+
+instance Auth.FromJWT User
$(deriveSafeCopy 0 'base ''User)
instance Indexable User where
empty =
ixSet
- [ ixFun <| \u -> [userEmail u]
+ [ ixFun <| \u -> [userEmail u],
+ ixFun <| \u -> [userGitHubId u]
]
-- | The database.
@@ -120,12 +158,36 @@ newUser u = do
put <| keep {users = IxSet.insert u (users keep)}
return u
-getUserByEmail :: Text -> Acid.Query Keep (Maybe User)
+updateUser :: User -> Acid.Update Keep User
+updateUser u = do
+ keep <- get
+ put <| keep {users = IxSet.updateIx (userGitHubId u) u (users keep)}
+ return u
+
+getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User)
getUserByEmail email = do
Keep {..} <- ask
return <| IxSet.getOne <| users @= email
-$(makeAcidic ''Keep ['newUser, 'getUserByEmail])
+$(makeAcidic ''Keep ['newUser, 'updateUser, 'getUserByEmail])
+
+upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User
+upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of
+ -- Nothing -> throwError err502 { errBody = "No user email" }
+ Nothing -> panic "No user email"
+ Just email ->
+ Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case
+ Just user ->
+ -- need to refresh the token
+ Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok}
+ Nothing ->
+ Acid.update keep
+ <| NewUser
+ User
+ { userEmail = UserEmail email,
+ userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
+ userGitHubToken = Encoding.decodeUtf8 tok
+ }
-- * main and test
@@ -136,27 +198,51 @@ main = Exception.bracket startup shutdown run
cfg <- Envy.decodeWithDefaults Envy.defConfig
oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
kp <- Acid.openLocalStateFrom (keep cfg) mempty :: IO (Acid.AcidState Keep)
+ jwk <- Auth.generateKey
putText "@"
putText "devalloc"
putText <| "port: " <> (show <| port cfg)
putText <| "depo: " <> (Text.pack <| depo cfg)
putText <| "keep: " <> (Text.pack <| keep cfg)
- return (cfg, serve paths (toServant <| htmlApp kp cfg oAuthArgs), kp)
+ let jwtCfg = Auth.defaultJWTSettings jwk
+ let cooks = case area cfg of
+ Test -> devCookieSettings
+ Live -> Auth.defaultCookieSettings
+ let ctx = cooks :. jwtCfg :. EmptyContext
+ let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs)
+ return (cfg, app, 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)
+devCookieSettings :: Auth.CookieSettings
+devCookieSettings =
+ Auth.defaultCookieSettings
+ { Auth.cookieIsSecure = Auth.NotSecure,
+ Auth.cookieXsrfSetting = Nothing
+ }
+
test :: IO Analysis
test = test_analyzeGitHub
-- * app configurations
+data Area = Test | Live
+ deriving (Generic, Show)
+
+instance Envy.Var Area where
+ toVar = show
+ fromVar "Test" = Just Test
+ fromVar "Live" = Just Live
+ fromVar _ = Just Test
+
data Config = Config
{ port :: Warp.Port,
-- | The repo depo! Depository of repositories!
depo :: FilePath,
- keep :: FilePath
+ keep :: FilePath,
+ area :: Area
}
deriving (Generic, Show)
@@ -165,7 +251,8 @@ instance Envy.DefConfig Config where
Config
{ port = 8005,
depo = "_/var/devalloc/depo",
- keep = "_/var/devalloc/keep"
+ keep = "_/var/devalloc/keep",
+ area = Test
}
instance Envy.FromEnv Config
@@ -197,6 +284,15 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
toHtml (HtmlApp x) =
Lucid.doctypehtml_ <| do
Lucid.head_ <| do
+ Lucid.title_ "Devalloc.io :: Know your codebase, know your team."
+ Lucid.meta_
+ [ Lucid.name_ "description",
+ Lucid.content_ "Know your codebase, know your team."
+ ]
+ Lucid.meta_
+ [ Lucid.name_ "viewport",
+ Lucid.content_ "width=device-width, initial-scale=1"
+ ]
Lucid.meta_ [Lucid.charset_ "utf-8"]
jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js"
cssRef "/css/main.css"
@@ -219,39 +315,89 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
-- | All of the routes in the app.
data Paths path = Paths
- { home :: path :- Get '[HTML] (HtmlApp Home),
+ { home ::
+ path
+ :- Get '[Lucid.HTML] (HtmlApp Home),
githubAuth ::
- path :- "auth" :> "github" :> "callback"
+ path
+ :- "auth"
+ :> "github"
+ :> "callback"
:> QueryParam "code" Text
- :> Get '[HTML] (HtmlApp SelectRepo),
+ :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)),
+ selectRepo ::
+ path
+ :- Auth.Auth '[Auth.Cookie] User
+ :> "select-repo"
+ :> Get '[Lucid.HTML] (HtmlApp SelectRepo),
githubAnalysis ::
- path :- "analysis" :> "github"
+ path
+ :- Auth.Auth '[Auth.Cookie] User
+ :> "analysis"
+ :> "github"
:> Capture "user" Text
:> Capture "repo" Text
- :> Get '[HTML] (HtmlApp Analysis),
- css :: path :- "css" :> "main.css" :> Get '[CSS] Text
+ :> Get '[Lucid.HTML] (HtmlApp Analysis),
+ css ::
+ path
+ :- "css"
+ :> "main.css"
+ :> Get '[CSS] Text
}
deriving (Generic)
+type SetCookies ret =
+ (Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret)
+
paths :: Proxy (ToServantApi Paths)
paths = genericApi (Proxy :: Proxy Paths)
-- | Main HTML handlers for all paths.
-htmlApp :: Acid.AcidState Keep -> Config -> OAuthArgs -> Paths AsServer
-htmlApp kp cfg oAuthArgs =
+htmlApp ::
+ Auth.CookieSettings ->
+ Acid.AcidState Keep ->
+ Config ->
+ JWK ->
+ OAuthArgs ->
+ Paths AsServer
+htmlApp cooks kp cfg jwk oAuthArgs =
Paths
- { home = page (Home oAuthArgs),
- githubAuth = auth kp oAuthArgs,
- githubAnalysis = \user repo ->
- liftIO <| analyzeGitHub cfg user repo >>= HtmlApp .> pure,
- css = look
+ { home =
+ pure <. HtmlApp <| Home oAuthArgs,
+ githubAuth =
+ auth kp cooks jwk oAuthArgs,
+ -- TODO: guard on (AuthResult)
+ selectRepo = \case
+ Auth.NoSuchUser -> throwError err401 {errBody = "No such user"}
+ Auth.BadPassword -> throwError err401 {errBody = "Bad password"}
+ Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"}
+ Auth.Authenticated user -> do
+ erepos <-
+ liftIO
+ <| GitHub.github
+ (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user)
+ (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
+ case erepos of
+ Left err -> throwError err502 {errBody = show err}
+ Right repos -> pure <. HtmlApp <| SelectRepo user repos,
+ githubAnalysis = \case
+ Auth.NoSuchUser -> panic "No such user"
+ Auth.BadPassword -> panic "Bad password"
+ Auth.Indefinite -> panic "Incorrect authentication method"
+ Auth.Authenticated user -> \owner repo ->
+ liftIO
+ <| analyzeGitHub
+ (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user)
+ cfg
+ owner
+ repo
+ >>= HtmlApp
+ .> pure,
+ css =
+ return <. toStrict <. Clay.render <| do
+ Biz.Look.fuckingStyle
+ "body" Clay.? Biz.Look.fontStack
}
- where
- page = HtmlApp .> pure
- look =
- return <. toStrict <. Clay.render <| do
- Biz.Look.fuckingStyle
- "body" Clay.? Biz.Look.fontStack
-- | The front page pitch. Eventually I'd like to load the content from markdown
-- files or some other store of data so I can A/B test.
@@ -288,6 +434,19 @@ instance Lucid.ToHtml Home where
Lucid.p_ "(Paid only)"
Lucid.toHtml <| loginButton oAuthArgs
+newtype UserHome = UserHome User
+
+instance Lucid.ToHtml UserHome where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (UserHome user) = do
+ Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+ Lucid.p_
+ <| Lucid.a_
+ [Lucid.linkHref_ "/" <| fieldLink selectRepo]
+ "Analyze one of your repos"
+ where
+ UserEmail email = userEmail user
+
-- | A type for parsing JSON auth responses, used in 'getAccessToken' below.
-- Should be moved to Biz.Auth with others.
data OAuthResponse = OAuthResponse
@@ -300,22 +459,36 @@ data OAuthResponse = OAuthResponse
-- | Login a user by authenticating with GitHub.
auth ::
Acid.AcidState Keep ->
+ Auth.CookieSettings ->
+ JWK ->
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
+ Handler (SetCookies (HtmlApp UserHome))
+auth _ _ _ _ Nothing = panic "no code from github api"
+auth keep cooks jwt oAuthArgs (Just code) = do
+ token <- liftIO <| getAccessToken oAuthArgs code
+ eghUser <- liftIO <| (GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR :: IO (Either GitHub.Error GitHub.User))
+ ghUser <- case eghUser of
+ Left err -> throwError err502 {errBody = show err}
+ Right user -> return user
+ user <- liftIO <| upsertGitHubUser keep token ghUser
+ mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user
+ case mApplyCookies of
+ Nothing -> panic "login didn't work"
+ Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user
+
+-- | POST to GitHub's oAuth service and return the user's oAuth token.
+-- TODO: I can also get access scope etc from this response
+getAccessToken ::
+ OAuthArgs ->
+ Text ->
+ -- | This should be GitHub.Token but GitHub.Auth doesn't export Token.
+ IO ByteString
getAccessToken OAuthArgs {..} code =
accessTokenRequest
>>= Req.responseBody
/> access_token
+ /> Encoding.encodeUtf8
/> return
|> Req.runReq Req.defaultHttpConfig
where
@@ -330,19 +503,14 @@ getAccessToken OAuthArgs {..} 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)
+data SelectRepo = SelectRepo User (Vector GitHub.Repo)
instance Lucid.ToHtml SelectRepo where
toHtmlRaw = Lucid.toHtml
- toHtml (SelectRepo repos) = do
- Lucid.h1_ "Select a repo to analyze"
+ toHtml (SelectRepo user repos) = do
+ Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+ Lucid.h2_ "Select a repo to analyze"
Lucid.ul_ <| forM_ (Vector.toList repos) <| \repo ->
Lucid.li_
<. Lucid.a_
@@ -355,6 +523,8 @@ instance Lucid.ToHtml SelectRepo where
<. Lucid.toHtml
<. GitHub.untagName
<| GitHub.repoName repo
+ where
+ UserEmail email = userEmail user
-- * parts
@@ -534,13 +704,15 @@ authorsFor gitDir path =
-- | Clones a repo from GitHub and does the analysis.
-- TODO: break this up into fetchGitHub and analyze functions.
analyzeGitHub ::
+ GitHub.AuthMethod authMethod =>
+ authMethod ->
Config ->
-- | GitHub owner
Text ->
-- | GitHub repo
Text ->
IO Analysis
-analyzeGitHub cfg o r = do
+analyzeGitHub githubAuth cfg o r = do
-- I currently have no way of getting active users... getting a list of
-- collaborators on a repo requires authentication for some reason.
--
@@ -556,7 +728,7 @@ analyzeGitHub cfg o r = do
-- Right activeUsers <- GitHub.github () (GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll)
Right user <-
GitHub.github
- ()
+ githubAuth
( GitHub.userInfoForR
<| GitHub.mkName (Proxy :: Proxy GitHub.User) o
)
@@ -571,7 +743,7 @@ analyzeGitHub cfg o r = do
ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r
test_analyzeGitHub :: IO Analysis
-test_analyzeGitHub = analyzeGitHub Envy.defConfig "bsima" "bin"
+test_analyzeGitHub = analyzeGitHub () Envy.defConfig "bsima" "bin"
-- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a
-- @git fetch@. Returns the full path to the local repo.
diff --git a/Biz/Devalloc.nix b/Biz/Devalloc.nix
index f994892..b7c7503 100644
--- a/Biz/Devalloc.nix
+++ b/Biz/Devalloc.nix
@@ -37,6 +37,7 @@ in
serviceConfig = {
Environment = [
"PORT=${toString cfg.port}"
+ "AREA=Live"
];
EnvironmentFile="/run/devalloc/env";
KillSignal = "INT";
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 16:26:24 +0000