diff options
| -rw-r--r-- | Hero/App.hs | 42 | ||||
| -rw-r--r-- | Hero/Client.hs | 25 | ||||
| -rw-r--r-- | Hero/Server.hs | 142 |
3 files changed, 107 insertions, 102 deletions
diff --git a/Hero/App.hs b/Hero/App.hs index 56289f8..6f7a8c4 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -295,29 +295,32 @@ data Action | DumpModel deriving (Show, Eq) -type ClientRoutes = - Home - :<|> ComicCover +type AppRoutes = + ComicCover :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo - :<|> Login :<|> Discover :<|> ChooseExperience handlers = - home - :<|> comicCover + comicCover :<|> comicReader :<|> comicReader :<|> comicReader - :<|> login :<|> discover :<|> comicReader -routes :: Proxy ClientRoutes +routes :: Proxy AppRoutes routes = Proxy +type PubRoutes = + Home + :<|> Login + +pubRoutes :: Proxy PubRoutes +pubRoutes = Proxy + -- * pages -- -- TODO: consider making a typeclass, something like: @@ -330,6 +333,8 @@ routes = Proxy -- link :: Api.URI -- * home +-- +-- this is the unauthenticated page that you see when you first visit type Home = View Action @@ -337,12 +342,14 @@ type Home = homeProxy :: Proxy Home homeProxy = Proxy +homeLink :: Api.URI +homeLink = linkURI $ Api.safeLink front homeProxy + where + front = Proxy :: Proxy Home + home :: Model -> View Action home = login -homeLink :: Api.URI -homeLink = linkURI $ Api.safeLink routes homeProxy - -- * login data LoginForm = LoginForm {loginEmail :: String, loginPass :: String} @@ -359,7 +366,7 @@ loginProxy :: Proxy Login loginProxy = Proxy loginLink :: Api.URI -loginLink = linkURI $ Api.safeLink routes loginProxy +loginLink = linkURI $ Api.safeLink pubRoutes loginProxy login :: Model -> View Action login _ = @@ -807,11 +814,12 @@ appmenu :: View Action appmenu = aside_ [id_ "appmenu"] $ btn </ links where links = + -- these extra 'discoverLink's are just dummies [ (discoverLink, "discover.svg", "discover"), - (homeLink, "save.svg", "library"), - (homeLink, "watch.svg", "videos"), + (discoverLink, "save.svg", "library"), + (discoverLink, "watch.svg", "videos"), (comicLink "1", "read.svg", "comics"), - (homeLink, "listen.svg", "music") + (discoverLink, "listen.svg", "music") ] btn (lnk, img, label) = a_ @@ -899,7 +907,9 @@ topbar = header_ [id_ "app-head", class_ "is-black", css euro] [ a_ - [class_ "button is-medium is-black", onClick $ ChangeURI homeLink] + [ class_ "button is-medium is-black", + onClick $ ChangeURI discoverLink + ] [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]], div_ [id_ "app-head-right"] diff --git a/Hero/Client.hs b/Hero/Client.hs index 06a7eab..5429855 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -21,7 +21,7 @@ module Hero.Client where import Alpha import Biz.Auth as Auth -import Data.Aeson (eitherDecodeStrict) +import qualified Data.Aeson as Aeson import qualified Data.Set as Set import qualified GHC.Show as Legacy import GHCJS.Types (JSVal) @@ -31,6 +31,7 @@ import Hero.App Comic (..), ComicReaderState (..), ComicReaderView (..), + LoginForm (..), Model (..), User (..), audioId, @@ -182,6 +183,7 @@ move ValidateUserPassword model = [doLogin, (SetComics </ fetchComics)] where doLogin = do + jslog "starting doLogin" user <- getValue =<< Document.getElementById "user" pass <- getValue =<< Document.getElementById "pass" jslog "sending login" @@ -201,7 +203,7 @@ fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case Just json -> pure $ Network.fromEither $ either (Left . ms) pure - $ eitherDecodeStrict json + $ Aeson.eitherDecodeStrict json where req = Ajax.Request @@ -226,26 +228,21 @@ sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case Just json -> pure $ Network.fromEither $ either (Left . ms) pure - $ eitherDecodeStrict json + $ Aeson.eitherDecodeStrict json where req = Ajax.Request { Ajax.reqMethod = Ajax.POST, - Ajax.reqURI = "/login-hook", - Ajax.reqLogin = Nothing, -- FIXME + Ajax.reqURI = "/auth", + Ajax.reqLogin = Nothing, -- FIXME? Ajax.reqHeaders = [ ("Accept", "application/json"), ("Content-Type", "application/json") ], Ajax.reqWithCredentials = False, - -- TODO: make this use Aeson Ajax.reqData = - Ajax.StringData $ - Miso.String.concat - [ "{\"loginEmail\": \"", - u, - "\", \"loginPass\": \"", - p, - "\"}" - ] + LoginForm (fromMisoString u) (fromMisoString p) + |> Aeson.encode + |> ms + |> Ajax.StringData } diff --git a/Hero/Server.hs b/Hero/Server.hs index 1cbcdd3..cdf89d0 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -47,7 +47,10 @@ -- : dep wai-middleware-metrics -- : dep warp -- : dep x509 -module Hero.Server where +module Hero.Server + ( main, + ) +where import Alpha import Biz.App (CSS (..), Manifest (..)) @@ -100,13 +103,16 @@ main = bracket startup shutdown run proxy = Proxy @(AllRoutes '[Auth.JWT]) static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg server = + -- assets, auth, and the homepage is public static :<|> cssHandlers - :<|> (return "hi") - :<|> loginHookHandler cs jwts - :<|> jsonHandlers keep - :<|> publicHandlers :<|> pure heroManifest + :<|> pubHostHandlers + :<|> authHandler cs jwts + -- app and api are private + :<|> wrapAuth (jsonHandlers keep) + :<|> wrapAuth appHostHandlers + -- fall through to 404 :<|> Tagged handle404 return ( cfg, @@ -157,20 +163,47 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -- | Convert client side routes into server-side web handlers -type ServerRoutes = ToServerRoutes ClientRoutes Templated Action +type AppHostRoutes = ToServerRoutes AppRoutes Templated Action + +-- | These are the main app handlers, and should require authentication. +appHostHandlers :: User -> Server AppHostRoutes +appHostHandlers _ = + comicCoverHandler + :<|> comicPageHandler + :<|> comicPageFullHandler + :<|> comicVideoHandler + :<|> discoverHandler + :<|> chooseExperienceHandler + +-- | Marketing pages +type PubHostRoutes = ToServerRoutes PubRoutes Templated Action + +pubHostHandlers :: Server PubHostRoutes +pubHostHandlers = + homeHandler :<|> loginHandler type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] +-- TODO: need a "you're not logged in" page +wrapAuth :: + Auth.ThrowAll route => + (user -> route) -> + Auth.AuthResult user -> + route +wrapAuth f (Auth.Authenticated user) = f user +wrapAuth _ _ = Auth.throwAll err401 + +jsonHandlers :: AcidState Keep.HeroKeep -> User -> Server JsonApi +jsonHandlers keep _ = Acid.query' keep $ Keep.GetComics 10 + type CssRoute = "css" :> "main.css" :> Get '[CSS] Text cssHandlers :: Server CssRoute cssHandlers = return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main -type Ping = "ping" :> Get '[JSON] Text - -type LoginHook = - "login-hook" +type AuthRoute = + "auth" :> ReqBody '[JSON] LoginForm :> Post '[JSON] ( Headers @@ -180,7 +213,15 @@ type LoginHook = User ) -loginHookHandler :: +instance Auth.ToJWT User + +instance Auth.FromJWT User + +-- | Endpoint for performing authentication +-- +-- TODO: get creds from keep +-- TODO: load initial library for user +authHandler :: Auth.CookieSettings -> Auth.JWTSettings -> LoginForm -> @@ -191,17 +232,29 @@ loginHookHandler :: ] User ) -loginHookHandler cs jwts = - checkCreds cs jwts +authHandler cookieSettings jwtSettings loginForm = + case loginForm of + (LoginForm "ben@bsima.me" "test") -> do + applyCreds $ User "ben@bsima.me" "ben" [] + (LoginForm "mcovino@heroprojects.io" "test") -> do + applyCreds $ User "mcovino@heroprojects.io" "mike" [] + _ -> throwError err401 + where + applyCreds usr = do + mApplyCookies <- liftIO $ Auth.acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies usr +-- | See also 'server' above type AllRoutes auths = ("static" :> Raw) :<|> CssRoute - :<|> Ping - :<|> LoginHook - :<|> (Auth.Auth auths User :> JsonApi) - :<|> ServerRoutes :<|> ("manifest.json" :> Get '[JSON] Manifest) + :<|> PubHostRoutes + :<|> AuthRoute + :<|> (Auth.Auth auths User :> JsonApi) + :<|> (Auth.Auth auths User :> AppHostRoutes) :<|> Raw heroManifest :: Manifest @@ -313,61 +366,6 @@ bulmaRef :: MisoString bulmaRef = "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" -publicHandlers :: Server ServerRoutes -publicHandlers = - homeHandler - :<|> comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> loginHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - -instance Auth.ToJWT User - -instance Auth.FromJWT User - --- TODO: get creds from keep --- TODO: load initial library for user -checkCreds :: - Auth.CookieSettings -> - Auth.JWTSettings -> - LoginForm -> - Handler - ( Headers - '[ Header "Set-Cookie" Auth.SetCookie, - Header "Set-Cookie" Auth.SetCookie - ] - User - ) -checkCreds cookieSettings jwtSettings (LoginForm "ben@bsima.me" "test") = do - applyCreds cookieSettings jwtSettings $ User "ben@bsima.me" "ben" [] -checkCreds cookieSettings jwtSettings (LoginForm "mcovino@heroprojects.io" "test") = do - applyCreds cookieSettings jwtSettings $ User "mcovino@heroprojects.io" "mike" [] -checkCreds _ _ _ = throwError err401 - -applyCreds :: - Auth.CookieSettings -> - Auth.JWTSettings -> - User -> - Handler - ( Headers - '[ Header "Set-Cookie" Auth.SetCookie, - Header "Set-Cookie" Auth.SetCookie - ] - User - ) -applyCreds cs jwts usr = do - mApplyCookies <- liftIO $ Auth.acceptLogin cs jwts usr - case mApplyCookies of - Nothing -> throwError err401 - Just applyCookies -> return $ applyCookies usr - -jsonHandlers :: AcidState Keep.HeroKeep -> Auth.AuthResult User -> Server JsonApi -jsonHandlers keep (Auth.Authenticated user) = Acid.query' keep $ Keep.GetComics 10 -jsonHandlers _ _ = Auth.throwAll err401 - homeHandler :: Handler (Templated (View Action)) homeHandler = pure . Templated . home $ initModel homeLink |