{-# LANGUAGE OverloadedStrings #-} {-# 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 miso -- : dep protolude -- : dep servant -- : dep split -- : dep string-quote -- : dep text -- : dep dhall -- : dep ekg -- : dep fast-logger -- : dep http-types -- : dep katip -- : dep lucid -- : dep monad-logger -- : dep monad-metrics -- : dep mtl -- : dep network-uri -- : dep safe -- : dep servant-lucid -- : dep servant-server -- : dep split -- : dep wai -- : dep wai-app-static -- : dep wai-extra -- : dep wai-middleware-metrics -- : dep warp module Com.MusicMeetsComics.Server where import qualified Clay import Com.MusicMeetsComics.App import qualified Com.MusicMeetsComics.Assets as Assets import qualified Com.MusicMeetsComics.Database as Database import qualified Com.MusicMeetsComics.Server.Config as Config import qualified Com.MusicMeetsComics.Server.Init as Init import qualified Com.MusicMeetsComics.Look as Look import qualified Com.MusicMeetsComics.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 Protolude import Servant main :: IO () main = do db <- Database.dummy Init.runApp (app db) app :: Database.ComicDB -> Config.Config -> Application app db cfg = serve (Proxy @AllRoutes) ( static :<|> cssHandlers :<|> jsonHandlers db :<|> serverHandlers :<|> pure heroManifest :<|> Tagged handle404 ) where static = serveDirectoryWith $ defaultWebAppSettings $ Config.configClient 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