diff options
| -rw-r--r-- | Hero/Core.hs | 8 | ||||
| -rw-r--r-- | Hero/Host.hs | 21 | ||||
| -rw-r--r-- | Hero/Node.hs | 20 |
3 files changed, 29 insertions, 20 deletions
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 |