Factor OAuth code into Biz.Auth

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]