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