summaryrefslogtreecommitdiff
path: root/Hero/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Server.hs')
-rw-r--r--Hero/Server.hs302
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 14:57:04 +0000