From b499befeb774a377e306bd65793f9eb6c9044377 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 19 Feb 2021 15:13:30 -0500
Subject: Factor out panics

---
 Biz/Devalloc.hs | 47 ++++++++++++++++++++++++++++++++---------------
 1 file changed, 32 insertions(+), 15 deletions(-)

(limited to 'Biz')

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