summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2021-02-19 15:13:30 -0500
committerBen Sima <ben@bsima.me>2021-02-19 15:13:30 -0500
commitb499befeb774a377e306bd65793f9eb6c9044377 (patch)
tree6073d3aeef70ca6fd458bb2fd6976795986e74f6 /Biz
parentbf9a684d725614a48fc68cd50e79138f1f2648c7 (diff)
Factor out panics
Diffstat (limited to 'Biz')
-rw-r--r--Biz/Devalloc.hs47
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