From 460d25b80051d99ec17128dac4fd9253e99e7515 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Sat, 26 Jun 2021 07:46:31 -0400
Subject: Factor OAuth code into Biz.Auth

---
 Biz/Auth.hs | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 78 insertions(+), 11 deletions(-)

(limited to 'Biz/Auth.hs')

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
-- 
cgit v1.2.3