diff options
Diffstat (limited to 'Hero/Host.hs')
| -rw-r--r-- | Hero/Host.hs | 396 |
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 |