diff options
Diffstat (limited to 'Hero')
| -rw-r--r-- | Hero/App.hs | 1012 | ||||
| -rw-r--r-- | Hero/Assets.hs | 3 | ||||
| -rw-r--r-- | Hero/Client.hs | 259 | ||||
| -rw-r--r-- | Hero/Database.hs | 38 | ||||
| -rw-r--r-- | Hero/Look.hs | 753 | ||||
| -rw-r--r-- | Hero/Look/Typography.hs | 48 | ||||
| -rw-r--r-- | Hero/Server.hs | 277 |
7 files changed, 1257 insertions, 1133 deletions
diff --git a/Hero/App.hs b/Hero/App.hs index 7f55052..6afcbd2 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -1,46 +1,48 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} + module Hero.App where -import Alpha +import Alpha import qualified Clay -import qualified Hero.Assets as Assets -import Hero.Look as Look -import Hero.Look.Typography -import Network.RemoteData -import Data.Aeson ( ToJSON(..) - , FromJSON(..) - , genericToJSON - , genericParseJSON - , defaultOptions - ) +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 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 Hero.Assets as Assets +import Hero.Look as Look +import Hero.Look.Typography +import Miso import qualified Miso (for_) -import Miso.String -import Protolude hiding (replace) -import Servant.API ( Capture - , URI(..) - , safeLink - , (:<|>)(..) - , (:>) - ) -import Servant.Links ( linkURI ) +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" @@ -53,30 +55,36 @@ audioId = "audioSource" -- overide 'a_' links, for example. onPreventClick :: Action -> Attribute Action onPreventClick action = - onWithOptions Miso.defaultOptions { preventDefault = True } - "click" emptyDecoder (\() -> 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 + snake :: str -> str instance CanSnakeCase Text where - snake = Data.Text.replace " " "-" . Data.Text.toLower + 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) +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 @@ -86,73 +94,93 @@ instance FromJSON Comic where -- | 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 + -- | 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 + 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 ] + [ 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 - ] + ] + 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 ] + ] + 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 - + ] + 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 + = 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 @@ -160,84 +188,100 @@ 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 (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 - el (ZoomIcon zmodel comic page) = button_ - [ id_ "zoom-button", class_ "button is-large" - , onClick $ ToggleZoom comic page + a_ + [class_ $ "wrs-button", onClick $ ToggleInLibrary c] + [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], + span_ [] [text "save"] ] - [ 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 (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 - 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" ] - ] + 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) + deriving (Show, Eq) type Library = [Comic] data ComicReaderState - = NotReading - | Cover ComicId - | ChooseExperience ComicId Page - | Reading ComicReaderView ComicId Page - | Watching ComicId - deriving (Show, Eq) + = 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 @@ -246,36 +290,39 @@ findComic id ls = List.find (\c -> comicId c == id) ls -- -- 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) +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 - } + 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 + ["", "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) @@ -283,8 +330,8 @@ type Page = Int data Action = NoOp - -- comic player stuff - | SelectExperience Comic + | -- comic player stuff + SelectExperience Comic | StartReading Comic | StartWatching Comic | NextPage @@ -294,11 +341,11 @@ data Action | FetchComics | SetComics (RemoteData MisoString [Comic]) | ToggleFullscreen - -- discover stuff - | SetMediaInfo (Maybe Comic) + | -- discover stuff + SetMediaInfo (Maybe Comic) | ToggleInLibrary Comic - -- app stuff - | ScrollIntoView MisoString + | -- app stuff + ScrollIntoView MisoString | HandleURI URI | ChangeURI URI | DumpModel @@ -307,50 +354,62 @@ data Action type Discover = "discover" :> View Action type Home = - View Action + View Action type ComicCover = - "comic" + "comic" :> Capture "comicId" ComicId :> View Action type ComicReaderSpread = - "comic" + "comic" :> Capture "id" ComicId :> Capture "page" Page :> View Action type ComicReaderFull = - "comic" + "comic" :> Capture "id" ComicId :> Capture "page" Page :> "full" :> View Action type ComicVideo = - "comic" + "comic" :> Capture "id" ComicId :> Capture "page" Page :> "video" :> View Action type ChooseExperience = - "comic" + "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 + "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 @@ -383,21 +442,23 @@ 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 (flip info lib) $ dMediaInfo model - ] - , appmenu - , discoverFooter - ] +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 (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 @@ -405,155 +466,173 @@ 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 ] +mediaInfo (Just comic) lib = div_ [class_ "media-info"] [info comic lib] appmenu :: View Action -appmenu = aside_ [ id_ "appmenu" ] $ btn </ links +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 + 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 ] + [ 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..." ] +loading = div_ [class_ "loading"] [text "Loading..."] nocomics :: View Action -nocomics = div_ [ class_ "loading" ] [ text "error: no comics found" ] +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 +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"] +discoverFooter = + footer_ + [ id_ "app-foot", + class_ "is-black" ] - , div_ - [ css euro, id_ "app-foot-logo", onClick DumpModel ] - [ a_ [ class_ "social-icon", href_ "#" ] [ img_ [ src_ $ ms $ Assets.icon <> "hero-logo.svg" ]] - , span_ [] [ text "© Hero Records, Inc. All Rights Reserved" ] + [ 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 "© 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 ]] + 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) + 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 + 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 + 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" ] +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" - ] +zoomScreen comic page model = + template + "comic-player" + [ topbar, + main_ + [id_ "app-body"] + [ img_ + [ src_ comicImg, + class_ "comic-page-full" + ] + ], + comicControls comic page model ] - , comicControls comic page model - ] - where - comicImg = + where + comicImg = ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" + <> 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 +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 ] - , appmenu - , comicControls comic page model - ] - where - comicImgLeft, comicImgRight :: MisoString - comicImgLeft = + where + comicImgLeft, comicImgRight :: MisoString + comicImgLeft = ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" - comicImgRight = + <> ms (comicSlug comic) + <> "-" + <> padLeft page + <> ".png" + comicImgRight = ms Assets.demo - <> ms (comicSlug comic) - <> "-" - <> (padLeft $ 1 + page) - <> ".png" + <> ms (comicSlug comic) + <> "-" + <> (padLeft $ 1 + page) + <> ".png" frameborder_ :: MisoString -> Attribute action frameborder_ = textProp "frameborder" @@ -562,125 +641,147 @@ 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 - ] - [] +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 +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 +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"] []] + ] ] - , 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 + 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" - ] - ] +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 ] + 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 +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 ] + 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") - ] - + [ ("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| +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, @@ -689,33 +790,36 @@ 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" ] [] +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 ] +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 ] +column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column] -- | Links - comicLink :: ComicId -> URI comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_ @@ -745,4 +849,4 @@ the404 _ = template "404" [p_ [] [text "Not found"]] chooseExperienceLink :: ComicId -> Page -> URI chooseExperienceLink id page = - linkURI $ safeLink routes chooseExperienceProxy id page + linkURI $ safeLink routes chooseExperienceProxy id page diff --git a/Hero/Assets.hs b/Hero/Assets.hs index 06386b8..2e2d72c 100644 --- a/Hero/Assets.hs +++ b/Hero/Assets.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} + -- | A module to wrap the CDN and provide convient helper functions to assets. module Hero.Assets where -import Protolude +import Protolude cdnEdge :: Text cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com" diff --git a/Hero/Client.hs b/Hero/Client.hs index 9a8fa02..0472d48 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} + -- | Hero app frontend -- -- : exe mmc.js @@ -17,52 +18,55 @@ -- : dep ghcjs-base module Hero.Client where -import Hero.App ( Action(..) - , Comic(..) - , ComicReaderState(..) - , ComicReaderView(..) - , Model(..) - , AudioState(..) - , audioId - , chooseExperienceLink - , comicPlayerSpreadLink - , comicPlayerFullLink - , comicVideoLink - , handlers - , initModel - , the404 - , routes - ) -import qualified Network.RemoteData as Network -import Data.Aeson ( eitherDecodeStrict ) +import Data.Aeson (eitherDecodeStrict) import qualified Data.Set as Set import qualified GHC.Show as Legacy -import JavaScript.Web.XMLHttpRequest ( Request(..) - , Method(GET) - , RequestData(NoData) - , contents - , xhrByteString - ) -import Miso -import Miso.Effect.DOM (scrollIntoView) +import Hero.App + ( Action (..), + AudioState (..), + Comic (..), + ComicReaderState (..), + ComicReaderView (..), + Model (..), + audioId, + chooseExperienceLink, + comicPlayerFullLink, + comicPlayerSpreadLink, + comicVideoLink, + handlers, + initModel, + routes, + the404, + ) +import JavaScript.Web.XMLHttpRequest + ( Method (GET), + Request (..), + RequestData (NoData), + contents, + xhrByteString, + ) +import Miso +import Miso.Effect.DOM (scrollIntoView) import qualified Miso.FFI.Audio as Audio import qualified Miso.FFI.Document as Document import qualified Miso.FFI.Fullscreen as Fullscreen -import Miso.String -import Protolude +import Miso.String +import qualified Network.RemoteData as Network +import Protolude -- | Entry point for a miso application main :: IO () -main = miso $ \currentURI -> App { model = initModel currentURI, .. } +main = miso $ \currentURI -> App {model = initModel currentURI, ..} where - update = move - view = see - subs = [ uriSub HandleURI - , keyboardSub keynav - ] - events = defaultEvents + update = move + view = see + subs = + [ uriSub HandleURI, + keyboardSub keynav + ] + events = defaultEvents initialAction = FetchComics - mountPoint = Nothing + mountPoint = Nothing (∈) :: Ord a => a -> Set a -> Bool (∈) = Set.member @@ -70,17 +74,17 @@ main = miso $ \currentURI -> App { model = initModel currentURI, .. } -- | Keyboard navigation - maps keys to actions. keynav :: Set Int -> Action keynav ks - | 37 ∈ ks = PrevPage -- ^ left arrow - | 39 ∈ ks = NextPage -- ^ right arrow - | 191 ∈ ks = DumpModel -- ^ ? - | 32 ∈ ks = ToggleAudio audioId -- ^ SPC - | otherwise = NoOp + | 37 ∈ ks = PrevPage -- left arrow + | 39 ∈ ks = NextPage -- right arrow + | 191 ∈ ks = DumpModel -- ? + | 32 ∈ ks = ToggleAudio audioId -- SPC + | otherwise = NoOp see :: Model -> View Action see model = - case runRoute routes handlers uri model of - Left _ -> the404 model - Right v -> v + case runRoute routes handlers uri model of + Left _ -> the404 model + Right v -> v -- | Console-logging foreign import javascript unsafe "console.log($1);" @@ -88,101 +92,104 @@ foreign import javascript unsafe "console.log($1);" -- | Updates model, optionally introduces side effects move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model +move NoOp model = noEff model move DumpModel model = model <# do - say $ ms $ Legacy.show model - pure NoOp -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 -move (StartWatching comic) model = model { cpState = Watching (comicId comic) } - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 + say $ ms $ Legacy.show model + pure NoOp +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 +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) - Reading Full id pg -> - model { cpState = Reading Full id (pg+1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg+1) - Cover id -> - model { cpState = Reading Spread id 1 } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id 1 - _ -> noEff model + Reading Spread id pg -> + model {cpState = Reading Spread id (pg + 2)} <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg + 2) + Reading Full id pg -> + model {cpState = Reading Full id (pg + 1)} <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg + 1) + Cover id -> + model {cpState = Reading Spread id 1} <# do + pure $ ChangeURI $ comicPlayerSpreadLink 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) - Reading Full id pg -> - model { cpState = Reading Full id (pg-1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg-1) - Cover _ -> noEff model - _ -> noEff model -move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act - where - 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) - x -> (x, NoOp) -move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp - where - newLib | c `elem` (userLibrary model) = - Protolude.filter (/= c) $ userLibrary model - | otherwise = c : (userLibrary model) -move (HandleURI u) model = model { uri = u } <# pure NoOp + Reading Spread id pg -> + model {cpState = Reading Spread id (pg -2)} <# do + pure $ ChangeURI $ comicPlayerSpreadLink id (pg -2) + Reading Full id pg -> + model {cpState = Reading Full id (pg -1)} <# do + pure $ ChangeURI $ comicPlayerFullLink id (pg -1) + Cover _ -> noEff model + _ -> noEff model +move (ToggleZoom c pg) m = m {cpState = newState} <# do pure act + where + 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) + x -> (x, NoOp) +move (ToggleInLibrary c) model = model {userLibrary = newLib} <# pure NoOp + where + newLib + | c `elem` (userLibrary model) = + Protolude.filter (/= c) $ userLibrary model + | otherwise = c : (userLibrary model) +move (HandleURI u) model = model {uri = u} <# pure NoOp move (ChangeURI u) model = model <# do pushURI u pure NoOp -move FetchComics model = model <# (SetComics <$> fetchComics) -move (SetComics cs) model = noEff model { appComics = cs } -move (ToggleAudio i ) model = model { cpAudioState = newState } <# do +move FetchComics model = model <# (SetComics <$> fetchComics) +move (SetComics cs) model = noEff model {appComics = cs} +move (ToggleAudio i) model = model {cpAudioState = newState} <# do el <- Document.getElementById i toggle el pure NoOp - where - (newState, toggle) = case cpAudioState model of - Playing -> (Paused, Audio.pause) - Paused -> (Playing, Audio.play) -move ToggleFullscreen model = model { cpState = newState } <# do - el <- Document.querySelector "body" - -- TODO: check Document.fullscreenEnabled - -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled - _ <- toggle el - pure NoOp where - (toggle, newState) = case cpState model of - Reading Full c n -> (const Fullscreen.exit, Reading Full c n) - Reading Spread c n -> (Fullscreen.request, Reading Spread c n) - -- otherwise, do nothing: - x -> (pure, x) -move (SetMediaInfo x) model = model { dMediaInfo = x } <# do - case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp + (newState, toggle) = case cpAudioState model of + Playing -> (Paused, Audio.pause) + Paused -> (Playing, Audio.play) +move ToggleFullscreen model = model {cpState = newState} <# do + el <- Document.querySelector "body" + -- TODO: check Document.fullscreenEnabled + -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled + _ <- toggle el + pure NoOp + where + (toggle, newState) = case cpState model of + Reading Full c n -> (const Fullscreen.exit, Reading Full c n) + Reading Spread c n -> (Fullscreen.request, Reading Spread c n) + -- otherwise, do nothing: + x -> (pure, x) +move (SetMediaInfo x) model = model {dMediaInfo = x} <# do + case x of + Just Comic {comicId = id} -> + pure $ ScrollIntoView $ "comic-" <> ms id + Nothing -> + pure NoOp move (ScrollIntoView id) model = model <# do - say $ ms $ Legacy.show id - scrollIntoView id - pure NoOp + say $ ms $ Legacy.show id + scrollIntoView id + pure NoOp fetchComics :: IO (Network.RemoteData MisoString [Comic]) fetchComics = do mjson <- contents <$> xhrByteString req case mjson of - Nothing -> + Nothing -> pure $ Network.Failure "Could not fetch comics from server." - Just json -> pure $ Network.fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict json - where - req = Request - { reqMethod = GET - , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } + Just json -> + pure $ Network.fromEither + $ either (Left . ms) pure + $ eitherDecodeStrict json + where + req = + Request + { reqMethod = GET, + reqURI = "/api/comic", -- FIXME: can we replace this hardcoding? + reqLogin = Nothing, + reqHeaders = [], + reqWithCredentials = False, + reqData = NoData + } diff --git a/Hero/Database.hs b/Hero/Database.hs index 5726f3c..0166c6f 100644 --- a/Hero/Database.hs +++ b/Hero/Database.hs @@ -2,20 +2,21 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Hero.Database - ( ComicDB - , getComics - , load - , dummy + ( ComicDB, + getComics, + load, + dummy, ) where -import Hero.App -import Data.Map ( Map ) -import qualified Data.Map as Map -import Dhall -import Protolude -import Servant ( Handler ) +import Data.Map (Map) +import qualified Data.Map as Map +import Dhall +import Hero.App +import Protolude +import Servant (Handler) type ComicDB = (Map ComicId Comic) @@ -25,14 +26,17 @@ load :: IO ComicDB load = listToComicDB <$> input auto "./comic-database.dhall" dummy :: IO ComicDB -dummy = return $ listToComicDB - [ Comic { comicId = "ComicId" - , comicPages = 10 - , comicName = "Dummy comic" - , comicIssue = "dummy issue" - , comicDescription = "Lorem ipsum" +dummy = + return $ + listToComicDB + [ Comic + { comicId = "ComicId", + comicPages = 10, + comicName = "Dummy comic", + comicIssue = "dummy issue", + comicDescription = "Lorem ipsum" } - ] + ] listToComicDB :: [Comic] -> ComicDB listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls diff --git a/Hero/Look.hs b/Hero/Look.hs index 109ea76..662b223 100644 --- a/Hero/Look.hs +++ b/Hero/Look.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Styles -- @@ -8,17 +8,17 @@ -- http://fvisser.nl/clay/ module Hero.Look where -import Clay +import Clay import qualified Clay.Flexbox as Flexbox import qualified Clay.Media as Media import qualified Clay.Render as Clay import qualified Clay.Stylesheet as Stylesheet -import Hero.Look.Typography as Typo import qualified Data.Map as Map import qualified Data.Text.Lazy as L -import Miso (Attribute, (=:), style_) -import Miso.String (MisoString, toMisoString) -import Protolude hiding ((**), (&), rem) +import Hero.Look.Typography as Typo +import Miso ((=:), Attribute, style_) +import Miso.String (MisoString, toMisoString) +import Protolude hiding ((&), (**), rem) main :: Css main = do @@ -28,41 +28,43 @@ main = do ".fixed" ? position fixed ".clickable" ? clickable ".row" ? do - display flex - alignItems center - justifyContent spaceBetween + display flex + alignItems center + justifyContent spaceBetween a <> a # hover <> a # visited ? do - color white - textDecoration none + color white + textDecoration none ".loading" ? do - display flex - justifyContent center - alignItems center - height $ vh 100 - width $ vw 100 + display flex + justifyContent center + alignItems center + height $ vh 100 + width $ vw 100 -- animations ".grow" ? do - transition "all" (sec 0.2) easeInOut (sec 0.2) - ":hover" & transform (scale 1.1 1.1) + transition "all" (sec 0.2) easeInOut (sec 0.2) + ":hover" & transform (scale 1.1 1.1) ".blur-out" ? do - position absolute - animation - "blur" - (sec 1) - easeInOut - (sec 1) - (iterationCount 1) - normal - forwards - keyframes "blur" [ (0, Clay.filter $ blur (px 0)) - , (50, Clay.filter $ blur (px 0)) - , (100, Clay.filter $ blur (px 10)) - ] + position absolute + animation + "blur" + (sec 1) + easeInOut + (sec 1) + (iterationCount 1) + normal + forwards + keyframes + "blur" + [ (0, Clay.filter $ blur (px 0)), + (50, Clay.filter $ blur (px 0)), + (100, Clay.filter $ blur (px 10)) + ] html <> body ? do - background nite - mobile $ do - overflowX hidden - width (vw 100) + background nite + mobile $ do + overflowX hidden + width (vw 100) -- general app wrapper stuf ".app" ? do display flex @@ -73,386 +75,376 @@ main = do "#hero-logo" ? zIndex (-1) "#app-head" <> "#app-body" <> "#app-foot" ? flexGrow 1 "#app-head" <> "#app-foot" ? do - display flex - alignItems center - flexShrink 0 - justifyContent spaceBetween - padding 0 (rem 2) 0 (rem 2) - width (pct 100) - height (px navbarHeight) - background nite - position fixed - zIndex 999 + display flex + alignItems center + flexShrink 0 + justifyContent spaceBetween + padding 0 (rem 2) 0 (rem 2) + width (pct 100) + height (px navbarHeight) + background nite + position fixed + zIndex 999 "#app-head" ? do - alignSelf flexStart - borderBottom solid (px 3) grai - wide - top (px 0) - mobile $ noBorder <> width (vw 100) + alignSelf flexStart + borderBottom solid (px 3) grai + wide + top (px 0) + mobile $ noBorder <> width (vw 100) "#app-body" ? do - display flex - desktop $ width (vw 93) - alignContent center - alignItems flexStart - justifyContent flexStart - flexDirection column - flexShrink 0 - padding (px 0) 0 0 0 - marginY $ px 74 - mobile $ flexDirection column + display flex + desktop $ width (vw 93) + alignContent center + alignItems flexStart + justifyContent flexStart + flexDirection column + flexShrink 0 + padding (px 0) 0 0 0 + marginY $ px 74 + mobile $ flexDirection column "#discover #app-body" ? do desktop $ marginLeft appmenuWidth "#app-head-right" ? do - display flex - justifyContent spaceBetween - textTransform Clay.uppercase - thicc - alignItems center - width (px 200) + display flex + justifyContent spaceBetween + textTransform Clay.uppercase + thicc + alignItems center + width (px 200) "#app-foot" ? do - alignSelf flexEnd - bottom (px 0) - mobile $ remove + alignSelf flexEnd + bottom (px 0) + mobile $ remove "#app-foot-social" ? do - display flex - flexDirection column - alignSelf flexStart - ".social-icon" ? padding 0 (px 20) (px 10) 0 + display flex + flexDirection column + alignSelf flexStart + ".social-icon" ? padding 0 (px 20) (px 10) 0 "#app-foot-logo" ? do - display flex - flexDirection column - alignItems flexEnd + display flex + flexDirection column + alignItems flexEnd "#app-foot-quote" ? do - textTransform Clay.uppercase - textAlign center - -- hide app-foot-quote when it gets crowded - query Clay.all [Media.maxDeviceWidth (px 800)] $ - hide - + textTransform Clay.uppercase + textAlign center + -- hide app-foot-quote when it gets crowded + query Clay.all [Media.maxDeviceWidth (px 800)] $ + hide -- login "#login" ? do - -- TODO: next 3 lines can be DRYed up, methinks - display flex - justifyContent center - alignItems center - alignSelf center - height (vh 100) + -- TODO: next 3 lines can be DRYed up, methinks + display flex + justifyContent center + alignItems center + alignSelf center + height (vh 100) "#login-inner" ? do - display flex - justifyContent center - alignItems center - flexDirection column - zIndex 1 - height (vh 100) - width (px 400) - mobile $ width (vw 90) + display flex + justifyContent center + alignItems center + flexDirection column + zIndex 1 + height (vh 100) + width (px 400) + mobile $ width (vw 90) "#login" ** ".help" ** a ? do - color white - display flex - alignItems center - flexDirection column + color white + display flex + alignItems center + flexDirection column "#login" ** form <> "#login" ** hr ? do - width (pct 100) + width (pct 100) "#login" ** hr ? border solid (px 1) grai "#login" ** ".button" ? do - marginTop (px 10) - display inlineBlock - border solid (px 2) white + marginTop (px 10) + display inlineBlock + border solid (px 2) white "#login" ** ".action" ? do - display flex - justifyContent spaceBetween - alignItems baseline - + display flex + justifyContent spaceBetween + alignItems baseline -- choose your experience "#choose-experience" ** "#app-body" ? do - euro <> wide - flexCenter - width (pct 100) - desktop $ marginLeft appmenuWidth <> height (vh 90) - mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) - h2 ? do - thicc <> wide <> smol <> lower <> coat 2 - textAlign center - mobile $ coat 0.8 - p ? do - thicc <> coat 0.8 <> textAlign center - maxWidth (px 900) - marginAll (rem 1) - mobile $ coat 0.6 - ul ? do - display flex - flexDirection row - flexWrap Flexbox.wrap - justifyContent spaceAround - li ? do - width (px 111) - position relative - display flex - flexDirection column - textAlign center - mobile $ coat 0.6 - coat 0.8 <> clickable - divv <? do - position relative - flexCenter - flexDirection column - span <? do - position absolute - width (pct 100) - smol <> thicc - - - + euro <> wide + flexCenter + width (pct 100) + desktop $ marginLeft appmenuWidth <> height (vh 90) + mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) + h2 ? do + thicc <> wide <> smol <> lower <> coat 2 + textAlign center + mobile $ coat 0.8 + p ? do + thicc <> coat 0.8 <> textAlign center + maxWidth (px 900) + marginAll (rem 1) + mobile $ coat 0.6 + ul ? do + display flex + flexDirection row + flexWrap Flexbox.wrap + justifyContent spaceAround + li ? do + width (px 111) + position relative + display flex + flexDirection column + textAlign center + mobile $ coat 0.6 + coat 0.8 <> clickable + divv <? do + position relative + flexCenter + flexDirection column + span <? do + position absolute + width (pct 100) + smol <> thicc -- comic player ".comic-player" ? marginAll auto ".comic-page" <> ".comic-page-full" ? do - width auto - marginAll auto - transform (scale 1 1) + width auto + marginAll auto + transform (scale 1 1) ".comic-page" ? height (vh 90) let ccb = ".comic-controls" ** button ccb <> ccb # hover ? do - background nite - borderColor nite - color white + background nite + borderColor nite + color white ".comic-controls-pages" ? do - justifyContent center - alignItems center - display flex + justifyContent center + alignItems center + display flex ".comic-video" |> iframe ? do - position absolute - height (pct 93) - width (pct 100) + position absolute + height (pct 93) + width (pct 100) "#close-button" ? do - euro <> wide - position fixed - cursor pointer - let z = rem 1.8 - fontSize z - lineHeight z - let m = 24 :: Double - top $ px $ navbarHeight + m - left $ px $ m - zIndex 999 - + euro <> wide + position fixed + cursor pointer + let z = rem 1.8 + fontSize z + lineHeight z + let m = 24 :: Double + top $ px $ navbarHeight + m + left $ px $ m + zIndex 999 -- zoom button and slider "#zoom-button" ? do - position relative - let sliderY = 75 - let sliderYY = 250 - euro <> wide - input ? do - transform $ Clay.rotate (deg (-90)) - margin 0 0 (px sliderYY) 0 - position absolute - height $ px sliderY - width $ px 200 - hide - label ? do - coat 0.9 - marginBottom $ px $ 2*sliderYY - position absolute - hide - ":hover" & ".ctrl" ? visibility visible - + position relative + let sliderY = 75 + let sliderYY = 250 + euro <> wide + input ? do + transform $ Clay.rotate (deg (-90)) + margin 0 0 (px sliderYY) 0 + position absolute + height $ px sliderY + width $ px 200 + hide + label ? do + coat 0.9 + marginBottom $ px $ 2 * sliderYY + position absolute + hide + ":hover" & ".ctrl" ? visibility visible -- discover "#discover" ? do - alignItems flexStart - flexDirection column + alignItems flexStart + flexDirection column ".media-info" ? do - padding (rem 2) 0 (rem 2) (rem 2) - margin (rem 2) 0 (rem 2) (rem 2) - borderTop solid (px 1) white - borderBottom solid (px 1) white - flexDirection row - display flex - alignItems center - justifyContent spaceBetween - mobile $ do - margin (rem 2) 0 (rem 2) 0 - padding 0 0 0 (rem 0) - noBorder - width (vw 100) - flexDirection column + padding (rem 2) 0 (rem 2) (rem 2) + margin (rem 2) 0 (rem 2) (rem 2) + borderTop solid (px 1) white + borderBottom solid (px 1) white + flexDirection row + display flex + alignItems center + justifyContent spaceBetween + mobile $ do + margin (rem 2) 0 (rem 2) 0 + padding 0 0 0 (rem 0) + noBorder + width (vw 100) + flexDirection column ".media-info-meta" ? do - Flexbox.flex 2 1 (px 0) - display flex - flexDirection row - divv # lastChild <? paddingLeft (rem 1) - mobile $ do - width (vw 90) -- this line can be commented if you want to center the meta - img ? width (px 150) - order (-1) - Flexbox.flex 1 1 (auto) + Flexbox.flex 2 1 (px 0) + display flex + flexDirection row + divv # lastChild <? paddingLeft (rem 1) + mobile $ do + width (vw 90) -- this line can be commented if you want to center the meta + img ? width (px 150) + order (-1) + Flexbox.flex 1 1 (auto) ".media-info-summary" ? do - Flexbox.flex 2 1 (px 0) - paddingRight (rem 3) - mobile $ do - marginAll (rem 1) - padding 0 0 0 (rem 0) + Flexbox.flex 2 1 (px 0) + paddingRight (rem 3) + mobile $ do + marginAll (rem 1) + padding 0 0 0 (rem 0) ".media-info-actions" ? do - Flexbox.flex 1 1 (px 132) - maxWidth (px 132) - display flex - flexDirection column - justifyContent spaceAround - mobile $ do - maxWidth (vw 100) - flexDirection row - order (1) - flexBasis auto -- initial - height (px 50) - + Flexbox.flex 1 1 (px 132) + maxWidth (px 132) + display flex + flexDirection column + justifyContent spaceAround + mobile $ do + maxWidth (vw 100) + flexDirection row + order (1) + flexBasis auto -- initial + height (px 50) -- appmenu "#appmenu" ? do - euro <> wide - fontVariant smallCaps - position fixed - height (pct 100) + euro <> wide + fontVariant smallCaps + position fixed + height (pct 100) + display flex + justifyContent center + zIndex 99 + alignContent center + alignItems center + flexDirection column + minWidth appmenuWidth + a ? do display flex + flexDirection column + color white + background nite + borderColor nite + a |> img ? do + width (px 22) + height (px 22) + desktop $ a |> span ? remove + mobile $ do + order 2 + flexDirection row + position fixed + bottom (px 0) + width (vw 100) + height (px 74) + background nite justifyContent center - zIndex 99 - alignContent center alignItems center - flexDirection column - minWidth appmenuWidth - a ? do - display flex - flexDirection column - color white - background nite - borderColor nite - a |> img ? do - width (px 22) - height (px 22) - desktop $ a |> span ? remove - mobile $ do - order 2 - flexDirection row - position fixed - bottom (px 0) - width (vw 100) - height (px 74) - background nite - justifyContent center - alignItems center - a |> span ? fontSize (rem 0.5) - - button ? margin (rem 0.5) 0 (rem 0.5) 0 - + a |> span ? fontSize (rem 0.5) + button ? margin (rem 0.5) 0 (rem 0.5) 0 -- feature "#featured-comic" ? do - display flex - flexDirection column - justifyContent center - Typo.euro - height (px 411) - mobile $ do - padding (px 0) 0 0 0 - margin 0 0 (px 50) 0 - after & do - display block - position relative - background $ linearGradient (straight sideTop) - [ (setA 0 nite, (pct 0)) - , (nite, (pct 100)) ] - let h = 149 - marginTop (px (-h)) - -- without +1, the gradient is offset by 1 px in chrome - height (px (h+1)) - content blank - ".hero-original" ? do - textTransform Clay.uppercase - fontSize (rem 1.2) - ".description" ? do - width (px 400) - mobile $ remove - "#featured-banner" ? do + display flex + flexDirection column + justifyContent center + Typo.euro + height (px 411) + mobile $ do + padding (px 0) 0 0 0 + margin 0 0 (px 50) 0 + after & do + display block position relative - minHeight (px 411) - minWidth (px 1214) - mobile $ marginLeft (px (-310)) + background $ + linearGradient + (straight sideTop) + [ (setA 0 nite, (pct 0)), + (nite, (pct 100)) + ] + let h = 149 + marginTop (px (- h)) + -- without +1, the gradient is offset by 1 px in chrome + height (px (h + 1)) + content blank + ".hero-original" ? do + textTransform Clay.uppercase + fontSize (rem 1.2) + ".description" ? do + width (px 400) + mobile $ remove + "#featured-banner" ? do + position relative + minHeight (px 411) + minWidth (px 1214) + mobile $ marginLeft (px (-310)) "#featured-content" ? do - position absolute - width (pct 100) - zIndex 9 - top (px 200) -- b/c Firefox & WebKit autocalc "top" differently - mobile $ do - marginTop (px 200) - alignItems center - display flex - flexDirection column - padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) - width (vw 100) - - + position absolute + width (pct 100) + zIndex 9 + top (px 200) -- b/c Firefox & WebKit autocalc "top" differently + mobile $ do + marginTop (px 200) + alignItems center + display flex + flexDirection column + padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) + width (vw 100) -- buttons - "a.wrs-button" ? do -- the "watch/read/save" button - flexCenter - height (px 36) - width (px 132) - border solid (px 2) white - rounded - color white - margin 0 (px 15) (rem 1) 0 - fontSize (rem 0.8) - fontVariant smallCaps - euro <> thicc <> wide - mobile $ do - height (px 26) - width (px 100) - margin 0 (px 5) 0 (px 5) - fontSize (rem 0.6) - let alive = backgroundColor hero <> borderColor hero <> color white - ":hover" & alive - ".saved" & alive - img ? do - marginRight (px 7) - height (px 15) - mobile $ height (px 10) - + "a.wrs-button" ? do + -- the "watch/read/save" button + flexCenter + height (px 36) + width (px 132) + border solid (px 2) white + rounded + color white + margin 0 (px 15) (rem 1) 0 + fontSize (rem 0.8) + fontVariant smallCaps + euro <> thicc <> wide + mobile $ do + height (px 26) + width (px 100) + margin 0 (px 5) 0 (px 5) + fontSize (rem 0.6) + let alive = backgroundColor hero <> borderColor hero <> color white + ":hover" & alive + ".saved" & alive + img ? do + marginRight (px 7) + height (px 15) + mobile $ height (px 10) -- ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left") - -- shelving ".shelf" ? do + display flex + flexDirection column + justifyContent flexStart + alignItems flexStart + mobile $ do + padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) + width (vw 100) + ".comic" ? do display flex flexDirection column - justifyContent flexStart - alignItems flexStart - mobile $ do - padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) - width (vw 100) - ".comic" ? do - display flex - flexDirection column - justifyContent center - textAlign center - euro - maxWidth (px 110) - img ? do - marginBottom (rem 0.5) - minHeight (px 170) - minWidth (px 110) + justifyContent center + textAlign center + euro + maxWidth (px 110) + img ? do + marginBottom (rem 0.5) + minHeight (px 170) + minWidth (px 110) ".shelf-head" ? do - width (pct 100) - margin (rem 1.5) 0 (rem 1.5) 0 - borderBottom solid (px 1) white - padding (rem 0.5) 0 0.5 0 - euro <> thicc + width (pct 100) + margin (rem 1.5) 0 (rem 1.5) 0 + borderBottom solid (px 1) white + padding (rem 0.5) 0 0.5 0 + euro <> thicc ".shelf-body" ? do - display flex - flexDirection row - justifyContent spaceBetween - width (vw 93) - alignItems baseline - li ? padding 0 (rem 0.5) 0 (rem 0.5) - overflowY visible - star ? overflowY visible - overflowX scroll - flexWrap Flexbox.nowrap - li <? do - margin 0 (rem 1) (rem 1) 0 - Flexbox.flex 0 0 auto + display flex + flexDirection row + justifyContent spaceBetween + width (vw 93) + alignItems baseline + li ? padding 0 (rem 0.5) 0 (rem 0.5) + overflowY visible + star ? overflowY visible + overflowX scroll + flexWrap Flexbox.nowrap + li <? do + margin 0 (rem 1) (rem 1) 0 + Flexbox.flex 0 0 auto navbarHeight :: Double navbarHeight = 74 @@ -484,11 +476,11 @@ appmenuWidth = (px 67) flexCenter :: Css flexCenter = do - display flex - justifyContent center - justifyItems center - alignContent center - alignItems center + display flex + justifyContent center + justifyItems center + alignContent center + alignItems center blank :: Content blank = stringContent "" @@ -511,10 +503,10 @@ clickable = cursor pointer -- heroic colors --------------------------------------------------------------- hero :: Color -hero = rgb 241 32 32 -- #f12020 +hero = rgb 241 32 32 -- #f12020 nite :: Color -nite = rgb 10 10 10 -- #0a0a0a +nite = rgb 10 10 10 -- #0a0a0a grai :: Color grai = rgb 221 221 221 -- #dddddd @@ -528,11 +520,11 @@ grai = rgb 221 221 221 -- #dddddd -- hacky, but works. css :: Clay.Css -> Attribute action css = Miso.style_ . Map.fromList . f . Clay.renderWith Clay.htmlInline [] - where - f :: L.Text -> [(MisoString, MisoString)] - f t = L.splitOn ";" t - <&> L.splitOn ":" - <&> \(x:y) -> (toMisoString x, toMisoString $ L.intercalate ":" y) + where + f :: L.Text -> [(MisoString, MisoString)] + f t = L.splitOn ";" t + <&> L.splitOn ":" + <&> \(x : y) -> (toMisoString x, toMisoString $ L.intercalate ":" y) inlineCss :: Css -> MisoString inlineCss = toMisoString . render @@ -558,10 +550,17 @@ uppercase = "text-transform" =: "uppercase" -- upstream this to Clay --------------------------------------------------------------------------------- - newtype JustifyItemsValue = JustifyItemsValue Value - deriving (Val, Other, Inherit, Center, FlexEnd - , FlexStart, SpaceAround, SpaceBetween) + deriving + ( Val, + Other, + Inherit, + Center, + FlexEnd, + FlexStart, + SpaceAround, + SpaceBetween + ) justifyItems :: JustifyItemsValue -> Css justifyItems = Stylesheet.key "justify-items" diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs index 4d4f976..6358ef3 100644 --- a/Hero/Look/Typography.hs +++ b/Hero/Look/Typography.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Hero.Look.Typography where -import Alpha -import Clay -import Clay.Stylesheet ( key ) -import qualified Hero.Assets as Assets -import Data.Semigroup ( (<>) ) +import Alpha +import Clay +import Clay.Stylesheet (key) +import Data.Semigroup ((<>)) +import qualified Hero.Assets as Assets main :: Css main = fonts @@ -15,25 +16,28 @@ main = fonts -- font modifiers euro, slim, wide, thicc, thinn, norm, lean, smol, lower, upper :: Css - euro = fontFamily ["Eurostile"] [sansSerif] -- | stretch slim = fontStretch condensed + wide = fontStretch expanded -- | weight thicc = fontWeight bold + thinn = fontWeight normal -- | style norm = fontStyle normal + lean = fontStyle italic -- | "smallcaps" is already taken by Clay smol = fontVariant smallCaps lower = textTransform lowercase + upper = textTransform uppercase -- | font sizing @@ -48,21 +52,21 @@ fontRoot = Assets.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" -- | font faces fonts :: Css fonts = - mconcat - $ mkEuro - </ [ ("-Reg.otf" , OpenType, fontWeight normal <> fontStyle normal) - , ("LTStd-Bold.otf" , OpenType, thicc <> norm) - , ("LTStd-Cn.otf" , OpenType, slim <> norm) - , ("LTStd-Ex2.otf" , OpenType, wide <> norm) - , ("LTStd-BoldCn.otf" , OpenType, slim <> thicc) - , ("LTStd-BoldEx2.otf", OpenType, wide <> thicc) - ] - where - mkEuro :: (Text, FontFaceFormat, Css) -> Css - mkEuro (sufx, fmt, extra) = fontFace $ do - fontFamily ["Eurostile"] [] - fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt] - extra + mconcat $ + mkEuro + </ [ ("-Reg.otf", OpenType, fontWeight normal <> fontStyle normal), + ("LTStd-Bold.otf", OpenType, thicc <> norm), + ("LTStd-Cn.otf", OpenType, slim <> norm), + ("LTStd-Ex2.otf", OpenType, wide <> norm), + ("LTStd-BoldCn.otf", OpenType, slim <> thicc), + ("LTStd-BoldEx2.otf", OpenType, wide <> thicc) + ] + where + mkEuro :: (Text, FontFaceFormat, Css) -> Css + mkEuro (sufx, fmt, extra) = fontFace $ do + fontFamily ["Eurostile"] [] + fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt] + extra -- TODO: add the below to Clay.Font upstream diff --git a/Hero/Server.hs b/Hero/Server.hs index 730aada..450bd0d 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + -- | Hero web app -- -- : exe mmc @@ -40,56 +41,59 @@ module Hero.Server where import qualified Clay -import Hero.App -import qualified Hero.Assets as Assets +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.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 - +import qualified Hero.Look as Look +import qualified Hero.Look.Typography as Typography +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) + 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 + { -- | HERO_PORT + heroPort :: Warp.Port, + -- | HERO_CLIENT + heroClient :: FilePath + } + deriving (Generic, Show) instance Envy.DefConfig Config where defConfig = Config 3000 "_bild/Hero.Client/static" @@ -97,17 +101,18 @@ instance Envy.DefConfig Config where 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 - +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 @@ -120,9 +125,10 @@ type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] type CssRoute = "css" :> "main.css" :> Get '[CSS] Text -newtype CSS = CSS - { unCSS :: Text - } +newtype CSS + = CSS + { unCSS :: Text + } instance Accept CSS where contentType _ = "text" // "css" /: ("charset", "utf-8") @@ -134,38 +140,37 @@ 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) +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" - } +heroManifest = + Manifest + { name = "Hero", + short_name = "Hero", + start_url = ".", + display = "standalone", + theme_color = "#0a0a0a", + description = "Comics for all" + } handle404 :: Application handle404 _ respond = @@ -186,44 +191,42 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where 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.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.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.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.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.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"] @@ -236,16 +239,18 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where 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] + 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" |