Factor OAuth code into Biz.Auth

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]