diff options
author | Ben Sima <ben@bsima.me> | 2020-02-15 23:03:40 -0800 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2020-02-16 00:37:52 -0800 |
commit | d480cce48d04d5e4353281f014f66fd61301c393 (patch) | |
tree | 395e1ed88036a9511f2197cce885c1a8a2256d64 /Com/MusicMeetsComics/Apex.hs | |
parent | 9c01b1fc7dac01b5d2a53ffc710c24811a773904 (diff) |
Split buildHaskellApp into buildGhc and buildGhcjs
Two functions makes it simpler to reason about what is being built and
when, even if it is a bit more explicit. I also removed the dumb
Apex/Aero naming thing because Server/Client is just easier to remember.
Diffstat (limited to 'Com/MusicMeetsComics/Apex.hs')
-rw-r--r-- | Com/MusicMeetsComics/Apex.hs | 235 |
1 files changed, 0 insertions, 235 deletions
diff --git a/Com/MusicMeetsComics/Apex.hs b/Com/MusicMeetsComics/Apex.hs deleted file mode 100644 index f652f68..0000000 --- a/Com/MusicMeetsComics/Apex.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Com.MusicMeetsComics.Apex 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.load - Init.runApp (app db) - -app :: Database.ComicDB -> Config.Config -> Application -app db _ = serve - (Proxy @AllRoutes) - ( static - :<|> cssHandlers - :<|> jsonHandlers db - :<|> serverHandlers - :<|> pure heroManifest - :<|> Tagged handle404 - ) - where - static = serveDirectoryWith (defaultWebAppSettings "static") - - --- | 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/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] - -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 |