{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Hero.App where import Alpha import qualified Clay import Data.Aeson ( FromJSON (..), ToJSON (..), defaultOptions, genericParseJSON, genericToJSON, ) import qualified Data.List as List import qualified Data.List.Split as List import Data.Proxy (Proxy (..)) import Data.String import Data.String.Quote import Data.Text (Text, replace, toLower) import GHC.Generics (Generic) import qualified GHC.Show as Legacy import qualified Hero.Assets as Assets import Hero.Look as Look import Hero.Look.Typography import Miso import qualified Miso (for_) import Miso.String import Network.RemoteData import Protolude hiding (replace) import Servant.API ( (:<|>) (..), (:>), Capture, URI (..), safeLink, ) import Servant.Links (linkURI) crossorigin_ :: MisoString -> Attribute action crossorigin_ = textProp "crossorigin" -- | The css id for controling music in the comic player. audioId :: MisoString audioId = "audioSource" -- | Like 'onClick' but prevents the default action from triggering. Use this to -- overide 'a_' links, for example. onPreventClick :: Action -> Attribute Action onPreventClick action = onWithOptions Miso.defaultOptions {preventDefault = True} "click" emptyDecoder (\() -> action) -- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html type ComicId = String -- | Class for turning different string types to snakeCase. class CanSnakeCase str where snake :: str -> str instance CanSnakeCase Text where snake = Data.Text.replace " " "-" . Data.Text.toLower -- | Used for looking up images on S3, mostly comicSlug :: Comic -> Text comicSlug Comic {..} = snake comicName <> "-" <> comicIssue data Comic = Comic { comicId :: ComicId, comicPages :: Integer, comicName :: Text, -- | Ideally this would be a dynamic number-like type comicIssue :: Text, comicDescription :: Text } deriving (Show, Eq, Generic) instance ToJSON Comic where toJSON = genericToJSON Data.Aeson.defaultOptions instance FromJSON Comic where parseJSON = genericParseJSON Data.Aeson.defaultOptions -- | Class for rendering media objects in different ways. class IsMediaObject o where -- | Render a thumbnail for use in a shelf, or otherwise. thumbnail :: o -> View Action -- | Render a featured banner. feature :: o -> Library -> View Action -- | Media info view info :: o -> Library -> View Action instance IsMediaObject Comic where thumbnail c@Comic {..} = li_ [] [ a_ [ class_ "comic grow clickable", id_ $ "comic-" <> ms comicId, onClick $ SetMediaInfo $ Just c ] [ img_ [src_ $ ms $ Assets.demo <> comicSlug c <> ".png"], span_ [] [text $ "Issue #" <> ms comicIssue], span_ [] [text $ ms comicName] ] ] feature comic lib = div_ [id_ "featured-comic"] [ img_ [id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png"], div_ [id_ "featured-content"] [ div_ [class_ "hero-original", css wide] [ span_ [css thicc] [text "Herø"], span_ [css euro] [text " Original"] ], div_ [class_ "comic-logo"] [img_ [src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png"]], div_ [class_ "comic-action-menu"] $ el <$> [Watch comic, Read comic, Save comic lib], p_ [class_ "description"] [ text . ms $ comicDescription comic ] ] ] info c@Comic {..} lib = div_ [class_ "media-info", css euro] [ div_ [class_ "media-info-meta"] [ column [img_ [src_ $ ms $ Assets.demo <> "dmc-widethumb.png"]], column [ span_ [style_ title] [text $ ms comicName], span_ [style_ subtitle] [text $ "Issue #" <> ms comicIssue], span_ [] [text "Released: "], span_ [] [text $ "Pages: " <> ms (show comicPages :: String)] ] ], div_ [class_ "media-info-summary"] [ p_ [style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem"] [text "Summary"], p_ [] [text $ ms comicDescription] ], div_ [class_ "media-info-actions"] $ el <$> [Save c lib, Read c, Watch c] -- , row [ text "credits" ] ] where title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase <> "line-height" =: "100%" <> Look.condensed <> bold subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed type ZoomModel = Int -- | All the buttons. data Button = Watch Comic | Read Comic | Save Comic Library | SaveIcon Comic Library | ZoomIcon ZoomModel Comic Page | PlayPause MisoString AudioState | Arrow Action -- | Class for defining general, widely used elements in the heroverse. class Elemental v where el :: v -> View Action -- TODO: what if I just did this on all actions? -- then I could e.g. `el $ ToggleAudio audioId audioState` instance Elemental Button where el (PlayPause id model) = button_ [ class_ "button is-large icon", onClick $ ToggleAudio id ] [i_ [class_ $ "fa " <> icon] []] where icon = case model of Paused -> "fa-play-circle" Playing -> "fa-pause-circle" el (Arrow act) = button_ [class_ "button is-large turn-page", onClick act] [img_ [src_ $ ms $ Assets.demo <> image <> ".png"]] where image = case act of PrevPage -> "prev-page" NextPage -> "next-page" _ -> "prev-page" el (Save c lib) = if c `elem` lib -- in library then a_ [class_ "wrs-button saved", onClick $ ToggleInLibrary c] [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], span_ [] [text "saved"] ] else-- not in library a_ [class_ "wrs-button", onClick $ ToggleInLibrary c] [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], span_ [] [text "save"] ] el (SaveIcon c lib) = if c `elem` lib -- in library then button_ [ class_ "button is-large has-background-black", onClick $ ToggleInLibrary c ] [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] else-- not in library button_ [ class_ "button is-large has-background-black-bis", onClick $ ToggleInLibrary c ] [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] el (ZoomIcon zmodel comic page) = button_ [ id_ "zoom-button", class_ "button is-large", onClick $ ToggleZoom comic page ] [ img_ [src_ $ ms $ Assets.demo <> "zoom.png"], input_ [ type_ "range", min_ "0", max_ "100", disabled_ True, value_ $ ms (show zmodel :: String), class_ "ctrl", id_ "zoom" ], label_ [class_ "ctrl", Miso.for_ "zoom"] [text $ ms $ (show zmodel :: String) ++ "%"] ] el (Read c) = a_ [class_ "wrs-button", onClick $ SelectExperience c] [ img_ [src_ $ ms $ Assets.icon <> "read.svg"], span_ [] [text "read"] ] el (Watch c) = a_ [class_ "wrs-button", onClick $ StartWatching c] [ img_ [src_ $ ms $ Assets.icon <> "watch.svg"], span_ [] [text "watch"] ] data AudioState = Playing | Paused deriving (Show, Eq) type Library = [Comic] data ComicReaderState = NotReading | Cover ComicId | ChooseExperience ComicId Page | Reading ComicReaderView ComicId Page | Watching ComicId deriving (Show, Eq) findComic :: ComicId -> [Comic] -> Maybe Comic findComic id = List.find (\c -> comicId c == id) -- | Main model for the app. -- -- Try to prefix component-specific state with the component initials: 'd' for -- discover, 'cp' for comic player. data Model = Model { uri :: URI, appComics :: RemoteData MisoString [Comic], userLibrary :: Library, dMediaInfo :: Maybe Comic, cpState :: ComicReaderState, cpAudioState :: AudioState, zoomModel :: ZoomModel } deriving (Show, Eq) initModel :: URI -> Model initModel uri_ = Model { uri = uri_, appComics = NotAsked, dMediaInfo = Nothing, userLibrary = Protolude.empty, cpState = detectPlayerState uri_, cpAudioState = Paused, zoomModel = 100 } -- | Hacky way to initialize the 'ComicReaderState' from the URI. detectPlayerState :: URI -> ComicReaderState detectPlayerState u = case List.splitOn "/" $ uriPath u of ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg ["", "comic", id, _, "video"] -> Watching id ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg ["", "comic", id, pg] -> Reading Spread id $ toPage pg ["", "comic", id] -> Cover id _ -> NotReading where toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) type Page = Int data Action = NoOp | -- comic player stuff SelectExperience Comic | StartReading Comic | StartWatching Comic | NextPage | PrevPage | ToggleZoom Comic Page | ToggleAudio MisoString | FetchComics | SetComics (RemoteData MisoString [Comic]) | ToggleFullscreen | -- discover stuff SetMediaInfo (Maybe Comic) | ToggleInLibrary Comic | -- app stuff ScrollIntoView MisoString | HandleURI URI | ChangeURI URI | 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 :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo :<|> Login :<|> Discover :<|> ChooseExperience handlers = home :<|> comicCover :<|> comicPlayer :<|> comicPlayer :<|> comicPlayer :<|> login :<|> discover :<|> comicPlayer routes :: Proxy ClientRoutes routes = Proxy comicPlayerSpreadProxy :: Proxy ComicReaderSpread comicPlayerSpreadProxy = Proxy comicPlayerFullProxy :: Proxy ComicReaderFull comicPlayerFullProxy = Proxy chooseExperienceProxy :: Proxy ChooseExperience chooseExperienceProxy = Proxy comicProxy :: Proxy ComicCover comicProxy = Proxy comicVideoProxy :: Proxy ComicVideo comicVideoProxy = Proxy homeProxy :: Proxy Home homeProxy = Proxy loginProxy :: Proxy Login loginProxy = Proxy discoverProxy :: Proxy Discover discoverProxy = Proxy home :: Model -> View Action home = login discover :: Model -> View Action discover model@Model {userLibrary = lib} = template "discover" [ topbar, main_ [id_ "app-body"] $ case appComics model of NotAsked -> [loading] Loading -> [loading] Failure _ -> [nocomics] Success [] -> [nocomics] Success (comic : rest) -> [ feature comic lib, shelf "Recent Releases" (comic : rest), maybeView (`info` lib) $ dMediaInfo model ], appmenu, 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 -> Library -> View Action mediaInfo Nothing _ = text "" mediaInfo (Just comic) lib = div_ [class_ "media-info"] [info comic lib] appmenu :: View Action appmenu = aside_ [id_ "appmenu"] $ btn 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 "hero-logo.svg"]], span_ [] [text "© Hero Records, Inc. All Rights Reserved"] ] ] where attrs Nothing = [class_ "social-icon"] attrs (Just lnk) = [class_ "social-icon", href_ lnk, target_ "_blank"] smallImg x lnk = a_ (attrs lnk) [img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x]] comicCover :: ComicId -> Model -> View Action comicCover comicId_ = comicPlayer comicId_ 1 data ComicReaderView = Spread | Full deriving (Show, Eq) comicPlayer :: ComicId -> Page -> Model -> View Action comicPlayer _ _ model = case appComics model of NotAsked -> loading Loading -> loading Failure _ -> nocomics Success comics -> case cpState model of NotReading -> template "comic-player" [text "error: not reading"] Cover id -> viewOr404 comics comicSpread id 1 model ChooseExperience id pg -> viewOr404 comics chooseExperiencePage id pg model Reading Spread id pg -> viewOr404 comics comicSpread id pg model 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 "comic-player" [ topbar, main_ [id_ "app-body"] [ img_ [ src_ comicImg, class_ "comic-page-full" ] ], comicControls comic page model ] where comicImg = ms Assets.demo <> ms (comicSlug comic) <> "-" <> padLeft page <> ".png" comicSpread :: Comic -> Page -> Model -> View Action comicSpread comic page model = template "comic-player" [ topbar, main_ [id_ "app-body"] [ div_ [class_ "comic-player"] [ img_ [src_ comicImgLeft, class_ "comic-page"], img_ [src_ comicImgRight, class_ "comic-page"] ], closeButton ], appmenu, comicControls comic page model ] where comicImgLeft, comicImgRight :: MisoString comicImgLeft = ms Assets.demo <> ms (comicSlug comic) <> "-" <> padLeft page <> ".png" comicImgRight = ms Assets.demo <> ms (comicSlug comic) <> "-" <> padLeft (1 + page) <> ".png" frameborder_ :: MisoString -> Attribute action frameborder_ = textProp "frameborder" allowfullscreen_ :: Bool -> Attribute action allowfullscreen_ = boolProp "allowfullscreen" comicVideo :: Comic -> Page -> Model -> View Action comicVideo _ _ _ = template "comic-player" [ topbar, main_ [id_ "app-body"] [ div_ [class_ "comic-video"] [ iframe_ [ src_ "//player.vimeo.com/video/325757560", frameborder_ "0", allowfullscreen_ True ] [] ] ] ] padLeft :: Int -> MisoString padLeft n | n < 10 = ms ("0" <> Legacy.show n) | otherwise = ms $ Legacy.show n comicControls :: Comic -> Page -> Model -> View Action comicControls comic page model = footer_ [id_ "app-foot", class_ "comic-controls"] [ div_ [ class_ "comic-nav-audio", css flexCenter ] [ audio_ [id_ audioId, loop_ True, crossorigin_ "anonymous"] [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]], el $ PlayPause audioId $ cpAudioState model, span_ [css $ euro <> thicc <> smol <> wide] [text "Experiencing: Original"] ], div_ [class_ "comic-controls-pages", css euro] [ el $ Arrow PrevPage, span_ [] [text $ leftPage <> "-" <> rightPage <> " of " <> totalpages], el $ Arrow NextPage ], div_ [class_ "comic-controls-share"] [ el $ SaveIcon comic $ userLibrary model, el $ ZoomIcon (zoomModel model) comic page, button_ [class_ "button icon is-large", onClick ToggleFullscreen] [i_ [class_ "fa fa-expand"] []] ] ] where leftPage = ms . Legacy.show $ page 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 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_ [id_ "app-head", class_ "is-black", css euro] [ a_ [class_ "button is-medium is-black", onClick $ ChangeURI homeLink] [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]], div_ [id_ "app-head-right"] [ button_ [class_ "button icon is-medium is-black"] [i_ [class_ "fas fa-search"] []], button_ [ class_ "button is-medium is-black is-size-7", css $ euro <> wide <> thicc ] [text "News"], span_ [class_ "icon is-large"] [ i_ [class_ "fas fa-user"] [] ] ] ] row :: [View Action] -> View Action row = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row] 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