From 42c7614b6a4bd7504e9bf31e0882db58b85857bc Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Thu, 28 Jan 2021 22:54:31 -0500 Subject: Refactor handler functions Created guardAuth and cleaned up the handlers to be as small and regular as possible. My custom operators make it really fun to write this kind of code, heh. And it looks cool. --- Biz/Devalloc.hs | 133 ++++++++++++++++++++++++++------------------------------ 1 file 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 :: -- cgit v1.2.3