hero: put app routes behind auth

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