Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

1 files changed, 302 insertions, 0 deletions

diff --git a/Hero/Server.hs b/Hero/Server.hs
new file mode 100644
index 0000000..730aada
--- /dev/null
+++ b/Hero/Server.hs
@@ -0,0 +1,302 @@
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+-- | Hero web app
+--
+-- : exe mmc
+--
+-- : dep aeson
+-- : dep clay
+-- : dep containers
+-- : dep dhall
+-- : dep envy
+-- : dep http-types
+-- : dep lucid
+-- : dep miso
+-- : dep mtl
+-- : dep network-uri
+-- : dep protolude
+-- : 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 qualified Clay
+import           Hero.App
+import qualified Hero.Assets   as Assets
+import qualified Hero.Database as Database
+import qualified Hero.Look     as Look
+import qualified Hero.Look.Typography
+                                               as Typography
+import           Data.Aeson
+import           Data.Proxy
+import           Data.Text                      ( Text )
+import qualified Data.Text.Lazy                as Lazy
+import qualified Data.Text.Lazy.Encoding       as Lazy
+import           GHC.Generics
+import qualified Lucid                         as L
+import           Lucid.Base
+import           Miso
+import           Miso.String
+import           Network.HTTP.Media             ( (//)
+                                                , (/:)
+                                                )
+import           Network.HTTP.Types      hiding ( Header )
+import           Network.Wai
+import           Network.Wai.Application.Static
+import qualified Network.Wai.Handler.Warp      as Warp
+import           Protolude
+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 $ uncurry Warp.run
+ where
+  say     = IO.hPutStrLn IO.stderr
+  startup = Envy.decodeEnv >>= \case
+    Left  e -> Exit.die e
+    Right c -> do
+      db <- Database.dummy
+      say $ "hero"
+      say $ "port: " ++ (show $ heroPort c)
+      say $ "client: " ++ heroClient c
+      let waiapp = app db c
+      return (heroPort c, waiapp)
+  shutdown :: a -> IO a
+  shutdown = pure . identity
+
+data Config = Config
+  { heroPort :: Warp.Port -- ^ HERO_PORT
+  , heroClient :: FilePath -- ^ HERO_CLIENT
+  } deriving (Generic, Show)
+
+instance Envy.DefConfig Config where
+  defConfig = Config 3000 "_bild/Hero.Client/static"
+
+instance Envy.FromEnv Config
+
+app :: Database.ComicDB -> Config -> Application
+app db cfg = serve
+  (Proxy @AllRoutes)
+  (    static
+  :<|> cssHandlers
+  :<|> jsonHandlers db
+  :<|> serverHandlers
+  :<|> pure heroManifest
+  :<|> Tagged handle404
+  )
+  where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
+
+
+-- | HtmlPage for setting HTML doctype and header
+newtype HtmlPage a = HtmlPage a
+  deriving (Show, Eq)
+
+-- | Convert client side routes into server-side web handlers
+type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action
+
+type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
+
+type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
+
+newtype CSS = CSS
+  { unCSS :: Text
+  }
+
+instance Accept CSS where
+  contentType _ = "text" // "css" /: ("charset", "utf-8")
+
+instance MimeRender CSS Text where
+  mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
+
+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
+
+data Manifest = Manifest
+  { name :: Text
+  , short_name :: Text
+  , start_url :: Text
+  , display :: Text
+  , theme_color :: Text
+  , description :: Text
+  } deriving (Show, Eq, Generic)
+
+instance ToJSON Manifest
+
+heroManifest :: Manifest
+heroManifest = Manifest { name        = "Hero"
+                        , short_name  = "Hero"
+                        , start_url   = "."
+                        , display     = "standalone"
+                        , theme_color = "#0a0a0a"
+                        , description = "Comics for all"
+                        }
+
+handle404 :: Application
+handle404 _ respond =
+  respond
+    $ responseLBS status404 [("Content-Type", "text/html")]
+    $ renderBS
+    $ toHtml
+    $ HtmlPage
+    $ the404
+    $ initModel homeLink
+
+instance L.ToHtml a => L.ToHtml (HtmlPage a) where
+  toHtmlRaw = L.toHtml
+  toHtml (HtmlPage 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]
+
+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 :: Database.ComicDB -> Server JsonApi
+jsonHandlers db = Database.getComics db
+
+homeHandler :: Handler (HtmlPage (View Action))
+homeHandler = pure . HtmlPage . home $ initModel homeLink
+
+comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action))
+comicCoverHandler id =
+  pure . HtmlPage . comicCover id . initModel $ comicLink id
+
+comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageHandler id n =
+  pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n
+
+comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageFullHandler id n =
+  pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n
+
+comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicVideoHandler id n =
+  pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n
+
+loginHandler :: Handler (HtmlPage (View Action))
+loginHandler = pure . HtmlPage . login $ initModel loginLink
+
+discoverHandler :: Handler (HtmlPage (View Action))
+discoverHandler = pure . HtmlPage . discover $ initModel discoverLink
+
+chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+chooseExperienceHandler id n =
+  pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n