path: root/Hero/Host.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# 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.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 = 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
                  { -- 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
          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 _ =
  homeHandler
    :<|> 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 authResult = case authResult of
  Auth.Authenticated user -> f user
  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 =
  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") ->
      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 -> 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_ $
              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/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