diff options
| -rw-r--r-- | Alpha.hs | 12 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 47 |
2 files changed, 40 insertions, 19 deletions
@@ -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 |