diff options
| -rw-r--r-- | Biz/Devalloc.hs | 133 |
1 files changed, 62 insertions, 71 deletions
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 5713db0..245d94d 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -57,7 +57,7 @@ import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Cli as Cli import qualified Biz.Id as Id import qualified Biz.Look -import Biz.Test ((@?!=), (@=?)) +import Biz.Test ((@=?), (@?!=)) import qualified Biz.Test as Test import qualified CMark as Cmark import qualified CMark.Lucid as Cmark @@ -610,6 +610,16 @@ type SetCookies ret = paths :: Proxy (ToServantApi Paths) paths = genericApi (Proxy :: Proxy Paths) +guardAuth :: + MonadError ServerError m => + Auth.AuthResult a -> + m a +guardAuth = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user -> pure user + -- | Main HTML handlers for all paths. htmlApp :: Auth.CookieSettings -> @@ -622,59 +632,62 @@ htmlApp cooks kp cfg jwk oAuthArgs = Paths { home = pure <. HtmlApp <| Home oAuthArgs, - login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, - githubAuth = - auth kp cooks jwk oAuthArgs, - getAccount = \case - Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user@User {..} -> do - pure <| HtmlApp <| UserAccount user, - postAccount = \case - Auth.NoSuchUser -> \_ -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> \_ -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> \_ -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user@User {..} -> \subscription -> do - newuser <- Acid.update' kp <| UpdateUser user {userSubscription = subscription} - pure <| HtmlApp <| UserAccount newuser, - selectRepo = \case - Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user@User {..} -> do - erepos <- - liftIO - <| GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) - (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) - case erepos of + login = + pure <| addHeader (githubLoginUrl oAuthArgs) NoContent, + githubAuth = \case + Nothing -> throwError err503 {errBody = "Bad response from GitHub API"} + Just code -> do + token <- getAccessToken oAuthArgs code |> liftIO + user <- + GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR + |> liftIO + >>= \case + Left err -> throwError err502 {errBody = show err} + Right ghUser -> liftIO <| upsertGitHubUser kp token ghUser + Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user + |> liftIO + >>= \case + Nothing -> panic "login didn't work" + -- I think this should redirect to instead of rendering UserAccount + Just applyCookies -> + UserAccount user + |> HtmlApp + |> applyCookies + |> return, + getAccount = \u -> + guardAuth u >>= UserAccount .> HtmlApp .> pure, + postAccount = \a subscription -> + guardAuth a >>= \user -> + UpdateUser user {userSubscription = subscription} + |> Acid.update' kp + >>= UserAccount + .> HtmlApp + .> pure, + selectRepo = \u -> + guardAuth u >>= \user@User {..} -> + GitHub.github + (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + |> liftIO + >>= \case Left err -> throwError err502 {errBody = show err} Right repos -> pure <. HtmlApp <| SelectRepo user repos, - getAnalyses = \case - Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user@User {..} -> do - analyses <- Acid.query' kp <| GetAnalysesByAsker user - pure <| HtmlApp <| Analyses user analyses, - getAnalysis = \case - Auth.NoSuchUser -> \_ -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> \_ -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> \_ -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user -> \analysisId -> - do - -- Acid.query' kp ( GetAnalysisById analysisId) >>= \case - GetAnalysisById analysisId + getAnalyses = \u -> + guardAuth u >>= \user@User {..} -> do + GetAnalysesByAsker user + |> Acid.query' kp + >>= Analyses user + .> HtmlApp + .> pure, + getAnalysis = \a analysisId -> + guardAuth a >>= \user -> + GetAnalysisById analysisId |> Acid.query' kp >>= \case - Nothing -> panic "404" + Nothing -> throwError err404 Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, - githubAnalysis = \case - Auth.NoSuchUser -> \_ _ -> throwError err401 {errBody = "No such user"} - Auth.BadPassword -> \_ _ -> throwError err401 {errBody = "Bad password"} - Auth.Indefinite -> \_ _ -> throwError err401 {errBody = "Incorrect authentication method"} - Auth.Authenticated user@User {..} -> \owner repo -> + githubAnalysis = \a owner repo -> + guardAuth a >>= \user -> analyzeGitHub kp user cfg owner repo |> liftIO >>= AnalysisDisplay user @@ -896,28 +909,6 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) --- | Login a user by authenticating with GitHub. -auth :: - Acid.AcidState Keep -> - Auth.CookieSettings -> - JWK -> - OAuthArgs -> - Maybe Text -> - Handler (SetCookies (HtmlApp UserAccount)) -auth _ _ _ _ Nothing = panic "no code from github api" -auth keep cooks jwt oAuthArgs (Just code) = do - token <- liftIO <| getAccessToken oAuthArgs code - eghUser <- liftIO <| (GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR :: IO (Either GitHub.Error GitHub.User)) - ghUser <- case eghUser of - Left err -> throwError err502 {errBody = show err} - Right user -> return user - user <- liftIO <| upsertGitHubUser keep token ghUser - mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user - case mApplyCookies of - Nothing -> panic "login didn't work" - -- I think this should redirect to instead of rendering UserAccount - Just applyCookies -> return <. applyCookies <. HtmlApp <| UserAccount user - -- | POST to GitHub's oAuth service and return the user's oAuth token. -- TODO: I can also get access scope etc from this response getAccessToken :: |