diff options
| -rw-r--r-- | Biz/Devalloc.hs | 63 |
1 files changed, 37 insertions, 26 deletions
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, |