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.

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 ::