@@ -19,7 +19,9 @@ import Control.Monad.Reader
1919import Data.Aeson (ToJSON (.. ))
2020import Data.Aeson qualified as Aeson
2121import Data.Map qualified as Map
22+ import Data.Maybe (fromJust )
2223import Data.Set qualified as Set
24+ import Network.URI (parseURI )
2325import Servant
2426import Share.App (shareAud , shareIssuer )
2527import Share.Env qualified as Env
@@ -38,11 +40,11 @@ import Share.OAuth.Session qualified as Session
3840import Share.OAuth.Types (AccessToken , AuthenticationRequest (.. ), Code , GrantType (AuthorizationCode ), OAuth2State , OAuthClientConfig (.. ), OAuthClientId , PKCEChallenge , PKCEChallengeMethod , RedirectReceiverErr (.. ), ResponseType (ResponseTypeCode ), TokenRequest (.. ), TokenResponse (.. ), TokenType (BearerToken ))
3941import Share.OAuth.Types qualified as OAuth
4042import Share.Postgres qualified as PG
41- import Share.Postgres.Ops qualified as PGO
4243import Share.Postgres.Users.Queries qualified as UserQ
4344import Share.Prelude
4445import Share.User (User (User ))
4546import Share.User qualified as User
47+ import Share.Utils.Deployment qualified as Deployment
4648import Share.Utils.Logging qualified as Logging
4749import Share.Utils.Servant
4850import Share.Utils.Servant.Cookies (CookieVal , cookieVal )
@@ -139,18 +141,20 @@ redirectReceiverEndpoint _mayGithubCode _mayStatePSID (Just errorType) mayErrorD
139141 otherErrType -> do
140142 Logging. logErrorText (" Github authentication error: " <> otherErrType <> " " <> fold mayErrorDescription)
141143 errorRedirect UnspecifiedError
142- redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@ Nothing _mayErrorDescription mayCookiePSID existingAuthSession = do
144+ redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@ Nothing _mayErrorDescription mayCookiePSID _existingAuthSession = do
143145 cookiePSID <- case cookieVal mayCookiePSID of
144146 Nothing -> respondError $ MissingOrExpiredPendingSession
145147 Just psid -> pure psid
146148 PendingSession {loginRequest, returnToURI = unvalidatedReturnToURI, additionalData} <- ensurePendingSession cookiePSID
147- newOrPreExistingUser <- case (mayGithubCode, mayStatePSID, existingAuthSession) of
148- -- The user has an already valid session, we can use that.
149- (_, _, Just session) -> do
150- user <- (PGO. expectUserById (sessionUserId session))
151- pure (UserQ. PreExisting user)
149+ newOrPreExistingUser <- case (mayGithubCode, mayStatePSID) of
152150 -- The user has completed the Github flow, we can log them in or create a new user.
153- (Just githubCode, Just statePSID, _noSession) -> do
151+ (Just githubCode, Just statePSID) -> do
152+ (ghUser, ghEmail) <-
153+ -- Skip the github flow when developing locally, and just use some dummy github user
154+ -- data.
155+ if Deployment. onLocal
156+ then pure localGithubUserInfo
157+ else getGithubUserInfo githubCode statePSID cookiePSID
154158 mayPreferredHandle <- runMaybeT do
155159 obj <- hoistMaybe additionalData
156160 case Aeson. fromJSON obj of
@@ -160,10 +164,10 @@ redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayError
160164 Aeson. Success m -> do
161165 handle <- hoistMaybe $ Map. lookup (" handle" :: Text ) m
162166 hoistMaybe . eitherToMaybe $ IDs. fromText handle
163- completeGithubFlow githubCode statePSID cookiePSID mayPreferredHandle
164- (Nothing , _, _ ) -> do
167+ completeGithubFlow ghUser ghEmail mayPreferredHandle
168+ (Nothing , _) -> do
165169 respondError $ MissingCode
166- (_, Nothing , _ ) -> do
170+ (_, Nothing ) -> do
167171 respondError $ MissingState
168172 let (User {User. user_id = uid}) = UserQ. getNewOrPreExisting newOrPreExistingUser
169173 when (UserQ. isNew newOrPreExistingUser) do
@@ -198,20 +202,37 @@ redirectReceiverEndpoint mayGithubCode mayStatePSID _errorType@Nothing _mayError
198202 Nothing -> respondError $ InternalServerError " session-create-failure" (" Failed to create session" :: Text )
199203 Just setAuthHeaders -> pure . clearPendingSessionCookie cookieSettings $ setAuthHeaders response
200204 where
201- completeGithubFlow ::
205+ localGithubUserInfo :: (Github. GithubUser , Github. GithubEmail )
206+ localGithubUserInfo =
207+ ( Github. GithubUser
208+ { githubHandle = " LocalGithubUser" ,
209+ githubUserId = 1 ,
210+ githubUserAvatarUrl = URIParam $ fromJust $ parseURI " https://avatars.githubusercontent.com/u/0?v=4" ,
211+ githubUserName = Just " Local Github User"
212+ },
213+ Github. GithubEmail
214+ { githubEmailEmail = " local@example.com" ,
215+ githubEmailIsPrimary = True ,
216+ githubEmailIsVerified = True
217+ }
218+ )
219+
220+ getGithubUserInfo ::
202221 ( OAuth. Code ->
203222 PendingSessionId ->
204223 PendingSessionId ->
205- Maybe UserHandle ->
206- WebApp (UserQ. NewOrPreExisting User )
224+ WebApp (Github. GithubUser , Github. GithubEmail )
207225 )
208- completeGithubFlow githubCode statePSID cookiePSID mayPreferredHandle = do
226+ getGithubUserInfo githubCode statePSID cookiePSID = do
209227 when (statePSID /= cookiePSID) do
210228 Redis. liftRedis $ Redis. failPendingSession cookiePSID
211229 respondError (MismatchedState cookiePSID statePSID)
212230 token <- Github. githubTokenForCode githubCode
213231 ghUser <- Github. githubUser token
214232 ghEmail <- Github. primaryGithubEmail token
233+ pure (ghUser, ghEmail)
234+ completeGithubFlow :: Github. GithubUser -> Github. GithubEmail -> Maybe UserHandle -> WebApp (UserQ. NewOrPreExisting User )
235+ completeGithubFlow ghUser ghEmail mayPreferredHandle = do
215236 PG. tryRunTransaction (UserQ. findOrCreateGithubUser AuthZ. userCreationOverride ghUser ghEmail mayPreferredHandle) >>= \ case
216237 Left (UserQ. UserHandleTaken _) -> do
217238 errorRedirect AccountCreationHandleAlreadyTaken
@@ -269,8 +290,19 @@ loginWithGithub ::
269290 NoContent
270291 )
271292loginWithGithub psid = do
272- githubAuthURI <- Github. githubAuthenticationURI psid
293+ githubAuthURI <-
294+ if Deployment. onLocal
295+ then skipGithubLoginURL psid
296+ else Github. githubAuthenticationURI psid
273297 pure $ redirectTo githubAuthURI
298+ where
299+ skipGithubLoginURL :: OAuth2State -> WebApp URI
300+ skipGithubLoginURL oauth2State = do
301+ sharePathQ [" oauth" , " redirect" ] $
302+ Map. fromList
303+ [ (" code" , " code" ),
304+ (" state" , toQueryParam oauth2State)
305+ ]
274306
275307-- | Log out the user by telling the browser to clear the session cookies.
276308-- Note that this doesn't (yet) invalidate the session itself, it just removes its cookie from the
0 commit comments