summaryrefslogtreecommitdiff
path: root/Hero/Host.hs
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2022-07-18 22:09:58 -0400
committerBen Sima <ben@bsima.me>2022-07-19 09:22:58 -0400
commitbc9e5b0ea863a17537987faa5a72b00efc7767d1 (patch)
treea22df5a00c29f5612a5f6885b9e6bb9a7a56d420 /Hero/Host.hs
parentf034ad709ba0de5a2e5ec6be47523f595e381d7a (diff)
Upgrade nixpkgs, ghc923
I ended up deleting miso, and consequently all files under Hero/ and Miso/, because I couldn't get miso to build with GHC 9.2. Other things: - Niv has been wrapped by Biz/Bild/Deps.hs, so I can extend it to my liking. - Apply-refact is gone because I couldn't get it to build. - Disabled python stuff.
Diffstat (limited to 'Hero/Host.hs')
-rw-r--r--Hero/Host.hs395
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