diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Devalloc.hs | 47 |
1 files changed, 32 insertions, 15 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index a16803b..6efbc53 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -339,17 +339,24 @@ $( makeAcidic ] ) -upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User +upsertGitHubUser :: + Acid.AcidState Keep -> + ByteString -> + GitHub.User -> + IO (Either Text User) upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of - Nothing -> panic "No user email" + Nothing -> pure <| Left <| "no user email for " <> (GitHub.untagName <| GitHub.userLogin ghUser) Just email -> - Acid.query keep (GetUserByEmail <| UserEmail email) +> \case - Just user -> + UserEmail email + |> GetUserByEmail + |> Acid.query keep + +> \case -- need to refresh the token - Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} - Nothing -> - Acid.update keep - <| CreateUser + Just user -> + UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} + |> Acid.update keep + Nothing -> + CreateUser User { userEmail = UserEmail email, userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser, @@ -357,6 +364,8 @@ upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of userSubscription = Free, userId = mempty } + |> Acid.update keep + /> Right test_upsertGitHubUser :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree test_upsertGitHubUser load = @@ -364,7 +373,7 @@ test_upsertGitHubUser load = "upsertUser" [ Test.unit "userId is not mempty" <| do (_, _, k) <- load - User {..} <- upsertGitHubUser k "token" ghUser + Right User {..} <- upsertGitHubUser k "token" ghUser userId @?!= mempty ] where @@ -665,16 +674,24 @@ htmlApp cooks kp cfg jwk oAuthArgs = OAuthResponse {..} <- githubOauth oAuthArgs code |> liftIO guardScope scope let token = Encoding.encodeUtf8 access_token + let warn :: Text -> Handler a + warn msg = + Log.warn [msg] + >> Log.br + |> liftIO + >> throwError err502 {errBody = str msg} user <- - GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR + GitHub.userInfoCurrentR + |> GitHub.github (GitHub.OAuth token) |> liftIO - +> \case - Left err -> throwError err502 {errBody = show err} - Right ghUser -> liftIO <| upsertGitHubUser kp token ghUser + +> either (show .> warn) pure + +> upsertGitHubUser kp token + .> liftIO + +> either warn pure Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user |> liftIO +> \case - Nothing -> panic "login didn't work" + Nothing -> throwError err502 {errBody = "login didn't work"} -- I think this should redirect to instead of rendering UserAccount Just applyCookies -> UserAccount user @@ -1276,7 +1293,7 @@ analyzeGitHub keep User {..} depo o r = do /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR) /> Vector.toList +> Async.mapConcurrently (GitHub.github ghAuth) - /> map (either (panic <. tshow) GitHub.userEmail) + /> map (either (const Nothing) GitHub.userEmail) /> catMaybes GitHub.github ghAuth (GitHub.repositoryR ghOwner ghRepo) +> \case Left err -> throwIO <| toException err |