From ddc9b826bdc568004451fb14b458476e4c7e5061 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sun, 19 Jul 2020 21:21:03 -0700 Subject: hero: rename stuff to new structure Working toward https://github.com/bsima/biz/issues/5 --- Hero/App.hs | 939 ------------------------------------------------------- Hero/Client.hs | 248 --------------- Hero/Core.hs | 939 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Hero/Host.hs | 396 +++++++++++++++++++++++ Hero/Keep.hs | 2 +- Hero/Node.hs | 248 +++++++++++++++ Hero/Server.hs | 396 ----------------------- Hero/Service.nix | 6 +- 8 files changed, 1587 insertions(+), 1587 deletions(-) delete mode 100644 Hero/App.hs delete mode 100644 Hero/Client.hs create mode 100644 Hero/Core.hs create mode 100644 Hero/Host.hs create mode 100644 Hero/Node.hs delete mode 100644 Hero/Server.hs (limited to 'Hero') diff --git a/Hero/App.hs b/Hero/App.hs deleted file mode 100644 index 6f7a8c4..0000000 --- a/Hero/App.hs +++ /dev/null @@ -1,939 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module Hero.App where - -import Alpha -import qualified Clay -import Data.Aeson - ( FromJSON (..), - ToJSON (..), - defaultOptions, - genericParseJSON, - genericToJSON, - ) -import Data.Data (Data, Typeable) -import qualified Data.List as List -import qualified Data.List.Split as List -import Data.Proxy (Proxy (..)) -import Data.String -import Data.String.Quote -import Data.Text (Text, replace, toLower) -import GHC.Generics (Generic) -import qualified GHC.Show as Legacy -import qualified Hero.Assets as Assets -import Hero.Look as Look -import Hero.Look.Typography -import Miso -import qualified Miso (for_) -import Miso.Extend -import Miso.String -import Network.RemoteData -import Servant.API - ( (:<|>) (..), - (:>), - ) -import qualified Servant.API as Api -import Servant.Links (linkURI) - --- | The css id for controling music in the comic player. -audioId :: MisoString -audioId = "audioSource" - --- TODO: make ComicId a hashid --- https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html -newtype ComicId - = ComicId String - deriving - ( Show, - Eq, - Ord, - Data, - Typeable, - Generic, - ToMisoString, - IsString, - Api.ToHttpApiData, - Api.FromHttpApiData - ) - -instance ToJSON ComicId where - toJSON = genericToJSON Data.Aeson.defaultOptions - -instance FromJSON ComicId where - parseJSON = genericParseJSON Data.Aeson.defaultOptions - --- | Used for looking up images on S3, mostly -comicSlug :: Comic -> Text -comicSlug Comic {..} = snake comicName <> "-" <> comicIssue - --- * user - -data User - = User - { userEmail :: Text, - userName :: Text, - userLibrary :: [Comic] - } - deriving (Show, Eq, Generic, Data, Ord) - -instance Semigroup User where - a <> b = - User - (userEmail a <> userEmail b) - (userName a <> userName b) - (userLibrary a <> userLibrary b) - -instance Monoid User where - mempty = User mempty mempty mempty - -instance ToJSON User where - toJSON = genericToJSON Data.Aeson.defaultOptions - -instance FromJSON User 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 -> User -> View Action - - -- | Media info view - info :: o -> User -> View Action - --- | How much to Zoom the comic image -type Magnification = Int - --- | All the buttons. -data Button - = Watch Comic - | Read Comic - | Save Comic User - | SaveIcon Comic User - | ZoomIcon Magnification 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 u) = - if c `elem` (userLibrary u) -- in library - then - a_ - [class_ "wrs-button saved", onClick $ ToggleInLibrary c] - [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], - span_ [] [text "saved"] - ] - else-- not in library - - a_ - [class_ "wrs-button", onClick $ ToggleInLibrary c] - [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], - span_ [] [text "save"] - ] - el (SaveIcon c u) = - if c `elem` (userLibrary u) -- in library - then - button_ - [ class_ "button is-large has-background-black", - onClick $ ToggleInLibrary c - ] - [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] - else-- not in library - - button_ - [ class_ "button is-large has-background-black-bis", - onClick $ ToggleInLibrary c - ] - [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] - el (ZoomIcon zmodel comic page) = - button_ - [ id_ "zoom-button", - class_ "button is-large", - onClick $ ToggleZoom comic page - ] - [ img_ [src_ $ ms $ Assets.demo <> "zoom.png"], - input_ - [ type_ "range", - min_ "0", - max_ "100", - disabled_ True, - value_ $ ms (show zmodel :: String), - class_ "ctrl", - id_ "zoom" - ], - label_ - [class_ "ctrl", Miso.for_ "zoom"] - [text $ ms $ (show zmodel :: String) ++ "%"] - ] - el (Read c) = - a_ - [class_ "wrs-button", onClick $ SelectExperience c] - [ img_ [src_ $ ms $ Assets.icon <> "read.svg"], - span_ [] [text "read"] - ] - el (Watch c) = - a_ - [class_ "wrs-button", onClick $ StartWatching c] - [ img_ [src_ $ ms $ Assets.icon <> "watch.svg"], - span_ [] [text "watch"] - ] - -data AudioState = Playing | Paused - deriving (Show, Eq) - -data ComicReaderState - = NotReading - | Cover ComicId - | ChooseExperience ComicId Page - | Reading ComicReaderView ComicId Page - | Watching ComicId - deriving (Show, Eq) - -findComic :: ComicId -> [Comic] -> Maybe Comic -findComic id = List.find (\c -> comicId c == id) - --- | Main model for the app. --- --- Try to prefix component-specific state with the component initials: 'd' for --- discover, 'cp' for comic player. -data Model - = Model - { uri :: Api.URI, - appComics :: RemoteData MisoString [Comic], - user :: User, - dMediaInfo :: Maybe Comic, - cpState :: ComicReaderState, - cpAudioState :: AudioState, - magnification :: Magnification - } - deriving (Show, Eq) - -initModel :: Api.URI -> Model -initModel uri_ = - Model - { uri = uri_, - appComics = NotAsked, - dMediaInfo = Nothing, - user = mempty, - cpState = detectPlayerState uri_, - cpAudioState = Paused, - magnification = 100 - } - --- | Hacky way to initialize the 'ComicReaderState' from the Api.URI. -detectPlayerState :: Api.URI -> ComicReaderState -detectPlayerState u = case List.splitOn "/" $ Api.uriPath u of - ["", "comic", id, pg, "experience"] -> ChooseExperience (ComicId id) (toPage pg) - ["", "comic", id, _, "video"] -> Watching $ ComicId id - ["", "comic", id, pg, "full"] -> Reading Full (ComicId id) (toPage pg) - ["", "comic", id, pg] -> Reading Spread (ComicId id) (toPage pg) - ["", "comic", id] -> Cover $ ComicId 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 - | -- login - ValidateUserPassword - | -- app stuff - ScrollIntoView MisoString - | HandleURI Api.URI - | ChangeURI Api.URI - | DumpModel - deriving (Show, Eq) - -type AppRoutes = - ComicCover - :<|> ComicReaderSpread - :<|> ComicReaderFull - :<|> ComicVideo - :<|> Discover - :<|> ChooseExperience - -handlers = - comicCover - :<|> comicReader - :<|> comicReader - :<|> comicReader - :<|> discover - :<|> comicReader - -routes :: Proxy AppRoutes -routes = Proxy - -type PubRoutes = - Home - :<|> Login - -pubRoutes :: Proxy PubRoutes -pubRoutes = Proxy - --- * pages --- --- TODO: consider making a typeclass, something like: --- --- class Page name where --- type Route name :: View Action --- proxy :: Proxy name --- proxy = Proxy name --- view :: Model -> View Action --- link :: Api.URI - --- * home --- --- this is the unauthenticated page that you see when you first visit - -type Home = - View Action - -homeProxy :: Proxy Home -homeProxy = Proxy - -homeLink :: Api.URI -homeLink = linkURI $ Api.safeLink front homeProxy - where - front = Proxy :: Proxy Home - -home :: Model -> View Action -home = login - --- * login - -data LoginForm = LoginForm {loginEmail :: String, loginPass :: String} - deriving (Eq, Show, Read, Generic) - -instance ToJSON LoginForm - -instance FromJSON LoginForm - -type Login = - "login" :> View Action - -loginProxy :: Proxy Login -loginProxy = Proxy - -loginLink :: Api.URI -loginLink = linkURI $ Api.safeLink pubRoutes loginProxy - -login :: Model -> View Action -login _ = - template - "login" - [ div_ - [id_ "login-inner"] - [ img_ - [ class_ fadeIn, - src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" - ], - hr_ [class_ fadeIn], - form_ - [class_ fadeIn] - [ ctrl [id_ "user", class_ "input", type_ "email", placeholder_ "Email"], - ctrl [id_ "pass", 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 ValidateUserPassword] - [text "Login"] - ] - ], - hr_ [class_ fadeIn], - p_ - [class_ $ "help " <> fadeIn] - [ a_ [href_ "#"] [text "Forgot your username or password?"], - a_ [href_ "#"] [text "Don't have an account? Sign Up"] - ], - img_ - [ id_ "hero-logo", - class_ "blur-out", - src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" - ] - ] - ] - where - fadeIn = "animated fadeIn delay-2s" - ctrl x = div_ [class_ "control"] [input_ x] - --- * discover - -type Discover = "discover" :> View Action - -discoverLink :: Api.URI -discoverLink = linkURI $ Api.safeLink routes discoverProxy - -discoverProxy :: Proxy Discover -discoverProxy = Proxy - -discover :: Model -> View Action -discover model@Model {user = u} = - template - "discover" - [ topbar, - main_ [id_ "app-body"] $ case appComics model of - NotAsked -> [loading] - Loading -> [loading] - Failure _ -> [nocomics] - Success [] -> [nocomics] - Success (comic : rest) -> - [ feature comic u, - shelf "Recent Releases" (comic : rest), - maybeView (`info` u) $ dMediaInfo model - ], - appmenu, - discoverFooter - ] - -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]] - --- * comic - -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, Data, Ord) - -instance ToJSON Comic where - toJSON = genericToJSON Data.Aeson.defaultOptions - -instance FromJSON Comic where - parseJSON = genericParseJSON Data.Aeson.defaultOptions - -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 ComicCover = - "comic" - :> Api.Capture "comicId" ComicId - :> View Action - -comicProxy :: Proxy ComicCover -comicProxy = Proxy - -comicCover :: ComicId -> Model -> View Action -comicCover comicId_ = comicReader comicId_ 1 - -comicLink :: ComicId -> Api.URI -comicLink comicId_ = linkURI $ Api.safeLink routes comicProxy comicId_ - --- * chooseExperience - -type ChooseExperience = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" Page - :> "experience" - :> View Action - -chooseExperienceProxy :: Proxy ChooseExperience -chooseExperienceProxy = Proxy - -chooseExperienceLink :: ComicId -> Page -> Api.URI -chooseExperienceLink id page = - linkURI $ Api.safeLink routes chooseExperienceProxy id page - -chooseExperiencePage :: Comic -> Page -> Model -> View Action -chooseExperiencePage comic page model = - template - "choose-experience" - [ topbar, - main_ - [id_ "app-body"] - [ h2_ [] [text "Choose Your Musical Experience"], - p_ [] [text experienceBlurb], - ul_ [] $ li comic name <> ".png"], - span_ [] [text $ ms name] - ], - span_ [css thicc] [text $ ms artist], - span_ [] [text $ ms track] - ] - experiences :: [(Text, Text, Text)] - experiences = - [ ("comedic", "RxGF", "Soft Reveal"), - ("dark", "Logan Henderson", "Speak of the Devil"), - ("original", "Mehcad Brooks", "Stars"), - ("energetic", "Skela", "What's wrong with me"), - ("dramatic", "Josh Jacobson", "Sideline") - ] - -experienceBlurb :: MisoString -experienceBlurb = - [s| -As you enter the world of Hero, you will find that music and visual art have a -symbiotic relationship that can only be experienced, not described. Here, choose -the tonality of the experience you wish to adventure on, whether it's a comedic, -dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey -with the original curated music for this piece of visual art. -|] - --- * comicReader - -data ComicReaderView = Spread | Full - deriving (Show, Eq) - -comicReader :: ComicId -> Page -> Model -> View Action -comicReader _ _ 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 - -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" - --- * comicReaderSpread - -type ComicReaderSpread = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" Page - :> View Action - -comicReaderSpreadProxy :: Proxy ComicReaderSpread -comicReaderSpreadProxy = Proxy - -comicReaderSpreadLink :: ComicId -> Page -> Api.URI -comicReaderSpreadLink id page = - linkURI $ Api.safeLink routes comicReaderSpreadProxy id page - -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" - -closeButton :: View Action -closeButton = - a_ - [id_ "close-button", onClick $ ChangeURI discoverLink] - [text "x"] - --- * comicReaderFull - -type ComicReaderFull = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" Page - :> "full" - :> View Action - -comicReaderFullProxy :: Proxy ComicReaderFull -comicReaderFullProxy = Proxy - -comicReaderFullLink :: ComicId -> Page -> Api.URI -comicReaderFullLink id page = - linkURI $ Api.safeLink routes comicReaderFullProxy id page - --- * comicVideo - -type ComicVideo = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" Page - :> "video" - :> View Action - -comicVideoProxy :: Proxy ComicVideo -comicVideoProxy = Proxy - -comicVideoLink :: ComicId -> Page -> Api.URI -comicVideoLink id page = - linkURI $ Api.safeLink routes comicVideoProxy id page - -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 - ] - [] - ] - ] - ] - --- * general page components & utils - --- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' -maybeView :: (a -> View action) -> Maybe a -> View action -maybeView = maybe (text "") - -mediaInfo :: Maybe Comic -> User -> View Action -mediaInfo Nothing _ = text "" -mediaInfo (Just comic) user = - div_ [class_ "media-info"] [info comic user] - -appmenu :: View Action -appmenu = aside_ [id_ "appmenu"] $ btn 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 - (Comic -> Page -> Model -> View Action) -> - ComicId -> - Page -> - Model -> - View Action -viewOr404 comics f id pg model = - case findComic id comics of - Just c -> f c pg model - Nothing -> the404 model - -template :: MisoString -> [View Action] -> View Action -template id = div_ [id_ id, class_ "app is-black"] - -padLeft :: Int -> MisoString -padLeft n - | n < 10 = ms ("0" <> Legacy.show n) - | 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 $ user model, - el $ ZoomIcon (magnification 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 - -topbar :: View Action -topbar = - header_ - [id_ "app-head", class_ "is-black", css euro] - [ a_ - [ class_ "button is-medium is-black", - onClick $ ChangeURI discoverLink - ] - [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 -the404 :: Model -> View Action -the404 _ = template "404" [p_ [] [text "Not found"]] diff --git a/Hero/Client.hs b/Hero/Client.hs deleted file mode 100644 index 5429855..0000000 --- a/Hero/Client.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# 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 Alpha -import Biz.Auth as Auth -import qualified Data.Aeson as Aeson -import qualified Data.Set as Set -import qualified GHC.Show as Legacy -import GHCJS.Types (JSVal) -import Hero.App - ( Action (..), - AudioState (..), - Comic (..), - ComicReaderState (..), - ComicReaderView (..), - LoginForm (..), - Model (..), - User (..), - audioId, - chooseExperienceLink, - comicReaderFullLink, - comicReaderSpreadLink, - comicVideoLink, - discoverLink, - handlers, - initModel, - routes, - the404, - ) -import JavaScript.Web.XMLHttpRequest as Ajax -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 qualified Network.RemoteData as Network -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 = NoOp - 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 -- ← - | 39 ∈ ks = NextPage -- → - | 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);" - jslog :: MisoString -> IO () - -foreign import javascript unsafe "$1.value" - getValue :: JSVal -> IO MisoString - --- | Updates model, optionally introduces side effects -move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model -move DumpModel model = model <# do - jslog $ 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 $ comicReaderSpreadLink (comicId comic) 1 -move (StartWatching comic) model = model {cpState = Watching (comicId comic)} - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 -move NextPage model = case cpState model of - Reading Spread id pg -> - model {cpState = Reading Spread id (pg + 2)} <# do - pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2) - Reading Full id pg -> - model {cpState = Reading Full id (pg + 1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg + 1) - Cover id -> - model {cpState = Reading Spread id 1} <# do - pure $ ChangeURI $ comicReaderSpreadLink id 1 - _ -> noEff model -move PrevPage model = case cpState model of - Reading Spread id pg -> - model {cpState = Reading Spread id (pg -2)} <# do - pure $ ChangeURI $ comicReaderSpreadLink id (pg -2) - Reading Full id pg -> - model {cpState = Reading Full id (pg -1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg -1) - Cover _ -> noEff model - _ -> noEff model -move (ToggleZoom c pg) m = m {cpState = newState} <# 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 comicReaderSpreadLink) - Reading Spread _ _ -> (reading Full, goto comicReaderFullLink) - x -> (x, NoOp) -move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp - where - newUser = (user model) {userLibrary = newLib} - newLib - | c `elem` (userLibrary $ user model) = - Protolude.filter (/= c) $ userLibrary $ user model - | otherwise = c : (userLibrary $ user 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} - <# case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) model = model <# do - jslog $ ms $ Legacy.show id - scrollIntoView id - pure NoOp -move ValidateUserPassword model = - batchEff - model - [doLogin, (SetComics >= \case - Network.Success user -> do - jslog "successful login" - pure $ ChangeURI discoverLink - -- TODO: handle these error cases - Network.Loading -> pure NoOp - Network.Failure _ -> pure NoOp - Network.NotAsked -> pure NoOp - -fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> - pure $ Network.fromEither - $ either (Left . ms) pure - $ Aeson.eitherDecodeStrict json - where - req = - Ajax.Request - { Ajax.reqMethod = Ajax.GET, - Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding? - Ajax.reqLogin = Nothing, - Ajax.reqHeaders = [], - Ajax.reqWithCredentials = False, - Ajax.reqData = Ajax.NoData - } - -sendLogin :: - Auth.Username -> - Auth.Password -> - IO - ( Network.RemoteData MisoString - User - ) -sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case - Nothing -> - pure $ Network.Failure "Could not send login request." - Just json -> - pure $ Network.fromEither - $ either (Left . ms) pure - $ Aeson.eitherDecodeStrict json - where - req = - Ajax.Request - { Ajax.reqMethod = Ajax.POST, - Ajax.reqURI = "/auth", - Ajax.reqLogin = Nothing, -- FIXME? - Ajax.reqHeaders = - [ ("Accept", "application/json"), - ("Content-Type", "application/json") - ], - Ajax.reqWithCredentials = False, - Ajax.reqData = - LoginForm (fromMisoString u) (fromMisoString p) - |> Aeson.encode - |> ms - |> Ajax.StringData - } diff --git a/Hero/Core.hs b/Hero/Core.hs new file mode 100644 index 0000000..c11456d --- /dev/null +++ b/Hero/Core.hs @@ -0,0 +1,939 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Hero.Core where + +import Alpha +import qualified Clay +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + defaultOptions, + genericParseJSON, + genericToJSON, + ) +import Data.Data (Data, Typeable) +import qualified Data.List as List +import qualified Data.List.Split as List +import Data.Proxy (Proxy (..)) +import Data.String +import Data.String.Quote +import Data.Text (Text, replace, toLower) +import GHC.Generics (Generic) +import qualified GHC.Show as Legacy +import qualified Hero.Assets as Assets +import Hero.Look as Look +import Hero.Look.Typography +import Miso +import qualified Miso (for_) +import Miso.Extend +import Miso.String +import Network.RemoteData +import Servant.API + ( (:<|>) (..), + (:>), + ) +import qualified Servant.API as Api +import Servant.Links (linkURI) + +-- | The css id for controling music in the comic player. +audioId :: MisoString +audioId = "audioSource" + +-- TODO: make ComicId a hashid +-- https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html +newtype ComicId + = ComicId String + deriving + ( Show, + Eq, + Ord, + Data, + Typeable, + Generic, + ToMisoString, + IsString, + Api.ToHttpApiData, + Api.FromHttpApiData + ) + +instance ToJSON ComicId where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON ComicId where + parseJSON = genericParseJSON Data.Aeson.defaultOptions + +-- | Used for looking up images on S3, mostly +comicSlug :: Comic -> Text +comicSlug Comic {..} = snake comicName <> "-" <> comicIssue + +-- * user + +data User + = User + { userEmail :: Text, + userName :: Text, + userLibrary :: [Comic] + } + deriving (Show, Eq, Generic, Data, Ord) + +instance Semigroup User where + a <> b = + User + (userEmail a <> userEmail b) + (userName a <> userName b) + (userLibrary a <> userLibrary b) + +instance Monoid User where + mempty = User mempty mempty mempty + +instance ToJSON User where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON User 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 -> User -> View Action + + -- | Media info view + info :: o -> User -> View Action + +-- | How much to Zoom the comic image +type Magnification = Int + +-- | All the buttons. +data Button + = Watch Comic + | Read Comic + | Save Comic User + | SaveIcon Comic User + | ZoomIcon Magnification 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 u) = + if c `elem` (userLibrary u) -- in library + then + a_ + [class_ "wrs-button saved", onClick $ ToggleInLibrary c] + [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], + span_ [] [text "saved"] + ] + else-- not in library + + a_ + [class_ "wrs-button", onClick $ ToggleInLibrary c] + [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], + span_ [] [text "save"] + ] + el (SaveIcon c u) = + if c `elem` (userLibrary u) -- in library + then + button_ + [ class_ "button is-large has-background-black", + onClick $ ToggleInLibrary c + ] + [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] + else-- not in library + + button_ + [ class_ "button is-large has-background-black-bis", + onClick $ ToggleInLibrary c + ] + [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]] + el (ZoomIcon zmodel comic page) = + button_ + [ id_ "zoom-button", + class_ "button is-large", + onClick $ ToggleZoom comic page + ] + [ img_ [src_ $ ms $ Assets.demo <> "zoom.png"], + input_ + [ type_ "range", + min_ "0", + max_ "100", + disabled_ True, + value_ $ ms (show zmodel :: String), + class_ "ctrl", + id_ "zoom" + ], + label_ + [class_ "ctrl", Miso.for_ "zoom"] + [text $ ms $ (show zmodel :: String) ++ "%"] + ] + el (Read c) = + a_ + [class_ "wrs-button", onClick $ SelectExperience c] + [ img_ [src_ $ ms $ Assets.icon <> "read.svg"], + span_ [] [text "read"] + ] + el (Watch c) = + a_ + [class_ "wrs-button", onClick $ StartWatching c] + [ img_ [src_ $ ms $ Assets.icon <> "watch.svg"], + span_ [] [text "watch"] + ] + +data AudioState = Playing | Paused + deriving (Show, Eq) + +data ComicReaderState + = NotReading + | Cover ComicId + | ChooseExperience ComicId Page + | Reading ComicReaderView ComicId Page + | Watching ComicId + deriving (Show, Eq) + +findComic :: ComicId -> [Comic] -> Maybe Comic +findComic id = List.find (\c -> comicId c == id) + +-- | Main model for the app. +-- +-- Try to prefix component-specific state with the component initials: 'd' for +-- discover, 'cp' for comic player. +data Model + = Model + { uri :: Api.URI, + appComics :: RemoteData MisoString [Comic], + user :: User, + dMediaInfo :: Maybe Comic, + cpState :: ComicReaderState, + cpAudioState :: AudioState, + magnification :: Magnification + } + deriving (Show, Eq) + +initModel :: Api.URI -> Model +initModel uri_ = + Model + { uri = uri_, + appComics = NotAsked, + dMediaInfo = Nothing, + user = mempty, + cpState = detectPlayerState uri_, + cpAudioState = Paused, + magnification = 100 + } + +-- | Hacky way to initialize the 'ComicReaderState' from the Api.URI. +detectPlayerState :: Api.URI -> ComicReaderState +detectPlayerState u = case List.splitOn "/" $ Api.uriPath u of + ["", "comic", id, pg, "experience"] -> ChooseExperience (ComicId id) (toPage pg) + ["", "comic", id, _, "video"] -> Watching $ ComicId id + ["", "comic", id, pg, "full"] -> Reading Full (ComicId id) (toPage pg) + ["", "comic", id, pg] -> Reading Spread (ComicId id) (toPage pg) + ["", "comic", id] -> Cover $ ComicId 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 + | -- login + ValidateUserPassword + | -- app stuff + ScrollIntoView MisoString + | HandleURI Api.URI + | ChangeURI Api.URI + | DumpModel + deriving (Show, Eq) + +type AppRoutes = + ComicCover + :<|> ComicReaderSpread + :<|> ComicReaderFull + :<|> ComicVideo + :<|> Discover + :<|> ChooseExperience + +handlers = + comicCover + :<|> comicReader + :<|> comicReader + :<|> comicReader + :<|> discover + :<|> comicReader + +routes :: Proxy AppRoutes +routes = Proxy + +type PubRoutes = + Home + :<|> Login + +pubRoutes :: Proxy PubRoutes +pubRoutes = Proxy + +-- * pages +-- +-- TODO: consider making a typeclass, something like: +-- +-- class Page name where +-- type Route name :: View Action +-- proxy :: Proxy name +-- proxy = Proxy name +-- view :: Model -> View Action +-- link :: Api.URI + +-- * home +-- +-- this is the unauthenticated page that you see when you first visit + +type Home = + View Action + +homeProxy :: Proxy Home +homeProxy = Proxy + +homeLink :: Api.URI +homeLink = linkURI $ Api.safeLink front homeProxy + where + front = Proxy :: Proxy Home + +home :: Model -> View Action +home = login + +-- * login + +data LoginForm = LoginForm {loginEmail :: String, loginPass :: String} + deriving (Eq, Show, Read, Generic) + +instance ToJSON LoginForm + +instance FromJSON LoginForm + +type Login = + "login" :> View Action + +loginProxy :: Proxy Login +loginProxy = Proxy + +loginLink :: Api.URI +loginLink = linkURI $ Api.safeLink pubRoutes loginProxy + +login :: Model -> View Action +login _ = + template + "login" + [ div_ + [id_ "login-inner"] + [ img_ + [ class_ fadeIn, + src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" + ], + hr_ [class_ fadeIn], + form_ + [class_ fadeIn] + [ ctrl [id_ "user", class_ "input", type_ "email", placeholder_ "Email"], + ctrl [id_ "pass", 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 ValidateUserPassword] + [text "Login"] + ] + ], + hr_ [class_ fadeIn], + p_ + [class_ $ "help " <> fadeIn] + [ a_ [href_ "#"] [text "Forgot your username or password?"], + a_ [href_ "#"] [text "Don't have an account? Sign Up"] + ], + img_ + [ id_ "hero-logo", + class_ "blur-out", + src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" + ] + ] + ] + where + fadeIn = "animated fadeIn delay-2s" + ctrl x = div_ [class_ "control"] [input_ x] + +-- * discover + +type Discover = "discover" :> View Action + +discoverLink :: Api.URI +discoverLink = linkURI $ Api.safeLink routes discoverProxy + +discoverProxy :: Proxy Discover +discoverProxy = Proxy + +discover :: Model -> View Action +discover model@Model {user = u} = + template + "discover" + [ topbar, + main_ [id_ "app-body"] $ case appComics model of + NotAsked -> [loading] + Loading -> [loading] + Failure _ -> [nocomics] + Success [] -> [nocomics] + Success (comic : rest) -> + [ feature comic u, + shelf "Recent Releases" (comic : rest), + maybeView (`info` u) $ dMediaInfo model + ], + appmenu, + discoverFooter + ] + +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]] + +-- * comic + +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, Data, Ord) + +instance ToJSON Comic where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON Comic where + parseJSON = genericParseJSON Data.Aeson.defaultOptions + +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 ComicCover = + "comic" + :> Api.Capture "comicId" ComicId + :> View Action + +comicProxy :: Proxy ComicCover +comicProxy = Proxy + +comicCover :: ComicId -> Model -> View Action +comicCover comicId_ = comicReader comicId_ 1 + +comicLink :: ComicId -> Api.URI +comicLink comicId_ = linkURI $ Api.safeLink routes comicProxy comicId_ + +-- * chooseExperience + +type ChooseExperience = + "comic" + :> Api.Capture "id" ComicId + :> Api.Capture "page" Page + :> "experience" + :> View Action + +chooseExperienceProxy :: Proxy ChooseExperience +chooseExperienceProxy = Proxy + +chooseExperienceLink :: ComicId -> Page -> Api.URI +chooseExperienceLink id page = + linkURI $ Api.safeLink routes chooseExperienceProxy id page + +chooseExperiencePage :: Comic -> Page -> Model -> View Action +chooseExperiencePage comic page model = + template + "choose-experience" + [ topbar, + main_ + [id_ "app-body"] + [ h2_ [] [text "Choose Your Musical Experience"], + p_ [] [text experienceBlurb], + ul_ [] $ li comic name <> ".png"], + span_ [] [text $ ms name] + ], + span_ [css thicc] [text $ ms artist], + span_ [] [text $ ms track] + ] + experiences :: [(Text, Text, Text)] + experiences = + [ ("comedic", "RxGF", "Soft Reveal"), + ("dark", "Logan Henderson", "Speak of the Devil"), + ("original", "Mehcad Brooks", "Stars"), + ("energetic", "Skela", "What's wrong with me"), + ("dramatic", "Josh Jacobson", "Sideline") + ] + +experienceBlurb :: MisoString +experienceBlurb = + [s| +As you enter the world of Hero, you will find that music and visual art have a +symbiotic relationship that can only be experienced, not described. Here, choose +the tonality of the experience you wish to adventure on, whether it's a comedic, +dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey +with the original curated music for this piece of visual art. +|] + +-- * comicReader + +data ComicReaderView = Spread | Full + deriving (Show, Eq) + +comicReader :: ComicId -> Page -> Model -> View Action +comicReader _ _ 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 + +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" + +-- * comicReaderSpread + +type ComicReaderSpread = + "comic" + :> Api.Capture "id" ComicId + :> Api.Capture "page" Page + :> View Action + +comicReaderSpreadProxy :: Proxy ComicReaderSpread +comicReaderSpreadProxy = Proxy + +comicReaderSpreadLink :: ComicId -> Page -> Api.URI +comicReaderSpreadLink id page = + linkURI $ Api.safeLink routes comicReaderSpreadProxy id page + +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" + +closeButton :: View Action +closeButton = + a_ + [id_ "close-button", onClick $ ChangeURI discoverLink] + [text "x"] + +-- * comicReaderFull + +type ComicReaderFull = + "comic" + :> Api.Capture "id" ComicId + :> Api.Capture "page" Page + :> "full" + :> View Action + +comicReaderFullProxy :: Proxy ComicReaderFull +comicReaderFullProxy = Proxy + +comicReaderFullLink :: ComicId -> Page -> Api.URI +comicReaderFullLink id page = + linkURI $ Api.safeLink routes comicReaderFullProxy id page + +-- * comicVideo + +type ComicVideo = + "comic" + :> Api.Capture "id" ComicId + :> Api.Capture "page" Page + :> "video" + :> View Action + +comicVideoProxy :: Proxy ComicVideo +comicVideoProxy = Proxy + +comicVideoLink :: ComicId -> Page -> Api.URI +comicVideoLink id page = + linkURI $ Api.safeLink routes comicVideoProxy id page + +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 + ] + [] + ] + ] + ] + +-- * general page components & utils + +-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' +maybeView :: (a -> View action) -> Maybe a -> View action +maybeView = maybe (text "") + +mediaInfo :: Maybe Comic -> User -> View Action +mediaInfo Nothing _ = text "" +mediaInfo (Just comic) user = + div_ [class_ "media-info"] [info comic user] + +appmenu :: View Action +appmenu = aside_ [id_ "appmenu"] $ btn 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 + (Comic -> Page -> Model -> View Action) -> + ComicId -> + Page -> + Model -> + View Action +viewOr404 comics f id pg model = + case findComic id comics of + Just c -> f c pg model + Nothing -> the404 model + +template :: MisoString -> [View Action] -> View Action +template id = div_ [id_ id, class_ "app is-black"] + +padLeft :: Int -> MisoString +padLeft n + | n < 10 = ms ("0" <> Legacy.show n) + | 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 $ user model, + el $ ZoomIcon (magnification 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 + +topbar :: View Action +topbar = + header_ + [id_ "app-head", class_ "is-black", css euro] + [ a_ + [ class_ "button is-medium is-black", + onClick $ ChangeURI discoverLink + ] + [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 +the404 :: Model -> View Action +the404 _ = template "404" [p_ [] [text "Not found"]] diff --git a/Hero/Host.hs b/Hero/Host.hs new file mode 100644 index 0000000..fc31c39 --- /dev/null +++ b/Hero/Host.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Hero web app +-- +-- : exe mmc +-- +-- : dep acid-state +-- : dep aeson +-- : dep clay +-- : dep containers +-- : dep envy +-- : dep http-types +-- : dep ixset +-- : dep lucid +-- : dep miso +-- : dep mtl +-- : dep network-uri +-- : dep protolude +-- : dep safecopy +-- : dep servant +-- : dep servant-auth +-- : dep servant-auth-server +-- : 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 +-- : dep x509 +module Hero.Host + ( main, + ) +where + +import Alpha +import Biz.App (CSS (..), Manifest (..)) +import qualified Clay +import qualified Crypto.JOSE.JWK as Crypto +import Data.Acid (AcidState) +import qualified Data.Acid.Abstract as Acid +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy +import Hero.Core +import qualified Hero.Assets as Assets +import qualified Hero.Keep as Keep +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.Types hiding (Header) +import Network.Wai +import Network.Wai.Application.Static +import qualified Network.Wai.Handler.Warp as Warp +import Servant +import qualified Servant.Auth.Server as Auth +import qualified System.Directory as Directory +import qualified System.Envy as Envy +import qualified System.Exit as Exit +import qualified System.IO as IO + +main :: IO () +main = bracket startup shutdown run + where + run (cfg, app, _) = Warp.run (heroPort cfg) app + prn = IO.hPutStrLn IO.stderr + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right cfg -> + do + keep <- Keep.open (heroKeep cfg) + skey <- upsertKey (heroSkey cfg) + say "hero" + prn $ "port: " ++ show (heroPort cfg) + prn $ "keep: " ++ heroKeep cfg + prn $ "node: " ++ heroNode cfg + prn $ "skey: " ++ heroSkey cfg + let jwts = Auth.defaultJWTSettings skey + cs = Auth.defaultCookieSettings + ctx = cs :. jwts :. EmptyContext + proxy = Proxy @(AllRoutes '[Auth.JWT]) + static = serveDirectoryWith $ defaultWebAppSettings $ heroNode cfg + server = + -- assets, auth, and the homepage is public + static + :<|> cssHandlers + :<|> pure heroManifest + :<|> pubHostHandlers + :<|> authHandler cs jwts + -- app and api are private + :<|> wrapAuth (jsonHandlers keep) + :<|> wrapAuth appHostHandlers + -- fall through to 404 + :<|> Tagged handle404 + return + ( cfg, + serveWithContext + proxy + ctx + server, + keep + ) + shutdown :: App -> IO () + shutdown (_, _, keep) = do + Keep.close keep + return () + +upsertKey :: FilePath -> IO Crypto.JWK +upsertKey fp = Directory.doesFileExist fp >>= \exists -> + if exists + then Auth.readKey fp + else Auth.writeKey fp >> Auth.readKey fp + +-- This part is a little confusing. I have: +-- +-- - 'App' which encapsulates the entire runtime state +-- - 'Config' has stuff I can set at startup +-- - 'HeroKeep' is the database and any other persistance +-- - the above are then put together in the 'startup' private function in +-- `main` above +-- +-- I'm sure this can be cleaned up with a monad stack of some sort, but I +-- haven't the brain power to think through that. For now, just try and keep +-- things named clearly so I don't get confused. + +-- | This can be generalized I think, put in Biz.App, or something +type App = (Config, Application, AcidState Keep.HeroKeep) + +data Config + = Config + { heroPort :: Warp.Port, + heroNode :: FilePath, + heroKeep :: FilePath, + heroSkey :: FilePath + } + deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 "_bild/Hero.Node/static" "_keep" "/run/hero/skey" + +instance Envy.FromEnv Config + +-- | Convert client side routes into server-side web handlers +type AppHostRoutes = ToServerRoutes AppRoutes Templated Action + +-- | These are the main app handlers, and should require authentication. +appHostHandlers :: User -> Server AppHostRoutes +appHostHandlers _ = + comicCoverHandler + :<|> comicPageHandler + :<|> comicPageFullHandler + :<|> comicVideoHandler + :<|> discoverHandler + :<|> chooseExperienceHandler + +-- | Marketing pages +type PubHostRoutes = ToServerRoutes PubRoutes Templated Action + +pubHostHandlers :: Server PubHostRoutes +pubHostHandlers = + homeHandler :<|> loginHandler + +type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] + +-- TODO: need a "you're not logged in" page +wrapAuth :: + Auth.ThrowAll route => + (user -> route) -> + Auth.AuthResult user -> + route +wrapAuth f (Auth.Authenticated user) = f user +wrapAuth _ _ = Auth.throwAll err401 + +jsonHandlers :: AcidState Keep.HeroKeep -> User -> Server JsonApi +jsonHandlers keep _ = Acid.query' keep $ Keep.GetComics 10 + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +cssHandlers :: Server CssRoute +cssHandlers = + return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main + +type AuthRoute = + "auth" + :> ReqBody '[JSON] LoginForm + :> Post '[JSON] + ( Headers + '[ Header "Set-Cookie" Auth.SetCookie, + Header "Set-Cookie" Auth.SetCookie + ] + User + ) + +instance Auth.ToJWT User + +instance Auth.FromJWT User + +-- | Endpoint for performing authentication +-- +-- TODO: get creds from keep +-- TODO: load initial library for user +authHandler :: + Auth.CookieSettings -> + Auth.JWTSettings -> + LoginForm -> + Handler + ( Headers + '[ Header "Set-Cookie" Auth.SetCookie, + Header "Set-Cookie" Auth.SetCookie + ] + User + ) +authHandler cookieSettings jwtSettings loginForm = + case loginForm of + (LoginForm "ben@bsima.me" "test") -> do + applyCreds $ User "ben@bsima.me" "ben" [] + (LoginForm "mcovino@heroprojects.io" "test") -> do + applyCreds $ User "mcovino@heroprojects.io" "mike" [] + _ -> throwError err401 + where + applyCreds usr = do + mApplyCookies <- liftIO $ Auth.acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies usr + +-- | See also 'server' above +type AllRoutes auths = + ("static" :> Raw) + :<|> CssRoute + :<|> ("manifest.json" :> Get '[JSON] Manifest) + :<|> PubHostRoutes + :<|> AuthRoute + :<|> (Auth.Auth auths User :> JsonApi) + :<|> (Auth.Auth auths User :> AppHostRoutes) + :<|> Raw + +heroManifest :: Manifest +heroManifest = + Manifest + { name = "Hero", + short_name = "Hero", + start_url = ".", + display = "standalone", + theme_color = "#0a0a0a", + description = "Comics for all" + } + +-- | Type for setting wrapping a view in HTML doctype, header, etc +newtype Templated a = Templated a + deriving (Show, Eq) + +instance L.ToHtml a => L.ToHtml (Templated a) where + toHtmlRaw = L.toHtml + toHtml (Templated 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] + +handle404 :: Application +handle404 _ respond = + respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ Templated + $ the404 + $ initModel homeLink + +fontAwesomeRef :: MisoString +fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" + +animateRef :: MisoString +animateRef = + "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" + +-- TODO: if I remove this, then the login form (and probably other stuff) gets +-- messed up. When I remove this, I need to also port the necessary CSS styles +-- to make stuff look good. +bulmaRef :: MisoString +bulmaRef = + "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" + +homeHandler :: Handler (Templated (View Action)) +homeHandler = pure . Templated . home $ initModel homeLink + +comicCoverHandler :: ComicId -> Handler (Templated (View Action)) +comicCoverHandler id = + pure . Templated . comicCover id . initModel $ comicLink id + +comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicPageHandler id n = + pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n + +comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicPageFullHandler id n = + pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n + +comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicVideoHandler id n = + pure . Templated . comicReader id n . initModel $ comicVideoLink id n + +discoverHandler :: Handler (Templated (View Action)) +discoverHandler = pure . Templated . discover $ initModel discoverLink + +chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action)) +chooseExperienceHandler id n = + pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n + +loginHandler :: Handler (Templated (View Action)) +loginHandler = pure . Templated . login $ initModel loginLink diff --git a/Hero/Keep.hs b/Hero/Keep.hs index ee625d8..72bd6c2 100644 --- a/Hero/Keep.hs +++ b/Hero/Keep.hs @@ -23,7 +23,7 @@ import qualified Data.IxSet as IxSet import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet) import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.Text as Text -import Hero.App +import Hero.Core -- * Keep diff --git a/Hero/Node.hs b/Hero/Node.hs new file mode 100644 index 0000000..e32cd59 --- /dev/null +++ b/Hero/Node.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# 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.Node where + +import Alpha +import Biz.Auth as Auth +import qualified Data.Aeson as Aeson +import qualified Data.Set as Set +import qualified GHC.Show as Legacy +import GHCJS.Types (JSVal) +import Hero.Core + ( Action (..), + AudioState (..), + Comic (..), + ComicReaderState (..), + ComicReaderView (..), + LoginForm (..), + Model (..), + User (..), + audioId, + chooseExperienceLink, + comicReaderFullLink, + comicReaderSpreadLink, + comicVideoLink, + discoverLink, + handlers, + initModel, + routes, + the404, + ) +import JavaScript.Web.XMLHttpRequest as Ajax +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 qualified Network.RemoteData as Network +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 = NoOp + 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 -- ← + | 39 ∈ ks = NextPage -- → + | 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);" + jslog :: MisoString -> IO () + +foreign import javascript unsafe "$1.value" + getValue :: JSVal -> IO MisoString + +-- | Updates model, optionally introduces side effects +move :: Action -> Model -> Effect Action Model +move NoOp model = noEff model +move DumpModel model = model <# do + jslog $ 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 $ comicReaderSpreadLink (comicId comic) 1 +move (StartWatching comic) model = model {cpState = Watching (comicId comic)} + <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 +move NextPage model = case cpState model of + Reading Spread id pg -> + model {cpState = Reading Spread id (pg + 2)} <# do + pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2) + Reading Full id pg -> + model {cpState = Reading Full id (pg + 1)} <# do + pure $ ChangeURI $ comicReaderFullLink id (pg + 1) + Cover id -> + model {cpState = Reading Spread id 1} <# do + pure $ ChangeURI $ comicReaderSpreadLink id 1 + _ -> noEff model +move PrevPage model = case cpState model of + Reading Spread id pg -> + model {cpState = Reading Spread id (pg -2)} <# do + pure $ ChangeURI $ comicReaderSpreadLink id (pg -2) + Reading Full id pg -> + model {cpState = Reading Full id (pg -1)} <# do + pure $ ChangeURI $ comicReaderFullLink id (pg -1) + Cover _ -> noEff model + _ -> noEff model +move (ToggleZoom c pg) m = m {cpState = newState} <# 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 comicReaderSpreadLink) + Reading Spread _ _ -> (reading Full, goto comicReaderFullLink) + x -> (x, NoOp) +move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp + where + newUser = (user model) {userLibrary = newLib} + newLib + | c `elem` (userLibrary $ user model) = + Protolude.filter (/= c) $ userLibrary $ user model + | otherwise = c : (userLibrary $ user 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} + <# case x of + Just Comic {comicId = id} -> + pure $ ScrollIntoView $ "comic-" <> ms id + Nothing -> + pure NoOp +move (ScrollIntoView id) model = model <# do + jslog $ ms $ Legacy.show id + scrollIntoView id + pure NoOp +move ValidateUserPassword model = + batchEff + model + [doLogin, (SetComics >= \case + Network.Success user -> do + jslog "successful login" + pure $ ChangeURI discoverLink + -- TODO: handle these error cases + Network.Loading -> pure NoOp + Network.Failure _ -> pure NoOp + Network.NotAsked -> pure NoOp + +fetchComics :: IO (Network.RemoteData MisoString [Comic]) +fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure $ Network.Failure "Could not fetch comics from server." + Just json -> + pure $ Network.fromEither + $ either (Left . ms) pure + $ Aeson.eitherDecodeStrict json + where + req = + Ajax.Request + { Ajax.reqMethod = Ajax.GET, + Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding? + Ajax.reqLogin = Nothing, + Ajax.reqHeaders = [], + Ajax.reqWithCredentials = False, + Ajax.reqData = Ajax.NoData + } + +sendLogin :: + Auth.Username -> + Auth.Password -> + IO + ( Network.RemoteData MisoString + User + ) +sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure $ Network.Failure "Could not send login request." + Just json -> + pure $ Network.fromEither + $ either (Left . ms) pure + $ Aeson.eitherDecodeStrict json + where + req = + Ajax.Request + { Ajax.reqMethod = Ajax.POST, + Ajax.reqURI = "/auth", + Ajax.reqLogin = Nothing, -- FIXME? + Ajax.reqHeaders = + [ ("Accept", "application/json"), + ("Content-Type", "application/json") + ], + Ajax.reqWithCredentials = False, + Ajax.reqData = + LoginForm (fromMisoString u) (fromMisoString p) + |> Aeson.encode + |> ms + |> Ajax.StringData + } diff --git a/Hero/Server.hs b/Hero/Server.hs deleted file mode 100644 index cdf89d0..0000000 --- a/Hero/Server.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Hero web app --- --- : exe mmc --- --- : dep acid-state --- : dep aeson --- : dep clay --- : dep containers --- : dep envy --- : dep http-types --- : dep ixset --- : dep lucid --- : dep miso --- : dep mtl --- : dep network-uri --- : dep protolude --- : dep safecopy --- : dep servant --- : dep servant-auth --- : dep servant-auth-server --- : 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 --- : dep x509 -module Hero.Server - ( main, - ) -where - -import Alpha -import Biz.App (CSS (..), Manifest (..)) -import qualified Clay -import qualified Crypto.JOSE.JWK as Crypto -import Data.Acid (AcidState) -import qualified Data.Acid.Abstract as Acid -import qualified Data.Aeson as Aeson -import Data.Text (Text) -import qualified Data.Text.Lazy as Lazy -import Hero.App -import qualified Hero.Assets as Assets -import qualified Hero.Keep as Keep -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.Types hiding (Header) -import Network.Wai -import Network.Wai.Application.Static -import qualified Network.Wai.Handler.Warp as Warp -import Servant -import qualified Servant.Auth.Server as Auth -import qualified System.Directory as Directory -import qualified System.Envy as Envy -import qualified System.Exit as Exit -import qualified System.IO as IO - -main :: IO () -main = bracket startup shutdown run - where - run (cfg, app, _) = Warp.run (heroPort cfg) app - prn = IO.hPutStrLn IO.stderr - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right cfg -> - do - keep <- Keep.open (heroKeep cfg) - skey <- upsertKey (heroSkey cfg) - say "hero" - prn $ "port: " ++ show (heroPort cfg) - prn $ "beam: " ++ heroBeam cfg - prn $ "keep: " ++ heroKeep cfg - prn $ "skey: " ++ heroSkey cfg - let jwts = Auth.defaultJWTSettings skey - cs = Auth.defaultCookieSettings - ctx = cs :. jwts :. EmptyContext - proxy = Proxy @(AllRoutes '[Auth.JWT]) - static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg - server = - -- assets, auth, and the homepage is public - static - :<|> cssHandlers - :<|> pure heroManifest - :<|> pubHostHandlers - :<|> authHandler cs jwts - -- app and api are private - :<|> wrapAuth (jsonHandlers keep) - :<|> wrapAuth appHostHandlers - -- fall through to 404 - :<|> Tagged handle404 - return - ( cfg, - serveWithContext - proxy - ctx - server, - keep - ) - shutdown :: App -> IO () - shutdown (_, _, keep) = do - Keep.close keep - return () - -upsertKey :: FilePath -> IO Crypto.JWK -upsertKey fp = Directory.doesFileExist fp >>= \exists -> - if exists - then Auth.readKey fp - else Auth.writeKey fp >> Auth.readKey fp - --- This part is a little confusing. I have: --- --- - 'App' which encapsulates the entire runtime state --- - 'Config' has stuff I can set at startup --- - 'HeroKeep' is the database and any other persistance --- - the above are then put together in the 'startup' private function in --- `main` above --- --- I'm sure this can be cleaned up with a monad stack of some sort, but I --- haven't the brain power to think through that. For now, just try and keep --- things named clearly so I don't get confused. - --- | This can be generalized I think, put in Biz.App, or something -type App = (Config, Application, AcidState Keep.HeroKeep) - -data Config - = Config - { heroPort :: Warp.Port, - heroBeam :: FilePath, - heroKeep :: FilePath, - heroSkey :: FilePath - } - deriving (Generic, Show) - -instance Envy.DefConfig Config where - defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" "/run/hero/skey" - -instance Envy.FromEnv Config - --- | Convert client side routes into server-side web handlers -type AppHostRoutes = ToServerRoutes AppRoutes Templated Action - --- | These are the main app handlers, and should require authentication. -appHostHandlers :: User -> Server AppHostRoutes -appHostHandlers _ = - comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - --- | Marketing pages -type PubHostRoutes = ToServerRoutes PubRoutes Templated Action - -pubHostHandlers :: Server PubHostRoutes -pubHostHandlers = - homeHandler :<|> loginHandler - -type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic] - --- TODO: need a "you're not logged in" page -wrapAuth :: - Auth.ThrowAll route => - (user -> route) -> - Auth.AuthResult user -> - route -wrapAuth f (Auth.Authenticated user) = f user -wrapAuth _ _ = Auth.throwAll err401 - -jsonHandlers :: AcidState Keep.HeroKeep -> User -> Server JsonApi -jsonHandlers keep _ = Acid.query' keep $ Keep.GetComics 10 - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -cssHandlers :: Server CssRoute -cssHandlers = - return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main - -type AuthRoute = - "auth" - :> ReqBody '[JSON] LoginForm - :> Post '[JSON] - ( Headers - '[ Header "Set-Cookie" Auth.SetCookie, - Header "Set-Cookie" Auth.SetCookie - ] - User - ) - -instance Auth.ToJWT User - -instance Auth.FromJWT User - --- | Endpoint for performing authentication --- --- TODO: get creds from keep --- TODO: load initial library for user -authHandler :: - Auth.CookieSettings -> - Auth.JWTSettings -> - LoginForm -> - Handler - ( Headers - '[ Header "Set-Cookie" Auth.SetCookie, - Header "Set-Cookie" Auth.SetCookie - ] - User - ) -authHandler cookieSettings jwtSettings loginForm = - case loginForm of - (LoginForm "ben@bsima.me" "test") -> do - applyCreds $ User "ben@bsima.me" "ben" [] - (LoginForm "mcovino@heroprojects.io" "test") -> do - applyCreds $ User "mcovino@heroprojects.io" "mike" [] - _ -> throwError err401 - where - applyCreds usr = do - mApplyCookies <- liftIO $ Auth.acceptLogin cookieSettings jwtSettings usr - case mApplyCookies of - Nothing -> throwError err401 - Just applyCookies -> return $ applyCookies usr - --- | See also 'server' above -type AllRoutes auths = - ("static" :> Raw) - :<|> CssRoute - :<|> ("manifest.json" :> Get '[JSON] Manifest) - :<|> PubHostRoutes - :<|> AuthRoute - :<|> (Auth.Auth auths User :> JsonApi) - :<|> (Auth.Auth auths User :> AppHostRoutes) - :<|> Raw - -heroManifest :: Manifest -heroManifest = - Manifest - { name = "Hero", - short_name = "Hero", - start_url = ".", - display = "standalone", - theme_color = "#0a0a0a", - description = "Comics for all" - } - --- | Type for setting wrapping a view in HTML doctype, header, etc -newtype Templated a = Templated a - deriving (Show, Eq) - -instance L.ToHtml a => L.ToHtml (Templated a) where - toHtmlRaw = L.toHtml - toHtml (Templated 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] - -handle404 :: Application -handle404 _ respond = - respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ Templated - $ the404 - $ initModel homeLink - -fontAwesomeRef :: MisoString -fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" - -animateRef :: MisoString -animateRef = - "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" - --- TODO: if I remove this, then the login form (and probably other stuff) gets --- messed up. When I remove this, I need to also port the necessary CSS styles --- to make stuff look good. -bulmaRef :: MisoString -bulmaRef = - "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" - -homeHandler :: Handler (Templated (View Action)) -homeHandler = pure . Templated . home $ initModel homeLink - -comicCoverHandler :: ComicId -> Handler (Templated (View Action)) -comicCoverHandler id = - pure . Templated . comicCover id . initModel $ comicLink id - -comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action)) -comicPageHandler id n = - pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n - -comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action)) -comicPageFullHandler id n = - pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n - -comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action)) -comicVideoHandler id n = - pure . Templated . comicReader id n . initModel $ comicVideoLink id n - -discoverHandler :: Handler (Templated (View Action)) -discoverHandler = pure . Templated . discover $ initModel discoverLink - -chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action)) -chooseExperienceHandler id n = - pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n - -loginHandler :: Handler (Templated (View Action)) -loginHandler = pure . Templated . login $ initModel loginLink diff --git a/Hero/Service.nix b/Hero/Service.nix index 89c6907..5885d1c 100644 --- a/Hero/Service.nix +++ b/Hero/Service.nix @@ -23,11 +23,11 @@ in default = "/var/lib/hero"; description = "herocomics-server database directory"; }; - deck = lib.mkOption { + host = lib.mkOption { type = lib.types.package; description = "herocomics-server package to use"; }; - beam = lib.mkOption { + node = lib.mkOption { type = lib.types.package; description = "herocomics-client package to use"; }; @@ -58,7 +58,7 @@ in serviceConfig = { KillSignal = "INT"; Environment = [ - "HERO_BEAM=${cfg.beam}/static" + "HERO_NODE=${cfg.node}/static" "HERO_PORT=${toString cfg.port}" "HERO_KEEP=${cfg.keep}" "HERO_SKEY=/run/hero/skey" -- cgit v1.2.3