hero: put app routes behind auth

1 files changed, 70 insertions, 72 deletions

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