From c2827b0560082f5499c178ead746e7ff9448dd64 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 24 Jul 2020 23:39:21 -0700
Subject: hero: working authenticated api calls

---
 Hero/Core.hs |  8 +++++---
 Hero/Host.hs | 21 +++++++++++++++------
 Hero/Node.hs | 20 +++++++++-----------
 3 files changed, 29 insertions(+), 20 deletions(-)

(limited to 'Hero')

diff --git a/Hero/Core.hs b/Hero/Core.hs
index c11456d..3870c59 100644
--- a/Hero/Core.hs
+++ b/Hero/Core.hs
@@ -296,7 +296,8 @@ data Action
   deriving (Show, Eq)
 
 type AppRoutes =
-  ComicCover
+  Home
+    :<|> ComicCover
     :<|> ComicReaderSpread
     :<|> ComicReaderFull
     :<|> ComicVideo
@@ -304,7 +305,8 @@ type AppRoutes =
     :<|> ChooseExperience
 
 handlers =
-  comicCover
+  home
+    :<|> comicCover
     :<|> comicReader
     :<|> comicReader
     :<|> comicReader
@@ -316,7 +318,7 @@ routes = Proxy
 
 type PubRoutes =
   Home
-  :<|> Login
+    :<|> Login
 
 pubRoutes :: Proxy PubRoutes
 pubRoutes = Proxy
diff --git a/Hero/Host.hs b/Hero/Host.hs
index fc31c39..267d475 100644
--- a/Hero/Host.hs
+++ b/Hero/Host.hs
@@ -61,8 +61,8 @@ import qualified Data.Acid.Abstract as Acid
 import qualified Data.Aeson as Aeson
 import Data.Text (Text)
 import qualified Data.Text.Lazy as Lazy
-import Hero.Core
 import qualified Hero.Assets as Assets
+import Hero.Core
 import qualified Hero.Keep as Keep
 import qualified Hero.Look as Look
 import qualified Hero.Look.Typography as Typography
@@ -98,9 +98,14 @@ main = bracket startup shutdown run
           prn $ "node: " ++ heroNode cfg
           prn $ "skey: " ++ heroSkey cfg
           let jwts = Auth.defaultJWTSettings skey
-              cs = Auth.defaultCookieSettings
+              cs =
+                Auth.defaultCookieSettings
+                  { -- uncomment this for insecure dev
+                    Auth.cookieIsSecure = Auth.NotSecure,
+                    Auth.cookieXsrfSetting = Nothing
+                  }
               ctx = cs :. jwts :. EmptyContext
-              proxy = Proxy @(AllRoutes '[Auth.JWT])
+              proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie])
               static = serveDirectoryWith $ defaultWebAppSettings $ heroNode cfg
               server =
                 -- assets, auth, and the homepage is public
@@ -168,7 +173,8 @@ type AppHostRoutes = ToServerRoutes AppRoutes Templated Action
 -- | These are the main app handlers, and should require authentication.
 appHostHandlers :: User -> Server AppHostRoutes
 appHostHandlers _ =
-  comicCoverHandler
+  homeHandler
+    :<|> comicCoverHandler
     :<|> comicPageHandler
     :<|> comicPageFullHandler
     :<|> comicVideoHandler
@@ -190,8 +196,11 @@ wrapAuth ::
   (user -> route) ->
   Auth.AuthResult user ->
   route
-wrapAuth f (Auth.Authenticated user) = f user
-wrapAuth _ _ = Auth.throwAll err401
+wrapAuth f authResult = case authResult of
+  Auth.Authenticated user -> f user
+  Auth.BadPassword -> Auth.throwAll err401
+  Auth.NoSuchUser -> Auth.throwAll err406
+  Auth.Indefinite -> Auth.throwAll err422
 
 jsonHandlers :: AcidState Keep.HeroKeep -> User -> Server JsonApi
 jsonHandlers keep _ = Acid.query' keep $ Keep.GetComics 10
diff --git a/Hero/Node.hs b/Hero/Node.hs
index e32cd59..55bc4b0 100644
--- a/Hero/Node.hs
+++ b/Hero/Node.hs
@@ -180,17 +180,13 @@ move (ScrollIntoView id) model = model <# do
 move ValidateUserPassword model =
   batchEff
     model
-    [doLogin, (SetComics </ fetchComics)]
+    [doLogin, pure FetchComics, pure <| ChangeURI discoverLink]
   where
     doLogin = do
-      jslog "starting doLogin"
       user <- getValue =<< Document.getElementById "user"
       pass <- getValue =<< Document.getElementById "pass"
-      jslog "sending login"
       sendLogin (ms user) (ms pass) >>= \case
-        Network.Success user -> do
-          jslog "successful login"
-          pure $ ChangeURI discoverLink
+        Network.Success _ -> pure NoOp
         -- TODO: handle these error cases
         Network.Loading -> pure NoOp
         Network.Failure _ -> pure NoOp
@@ -201,9 +197,11 @@ fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case
   Nothing ->
     pure $ Network.Failure "Could not fetch comics from server."
   Just json ->
-    pure $ Network.fromEither
-      $ either (Left . ms) pure
-      $ Aeson.eitherDecodeStrict json
+    json
+      |> Aeson.eitherDecodeStrict
+      |> either (Left . ms) pure
+      |> Network.fromEither
+      |> pure
   where
     req =
       Ajax.Request
@@ -211,7 +209,7 @@ fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case
           Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
           Ajax.reqLogin = Nothing,
           Ajax.reqHeaders = [],
-          Ajax.reqWithCredentials = False,
+          Ajax.reqWithCredentials = True,
           Ajax.reqData = Ajax.NoData
         }
 
@@ -239,7 +237,7 @@ sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case
             [ ("Accept", "application/json"),
               ("Content-Type", "application/json")
             ],
-          Ajax.reqWithCredentials = False,
+          Ajax.reqWithCredentials = True,
           Ajax.reqData =
             LoginForm (fromMisoString u) (fromMisoString p)
               |> Aeson.encode
-- 
cgit v1.2.3