path: root/Hero/Host.hs

{-# 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
--
-- : dep acid-state
-- : dep aeson
-- : dep clay
-- : dep containers
-- : dep docopt
-- : 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 tasty
-- : dep tasty-hunit
-- : dep text
-- : dep wai
-- : dep wai-app-static
-- : dep wai-extra
-- : dep wai-middleware-metrics
-- : dep warp
-- : dep x509
-- : dep regex-applicative
module Hero.Host
  ( main,
  )
where

import Alpha
import Biz.App (CSS (..), Manifest (..))
import qualified Biz.Cli as Cli
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.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

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)
            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/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 =
  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/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