diff options
Diffstat (limited to 'Hero/Server.hs')
| -rw-r--r-- | Hero/Server.hs | 111 |
1 files changed, 41 insertions, 70 deletions
diff --git a/Hero/Server.hs b/Hero/Server.hs index 351e839..97ce7a2 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -40,15 +40,13 @@ -- : dep warp module Hero.Server where +import Alpha +import Biz.App (CSS(..), Manifest(..)) import qualified Clay import Data.Acid (AcidState) import qualified Data.Acid.Abstract as Acid -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 Hero.App import qualified Hero.Assets as Assets import qualified Hero.Keep as Keep @@ -58,15 +56,10 @@ 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 @@ -76,15 +69,15 @@ main :: IO () main = bracket startup shutdown run where run (cfg, app, _) = Warp.run (heroPort cfg) app - say = IO.hPutStrLn IO.stderr + prn = IO.hPutStrLn IO.stderr startup = Envy.decodeEnv >>= \case Left e -> Exit.die e Right cfg -> do keep <- Keep.open (heroKeep cfg) say "hero" - say $ "port: " ++ show (heroPort cfg) - say $ "beam: " ++ heroBeam cfg - say $ "keep: " ++ heroKeep cfg + prn $ "port: " ++ show (heroPort cfg) + prn $ "beam: " ++ heroBeam cfg + prn $ "keep: " ++ heroKeep cfg let waiapp = mkApp keep cfg return (cfg, waiapp, keep) shutdown :: App -> IO () @@ -134,28 +127,13 @@ mkApp keep cfg = where static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam 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 ServerRoutes = ToServerRoutes ClientRoutes Templated 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 @@ -168,19 +146,6 @@ type AllRoutes = :<|> ("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 @@ -192,19 +157,13 @@ heroManifest = description = "Comics for all" } -handle404 :: Application -handle404 _ respond = - respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ the404 - $ initModel homeLink +-- | Type for setting wrapping a view in HTML doctype, header, etc +newtype Templated a = Templated a + deriving (Show, Eq) -instance L.ToHtml a => L.ToHtml (HtmlPage a) where +instance L.ToHtml a => L.ToHtml (Templated a) where toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = do + toHtml (Templated x) = do L.doctype_ L.html_ [L.lang_ "en"] $ do L.head_ $ do @@ -272,6 +231,17 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where (L.link_ mempty) [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +handle404 :: Application +handle404 _ respond = + respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ Templated + $ the404 + $ initModel homeLink + fontAwesomeRef :: MisoString fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" @@ -297,31 +267,32 @@ serverHandlers = jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10 -homeHandler :: Handler (HtmlPage (View Action)) -homeHandler = pure . HtmlPage . home $ initModel homeLink +homeHandler :: Handler (Templated (View Action)) +homeHandler = pure . Templated . home $ initModel homeLink -comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action)) +comicCoverHandler :: ComicId -> Handler (Templated (View Action)) comicCoverHandler id = - pure . HtmlPage . comicCover id . initModel $ comicLink id + pure . Templated . comicCover id . initModel $ comicLink id -comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action)) comicPageHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n + pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n -comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action)) comicPageFullHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n + pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n -comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action)) comicVideoHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n + pure . Templated . comicReader id n . initModel $ comicVideoLink id n -loginHandler :: Handler (HtmlPage (View Action)) -loginHandler = pure . HtmlPage . login $ initModel loginLink +discoverHandler :: Handler (Templated (View Action)) +discoverHandler = pure . Templated . discover $ initModel discoverLink -discoverHandler :: Handler (HtmlPage (View Action)) -discoverHandler = pure . HtmlPage . discover $ initModel discoverLink - -chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action)) +chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action)) chooseExperienceHandler id n = - pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n + pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n + +loginHandler :: Handler (Templated (View Action)) +loginHandler = pure . Templated . login $ initModel loginLink + |