path: root/Hero/Server.hs

{-# 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.Server 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.App
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 $ "beam: " ++ heroBeam cfg
          prn $ "keep: " ++ heroKeep 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 $ heroBeam cfg
              server =
                static
                  :<|> cssHandlers
                  :<|> (return "hi")
                  :<|> loginHookHandler cs jwts
                  :<|> jsonHandlers keep
                  :<|> publicHandlers
                  :<|> pure heroManifest
                  :<|> 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,
        heroBeam :: FilePath,
        heroKeep :: FilePath,
        heroSkey :: FilePath
      }
  deriving (Generic, Show)

instance Envy.DefConfig Config where
  defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" "/run/hero/skey"

instance Envy.FromEnv Config

-- | Convert client side routes into server-side web handlers
type ServerRoutes = ToServerRoutes ClientRoutes Templated Action

type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]

type CssRoute = "css" :> "main.css" :> Get '[CSS] Text

cssHandlers :: Server CssRoute
cssHandlers =
  return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main

type Ping = "ping" :> Get '[JSON] Text

type LoginHook =
  "login-hook"
    :> ReqBody '[JSON] LoginForm
    :> Post '[JSON]
         ( Headers
             '[ Header "Set-Cookie" Auth.SetCookie,
                Header "Set-Cookie" Auth.SetCookie
              ]
             User
         )

loginHookHandler ::
  Auth.CookieSettings ->
  Auth.JWTSettings ->
  LoginForm ->
  Handler
    ( Headers
        '[ Header "Set-Cookie" Auth.SetCookie,
           Header "Set-Cookie" Auth.SetCookie
         ]
        User
    )
loginHookHandler cs jwts =
  checkCreds cs jwts

type AllRoutes auths =
  ("static" :> Raw)
    :<|> CssRoute
    :<|> Ping
    :<|> LoginHook
    :<|> (Auth.Auth auths User :> JsonApi)
    :<|> ServerRoutes
    :<|> ("manifest.json" :> Get '[JSON] Manifest)
    :<|> 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"

publicHandlers :: Server ServerRoutes
publicHandlers =
  homeHandler
    :<|> comicCoverHandler
    :<|> comicPageHandler
    :<|> comicPageFullHandler
    :<|> comicVideoHandler
    :<|> loginHandler
    :<|> discoverHandler
    :<|> chooseExperienceHandler

instance Auth.ToJWT User

instance Auth.FromJWT User

-- TODO: get creds from keep
-- TODO: load initial library for user
checkCreds ::
  Auth.CookieSettings ->
  Auth.JWTSettings ->
  LoginForm ->
  Handler
    ( Headers
        '[ Header "Set-Cookie" Auth.SetCookie,
           Header "Set-Cookie" Auth.SetCookie
         ]
        User
    )
checkCreds cookieSettings jwtSettings (LoginForm "ben@bsima.me" "test") = do
  applyCreds cookieSettings jwtSettings $ User "ben@bsima.me" "ben" []
checkCreds cookieSettings jwtSettings (LoginForm "mcovino@heroprojects.io" "test") = do
  applyCreds cookieSettings jwtSettings $ User "mcovino@heroprojects.io" "mike" []
checkCreds _ _ _ = throwError err401

applyCreds ::
  Auth.CookieSettings ->
  Auth.JWTSettings ->
  User ->
  Handler
    ( Headers
        '[ Header "Set-Cookie" Auth.SetCookie,
           Header "Set-Cookie" Auth.SetCookie
         ]
        User
    )
applyCreds cs jwts usr = do
  mApplyCookies <- liftIO $ Auth.acceptLogin cs jwts usr
  case mApplyCookies of
    Nothing -> throwError err401
    Just applyCookies -> return $ applyCookies usr

jsonHandlers :: AcidState Keep.HeroKeep -> Auth.AuthResult User -> Server JsonApi
jsonHandlers keep (Auth.Authenticated user) = Acid.query' keep $ Keep.GetComics 10
jsonHandlers _ _ = Auth.throwAll err401

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