summaryrefslogtreecommitdiff
path: root/Hero
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2020-04-15 09:54:10 -0700
committerBen Sima <ben@bsima.me>2020-04-15 10:06:56 -0700
commitf4b8c0df041b063c0b47d2ec6c818a9c202fd833 (patch)
tree01ad246a83fda29c079847b3397ca6509a7f6106 /Hero
parent6ed475ca94209ce92e75f48764cb9d361029ea26 (diff)
Re-namespacing
Moving away from the DNS-driven namespacing toward more condensed names, mostly because I don't like typing so much.
Diffstat (limited to 'Hero')
-rw-r--r--Hero/App.hs748
-rw-r--r--Hero/Assets.hs15
-rw-r--r--Hero/Client.hs188
-rw-r--r--Hero/Database.hs41
-rw-r--r--Hero/Look.hs567
-rw-r--r--Hero/Look/Typography.hs79
-rw-r--r--Hero/Prod.nix43
-rw-r--r--Hero/Server.hs302
-rw-r--r--Hero/Service.nix76
9 files changed, 2059 insertions, 0 deletions
diff --git a/Hero/App.hs b/Hero/App.hs
new file mode 100644
index 0000000..7f55052
--- /dev/null
+++ b/Hero/App.hs
@@ -0,0 +1,748 @@
+{-# 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 Hero.App where
+
+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 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 -> [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
+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 "© Hero Records, Inc. All Rights Reserved" ]
+ ]
+ ]
+ where
+ attrs Nothing = [ class_ "social-icon" ]
+ attrs (Just lnk) = [ class_ "social-icon", href_ lnk, target_ "_blank" ]
+ smallImg x lnk = a_ (attrs lnk)
+ [ img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x ]]
+
+comicCover :: ComicId -> Model -> View Action
+comicCover comicId_ 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 -> loading
+ Loading -> loading
+ Failure _ -> nocomics
+ Success comics -> case cpState model of
+ NotReading -> template "comic-player" [ text "error: not reading" ]
+ Cover id -> viewOr404 comics comicSpread id 1 model
+ ChooseExperience id pg ->
+ viewOr404 comics chooseExperiencePage id pg model
+ Reading Spread id pg -> viewOr404 comics comicSpread id pg model
+ Reading Full id pg -> viewOr404 comics zoomScreen id pg model
+ Watching id -> viewOr404 comics comicVideo id 0 model
+
+viewOr404 :: [Comic]
+ -> (Comic -> Page -> Model -> View Action)
+ -> ComicId -> Page -> Model -> View Action
+viewOr404 comics f id pg model =
+ case findComic id comics of
+ Just c -> f c pg model
+ Nothing -> the404 model
+
+template :: MisoString -> [View Action] -> View Action
+template id 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
diff --git a/Hero/Assets.hs b/Hero/Assets.hs
new file mode 100644
index 0000000..06386b8
--- /dev/null
+++ b/Hero/Assets.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- | A module to wrap the CDN and provide convient helper functions to assets.
+module Hero.Assets where
+
+import Protolude
+
+cdnEdge :: Text
+cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com"
+
+demo :: Text
+demo = cdnEdge <> "/old-assets/demo/"
+
+icon :: Text
+icon = cdnEdge <> "/icons/"
diff --git a/Hero/Client.hs b/Hero/Client.hs
new file mode 100644
index 0000000..9a8fa02
--- /dev/null
+++ b/Hero/Client.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- | Hero app frontend
+--
+-- : exe mmc.js
+--
+-- : dep aeson
+-- : dep clay
+-- : dep containers
+-- : dep miso
+-- : dep protolude
+-- : dep servant
+-- : dep split
+-- : dep string-quote
+-- : dep text
+-- : 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 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 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
+
+-- | Entry point for a miso application
+main :: IO ()
+main = miso $ \currentURI -> App { model = initModel currentURI, .. }
+ where
+ update = move
+ view = see
+ subs = [ uriSub HandleURI
+ , keyboardSub keynav
+ ]
+ events = defaultEvents
+ initialAction = FetchComics
+ mountPoint = Nothing
+
+(∈) :: Ord a => a -> Set a -> Bool
+(∈) = Set.member
+
+-- | 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
+
+see :: Model -> View Action
+see model =
+ case runRoute routes handlers uri model of
+ Left _ -> the404 model
+ Right v -> v
+
+-- | Console-logging
+foreign import javascript unsafe "console.log($1);"
+ say :: MisoString -> IO ()
+
+-- | Updates model, optionally introduces side effects
+move :: Action -> Model -> Effect Action 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
+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
+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
+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
+ 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
+move (ScrollIntoView id) model = model <# do
+ 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 ->
+ 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
+ }
diff --git a/Hero/Database.hs b/Hero/Database.hs
new file mode 100644
index 0000000..5726f3c
--- /dev/null
+++ b/Hero/Database.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hero.Database
+ ( 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 )
+
+type ComicDB = (Map ComicId Comic)
+
+instance Interpret Comic
+
+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"
+ }
+ ]
+
+listToComicDB :: [Comic] -> ComicDB
+listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls
+
+getComics :: ComicDB -> Handler [Comic]
+getComics db = return $ Map.elems db
diff --git a/Hero/Look.hs b/Hero/Look.hs
new file mode 100644
index 0000000..109ea76
--- /dev/null
+++ b/Hero/Look.hs
@@ -0,0 +1,567 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Styles
+--
+-- Eventually move make this mostly well-typed. Use this EDSL:
+-- http://fvisser.nl/clay/
+module Hero.Look where
+
+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)
+
+main :: Css
+main = do
+ -- bulma adjustments
+ input ? marginRight (px 10) <> marginBottom (px 10)
+ -- base
+ ".fixed" ? position fixed
+ ".clickable" ? clickable
+ ".row" ? do
+ display flex
+ alignItems center
+ justifyContent spaceBetween
+ a <> a # hover <> a # visited ? do
+ color white
+ textDecoration none
+ ".loading" ? do
+ 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)
+ ".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))
+ ]
+ html <> body ? do
+ background nite
+ mobile $ do
+ overflowX hidden
+ width (vw 100)
+ -- general app wrapper stuf
+ ".app" ? do
+ display flex
+ justifyContent spaceBetween
+ alignItems stretch
+ flexDirection column
+ color white
+ "#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
+ "#app-head" ? do
+ 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
+ "#discover #app-body" ? do desktop $ marginLeft appmenuWidth
+ "#app-head-right" ? do
+ display flex
+ justifyContent spaceBetween
+ textTransform Clay.uppercase
+ thicc
+ alignItems center
+ width (px 200)
+ "#app-foot" ? do
+ 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
+ "#app-foot-logo" ? do
+ 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
+
+ -- login
+ "#login" ? do
+ -- 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)
+ "#login" ** ".help" ** a ? do
+ color white
+ display flex
+ alignItems center
+ flexDirection column
+ "#login" ** form <> "#login" ** hr ? do
+ width (pct 100)
+ "#login" ** hr ? border solid (px 1) grai
+ "#login" ** ".button" ? do
+ marginTop (px 10)
+ display inlineBlock
+ border solid (px 2) white
+ "#login" ** ".action" ? do
+ 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
+
+
+
+ -- comic player
+ ".comic-player" ? marginAll auto
+ ".comic-page" <> ".comic-page-full" ? do
+ 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
+ ".comic-controls-pages" ? do
+ justifyContent center
+ alignItems center
+ display flex
+ ".comic-video" |> iframe ? do
+ 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
+
+ -- 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
+
+ -- discover
+ "#discover" ? do
+ 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
+ ".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)
+ ".media-info-summary" ? do
+ 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)
+
+ -- appmenu
+ "#appmenu" ? do
+ 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
+ alignItems center
+ 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
+ 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)
+
+
+ -- 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)
+
+ --
+ ".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 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
+ ".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
+
+navbarHeight :: Double
+navbarHeight = 74
+
+---------------------------------------------------------------------------------
+-- utilities
+---------------------------------------------------------------------------------
+
+hide :: Css
+hide = visibility hidden
+
+remove :: Css
+remove = display none
+
+noBorder :: Css
+noBorder = border none 0 transparent
+
+mobile :: Css -> Css
+mobile = query Clay.all [Media.maxDeviceWidth (px 500)]
+
+desktop :: Css -> Css
+desktop = query Clay.all [Media.minDeviceWidth (px 500)]
+
+rounded :: Css
+rounded = borderRadius (px 30) (px 30) (px 30) (px 30)
+
+appmenuWidth :: Size LengthUnit
+appmenuWidth = (px 67)
+
+flexCenter :: Css
+flexCenter = do
+ display flex
+ justifyContent center
+ justifyItems center
+ alignContent center
+ alignItems center
+
+blank :: Content
+blank = stringContent ""
+
+divv :: Clay.Selector
+divv = Clay.div
+
+marginAll :: Size a -> Css
+marginAll x = margin x x x x
+
+marginX :: Size a -> Css
+marginX n = marginLeft n <> marginRight n
+
+marginY :: Size a -> Css
+marginY n = marginTop n <> marginBottom n
+
+clickable :: Css
+clickable = cursor pointer
+
+-- heroic colors ---------------------------------------------------------------
+
+hero :: Color
+hero = rgb 241 32 32 -- #f12020
+
+nite :: Color
+nite = rgb 10 10 10 -- #0a0a0a
+
+grai :: Color
+grai = rgb 221 221 221 -- #dddddd
+
+-- runtime (client) style stuff ------------------------------------------------
+
+-- | Put 'Clay.Css' into a Miso-compatible style property.
+--
+-- Allows us to use any amount of CSS written with Clay inlined in HTML or
+-- dynamically as JavaScript object properties. The implementation is a bit
+-- 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)
+
+inlineCss :: Css -> MisoString
+inlineCss = toMisoString . render
+
+type Style = Map MisoString MisoString
+
+red :: MisoString
+red = "#f12020"
+
+bold :: Style
+bold = "font-weight" =: "bold"
+
+condensed :: Style
+condensed = "font-stretch" =: "condensed"
+
+expanded :: Style
+expanded = "font-stretch" =: "expanded"
+
+uppercase :: Style
+uppercase = "text-transform" =: "uppercase"
+
+---------------------------------------------------------------------------------
+-- upstream this to Clay
+---------------------------------------------------------------------------------
+
+
+newtype JustifyItemsValue = JustifyItemsValue Value
+ 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
new file mode 100644
index 0000000..4d4f976
--- /dev/null
+++ b/Hero/Look/Typography.hs
@@ -0,0 +1,79 @@
+{-# 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 ( (<>) )
+
+main :: Css
+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
+
+-- | apparently "coat" is a synonym for "size"
+coat :: Double -> Css
+coat = fontSize . Clay.rem
+
+fontRoot :: Text
+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
+
+-- TODO: add the below to Clay.Font upstream
+
+newtype FontStretch = FontStretch Value
+ deriving (Val, Inherit, Normal, Other)
+
+expanded :: FontStretch
+expanded = FontStretch "expanded"
+
+condensed :: FontStretch
+condensed = FontStretch "condensed"
+
+fontStretch :: FontStretch -> Css
+fontStretch = key "font-stretch"
diff --git a/Hero/Prod.nix b/Hero/Prod.nix
new file mode 100644
index 0000000..10650ee
--- /dev/null
+++ b/Hero/Prod.nix
@@ -0,0 +1,43 @@
+{ config, pkgs, lib, ... }:
+{
+ imports = [ <nixpkgs/nixos/modules/profiles/qemu-guest.nix> ];
+ boot.loader.grub.device = "/dev/vda";
+ fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; };
+
+ services.herocomics = {
+ enable = true;
+ port = 3000;
+ server = pkgs.herocomics-server;
+ client = pkgs.herocomics-client;
+ };
+
+ networking = {
+ firewall.allowedTCPPorts = [ 22 80 443 ];
+ nameservers = [
+ "67.207.67.2"
+ "67.207.67.3"
+ ];
+ defaultGateway = "138.68.40.1";
+ defaultGateway6 = "";
+ dhcpcd.enable = false;
+ usePredictableInterfaceNames = lib.mkForce true;
+ interfaces = {
+ eth0 = {
+ ipv4.addresses = [
+ { address="138.68.40.97"; prefixLength=21; }
+ { address="10.46.0.5"; prefixLength=16; }
+ ];
+ ipv6.addresses = [
+ { address="fe80::b063:c4ff:fee5:d636"; prefixLength=64; }
+ ];
+ ipv4.routes = [ { address = "138.68.40.1"; prefixLength = 32; } ];
+ ipv6.routes = [ { address = ""; prefixLength = 32; } ];
+ };
+
+ };
+ };
+ services.udev.extraRules = ''
+ ATTR{address}=="b2:63:c4:e5:d6:36", NAME="eth0"
+
+ '';
+}
diff --git a/Hero/Server.hs b/Hero/Server.hs
new file mode 100644
index 0000000..730aada
--- /dev/null
+++ b/Hero/Server.hs
@@ -0,0 +1,302 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- | Hero web app
+--
+-- : exe mmc
+--
+-- : dep aeson
+-- : dep clay
+-- : dep containers
+-- : dep dhall
+-- : dep envy
+-- : dep http-types
+-- : dep lucid
+-- : dep miso
+-- : dep mtl
+-- : dep network-uri
+-- : dep protolude
+-- : dep servant
+-- : dep servant-lucid
+-- : dep servant-server
+-- : dep split
+-- : dep split
+-- : dep string-quote
+-- : dep text
+-- : dep wai
+-- : dep wai-app-static
+-- : dep wai-extra
+-- : dep wai-middleware-metrics
+-- : dep warp
+module Hero.Server where
+
+import qualified Clay
+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
+
+
+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)
+
+instance Envy.DefConfig Config where
+ defConfig = Config 3000 "_bild/Hero.Client/static"
+
+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
+
+
+-- | HtmlPage for setting HTML doctype and header
+newtype HtmlPage a = HtmlPage a
+ deriving (Show, Eq)
+
+-- | Convert client side routes into server-side web handlers
+type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action
+
+type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
+
+type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
+
+newtype CSS = CSS
+ { unCSS :: Text
+ }
+
+instance Accept CSS where
+ contentType _ = "text" // "css" /: ("charset", "utf-8")
+
+instance MimeRender CSS Text where
+ mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
+
+cssHandlers :: Server CssRoute
+cssHandlers =
+ return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
+
+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"
+ }
+
+handle404 :: Application
+handle404 _ respond =
+ respond
+ $ responseLBS status404 [("Content-Type", "text/html")]
+ $ renderBS
+ $ toHtml
+ $ HtmlPage
+ $ the404
+ $ initModel homeLink
+
+instance L.ToHtml a => L.ToHtml (HtmlPage a) where
+ toHtmlRaw = L.toHtml
+ toHtml (HtmlPage x) = do
+ L.doctype_
+ L.html_ [L.lang_ "en"] $ do
+ L.head_ $ do
+ 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.link_
+ [ 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.link_
+ [ 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.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"]
+ L.meta_
+ [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"]
+ cssRef animateRef
+ cssRef bulmaRef
+ cssRef fontAwesomeRef
+ cssRef "/css/main.css" -- TODO: make this a safeLink?
+ 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]
+
+fontAwesomeRef :: MisoString
+fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
+
+animateRef :: MisoString
+animateRef =
+ "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css"
+
+bulmaRef :: MisoString
+bulmaRef =
+ "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"
+
+serverHandlers :: Server ServerRoutes
+serverHandlers =
+ homeHandler
+ :<|> comicCoverHandler
+ :<|> comicPageHandler
+ :<|> comicPageFullHandler
+ :<|> comicVideoHandler
+ :<|> loginHandler
+ :<|> discoverHandler
+ :<|> chooseExperienceHandler
+
+jsonHandlers :: Database.ComicDB -> Server JsonApi
+jsonHandlers db = Database.getComics db
+
+homeHandler :: Handler (HtmlPage (View Action))
+homeHandler = pure . HtmlPage . home $ initModel homeLink
+
+comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action))
+comicCoverHandler id =
+ pure . HtmlPage . comicCover id . initModel $ comicLink id
+
+comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n
+
+comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageFullHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n
+
+comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicVideoHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n
+
+loginHandler :: Handler (HtmlPage (View Action))
+loginHandler = pure . HtmlPage . login $ initModel loginLink
+
+discoverHandler :: Handler (HtmlPage (View Action))
+discoverHandler = pure . HtmlPage . discover $ initModel discoverLink
+
+chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+chooseExperienceHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n
diff --git a/Hero/Service.nix b/Hero/Service.nix
new file mode 100644
index 0000000..f0f4227
--- /dev/null
+++ b/Hero/Service.nix
@@ -0,0 +1,76 @@
+{ options
+, lib
+, config
+, pkgs
+, modulesPath
+}:
+
+let
+ cfg = config.services.herocomics;
+in
+{
+ options.services.herocomics = {
+ enable = lib.mkEnableOption "Enable the herocomics service";
+ port = lib.mkOption {
+ type = lib.types.int;
+ default = 3000;
+ description = ''
+ The port on which herocomics-server will listen for incoming HTTP traffic.
+ '';
+ };
+ server = lib.mkOption {
+ type = lib.types.package;
+ description = "herocomics-server package to use";
+ };
+ client = lib.mkOption {
+ type = lib.types.package;
+ description = "herocomics-client package to use";
+ };
+ domain = lib.mkOption {
+ type = lib.types.str;
+ default = "herocomics.app";
+ description = ''
+ Domain on which to bind herocomics-server. This is passed
+ to services.nginx.virtualHosts.<name> directly.
+ '';
+ };
+ };
+ config = lib.mkIf cfg.enable {
+ systemd.services.herocomics = {
+ path = [ cfg.server ];
+ wantedBy = [ "multi-user.target" ];
+ script = ''
+ ${cfg.server}/bin/mmc
+ '';
+ description = ''
+ Hero Comics app server
+ '';
+ serviceConfig = {
+ KillSignal = "INT";
+ Environment = [
+ "HERO_CLIENT=${cfg.client}/static"
+ "HERO_PORT=${toString cfg.port}"
+ ];
+ Type = "simple";
+ Restart = "on-abort";
+ RestartSec = "1";
+ };
+ };
+ services.nginx = {
+ enable = cfg.enable;
+ recommendedGzipSettings = true;
+ recommendedOptimisation = true;
+ recommendedProxySettings = true;
+ recommendedTlsSettings = true;
+ virtualHosts = {
+ "${cfg.domain}" = {
+ forceSSL = true;
+ enableACME = true;
+ locations."/" = {
+ proxyPass = "http://localhost:${toString cfg.port}";
+ };
+ };
+ };
+ };
+ };
+}