diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Auth.hs | 89 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 75 |
2 files changed, 88 insertions, 76 deletions
diff --git a/Biz/Auth.hs b/Biz/Auth.hs index 3648395..ed904b9 100644 --- a/Biz/Auth.hs +++ b/Biz/Auth.hs @@ -1,18 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A module for common OAuth flows. +-- +-- Consider using authenticate-oauth package module Biz.Auth - ( Error (..), - Password, - Username, + ( -- * OAuth + OAuthResponse (..), + OAuthArgs (..), + + -- * GitHub Authentication + githubOauth, + + -- * Servant Helpers + SetCookies, ) where -import Data.ByteString (ByteString) -import Data.Text (Text) -import Miso.String +import Alpha +import qualified Data.Aeson as Aeson +import Network.HTTP.Req ((/:), (=:)) +import qualified Network.HTTP.Req as Req +import Servant (Header, Headers) +import qualified Servant.Auth.Server as Auth +import qualified System.Envy as Envy + +-- | Wrapper around 'Auth.SetCookie' that you can put in a servant path +-- descriptor. +type SetCookies ret = + (Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret) + +-- | These are arguments that a 3rd-party OAuth provider needs in order for us +-- to authenticate a user. +data OAuthArgs = OAuthArgs + { clientSecret :: Text, + clientId :: Text, + clientState :: Text + } + deriving (Generic, Show) + +instance Envy.DefConfig OAuthArgs where + defConfig = + OAuthArgs + { clientSecret = mempty, + clientId = mempty, + clientState = mempty + } -data Error - = BadUsername - | BadPassword +instance Envy.FromEnv OAuthArgs -type Password = MisoString +-- | A type for parsing JSON auth responses, used in 'githubOauth' below. +-- Should be moved to Biz.Auth with others. +data OAuthResponse = OAuthResponse + { access_token :: Text, + scope :: Text, + token_type :: Text + } + deriving (Generic, Aeson.FromJSON) -type Username = MisoString +-- | POST to GitHub's OAuth service and get the user's oAuth token. +githubOauth :: + OAuthArgs -> + -- | This should be GitHub.Token but GitHub.Auth doesn't export Token. + Text -> + IO OAuthResponse +githubOauth OAuthArgs {..} code = + accessTokenRequest + /> Req.responseBody + |> Req.runReq Req.defaultHttpConfig + where + accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) + accessTokenRequest = + Req.req + Req.POST + (Req.https "github.com" /: "login" /: "oauth" /: "access_token") + Req.NoReqBody + Req.jsonResponse + <| "client_id" =: clientId + <> "client_secret" =: clientSecret + <> "code" =: code + <> "state" =: clientState diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index b920241..1813f3a 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -59,6 +59,7 @@ where import Alpha hiding (rem, (<.>)) import qualified Biz.App as App +import qualified Biz.Auth as Auth import qualified Biz.Cli as Cli import qualified Biz.Id as Id import qualified Biz.Log as Log @@ -102,8 +103,6 @@ import qualified Lucid import qualified Lucid.Base as Lucid import qualified Lucid.Servant as Lucid import NeatInterpolation -import Network.HTTP.Req ((/:), (=:)) -import qualified Network.HTTP.Req as Req import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import Servant @@ -869,25 +868,6 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config --- | These are arguments that a 3rd-party OAuth provider needs in order for us --- to authenticate a user. -data OAuthArgs = OAuthArgs - { githubClientSecret :: Text, - githubClientId :: Text, - githubState :: Text - } - deriving (Generic, Show) - -instance Envy.DefConfig OAuthArgs where - defConfig = - OAuthArgs - { githubClientSecret = mempty, - githubClientId = mempty, - githubState = mempty - } - -instance Envy.FromEnv OAuthArgs - -- * paths and pages -- | Wraps pages in default HTML @@ -944,7 +924,7 @@ data Paths path = Paths :> "github" :> "callback" :> QueryParam "code" Text - :> Get '[Lucid.HTML] (SetCookies (App.Html UserAccount)), + :> Get '[Lucid.HTML] (Auth.SetCookies (App.Html UserAccount)), getAccount :: path :- Auth.Auth '[Auth.Cookie] User @@ -986,9 +966,6 @@ data Paths path = Paths } 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) @@ -1033,7 +1010,7 @@ htmlApp :: Acid.AcidState Keep -> Config -> JWK -> - OAuthArgs -> + Auth.OAuthArgs -> Paths AsServer htmlApp cooks kp cfg jwk oAuthArgs = Paths @@ -1049,7 +1026,7 @@ htmlApp cooks kp cfg jwk oAuthArgs = githubAuth = \case Nothing -> throwError err503 {errBody = "Bad response from GitHub API"} Just code -> do - OAuthResponse {..} <- githubOauth oAuthArgs code |> liftIO + Auth.OAuthResponse {..} <- Auth.githubOauth oAuthArgs code |> liftIO guardScope scope let warn :: Text -> Servant.Handler a warn msg = @@ -1279,7 +1256,7 @@ instance Lucid.ToHtml AdminDashboard where -- | 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. -data Home = Home OAuthArgs (Maybe Analysis) +data Home = Home Auth.OAuthArgs (Maybe Analysis) instance App.HasCss Home where cssFor (Home _ mAnalysis) = do @@ -1455,52 +1432,20 @@ instance Lucid.ToHtml UserAccount where css :: Clay.Css -> Lucid.Attribute css = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline [] --- | A type for parsing JSON auth responses, used in 'githubOauth' below. --- Should be moved to Biz.Auth with others. -data OAuthResponse = OAuthResponse - { access_token :: Text, - scope :: Text, - token_type :: Text - } - deriving (Generic, Aeson.FromJSON) - userGitHubAuth :: -- | Token from `User.userGitHubToken` or `Config.tokn` Text -> GitHub.Auth userGitHubAuth = GitHub.OAuth <. Encoding.encodeUtf8 --- | POST to GitHub's OAuth service and get the user's oAuth token. -githubOauth :: - OAuthArgs -> - Text -> - -- | This should be GitHub.Token but GitHub.Auth doesn't export Token. - IO OAuthResponse -githubOauth OAuthArgs {..} code = - accessTokenRequest - /> Req.responseBody - |> Req.runReq Req.defaultHttpConfig - where - accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) - accessTokenRequest = - Req.req - Req.POST - (Req.https "github.com" /: "login" /: "oauth" /: "access_token") - Req.NoReqBody - Req.jsonResponse - <| "client_id" =: githubClientId - <> "client_secret" =: githubClientSecret - <> "code" =: code - <> "state" =: githubState - -- GitHub OAuth endpoint. For what the parameters mean, see: -- https://docs.github.com/en/developers/apps/authorizing-oauth-apps -githubLoginUrl :: OAuthArgs -> Text -githubLoginUrl OAuthArgs {..} = +githubLoginUrl :: Auth.OAuthArgs -> Text +githubLoginUrl Auth.OAuthArgs {..} = "https://github.com/login/oauth/authorize?" <> encodeParams - [ ("client_id", githubClientId), - ("state", githubState), + [ ("client_id", clientId), + ("state", clientState), ("scope", Text.intercalate " " <| Set.toList requiredScopes) ] @@ -1565,7 +1510,7 @@ encodeParams = <. Web.urlEncodeParams -- | Login button for GitHub. -tryButton :: OAuthArgs -> Text -> Text -> Lucid.Html () +tryButton :: Auth.OAuthArgs -> Text -> Text -> Lucid.Html () tryButton oAuthArgs title subtitle = Lucid.a_ [Lucid.id_ "try-button", Lucid.href_ <| githubLoginUrl oAuthArgs] |