diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 75 |
1 files changed, 10 insertions, 65 deletions
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] |