diff options
Diffstat (limited to 'Hero/Host.hs')
| -rw-r--r-- | Hero/Host.hs | 395 |
1 files changed, 0 insertions, 395 deletions
diff --git a/Hero/Host.hs b/Hero/Host.hs deleted file mode 100644 index 7cc5986..0000000 --- a/Hero/Host.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Hero web app --- --- : out mmc -module Hero.Host - ( main, - ) -where - -import Alpha -import Biz.App (CSS (..), Manifest (..)) -import qualified Biz.Cli as Cli -import qualified Biz.Log as Log -import Biz.Test ((@=?)) -import qualified Biz.Test as Test -import qualified Clay -import qualified Crypto.JOSE.JWK as Crypto -import Data.Acid (AcidState) -import qualified Data.Acid.Abstract as Acid -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import Hero.Core -import qualified Hero.Keep as Keep -import qualified Hero.Look as Look -import qualified Hero.Look.Typography as Typography -import qualified Hero.Pack as Pack -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 = Cli.main <| Cli.Plan help move test pure - -help :: Cli.Docopt -help = - [Cli.docopt| -mmc - -Usage: - mmc - mmc test -|] - -test :: Test.Tree -test = Test.group "Hero.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)] - -move :: Cli.Arguments -> IO () -move _ = 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) - Log.info ["!", "hero"] >> Log.br - Log.info ["port", show <| heroPort cfg] >> Log.br - Log.info ["keep", Text.pack <| heroKeep cfg] >> Log.br - Log.info ["node", Text.pack <| heroNode cfg] >> Log.br - Log.info ["skey", Text.pack <| heroSkey cfg] >> Log.br - let jwts = Auth.defaultJWTSettings skey - cs = - Auth.defaultCookieSettings - { -- uncomment this for insecure dev - Auth.cookieIsSecure = Auth.NotSecure, - Auth.cookieXsrfSetting = Nothing - } - ctx = cs :. jwts :. EmptyContext - proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie]) - 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 - pure - ( cfg, - serveWithContext - proxy - ctx - server, - keep - ) - shutdown :: App -> IO () - shutdown (_, _, keep) = do - Keep.close keep - pure () - -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/dev/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 Move - --- | These are the main app handlers, and should require authentication. -appHostHandlers :: User -> Server AppHostRoutes -appHostHandlers _ = - homeHandler - :<|> comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - --- | Marketing pages -type PubHostRoutes = ToServerRoutes PubRoutes Templated Move - -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 authResult = case authResult of - Auth.Authenticated u -> f u - Auth.BadPassword -> Auth.throwAll err401 - Auth.NoSuchUser -> Auth.throwAll err406 - Auth.Indefinite -> Auth.throwAll err422 - -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 = - pure <. 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") -> - applyCreds <| User "ben@bsima.me" "ben" [] - (LoginForm "mcovino@heroprojects.io" "test") -> - 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 -> pure <| 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_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" - ] - L.link_ - [ L.rel_ "icon", - L.type_ "image/png", - L.sizes_ "32x32", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-32x32.png" - ] - L.link_ - [ L.rel_ "icon", - L.type_ "image/png", - L.sizes_ "16x16", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-16x16.png" - ] - L.link_ - [ L.rel_ "manifest", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/manifest.json" - ] - L.link_ - [ L.rel_ "mask-icon", - L.href_ - <| Pack.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/all.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 - <| initForm 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 Move)) -homeHandler = pure <. Templated <. home <| initForm homeLink - -comicCoverHandler :: ComicId -> Handler (Templated (View Move)) -comicCoverHandler id = - pure <. Templated <. comicCover id <. initForm <| comicLink id - -comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicPageHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicReaderSpreadLink id n - -comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicPageFullHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicReaderFullLink id n - -comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicVideoHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n - -discoverHandler :: Handler (Templated (View Move)) -discoverHandler = pure <. Templated <. discover <| initForm discoverLink - -chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -chooseExperienceHandler id n = - pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n - -loginHandler :: Handler (Templated (View Move)) -loginHandler = pure <. Templated <. login <| initForm loginLink |