From bb69bce04e4ead0eb6a867a982eb57fd855ff1ad Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 22 Feb 2021 20:01:51 -0500
Subject: Handle case when GitHub API provides no email

---
 Biz/Devalloc.hs | 63 +++++++++++++++++++++++++++++++++------------------------
 1 file changed, 37 insertions(+), 26 deletions(-)

(limited to 'Biz')

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 4b3bf3b..3fdbdfa 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -121,7 +121,7 @@ import qualified Web.FormUrlEncoded as Web
 -- When changing a persisted type T, first make `T0 == T`, then make the
 -- `SafeCopy.Migrate T` class compile, then make changes to `T`.
 
-newtype UserEmail = UserEmail {unUserEmail :: Text}
+newtype UserEmail = UserEmail {unUserEmail :: Maybe Text}
   deriving (Eq, Ord, Data, Typeable, Generic, Show)
 
 instance Aeson.ToJSON UserEmail
@@ -132,6 +132,11 @@ instance Auth.ToJWT UserEmail
 
 instance Auth.FromJWT UserEmail
 
+instance Lucid.ToHtml UserEmail where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (UserEmail (Just email)) = Lucid.toHtml email
+  toHtml (UserEmail Nothing) = mempty
+
 $(deriveSafeCopy 0 'base ''UserEmail)
 
 -- | In 'GitHub.Data.Definitions' this is '(Id User)', but I don't want the
@@ -289,6 +294,11 @@ getUserByEmail email = do
   Keep {..} <- ask
   pure <| IxSet.getOne <| users @= email
 
+getUserByGitHubId :: GitHubId -> Acid.Query Keep (Maybe User)
+getUserByGitHubId id = do
+  Keep {..} <- ask
+  pure <| IxSet.getOne <| users @= id
+
 getUsers :: Acid.Query Keep [User]
 getUsers = do
   Keep {..} <- ask
@@ -331,6 +341,7 @@ $( makeAcidic
        'updateUser,
        'getUsers,
        'getUserByEmail,
+       'getUserByGitHubId,
        'createAnalysis,
        'getAnalysisById,
        'getAllAnalyses,
@@ -344,28 +355,29 @@ upsertGitHubUser ::
   ByteString ->
   GitHub.User ->
   IO (Either Text User)
-upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of
-  Nothing -> pure <| Left <| "no user email for " <> (GitHub.untagName <| GitHub.userLogin ghUser)
-  Just email ->
-    UserEmail email
-      |> GetUserByEmail
-      |> Acid.query keep
-      +> \case
-        -- need to refresh the token
-        Just user ->
-          UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok}
-            |> Acid.update keep
-        Nothing ->
-          CreateUser
-            User
-              { userEmail = UserEmail email,
-                userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
-                userGitHubToken = Encoding.decodeUtf8 tok,
-                userSubscription = Free,
-                userId = mempty
-              }
-            |> Acid.update keep
-      /> Right
+upsertGitHubUser keep tok ghUser =
+  ghUser
+    |> GitHub.userId
+    |> GitHub.untagId
+    |> GitHubId
+    |> GetUserByGitHubId
+    |> Acid.query keep
+    +> \case
+      Just user ->
+        -- if we already know this user, we need to refresh the token
+        UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok}
+          |> Acid.update keep
+      Nothing ->
+        CreateUser
+          User
+            { userEmail = UserEmail <| GitHub.userEmail ghUser,
+              userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
+              userGitHubToken = Encoding.decodeUtf8 tok,
+              userSubscription = Free,
+              userId = mempty
+            }
+          |> Acid.update keep
+    /> Right
 
 test_upsertGitHubUser :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree
 test_upsertGitHubUser load =
@@ -955,7 +967,7 @@ instance Lucid.ToHtml UserAccount where
   toHtml (UserAccount user@User {..}) = do
     header <| Just user
     Lucid.main_ <| do
-      Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+      Lucid.h1_ "Welcome!"
       Lucid.section_ <| do
         Lucid.h2_ "Subscription"
         let action = linkAction_ "/" <| fieldLink postAccount
@@ -978,7 +990,6 @@ instance Lucid.ToHtml UserAccount where
         if userSubscription == sel
           then [Lucid.selected_ <| tshow sel]
           else mempty
-      UserEmail email = userEmail
 
 style :: Clay.Css -> Lucid.Attribute
 style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline []
@@ -1345,7 +1356,7 @@ test_analyzeGitHub load =
             /> maybe (panic "need GITHUB_USER_TOKEN") Text.pack
         let user =
               User
-                { userEmail = UserEmail "user@example.com",
+                { userEmail = UserEmail <| Just "user@example.com",
                   userGitHubId = GitHubId 0,
                   userGitHubToken = tok,
                   userSubscription = Free,
-- 
cgit v1.2.3