diff options
Diffstat (limited to 'Com/MusicMeetsComics/Server.hs')
| -rw-r--r-- | Com/MusicMeetsComics/Server.hs | 235 |
1 files changed, 235 insertions, 0 deletions
diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs new file mode 100644 index 0000000..7bb94a2 --- /dev/null +++ b/Com/MusicMeetsComics/Server.hs @@ -0,0 +1,235 @@ +{-# 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.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.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 |