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