hero: rename stuff to new structure

Working toward https://github.com/bsima/biz/issues/5

1 files changed, 396 insertions, 0 deletions

diff --git a/Hero/Host.hs b/Hero/Host.hs
new file mode 100644
index 0000000..fc31c39
--- /dev/null
+++ b/Hero/Host.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Hero web app
+--
+-- : exe mmc
+--
+-- : dep acid-state
+-- : dep aeson
+-- : dep clay
+-- : dep containers
+-- : dep envy
+-- : dep http-types
+-- : dep ixset
+-- : dep lucid
+-- : dep miso
+-- : dep mtl
+-- : dep network-uri
+-- : dep protolude
+-- : dep safecopy
+-- : dep servant
+-- : dep servant-auth
+-- : dep servant-auth-server
+-- : dep servant-lucid
+-- : dep servant-server
+-- : dep split
+-- : dep split
+-- : dep string-quote
+-- : dep text
+-- : dep wai
+-- : dep wai-app-static
+-- : dep wai-extra
+-- : dep wai-middleware-metrics
+-- : dep warp
+-- : dep x509
+module Hero.Host
+  ( main,
+  )
+where
+
+import Alpha
+import Biz.App (CSS (..), Manifest (..))
+import qualified Clay
+import qualified Crypto.JOSE.JWK as Crypto
+import Data.Acid (AcidState)
+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 qualified Hero.Keep as Keep
+import qualified Hero.Look as Look
+import qualified Hero.Look.Typography as Typography
+import qualified Lucid as L
+import Lucid.Base
+import Miso
+import Miso.String
+import Network.HTTP.Types hiding (Header)
+import Network.Wai
+import Network.Wai.Application.Static
+import qualified Network.Wai.Handler.Warp as Warp
+import Servant
+import qualified Servant.Auth.Server as Auth
+import qualified System.Directory as Directory
+import qualified System.Envy as Envy
+import qualified System.Exit as Exit
+import qualified System.IO as IO
+
+main :: IO ()
+main = bracket startup shutdown run
+  where
+    run (cfg, app, _) = Warp.run (heroPort cfg) app
+    prn = IO.hPutStrLn IO.stderr
+    startup = Envy.decodeEnv >>= \case
+      Left e -> Exit.die e
+      Right cfg ->
+        do
+          keep <- Keep.open (heroKeep cfg)
+          skey <- upsertKey (heroSkey cfg)
+          say "hero"
+          prn $ "port: " ++ show (heroPort cfg)
+          prn $ "keep: " ++ heroKeep cfg
+          prn $ "node: " ++ heroNode cfg
+          prn $ "skey: " ++ heroSkey cfg
+          let jwts = Auth.defaultJWTSettings skey
+              cs = Auth.defaultCookieSettings
+              ctx = cs :. jwts :. EmptyContext
+              proxy = Proxy @(AllRoutes '[Auth.JWT])
+              static = serveDirectoryWith $ defaultWebAppSettings $ heroNode cfg
+              server =
+                -- assets, auth, and the homepage is public
+                static
+                  :<|> cssHandlers
+                  :<|> pure heroManifest
+                  :<|> pubHostHandlers
+                  :<|> authHandler cs jwts
+                  -- app and api are private
+                  :<|> wrapAuth (jsonHandlers keep)
+                  :<|> wrapAuth appHostHandlers
+                  -- fall through to 404
+                  :<|> Tagged handle404
+          return
+            ( cfg,
+              serveWithContext
+                proxy
+                ctx
+                server,
+              keep
+            )
+    shutdown :: App -> IO ()
+    shutdown (_, _, keep) = do
+      Keep.close keep
+      return ()
+
+upsertKey :: FilePath -> IO Crypto.JWK
+upsertKey fp = Directory.doesFileExist fp >>= \exists ->
+  if exists
+    then Auth.readKey fp
+    else Auth.writeKey fp >> Auth.readKey fp
+
+-- This part is a little confusing. I have:
+--
+--   - 'App' which encapsulates the entire runtime state
+--   - 'Config' has stuff I can set at startup
+--   - 'HeroKeep' is the database and any other persistance
+--   - the above are then put together in the 'startup' private function in
+--     `main` above
+--
+-- I'm sure this can be cleaned up with a monad stack of some sort, but I
+-- haven't the brain power to think through that. For now, just try and keep
+-- things named clearly so I don't get confused.
+
+-- | This can be generalized I think, put in Biz.App, or something
+type App = (Config, Application, AcidState Keep.HeroKeep)
+
+data Config
+  = Config
+      { heroPort :: Warp.Port,
+        heroNode :: FilePath,
+        heroKeep :: FilePath,
+        heroSkey :: FilePath
+      }
+  deriving (Generic, Show)
+
+instance Envy.DefConfig Config where
+  defConfig = Config 3000 "_bild/Hero.Node/static" "_keep" "/run/hero/skey"
+
+instance Envy.FromEnv Config
+
+-- | Convert client side routes into server-side web handlers
+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 AuthRoute =
+  "auth"
+    :> ReqBody '[JSON] LoginForm
+    :> Post '[JSON]
+         ( Headers
+             '[ Header "Set-Cookie" Auth.SetCookie,
+                Header "Set-Cookie" Auth.SetCookie
+              ]
+             User
+         )
+
+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 ->
+  Handler
+    ( Headers
+        '[ Header "Set-Cookie" Auth.SetCookie,
+           Header "Set-Cookie" Auth.SetCookie
+         ]
+        User
+    )
+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
+    :<|> ("manifest.json" :> Get '[JSON] Manifest)
+    :<|> PubHostRoutes
+    :<|> AuthRoute
+    :<|> (Auth.Auth auths User :> JsonApi)
+    :<|> (Auth.Auth auths User :> AppHostRoutes)
+    :<|> Raw
+
+heroManifest :: Manifest
+heroManifest =
+  Manifest
+    { name = "Hero",
+      short_name = "Hero",
+      start_url = ".",
+      display = "standalone",
+      theme_color = "#0a0a0a",
+      description = "Comics for all"
+    }
+
+-- | Type for setting wrapping a view in HTML doctype, header, etc
+newtype Templated a = Templated a
+  deriving (Show, Eq)
+
+instance L.ToHtml a => L.ToHtml (Templated a) where
+  toHtmlRaw = L.toHtml
+  toHtml (Templated x) = do
+    L.doctype_
+    L.html_ [L.lang_ "en"] $ do
+      L.head_ $ do
+        L.title_ "Hero [alpha]"
+        L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"]
+        L.link_ [L.rel_ "icon", L.type_ ""]
+        -- icons
+        L.link_
+          [ L.rel_ "apple-touch-icon",
+            L.sizes_ "180x180",
+            L.href_ $
+              Assets.cdnEdge
+                <> "/old-assets/images/favicons/apple-touch-icon.png"
+          ]
+        L.link_
+          [ L.rel_ "icon",
+            L.type_ "image/png",
+            L.sizes_ "32x32",
+            L.href_ $
+              Assets.cdnEdge
+                <> "/old-assets/images/favicons/favicon-32x32.png"
+          ]
+        L.link_
+          [ L.rel_ "icon",
+            L.type_ "image/png",
+            L.sizes_ "16x16",
+            L.href_ $
+              Assets.cdnEdge
+                <> "/old-assets/images/favicons/favicon-16x16.png"
+          ]
+        L.link_
+          [ L.rel_ "manifest",
+            L.href_ $
+              Assets.cdnEdge
+                <> "/old-assets/images/favicons/manifest.json"
+          ]
+        L.link_
+          [ L.rel_ "mask-icon",
+            L.href_ $
+              Assets.cdnEdge
+                <> "/old-assets/images/favicons/safari-pinned-tab.svg"
+          ]
+        L.meta_ [L.charset_ "utf-8"]
+        L.meta_ [L.name_ "theme-color", L.content_ "#000"]
+        L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"]
+        L.meta_
+          [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"]
+        cssRef animateRef
+        cssRef bulmaRef
+        cssRef fontAwesomeRef
+        cssRef "/css/main.css" -- TODO: make this a safeLink?
+        jsRef "/static/mmc.js"
+        jsRef "/static/usersnap.js"
+      L.body_ (L.toHtml x)
+    where
+      jsRef href =
+        L.with
+          (L.script_ mempty)
+          [ makeAttribute "src" href,
+            makeAttribute "async" mempty,
+            makeAttribute "defer" mempty
+          ]
+      cssRef href =
+        L.with
+          (L.link_ mempty)
+          [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
+
+handle404 :: Application
+handle404 _ respond =
+  respond
+    $ responseLBS status404 [("Content-Type", "text/html")]
+    $ renderBS
+    $ toHtml
+    $ Templated
+    $ the404
+    $ initModel homeLink
+
+fontAwesomeRef :: MisoString
+fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
+
+animateRef :: MisoString
+animateRef =
+  "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css"
+
+-- TODO: if I remove this, then the login form (and probably other stuff) gets
+-- messed up. When I remove this, I need to also port the necessary CSS styles
+-- to make stuff look good.
+bulmaRef :: MisoString
+bulmaRef =
+  "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"
+
+homeHandler :: Handler (Templated (View Action))
+homeHandler = pure . Templated . home $ initModel homeLink
+
+comicCoverHandler :: ComicId -> Handler (Templated (View Action))
+comicCoverHandler id =
+  pure . Templated . comicCover id . initModel $ comicLink id
+
+comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action))
+comicPageHandler id n =
+  pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n
+
+comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action))
+comicPageFullHandler id n =
+  pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n
+
+comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action))
+comicVideoHandler id n =
+  pure . Templated . comicReader id n . initModel $ comicVideoLink id n
+
+discoverHandler :: Handler (Templated (View Action))
+discoverHandler = pure . Templated . discover $ initModel discoverLink
+
+chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action))
+chooseExperienceHandler id n =
+  pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n
+
+loginHandler :: Handler (Templated (View Action))
+loginHandler = pure . Templated . login $ initModel loginLink