{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Com.MusicMeetsComics.App where import qualified Clay import qualified Com.MusicMeetsComics.Assets as Assets import Com.MusicMeetsComics.Look as Look import Com.MusicMeetsComics.Look.Typography import Com.Simatime.Alpha import Com.Simatime.Network import Data.Aeson ( ToJSON(..) , FromJSON(..) , genericToJSON , genericParseJSON , defaultOptions ) 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 Miso import qualified Miso (for_) import Miso.String 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 , comicIssue :: Text -- ^ Ideally this would be a dynamic number-like type , 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 then -- in library 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 then -- in library 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 ls = List.find (\c -> comicId c == id) ls -- | 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 -> undefined Loading -> [loading] Failure e -> undefined Success [] -> [nocomics] Success (comic:rest) -> [ feature comic lib , shelf "Recent Releases" (comic:rest) , maybeView (flip 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 f obj = maybe (text "") f obj 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 /@ 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_ [ id_ "app-foot" , class_ "is-black" ] [ div_ [id_ "app-foot-social", css euro] [ div_ [class_ "row is-marginless"] [ smallImg "facebook.png" $ Just "https://www.facebook.com/musicmeetscomics" , smallImg "twitter.png" $ Just "https://twitter.com/musicmeetscomic" , smallImg "instagram.png" $ Just "https://www.instagram.com/musicmeetscomics/" , smallImg "spotify.png" $ Just "https://open.spotify.com/user/i4ntfg6ganjgxdsylinigcjlq?si=ymWsSkwsT9iaLw2LeAJNNg" , smallImg "youtube.png" $ Just "https://www.youtube.com/channel/UCnNPLiuJ1ueo1KTPgHDE7lA/" ] , div_ [class_ "row"] [ text "Team | Contact Us | Privacy Policy" ] ] , div_ [ id_ "app-foot-quote", css euro ] [ p_ [] [text "With great power comes great responsiblity."] , p_ [] [text "-Stan Lee"] ] , div_ [ css euro, id_ "app-foot-logo", onClick DumpModel ] [ a_ [ class_ "social-icon", href_ "#" ] [ img_ [ src_ $ ms $ Assets.icon <> "hero-logo.svg" ]] , span_ [] [ text "© Com.MusicMeetsComics 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_ model = comicPlayer comicId_ 1 model data ComicReaderView = Spread | Full deriving (Show, Eq) comicPlayer :: ComicId -> Page -> Model -> View Action comicPlayer _ _ model = case appComics model of NotAsked -> undefined Loading -> loading Failure e -> undefined 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 rest = div_ [id_ id, class_ "app is-black"] rest 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 /@ 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_ [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