Skip Github flow on local for easier testing of user creation flows

src/Share/Github.hs

@@ -45,44 +45,44 @@ instance ToServerError GithubError where
     GithubDecodeError _ce -> (ErrorID "github:decode-error", err500 {errBody = "Github returned an unexpected response. Please try again."})
 
 data GithubUser = GithubUser
-  { github_user_login :: Text,
-    github_user_id :: Int64,
-    github_user_avatar_url :: URIParam,
-    github_user_name :: Maybe Text
+  { githubHandle :: Text,
+    githubUserId :: Int64,
+    githubUserAvatarUrl :: URIParam,
+    githubUserName :: Maybe Text
   }
   deriving (Show)
 
 instance FromJSON GithubUser where
   parseJSON = withObject "GithubUser" $ \u ->
     GithubUser
       <$> u
-      .: "login"
+        .: "login"
       <*> u
-      .: "id"
+        .: "id"
       <*> u
-      .: "avatar_url"
+        .: "avatar_url"
       -- We don't use this email because it's the "publicly visible" email, instead we fetch
       -- the primary email using the emails API.
       -- <*> u .: "email"
       <*> u
-      .:? "name"
+        .:? "name"
 
 data GithubEmail = GithubEmail
-  { github_email_email :: Text,
-    github_email_primary :: Bool,
-    github_email_verified :: Bool
+  { githubEmailEmail :: Text,
+    githubEmailIsPrimary :: Bool,
+    githubEmailIsVerified :: Bool
   }
   deriving (Show)
 
 instance FromJSON GithubEmail where
   parseJSON = withObject "GithubEmail" $ \u ->
     GithubEmail
       <$> u
-      .: "email"
+        .: "email"
       <*> u
-      .: "primary"
+        .: "primary"
       <*> u
-      .: "verified"
+        .: "verified"
 
 type GithubTokenApi =
   "login"
@@ -190,7 +190,7 @@ primaryGithubEmail auth = do
   emails <- runGithubClient githubAPIBaseURL (githubEmailsClient auth)
   -- Github's api docs suggest there will always be a primary email.
   -- https://docs.github.com/en/rest/users/emails#list-email-addresses-for-the-authenticated-user
-  case find github_email_primary emails of
+  case find githubEmailIsPrimary emails of
     Nothing -> respondError GithubUserWithoutPrimaryEmail
     Just email -> pure email
 

src/Share/Postgres/Users/Queries.hs

@@ -197,7 +197,7 @@ userByHandle handle = do
 
 createFromGithubUser :: AuthZ.AuthZReceipt -> GithubUser -> GithubEmail -> Maybe UserHandle -> PG.Transaction UserCreationError User
 createFromGithubUser !authzReceipt (GithubUser githubHandle githubUserId avatar_url user_name) primaryEmail mayPreferredHandle = do
-  let (GithubEmail {github_email_email = user_email, github_email_verified = emailVerified}) = primaryEmail
+  let (GithubEmail {githubEmailEmail = user_email, githubEmailIsVerified = emailVerified}) = primaryEmail
   userHandle <- case mayPreferredHandle of
     Just handle -> pure handle
     Nothing -> case IDs.fromText @UserHandle (Text.toLower githubHandle) of

src/Share/Web/OAuth/Impl.hs

@@ -19,7 +19,9 @@ import Control.Monad.Reader
 import Data.Aeson (ToJSON (..))
 import Data.Aeson qualified as Aeson
 import Data.Map qualified as Map
+import Data.Maybe (fromJust)
 import Data.Set qualified as Set
+import Network.URI (parseURI)
 import Servant
 import Share.App (shareAud, shareIssuer)
 import Share.Env qualified as Env
@@ -38,11 +40,11 @@ import Share.OAuth.Session qualified as Session
 import Share.OAuth.Types (AccessToken, AuthenticationRequest (..), Code, GrantType (AuthorizationCode), OAuth2State, OAuthClientConfig (..), OAuthClientId, PKCEChallenge, PKCEChallengeMethod, RedirectReceiverErr (..), ResponseType (ResponseTypeCode), TokenRequest (..), TokenResponse (..), TokenType (BearerToken))
 import Share.OAuth.Types qualified as OAuth
 import Share.Postgres qualified as PG
-import Share.Postgres.Ops qualified as PGO
 import Share.Postgres.Users.Queries qualified as UserQ
 import Share.Prelude
 import Share.User (User (User))
 import Share.User qualified as User
+import Share.Utils.Deployment qualified as Deployment
 import Share.Utils.Logging qualified as Logging
 import Share.Utils.Servant
 import Share.Utils.Servant.Cookies (CookieVal, cookieVal)
@@ -139,18 +141,20 @@ redirectReceiverEndpoint _mayGithubCode _mayStatePSID (Just errorType) mayErrorD
     otherErrType -> do
       Logging.logErrorText ("Github authentication error: " <> otherErrType <> " " <> fold mayErrorDescription)
       errorRedirect UnspecifiedError
-redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayErrorDescription mayCookiePSID existingAuthSession = do
+redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayErrorDescription mayCookiePSID _existingAuthSession = do
   cookiePSID <- case cookieVal mayCookiePSID of
     Nothing -> respondError $ MissingOrExpiredPendingSession
     Just psid -> pure psid
   PendingSession {loginRequest, returnToURI = unvalidatedReturnToURI, additionalData} <- ensurePendingSession cookiePSID
-  newOrPreExistingUser <- case (mayGithubCode, mayStatePSID, existingAuthSession) of
-    -- The user has an already valid session, we can use that.
-    (_, _, Just session) -> do
-      user <- (PGO.expectUserById (sessionUserId session))
-      pure (UserQ.PreExisting user)
+  newOrPreExistingUser <- case (mayGithubCode, mayStatePSID) of
     -- The user has completed the Github flow, we can log them in or create a new user.
-    (Just githubCode, Just statePSID, _noSession) -> do
+    (Just githubCode, Just statePSID) -> do
+      (ghUser, ghEmail) <-
+        -- Skip the github flow when developing locally, and just use some dummy github user
+        -- data.
+        if Deployment.onLocal
+          then pure localGithubUserInfo
+          else getGithubUserInfo githubCode statePSID cookiePSID
       mayPreferredHandle <- runMaybeT do
         obj <- hoistMaybe additionalData
         case Aeson.fromJSON obj of
@@ -160,10 +164,10 @@ redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayError
           Aeson.Success m -> do
             handle <- hoistMaybe $ Map.lookup ("handle" :: Text) m
             hoistMaybe . eitherToMaybe $ IDs.fromText handle
-      completeGithubFlow githubCode statePSID cookiePSID mayPreferredHandle
-    (Nothing, _, _) -> do
+      completeGithubFlow ghUser ghEmail mayPreferredHandle
+    (Nothing, _) -> do
       respondError $ MissingCode
-    (_, Nothing, _) -> do
+    (_, Nothing) -> do
       respondError $ MissingState
   let (User {User.user_id = uid}) = UserQ.getNewOrPreExisting newOrPreExistingUser
   when (UserQ.isNew newOrPreExistingUser) do
@@ -198,20 +202,37 @@ redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayError
         Nothing -> respondError $ InternalServerError "session-create-failure" ("Failed to create session" :: Text)
         Just setAuthHeaders -> pure . clearPendingSessionCookie cookieSettings $ setAuthHeaders response
   where
-    completeGithubFlow ::
+    localGithubUserInfo :: (Github.GithubUser, Github.GithubEmail)
+    localGithubUserInfo =
+      ( Github.GithubUser
+          { githubHandle = "LocalGithubUser",
+            githubUserId = 1,
+            githubUserAvatarUrl = URIParam $ fromJust $ parseURI "https://avatars.githubusercontent.com/u/0?v=4",
+            githubUserName = Just "Local Github User"
+          },
+        Github.GithubEmail
+          { githubEmailEmail = "[email protected]",
+            githubEmailIsPrimary = True,
+            githubEmailIsVerified = True
+          }
+      )
+
+    getGithubUserInfo ::
       ( OAuth.Code ->
         PendingSessionId ->
         PendingSessionId ->
-        Maybe UserHandle ->
-        WebApp (UserQ.NewOrPreExisting User)
+        WebApp (Github.GithubUser, Github.GithubEmail)
       )
-    completeGithubFlow githubCode statePSID cookiePSID mayPreferredHandle = do
+    getGithubUserInfo githubCode statePSID cookiePSID = do
       when (statePSID /= cookiePSID) do
         Redis.liftRedis $ Redis.failPendingSession cookiePSID
         respondError (MismatchedState cookiePSID statePSID)
       token <- Github.githubTokenForCode githubCode
       ghUser <- Github.githubUser token
       ghEmail <- Github.primaryGithubEmail token
+      pure (ghUser, ghEmail)
+    completeGithubFlow :: Github.GithubUser -> Github.GithubEmail -> Maybe UserHandle -> WebApp (UserQ.NewOrPreExisting User)
+    completeGithubFlow ghUser ghEmail mayPreferredHandle = do
       PG.tryRunTransaction (UserQ.findOrCreateGithubUser AuthZ.userCreationOverride ghUser ghEmail mayPreferredHandle) >>= \case
         Left (UserQ.UserHandleTaken _) -> do
           errorRedirect AccountCreationHandleAlreadyTaken
@@ -269,8 +290,19 @@ loginWithGithub ::
         NoContent
     )
 loginWithGithub psid = do
-  githubAuthURI <- Github.githubAuthenticationURI psid
+  githubAuthURI <-
+    if Deployment.onLocal
+      then skipGithubLoginURL psid
+      else Github.githubAuthenticationURI psid
   pure $ redirectTo githubAuthURI
+  where
+    skipGithubLoginURL :: OAuth2State -> WebApp URI
+    skipGithubLoginURL oauth2State = do
+      sharePathQ ["oauth", "redirect"] $
+        Map.fromList
+          [ ("code", "code"),
+            ("state", toQueryParam oauth2State)
+          ]
 
 -- | Log out the user by telling the browser to clear the session cookies.
 -- Note that this doesn't (yet) invalidate the session itself, it just removes its cookie from the

transcripts/run-transcripts.zsh

@@ -16,6 +16,7 @@ transcripts=(
     contribution-merge transcripts/share-apis/contribution-merge/
     search transcripts/share-apis/search/
     users transcripts/share-apis/users/
+    user-creation transcripts/share-apis/user-creation/
     contribution-diffs transcripts/share-apis/contribution-diffs/
     definition-diffs transcripts/share-apis/definition-diffs/
     tickets transcripts/share-apis/tickets/

transcripts/share-apis/user-creation/new-user-login.json

@@ -0,0 +1 @@
+{"status_code": 200, "result_url": "http://localhost:1234/?event=new-user-log-in"}

transcripts/share-apis/user-creation/new-user-profile.json

@@ -0,0 +1,16 @@
+{
+  "body": {
+    "avatarUrl": "https://avatars.githubusercontent.com/u/0?v=4",
+    "completedTours": [],
+    "handle": "localgithubuser",
+    "name": "Local Github User",
+    "organizationMemberships": [],
+    "primaryEmail": "[email protected]",
+    "userId": "U-<UUID>"
+  },
+  "status": [
+    {
+      "status_code": 200
+    }
+  ]
+}

transcripts/share-apis/user-creation/run.zsh

@@ -0,0 +1,19 @@
+#!/usr/bin/env zsh
+
+set -ex
+
+source "../../transcript_helpers.sh"
+
+# Create a cookie jar we can use to store cookies for the new user we're goin to create.
+new_user_cookie_jar=$(cookie_jar_for_user_id "new_user")
+
+# Should be able to create a new user via the login flow by following redirects.
+curl -v -s -L -I -o /dev/null -w '{"status_code": %{http_code}, "result_url": "%{url_effective}"}' --request "GET" --cookie "$new_user_cookie_jar" --cookie-jar "$new_user_cookie_jar" "localhost:5424/login" > ./new-user-login.json
+
+echo "Created new user!"
+
+# user should now be logged in as the local github user.
+fetch "new_user" GET new-user-profile /account
+
+
+echo "DONE"