path: root/Hero/Server.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# 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-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
module Hero.Server where

import Alpha
import Biz.App (CSS(..), Manifest(..))
import qualified Clay
import Data.Acid (AcidState)
import qualified Data.Acid.Abstract as Acid
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 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)
        say "hero"
        prn $ "port: " ++ show (heroPort cfg)
        prn $ "beam: " ++ heroBeam cfg
        prn $ "keep: " ++ heroKeep cfg
        let waiapp = mkApp keep cfg
        return (cfg, waiapp, keep)
    shutdown :: App -> IO ()
    shutdown (_, _, keep) = do
      Keep.close keep
      return ()

-- 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
--   - 'mkApp' take the second two and makes a 'Wai.Application', should really be
--     called 'serve', and might need to be Servant's 'hoistServer' thing
--
-- 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
      }
  deriving (Generic, Show)

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

instance Envy.FromEnv Config

mkApp :: AcidState Keep.HeroKeep -> Config -> Application
mkApp keep cfg =
  serve
    (Proxy @AllRoutes)
    ( static
        :<|> cssHandlers
        :<|> jsonHandlers keep
        :<|> serverHandlers
        :<|> pure heroManifest
        :<|> Tagged handle404
    )
  where
    static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg

-- | 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 AllRoutes =
  ("static" :> Raw)
    :<|> CssRoute
    :<|> 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"

bulmaRef :: MisoString
bulmaRef =
  "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"

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

jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi
jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10

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