Factor out panics

2 files changed, 40 insertions, 19 deletions

diff --git a/Alpha.hs b/Alpha.hs
index 9feb123..71ceef6 100644
--- a/Alpha.hs
+++ b/Alpha.hs
@@ -55,6 +55,7 @@ module Alpha
     (?+),
 
     -- * Text
+    str,
     tshow,
     chomp,
     lchomp,
@@ -200,18 +201,18 @@ don't = do not
 {-# ANN don't ("HLint: ignore Redundant do" :: String) #-}
 
 -- | Class for turning different string types to snakeCase.
-class CanSnakeCase str where
-  snake :: str -> str
+class CanSnakeCase s where
+  snake :: s -> s
 
 instance CanSnakeCase Text where
   snake = Text.toLower .> Text.replace " " "-"
 
 capitalize :: String -> String
 capitalize [] = []
-capitalize str = (Char.toUpper <| List.head str) : (Char.toLower </ List.tail str)
+capitalize s = (Char.toUpper <| List.head s) : (Char.toLower </ List.tail s)
 
 lowercase :: String -> String
-lowercase str = [Char.toLower c | c <- str]
+lowercase s = [Char.toLower c | c <- s]
 
 {-# WARNING require "'require' remains in code" #-}
 require :: Text -> Maybe a -> a
@@ -231,5 +232,8 @@ wrap lim = Text.words .> wrap_ 0 .> Text.unwords
       where
         lw = Text.length w
 
+str :: StringConv a b => a -> b
+str = toS
+
 tshow :: Show a => a -> Text
 tshow = show
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