diff options
| -rw-r--r-- | Biz/App.hs | 43 | ||||
| -rw-r--r-- | Hero/App.hs | 520 | ||||
| -rw-r--r-- | Hero/Client.hs | 20 | ||||
| -rw-r--r-- | Hero/Server.hs | 111 |
4 files changed, 372 insertions, 322 deletions
diff --git a/Biz/App.hs b/Biz/App.hs new file mode 100644 index 0000000..95e7271 --- /dev/null +++ b/Biz/App.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | General utils for apps +module Biz.App (CSS(..), Manifest(..)) where + +import Alpha +import Data.Aeson (ToJSON) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import Network.HTTP.Media + ( (//), + (/:), + ) +import Servant + +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 + +-- | The manifest describes your app for web app thumbnails, iPhone tiles, etc. +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 + + diff --git a/Hero/App.hs b/Hero/App.hs index da2289c..418993d 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -395,46 +395,6 @@ data Action | DumpModel deriving (Show, Eq) -type Discover = "discover" :> View Action - -type Home = - View Action - -type ComicCover = - "comic" - :> Capture "comicId" ComicId - :> View Action - -type ComicReaderSpread = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> View Action - -type ComicReaderFull = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "full" - :> View Action - -type ComicVideo = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "video" - :> View Action - -type ChooseExperience = - "comic" - :> Capture "id" ComicId - :> Capture "page" Page - :> "experience" - :> View Action - -type Login = - "login" :> View Action - type ClientRoutes = Home :<|> ComicCover @@ -448,43 +408,106 @@ type ClientRoutes = handlers = home :<|> comicCover - :<|> comicPlayer - :<|> comicPlayer - :<|> comicPlayer + :<|> comicReader + :<|> comicReader + :<|> comicReader :<|> login :<|> discover - :<|> comicPlayer + :<|> comicReader routes :: Proxy ClientRoutes routes = Proxy -comicPlayerSpreadProxy :: Proxy ComicReaderSpread -comicPlayerSpreadProxy = Proxy - -comicPlayerFullProxy :: Proxy ComicReaderFull -comicPlayerFullProxy = Proxy - -chooseExperienceProxy :: Proxy ChooseExperience -chooseExperienceProxy = Proxy +-- * pages +-- +-- TODO: consider making a typeclass, something like: +-- +-- class Page name where +-- type Route name :: View Action +-- proxy :: Proxy name +-- proxy = Proxy name +-- view :: Model -> View Action +-- link :: URI -comicProxy :: Proxy ComicCover -comicProxy = Proxy +-- * home -comicVideoProxy :: Proxy ComicVideo -comicVideoProxy = Proxy +type Home = + View Action homeProxy :: Proxy Home homeProxy = Proxy +home :: Model -> View Action +home = login + +homeLink :: URI +homeLink = linkURI $ safeLink routes homeProxy + +-- * login + +type Login = + "login" :> View Action + loginProxy :: Proxy Login loginProxy = Proxy +loginLink :: URI +loginLink = linkURI $ safeLink routes loginProxy + +login :: Model -> View Action +login _ = + template + "login" + [ div_ + [id_ "login-inner"] + [ img_ + [ class_ fadeIn, + src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" + ], + hr_ [class_ fadeIn], + form_ + [class_ fadeIn] + [ ctrl [class_ "input", type_ "email", placeholder_ "Email"], + ctrl [class_ "input", type_ "password", placeholder_ "Password"], + div_ + [class_ "action", css euro] + [ div_ + [class_ "checkbox remember-me"] + [ input_ [type_ "checkbox"], + label_ [Miso.for_ "checkbox"] [text "Remember Me"] + ], + div_ + [class_ "button is-black", onClick $ ChangeURI discoverLink] + [text "Login"] + ] + ], + hr_ [class_ fadeIn], + p_ + [class_ $ "help " <> fadeIn] + [ a_ [href_ "#"] [text "Forgot your username or password?"], + a_ [href_ "#"] [text "Don't have an account? Sign Up"] + ], + img_ + [ id_ "hero-logo", + class_ "blur-out", + src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" + ] + ] + ] + where + fadeIn = "animated fadeIn delay-2s" + ctrl x = div_ [class_ "control"] [input_ x] + +-- * discover + +type Discover = "discover" :> View Action + +discoverLink :: URI +discoverLink = linkURI $ safeLink routes discoverProxy + discoverProxy :: Proxy Discover discoverProxy = Proxy -home :: Model -> View Action -home = login - discover :: Model -> View Action discover model@Model {user = u} = template @@ -504,49 +527,6 @@ discover model@Model {user = u} = discoverFooter ] --- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' -maybeView :: (a -> View action) -> Maybe a -> View action -maybeView = maybe (text "") - -mediaInfo :: Maybe Comic -> User -> View Action -mediaInfo Nothing _ = text "" -mediaInfo (Just comic) user = - div_ [class_ "media-info"] [info comic user] - -appmenu :: View Action -appmenu = aside_ [id_ "appmenu"] $ btn </ links - where - links = - [ (discoverLink, "discover.svg", "discover"), - (homeLink, "save.svg", "library"), - (homeLink, "watch.svg", "videos"), - (comicLink "1", "read.svg", "comics"), - (homeLink, "listen.svg", "music") - ] - btn (lnk, img, label) = - a_ - [ class_ "button", - onPreventClick $ ChangeURI lnk - ] - [ img_ [src_ $ ms $ Assets.icon <> img], - span_ [] [text label] - ] - --- TODO: make this a loading gif of some sort... maybe the hero icon filling from white to red -loading :: View Action -loading = div_ [class_ "loading"] [text "Loading..."] - -nocomics :: View Action -nocomics = div_ [class_ "loading"] [text "error: no comics found"] - -shelf :: IsMediaObject o => MisoString -> [o] -> View Action -shelf title comics = - div_ - [class_ "shelf"] - [ div_ [class_ "shelf-head"] [text title], - ul_ [class_ "shelf-body"] $ thumbnail </ comics - ] - discoverFooter :: View Action discoverFooter = footer_ @@ -584,14 +564,91 @@ discoverFooter = (attrs lnk) [img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x]] +-- * comic + +type ComicCover = + "comic" + :> Capture "comicId" ComicId + :> View Action + +comicProxy :: Proxy ComicCover +comicProxy = Proxy + comicCover :: ComicId -> Model -> View Action -comicCover comicId_ = comicPlayer comicId_ 1 +comicCover comicId_ = comicReader comicId_ 1 + +comicLink :: ComicId -> URI +comicLink comicId_ = linkURI $ safeLink routes comicProxy comicId_ + +-- * chooseExperience + +type ChooseExperience = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "experience" + :> View Action + +chooseExperienceProxy :: Proxy ChooseExperience +chooseExperienceProxy = Proxy + +chooseExperienceLink :: ComicId -> Page -> URI +chooseExperienceLink id page = + linkURI $ safeLink routes chooseExperienceProxy id page + +chooseExperiencePage :: Comic -> Page -> Model -> View Action +chooseExperiencePage comic page model = + template + "choose-experience" + [ topbar, + main_ + [id_ "app-body"] + [ h2_ [] [text "Choose Your Musical Experience"], + p_ [] [text experienceBlurb], + ul_ [] $ li comic </ experiences + ], + appmenu, + comicControls comic page model + ] + where + li c (name, artist, track) = + li_ + [onClick $ StartReading c] + [ div_ + [] + [ img_ [src_ $ ms $ Assets.demo <> name <> ".png"], + span_ [] [text $ ms name] + ], + span_ [css thicc] [text $ ms artist], + span_ [] [text $ ms track] + ] + experiences :: [(Text, Text, Text)] + experiences = + [ ("comedic", "RxGF", "Soft Reveal"), + ("dark", "Logan Henderson", "Speak of the Devil"), + ("original", "Mehcad Brooks", "Stars"), + ("energetic", "Skela", "What's wrong with me"), + ("dramatic", "Josh Jacobson", "Sideline") + ] + +experienceBlurb :: MisoString +experienceBlurb = + [s| +As you enter the world of Hero, you will find that music and visual art have a +symbiotic relationship that can only be experienced, not described. Here, choose +the tonality of the experience you wish to adventure on, whether it's a comedic, +dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey +with the original curated music for this piece of visual art. +|] + + +-- * comicReader data ComicReaderView = Spread | Full deriving (Show, Eq) -comicPlayer :: ComicId -> Page -> Model -> View Action -comicPlayer _ _ model = case appComics model of +comicReader :: ComicId -> Page -> Model -> View Action +comicReader _ _ model = case appComics model of NotAsked -> loading Loading -> loading Failure _ -> nocomics @@ -604,27 +661,6 @@ comicPlayer _ _ model = case appComics model of Reading Full id pg -> viewOr404 comics zoomScreen id pg model Watching id -> viewOr404 comics comicVideo id 0 model -viewOr404 :: - [Comic] -> - (Comic -> Page -> Model -> View Action) -> - ComicId -> - Page -> - Model -> - View Action -viewOr404 comics f id pg model = - case findComic id comics of - Just c -> f c pg model - Nothing -> the404 model - -template :: MisoString -> [View Action] -> View Action -template id = div_ [id_ id, class_ "app is-black"] - -closeButton :: View Action -closeButton = - a_ - [id_ "close-button", onClick $ ChangeURI discoverLink] - [text "x"] - zoomScreen :: Comic -> Page -> Model -> View Action zoomScreen comic page model = template @@ -647,6 +683,22 @@ zoomScreen comic page model = <> padLeft page <> ".png" + +-- * comicReaderSpread + +type ComicReaderSpread = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> View Action + +comicReaderSpreadProxy :: Proxy ComicReaderSpread +comicReaderSpreadProxy = Proxy + +comicReaderSpreadLink :: ComicId -> Page -> URI +comicReaderSpreadLink id page = + linkURI $ safeLink routes comicReaderSpreadProxy id page + comicSpread :: Comic -> Page -> Model -> View Action comicSpread comic page model = template @@ -679,6 +731,44 @@ comicSpread comic page model = <> padLeft (1 + page) <> ".png" +closeButton :: View Action +closeButton = + a_ + [id_ "close-button", onClick $ ChangeURI discoverLink] + [text "x"] + +-- * comicReaderFull + +type ComicReaderFull = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "full" + :> View Action + +comicReaderFullProxy :: Proxy ComicReaderFull +comicReaderFullProxy = Proxy + +comicReaderFullLink :: ComicId -> Page -> URI +comicReaderFullLink id page = + linkURI $ safeLink routes comicReaderFullProxy id page + +-- * comicVideo + +type ComicVideo = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "video" + :> View Action + +comicVideoProxy :: Proxy ComicVideo +comicVideoProxy = Proxy + +comicVideoLink :: ComicId -> Page -> URI +comicVideoLink id page = + linkURI $ safeLink routes comicVideoProxy id page + frameborder_ :: MisoString -> Attribute action frameborder_ = textProp "frameborder" @@ -704,6 +794,68 @@ comicVideo _ _ _ = ] ] + +-- * general page components & utils + +-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' +maybeView :: (a -> View action) -> Maybe a -> View action +maybeView = maybe (text "") + +mediaInfo :: Maybe Comic -> User -> View Action +mediaInfo Nothing _ = text "" +mediaInfo (Just comic) user = + div_ [class_ "media-info"] [info comic user] + +appmenu :: View Action +appmenu = aside_ [id_ "appmenu"] $ btn </ links + where + links = + [ (discoverLink, "discover.svg", "discover"), + (homeLink, "save.svg", "library"), + (homeLink, "watch.svg", "videos"), + (comicLink "1", "read.svg", "comics"), + (homeLink, "listen.svg", "music") + ] + btn (lnk, img, label) = + a_ + [ class_ "button", + onPreventClick $ ChangeURI lnk + ] + [ img_ [src_ $ ms $ Assets.icon <> img], + span_ [] [text label] + ] + +-- TODO: make this a loading gif of some sort... maybe the hero icon filling +-- from white to red +loading :: View Action +loading = div_ [class_ "loading"] [text "Loading..."] + +nocomics :: View Action +nocomics = div_ [class_ "loading"] [text "error: no comics found"] + +shelf :: IsMediaObject o => MisoString -> [o] -> View Action +shelf title comics = + div_ + [class_ "shelf"] + [ div_ [class_ "shelf-head"] [text title], + ul_ [class_ "shelf-body"] $ thumbnail </ comics + ] + +viewOr404 :: + [Comic] -> + (Comic -> Page -> Model -> View Action) -> + ComicId -> + Page -> + Model -> + View Action +viewOr404 comics f id pg model = + case findComic id comics of + Just c -> f c pg model + Nothing -> the404 model + +template :: MisoString -> [View Action] -> View Action +template id = div_ [id_ id, class_ "app is-black"] + padLeft :: Int -> MisoString padLeft n | n < 10 = ms ("0" <> Legacy.show n) @@ -745,95 +897,6 @@ comicControls comic page model = rightPage = ms . Legacy.show $ 1 + page totalpages = ms . Legacy.show $ comicPages comic -login :: Model -> View Action -login _ = - template - "login" - [ div_ - [id_ "login-inner"] - [ img_ - [ class_ fadeIn, - src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" - ], - hr_ [class_ fadeIn], - form_ - [class_ fadeIn] - [ ctrl [class_ "input", type_ "email", placeholder_ "Email"], - ctrl [class_ "input", type_ "password", placeholder_ "Password"], - div_ - [class_ "action", css euro] - [ div_ - [class_ "checkbox remember-me"] - [ input_ [type_ "checkbox"], - label_ [Miso.for_ "checkbox"] [text "Remember Me"] - ], - div_ - [class_ "button is-black", onClick $ ChangeURI discoverLink] - [text "Login"] - ] - ], - hr_ [class_ fadeIn], - p_ - [class_ $ "help " <> fadeIn] - [ a_ [href_ "#"] [text "Forgot your username or password?"], - a_ [href_ "#"] [text "Don't have an account? Sign Up"] - ], - img_ - [ id_ "hero-logo", - class_ "blur-out", - src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" - ] - ] - ] - where - fadeIn = "animated fadeIn delay-2s" - ctrl x = div_ [class_ "control"] [input_ x] - -chooseExperiencePage :: Comic -> Page -> Model -> View Action -chooseExperiencePage comic page model = - template - "choose-experience" - [ topbar, - main_ - [id_ "app-body"] - [ h2_ [] [text "Choose Your Musical Experience"], - p_ [] [text experienceBlurb], - ul_ [] $ li comic </ experiences - ], - appmenu, - comicControls comic page model - ] - where - li c (name, artist, track) = - li_ - [onClick $ StartReading c] - [ div_ - [] - [ img_ [src_ $ ms $ Assets.demo <> name <> ".png"], - span_ [] [text $ ms name] - ], - span_ [css thicc] [text $ ms artist], - span_ [] [text $ ms track] - ] - experiences :: [(Text, Text, Text)] - experiences = - [ ("comedic", "RxGF", "Soft Reveal"), - ("dark", "Logan Henderson", "Speak of the Devil"), - ("original", "Mehcad Brooks", "Stars"), - ("energetic", "Skela", "What's wrong with me"), - ("dramatic", "Josh Jacobson", "Sideline") - ] - -experienceBlurb :: MisoString -experienceBlurb = - [s| -As you enter the world of Hero, you will find that music and visual art have a -symbiotic relationship that can only be experienced, not described. Here, choose -the tonality of the experience you wish to adventure on, whether it's a comedic, -dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey -with the original curated music for this piece of visual art. -|] - topbar :: View Action topbar = header_ @@ -865,33 +928,6 @@ column :: [View Action] -> View Action column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column] -- | Links -comicLink :: ComicId -> URI -comicLink comicId_ = linkURI $ safeLink routes comicProxy comicId_ - -comicPlayerSpreadLink :: ComicId -> Page -> URI -comicPlayerSpreadLink id page = - linkURI $ safeLink routes comicPlayerSpreadProxy id page - -comicPlayerFullLink :: ComicId -> Page -> URI -comicPlayerFullLink id page = - linkURI $ safeLink routes comicPlayerFullProxy id page - -comicVideoLink :: ComicId -> Page -> URI -comicVideoLink id page = - linkURI $ safeLink routes comicVideoProxy id page - -homeLink :: URI -homeLink = linkURI $ safeLink routes homeProxy - -loginLink :: URI -loginLink = linkURI $ safeLink routes loginProxy - -discoverLink :: URI -discoverLink = linkURI $ safeLink routes discoverProxy the404 :: Model -> View Action the404 _ = template "404" [p_ [] [text "Not found"]] - -chooseExperienceLink :: ComicId -> Page -> URI -chooseExperienceLink id page = - linkURI $ safeLink routes chooseExperienceProxy id page diff --git a/Hero/Client.hs b/Hero/Client.hs index 4189fd8..2b222bd 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -31,8 +31,8 @@ import Hero.App User (..), audioId, chooseExperienceLink, - comicPlayerFullLink, - comicPlayerSpreadLink, + comicReaderFullLink, + comicReaderSpreadLink, comicVideoLink, handlers, initModel, @@ -100,27 +100,27 @@ move DumpModel model = model <# do move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1} <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 move (StartReading comic) model = model {cpState = Reading Spread (comicId comic) 1} - <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 + <# do pure $ ChangeURI $ comicReaderSpreadLink (comicId comic) 1 move (StartWatching comic) model = model {cpState = Watching (comicId comic)} <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 move NextPage model = case cpState model of Reading Spread id pg -> model {cpState = Reading Spread id (pg + 2)} <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg + 2) + pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2) Reading Full id pg -> model {cpState = Reading Full id (pg + 1)} <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg + 1) + pure $ ChangeURI $ comicReaderFullLink id (pg + 1) Cover id -> model {cpState = Reading Spread id 1} <# do - pure $ ChangeURI $ comicPlayerSpreadLink id 1 + pure $ ChangeURI $ comicReaderSpreadLink id 1 _ -> noEff model move PrevPage model = case cpState model of Reading Spread id pg -> model {cpState = Reading Spread id (pg -2)} <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg -2) + pure $ ChangeURI $ comicReaderSpreadLink id (pg -2) Reading Full id pg -> model {cpState = Reading Full id (pg -1)} <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg -1) + pure $ ChangeURI $ comicReaderFullLink id (pg -1) Cover _ -> noEff model _ -> noEff model move (ToggleZoom c pg) m = m {cpState = newState} <# pure act @@ -128,8 +128,8 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act goto lnk = ChangeURI $ lnk (comicId c) pg reading v = Reading v (comicId c) pg (newState, act) = case cpState m of - Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) - Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) + Reading Full _ _ -> (reading Spread, goto comicReaderSpreadLink) + Reading Spread _ _ -> (reading Full, goto comicReaderFullLink) x -> (x, NoOp) move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp where 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 + |