diff options
Diffstat (limited to 'Com/MusicMeetsComics')
| -rw-r--r-- | Com/MusicMeetsComics/Aero.hs | 174 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Apex.hs | 235 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/App.hs | 748 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Assets.hs | 15 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Database.hs | 30 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Look.hs | 567 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Look/Typography.hs | 89 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Config.hs | 131 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Init.hs | 49 | ||||
| -rw-r--r-- | Com/MusicMeetsComics/Server/Logger.hs | 48 |
10 files changed, 2086 insertions, 0 deletions
diff --git a/Com/MusicMeetsComics/Aero.hs b/Com/MusicMeetsComics/Aero.hs new file mode 100644 index 0000000..26d8aaf --- /dev/null +++ b/Com/MusicMeetsComics/Aero.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Aero where + +import Com.MusicMeetsComics.App ( Action(..) + , Comic(..) + , ComicReaderState(..) + , ComicReaderView(..) + , Model(..) + , AudioState(..) + , audioId + , chooseExperienceLink + , comicPlayerSpreadLink + , comicPlayerFullLink + , comicVideoLink + , handlers + , initModel + , the404 + , routes + ) +import qualified Com.Simatime.Network 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/Com/MusicMeetsComics/Apex.hs b/Com/MusicMeetsComics/Apex.hs new file mode 100644 index 0000000..f652f68 --- /dev/null +++ b/Com/MusicMeetsComics/Apex.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Apex where + +import qualified Clay +import Com.MusicMeetsComics.App +import qualified Com.MusicMeetsComics.Assets as Assets +import qualified Com.MusicMeetsComics.Database as Database +import qualified Com.MusicMeetsComics.Server.Config as Config +import qualified Com.MusicMeetsComics.Server.Init as Init +import qualified Com.MusicMeetsComics.Look as Look +import qualified Com.MusicMeetsComics.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 Protolude +import Servant + + +main :: IO () +main = do + db <- Database.load + Init.runApp (app db) + +app :: Database.ComicDB -> Config.Config -> Application +app db _ = serve + (Proxy @AllRoutes) + ( static + :<|> cssHandlers + :<|> jsonHandlers db + :<|> serverHandlers + :<|> pure heroManifest + :<|> Tagged handle404 + ) + where + static = serveDirectoryWith (defaultWebAppSettings "static") + + +-- | 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/all.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/Com/MusicMeetsComics/App.hs b/Com/MusicMeetsComics/App.hs new file mode 100644 index 0000000..2a9220b --- /dev/null +++ b/Com/MusicMeetsComics/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 Com.MusicMeetsComics.App where + +import qualified Clay +import qualified Com.MusicMeetsComics.Assets as Assets +import Com.MusicMeetsComics.Look as Look +import Com.MusicMeetsComics.Look.Typography +import Com.Simatime.Alpha +import Com.Simatime.Network +import Data.Aeson ( ToJSON(..) + , FromJSON(..) + , genericToJSON + , genericParseJSON + , defaultOptions + ) +import qualified Data.List as List +import qualified Data.List.Split as List +import Data.Proxy ( Proxy(..) ) +import Data.String +import Data.String.Quote +import Data.Text ( Text, replace, toLower ) +import GHC.Generics ( Generic ) +import qualified GHC.Show as Legacy +import Miso +import qualified Miso (for_) +import Miso.String +import Protolude hiding (replace) +import Servant.API ( Capture + , URI(..) + , safeLink + , (:<|>)(..) + , (:>) + ) +import Servant.Links ( linkURI ) + +crossorigin_ :: MisoString -> Attribute action +crossorigin_ = textProp "crossorigin" + +-- | The css id for controling music in the comic player. +audioId :: MisoString +audioId = "audioSource" + +-- | Like 'onClick' but prevents the default action from triggering. Use this to +-- overide 'a_' links, for example. +onPreventClick :: Action -> Attribute Action +onPreventClick action = + onWithOptions Miso.defaultOptions { preventDefault = True } + "click" emptyDecoder (\() -> action) + +-- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html +type ComicId = String + +-- | Class for turning different string types to snakeCase. +class CanSnakeCase str where + snake :: str -> str + +instance CanSnakeCase Text where + snake = Data.Text.replace " " "-" . Data.Text.toLower + +-- | Used for looking up images on S3, mostly +comicSlug :: Comic -> Text +comicSlug Comic{..} = snake comicName <> "-" <> comicIssue + +data Comic = Comic + { comicId :: ComicId + , comicPages :: Integer + , comicName :: Text + , comicIssue :: Text -- ^ Ideally this would be a dynamic number-like type + , comicDescription :: Text + } deriving (Show, Eq, Generic) + +instance ToJSON Comic where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON Comic where + parseJSON = genericParseJSON Data.Aeson.defaultOptions + +-- | Class for rendering media objects in different ways. +class IsMediaObject o where + -- | Render a thumbnail for use in a shelf, or otherwise. + thumbnail :: o -> View Action + -- | Render a featured banner. + feature :: o -> Library -> View Action + -- | Media info view + info :: o -> Library -> View Action + +instance IsMediaObject Comic where + thumbnail c@Comic{..} = li_ [] + [ a_ + [ class_ "comic grow clickable" + , id_ $ "comic-" <> ms comicId + , onClick $ SetMediaInfo $ Just c + ] + [ img_ [ src_ $ ms $ Assets.demo <> comicSlug c <> ".png" ] + , span_ [] [ text $ "Issue #" <> ms comicIssue ] + , span_ [] [ text $ ms comicName ] + ] + ] + feature comic lib = div_ [ id_ "featured-comic" ] + [ img_ [ id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png" ] + , div_ [ id_ "featured-content" ] + [ div_ [ class_ "hero-original", css wide ] + [ span_ [ css thicc ] [ text "Herø" ] + , span_ [ css euro ] [ text " Original" ] + ] + , div_ [ class_ "comic-logo" ] + [ img_ [ src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png" ] ] + , div_ [ class_ "comic-action-menu" ] $ el <$> [ Watch comic, Read comic, Save comic lib ] + , p_ [ class_ "description" ] + [ text . ms $ comicDescription comic + ] + ] + ] + info c@Comic {..} lib = div_ [ class_ "media-info", css euro ] + [ div_ [ class_ "media-info-meta" ] + [ column [ img_ [ src_ $ ms $ Assets.demo <> "dmc-widethumb.png" ] ] + , column + [ span_ [ style_ title ] [ text $ ms comicName ] + , span_ [ style_ subtitle ] [ text $ "Issue #" <> ms comicIssue ] + , span_ [] [ text "Released: " ] + , span_ [] [ text $ "Pages: " <> ms (show comicPages :: String) ] + ] + ] + , div_ [ class_ "media-info-summary" ] + [ p_ [ style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem" ] + [ text "Summary" ] + , p_ [] [ text $ ms comicDescription ] + ] + , div_ [ class_ "media-info-actions" ] $ el <$> [ Save c lib, Read c, Watch c ] + -- , row [ text "credits" ] + ] + where + title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase + <> "line-height" =: "100%" <> Look.condensed <> bold + subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed + + +type ZoomModel = Int + +-- | All the buttons. +data Button + = Watch Comic | Read Comic | Save Comic Library + | SaveIcon Comic Library + | ZoomIcon ZoomModel Comic Page + | PlayPause MisoString AudioState + | Arrow Action + +-- | Class for defining general, widely used elements in the heroverse. +class Elemental v where el :: v -> View Action + +-- TODO: what if I just did this on all actions? +-- then I could e.g. `el $ ToggleAudio audioId audioState` +instance Elemental Button where + el (PlayPause id model) = button_ + [ class_ "button is-large icon" + , onClick $ ToggleAudio id + ] + [ i_ [ class_ $ "fa " <> icon ][]] + where + icon = case model of + Paused -> "fa-play-circle" + Playing -> "fa-pause-circle" + el (Arrow act) = button_ + [class_ "button is-large turn-page", onClick act] + [ img_ [src_ $ ms $ Assets.demo <> image <> ".png"]] + where image = case act of + PrevPage -> "prev-page" + NextPage -> "next-page" + _ -> "prev-page" + el (Save c lib) = + if c `elem` lib then -- in library + a_ [ class_ $ "wrs-button saved", onClick $ ToggleInLibrary c ] + [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] + , span_ [] [ text "saved" ] + ] + else -- not in library + a_ [ class_ $ "wrs-button", onClick $ ToggleInLibrary c ] + [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ] + , span_ [] [ text "save" ] + ] + el (SaveIcon c lib) = + if c `elem` lib then -- in library + button_ + [ class_ "button is-large has-background-black" + , onClick $ ToggleInLibrary c + ] + [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] + else -- not in library + button_ + [ class_ "button is-large has-background-black-bis" + , onClick $ ToggleInLibrary c + ] + [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ] + + el (ZoomIcon zmodel comic page) = button_ + [ id_ "zoom-button", class_ "button is-large" + , onClick $ ToggleZoom comic page + ] + [ img_ [ src_ $ ms $ Assets.demo <> "zoom.png" ] + , input_ + [ type_ "range", min_ "0", max_ "100", disabled_ True + , value_ $ ms (show zmodel :: String) + , class_ "ctrl", id_ "zoom" + ] + , label_ + [ class_ "ctrl", Miso.for_ "zoom" ] + [ text $ ms $ (show zmodel :: String) ++ "%" ] + ] + + el (Read c) = a_ [ class_ $ "wrs-button", onClick $ SelectExperience c ] + [ img_ [ src_ $ ms $ Assets.icon <> "read.svg" ] + , span_ [] [ text "read" ] + ] + + el (Watch c) = a_ [ class_ $ "wrs-button", onClick $ StartWatching c ] + [ img_ [ src_ $ ms $ Assets.icon <> "watch.svg" ] + , span_ [] [ text "watch" ] + ] + +data AudioState = Playing | Paused + deriving (Show, Eq) + +type Library = [Comic] + +data ComicReaderState + = NotReading + | Cover ComicId + | ChooseExperience ComicId Page + | Reading ComicReaderView ComicId Page + | Watching ComicId + deriving (Show, Eq) + +findComic :: ComicId -> [Comic] -> Maybe Comic +findComic id ls = List.find (\c -> comicId c == id) ls + +-- | Main model for the app. +-- +-- Try to prefix component-specific state with the component initials: 'd' for +-- discover, 'cp' for comic player. +data Model = Model + { uri :: URI + , appComics :: RemoteData MisoString [Comic] + , userLibrary :: Library + , dMediaInfo :: Maybe Comic + , cpState :: ComicReaderState + , cpAudioState :: AudioState + , zoomModel :: ZoomModel + } deriving (Show, Eq) + +initModel :: URI -> Model +initModel uri_ = + Model { uri = uri_ + , appComics = NotAsked + , dMediaInfo = Nothing + , userLibrary = Protolude.empty + , cpState = detectPlayerState uri_ + , cpAudioState = Paused + , zoomModel = 100 + } + +-- | Hacky way to initialize the 'ComicReaderState' from the URI. +detectPlayerState :: URI -> ComicReaderState +detectPlayerState u = case List.splitOn "/" $ uriPath u of + ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg + ["", "comic", id, _, "video"] -> Watching id + ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg + ["", "comic", id, pg] -> Reading Spread id $ toPage pg + ["", "comic", id] -> Cover id + _ -> NotReading + where + toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) + +type Page = Int + +data Action + = NoOp + -- comic player stuff + | SelectExperience Comic + | StartReading Comic + | StartWatching Comic + | NextPage + | PrevPage + | ToggleZoom Comic Page + | ToggleAudio MisoString + | FetchComics + | SetComics (RemoteData MisoString [Comic]) + | ToggleFullscreen + -- discover stuff + | SetMediaInfo (Maybe Comic) + | ToggleInLibrary Comic + -- app stuff + | ScrollIntoView MisoString + | HandleURI URI + | ChangeURI URI + | DumpModel + deriving (Show, Eq) + +type Discover = "discover" :> View Action + +type Home = + View Action + +type ComicCover = + "comic" + :> Capture "comicId" ComicId + :> View Action + +type ComicReaderSpread = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> View Action + +type ComicReaderFull = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "full" + :> View Action + +type ComicVideo = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "video" + :> View Action + +type ChooseExperience = + "comic" + :> Capture "id" ComicId + :> Capture "page" Page + :> "experience" + :> View Action + +type Login = + "login" :> View Action + +type ClientRoutes = Home + :<|> ComicCover :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo + :<|> Login :<|> Discover :<|> ChooseExperience + +handlers = home + :<|> comicCover :<|> comicPlayer :<|> comicPlayer :<|> comicPlayer + :<|> login :<|> discover :<|> comicPlayer + +routes :: Proxy ClientRoutes +routes = Proxy + +comicPlayerSpreadProxy :: Proxy ComicReaderSpread +comicPlayerSpreadProxy = Proxy + +comicPlayerFullProxy :: Proxy ComicReaderFull +comicPlayerFullProxy = Proxy + +chooseExperienceProxy :: Proxy ChooseExperience +chooseExperienceProxy = Proxy + +comicProxy :: Proxy ComicCover +comicProxy = Proxy + +comicVideoProxy :: Proxy ComicVideo +comicVideoProxy = Proxy + +homeProxy :: Proxy Home +homeProxy = Proxy + +loginProxy :: Proxy Login +loginProxy = Proxy + +discoverProxy :: Proxy Discover +discoverProxy = Proxy + +home :: Model -> View Action +home = login + +discover :: Model -> View Action +discover model@(Model { userLibrary = lib}) = template "discover" + [ topbar + , main_ [id_ "app-body"] $ case appComics model of + NotAsked -> undefined + Loading -> [loading] + Failure e -> undefined + Success [] -> [nocomics] + Success (comic:rest) -> + [ feature comic lib + , shelf "Recent Releases" (comic:rest) + , maybeView (flip info lib) $ dMediaInfo model + ] + , appmenu + , discoverFooter + ] + +-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' +maybeView :: (a -> View action) -> Maybe a -> View action +maybeView f obj = maybe (text "") f obj + +mediaInfo :: Maybe Comic -> Library -> View Action +mediaInfo Nothing _ = text "" +mediaInfo (Just comic) lib = div_ [ class_ "media-info" ] [ info comic lib ] + +appmenu :: View Action +appmenu = aside_ [ id_ "appmenu" ] $ btn /@ links + where + links = [ (discoverLink, "discover.svg", "discover") + , (homeLink, "save.svg", "library") + , (homeLink, "watch.svg", "videos") + , (comicLink "1", "read.svg", "comics") + , (homeLink, "listen.svg", "music") + ] + btn (lnk,img,label) = a_ + [ class_ "button" + , onPreventClick $ ChangeURI $ lnk + ] + [ img_ [src_ $ ms $ Assets.icon <> img] + , span_ [] [ text label ] + ] + +-- TODO: make this a loading gif of some sort... maybe the hero icon filling from white to red +loading :: View Action +loading = div_ [ class_ "loading" ] [ text "Loading..." ] + +nocomics :: View Action +nocomics = div_ [ class_ "loading" ] [ text "error: no comics found" ] + +shelf :: IsMediaObject o => MisoString -> [o] -> View Action +shelf title comics = div_ [ class_ "shelf" ] + [ div_ [ class_ "shelf-head" ] [ text title ] + , ul_ [ class_ "shelf-body" ] $ thumbnail /@ comics + ] + +discoverFooter :: View Action +discoverFooter = footer_ + [ id_ "app-foot" + , class_ "is-black" + ] + [ div_ + [id_ "app-foot-social", css euro] + [ div_ [class_ "row is-marginless"] + [ smallImg "facebook.png" $ Just "https://www.facebook.com/musicmeetscomics" + , smallImg "twitter.png" $ Just "https://twitter.com/musicmeetscomic" + , smallImg "instagram.png" $ Just "https://www.instagram.com/musicmeetscomics/" + , smallImg "spotify.png" $ Just "https://open.spotify.com/user/i4ntfg6ganjgxdsylinigcjlq?si=ymWsSkwsT9iaLw2LeAJNNg" + , smallImg "youtube.png" $ Just "https://www.youtube.com/channel/UCnNPLiuJ1ueo1KTPgHDE7lA/" + ] + , div_ [class_ "row"] [ text "Team | Contact Us | Privacy Policy" ] + ] + , div_ + [ id_ "app-foot-quote", css euro ] + [ p_ [] [text "With great power comes great responsiblity."] + , p_ [] [text "-Stan Lee"] + ] + , div_ + [ css euro, id_ "app-foot-logo", onClick DumpModel ] + [ a_ [ class_ "social-icon", href_ "#" ] [ img_ [ src_ $ ms $ Assets.icon <> "hero-logo.svg" ]] + , span_ [] [ text "© Com.MusicMeetsComics Records, Inc. All Rights Reserved" ] + ] + ] + where + attrs Nothing = [ class_ "social-icon" ] + attrs (Just lnk) = [ class_ "social-icon", href_ lnk, target_ "_blank" ] + smallImg x lnk = a_ (attrs lnk) + [ img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x ]] + +comicCover :: ComicId -> Model -> View Action +comicCover comicId_ model = comicPlayer comicId_ 1 model + +data ComicReaderView = Spread | Full + deriving (Show, Eq) + +comicPlayer :: ComicId -> Page -> Model -> View Action +comicPlayer _ _ model = case appComics model of + NotAsked -> undefined + Loading -> loading + Failure e -> undefined + Success comics -> case cpState model of + NotReading -> template "comic-player" [ text "error: not reading" ] + Cover id -> viewOr404 comics comicSpread id 1 model + ChooseExperience id pg -> + viewOr404 comics chooseExperiencePage id pg model + Reading Spread id pg -> viewOr404 comics comicSpread id pg model + Reading Full id pg -> viewOr404 comics zoomScreen id pg model + Watching id -> viewOr404 comics comicVideo id 0 model + +viewOr404 :: [Comic] + -> (Comic -> Page -> Model -> View Action) + -> ComicId -> Page -> Model -> View Action +viewOr404 comics f id pg model = + case findComic id comics of + Just c -> f c pg model + Nothing -> the404 model + +template :: MisoString -> [View Action] -> View Action +template id rest = div_ [id_ id, class_ "app is-black"] rest + +closeButton :: View Action +closeButton = a_ [ id_ "close-button", onClick $ ChangeURI discoverLink ] + [ text "x" ] + +zoomScreen :: Comic -> Page -> Model -> View Action +zoomScreen comic page model = template "comic-player" + [ topbar + , main_ + [id_ "app-body"] + [ img_ + [ src_ comicImg + , class_ "comic-page-full" + ] + ] + , comicControls comic page model + ] + where + comicImg = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> padLeft page + <> ".png" + +comicSpread :: Comic -> Page -> Model -> View Action +comicSpread comic page model = template "comic-player" + [ topbar + , main_ + [id_ "app-body"] + [ div_ + [class_ "comic-player"] + [ img_ [ src_ comicImgLeft, class_ "comic-page" ] + , img_ [ src_ comicImgRight, class_ "comic-page" ] + ] + , closeButton + ] + , appmenu + , comicControls comic page model + ] + where + comicImgLeft, comicImgRight :: MisoString + comicImgLeft = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> padLeft page + <> ".png" + comicImgRight = + ms Assets.demo + <> ms (comicSlug comic) + <> "-" + <> (padLeft $ 1 + page) + <> ".png" + +frameborder_ :: MisoString -> Attribute action +frameborder_ = textProp "frameborder" + +allowfullscreen_ :: Bool -> Attribute action +allowfullscreen_ = boolProp "allowfullscreen" + +comicVideo :: Comic -> Page -> Model -> View Action +comicVideo _ _ _ = template "comic-player" + [ topbar + , main_ + [ id_ "app-body" ] + [ div_ [class_ "comic-video"] + [ iframe_ + [ src_ "//player.vimeo.com/video/325757560" + , frameborder_ "0" + , allowfullscreen_ True + ] + [] + ] + ] + ] + +padLeft :: Int -> MisoString +padLeft n | n < 10 = ms $ ("0" <> Legacy.show n) + | otherwise = ms $ Legacy.show n + +comicControls :: Comic -> Page -> Model -> View Action +comicControls comic page model = footer_ + [ id_ "app-foot", class_ "comic-controls" ] + [ div_ + [ class_ "comic-nav-audio" + , css $ flexCenter ] + [ audio_ + [id_ audioId, loop_ True, crossorigin_ "anonymous"] + [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]] + , el $ PlayPause audioId $ cpAudioState model + , span_ + [ css $ euro <> thicc <> smol <> wide ] + [ text "Experiencing: Original" ] + ] + , div_ + [ class_ "comic-controls-pages", css euro ] + [ el $ Arrow $ PrevPage + , span_ [] [ text $ leftPage <> "-" <> rightPage <> " of " <> totalpages ] + , el $ Arrow $ NextPage + ] + , div_ [class_ "comic-controls-share"] + [ el $ SaveIcon comic $ userLibrary model + , el $ ZoomIcon (zoomModel model) comic page + , button_ + [class_ "button icon is-large", onClick ToggleFullscreen] + [i_ [ class_ "fa fa-expand" ] []] + ] + ] + where + leftPage = ms . Legacy.show $ page + rightPage = ms . Legacy.show $ 1 + page + totalpages = ms . Legacy.show $ comicPages comic + +login :: Model -> View Action +login _ = template "login" + [ div_ [ id_ "login-inner" ] + [ img_ [ class_ fadeIn + , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png" + ] + , hr_ [class_ fadeIn] + , form_ [class_ fadeIn] + [ ctrl [class_ "input", type_ "email", placeholder_ "Email"] + , ctrl [class_ "input", type_ "password", placeholder_ "Password"] + , div_ [class_ "action", css euro] + [ div_ [class_ "checkbox remember-me"] + [ input_ [type_ "checkbox"] + , label_ [Miso.for_ "checkbox"] [text "Remember Me"] + ] + , div_ [class_ "button is-black", onClick $ ChangeURI discoverLink] + [ text "Login" ] + ] + ] + , hr_ [class_ fadeIn] + , p_ [ class_ $ "help " <> fadeIn ] + [ a_ [href_ "#"][text "Forgot your username or password?"] + , a_ [href_ "#"][text "Don't have an account? Sign Up"] + ] + , img_ [ id_ "hero-logo" + , class_ "blur-out" + , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png" + ] + ] + ] + where + fadeIn = "animated fadeIn delay-2s" + ctrl x = div_ [class_ "control"] [ input_ x ] + +chooseExperiencePage :: Comic -> Page -> Model -> View Action +chooseExperiencePage comic page model = template "choose-experience" + [ topbar + , main_ [ id_ "app-body" ] + [ h2_ [] [ text "Choose Your Musical Experience" ] + , p_ [] [ text experienceBlurb ] + , ul_ [] $ li comic /@ experiences + ] + , appmenu + , comicControls comic page model + ] + where + li c (name, artist, track) = li_ + [ onClick $ StartReading c ] + [ div_ [] + [ img_ [ src_ $ ms $ Assets.demo <> name <> ".png" ] + , span_ [] [ text $ ms name ] + ] + , span_ [ css $ thicc ] [ text $ ms artist ] + , span_ [] [ text $ ms track ] + ] + experiences :: [(Text, Text, Text)] + experiences = + [ ("comedic", "RxGF", "Soft Reveal") + , ("dark", "Logan Henderson", "Speak of the Devil") + , ("original", "Mehcad Brooks", "Stars") + , ("energetic", "Skela", "What's wrong with me") + , ("dramatic", "Josh Jacobson", "Sideline") + ] + + +experienceBlurb :: MisoString +experienceBlurb = [s| +As you enter the world of Hero, you will find that music and visual art have a +symbiotic relationship that can only be experienced, not described. Here, choose +the tonality of the experience you wish to adventure on, whether it's a comedic, +dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey +with the original curated music for this piece of visual art. +|] + +topbar :: View Action +topbar = header_ + [id_ "app-head", class_ "is-black", css euro] + [ a_ + [class_ "button is-medium is-black", onClick $ ChangeURI homeLink] + [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]] + , div_ + [id_ "app-head-right"] + [ button_ [class_ "button icon is-medium is-black"] + [i_ [class_ "fas fa-search" ] []] + , button_ [ class_ "button is-medium is-black is-size-7" + , css $ euro <> wide <> thicc + ] + [text "News"] + , span_ [ class_ "icon is-large" ] + [ i_ [ class_ "fas fa-user" ] [] + ] + ] + ] + +row :: [View Action] -> View Action +row = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row ] + +column :: [View Action] -> View Action +column = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column ] + +-- | Links + +comicLink :: ComicId -> URI +comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_ + +comicPlayerSpreadLink :: ComicId -> Page -> URI +comicPlayerSpreadLink id page = + linkURI $ safeLink routes comicPlayerSpreadProxy id page + +comicPlayerFullLink :: ComicId -> Page -> URI +comicPlayerFullLink id page = + linkURI $ safeLink routes comicPlayerFullProxy id page + +comicVideoLink :: ComicId -> Page -> URI +comicVideoLink id page = + linkURI $ safeLink routes comicVideoProxy id page + +homeLink :: URI +homeLink = linkURI $ safeLink routes homeProxy + +loginLink :: URI +loginLink = linkURI $ safeLink routes loginProxy + +discoverLink :: URI +discoverLink = linkURI $ safeLink routes discoverProxy + +the404 :: Model -> View Action +the404 _ = template "404" [p_ [] [text "Not found"]] + +chooseExperienceLink :: ComicId -> Page -> URI +chooseExperienceLink id page = + linkURI $ safeLink routes chooseExperienceProxy id page diff --git a/Com/MusicMeetsComics/Assets.hs b/Com/MusicMeetsComics/Assets.hs new file mode 100644 index 0000000..f4fabde --- /dev/null +++ b/Com/MusicMeetsComics/Assets.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | A module to wrap the CDN and provide convient helper functions to assets. +module Com.MusicMeetsComics.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/Com/MusicMeetsComics/Database.hs b/Com/MusicMeetsComics/Database.hs new file mode 100644 index 0000000..8178e9a --- /dev/null +++ b/Com/MusicMeetsComics/Database.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Com.MusicMeetsComics.Database + ( + ComicDB + , getComics + , load + ) where + +import Com.MusicMeetsComics.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" + +listToComicDB :: [Comic] -> ComicDB +listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls + +getComics :: ComicDB -> Handler [Comic] +getComics db = return $ Map.elems db diff --git a/Com/MusicMeetsComics/Look.hs b/Com/MusicMeetsComics/Look.hs new file mode 100644 index 0000000..f53955c --- /dev/null +++ b/Com/MusicMeetsComics/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 Com.MusicMeetsComics.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 Com.MusicMeetsComics.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/Com/MusicMeetsComics/Look/Typography.hs b/Com/MusicMeetsComics/Look/Typography.hs new file mode 100644 index 0000000..91e157a --- /dev/null +++ b/Com/MusicMeetsComics/Look/Typography.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Com.MusicMeetsComics.Look.Typography where + +import Clay +import Clay.Stylesheet (key) +import qualified Com.MusicMeetsComics.Assets as Assets +import Com.Simatime.Alpha +import Data.Semigroup ((<>)) +import Protolude + +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 + +--------------------------------------------------------------------------------- +-- font faces +--------------------------------------------------------------------------------- + +fontRoot :: Text +fontRoot = Assets.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" + +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/Com/MusicMeetsComics/Server/Config.hs b/Com/MusicMeetsComics/Server/Config.hs new file mode 100644 index 0000000..2bbfabc --- /dev/null +++ b/Com/MusicMeetsComics/Server/Config.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Com.MusicMeetsComics.Server.Config where + +import Com.MusicMeetsComics.Server.Logger +import Control.Concurrent (ThreadId) +import Control.Monad.Except (ExceptT, MonadError) +import Control.Monad.IO.Class +import Control.Monad.Logger (MonadLogger(..)) +import Control.Monad.Metrics (Metrics, MonadMetrics, getMetrics) +import qualified Control.Monad.Metrics as M +import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks) +import Data.Text (pack) +import GHC.Base (String) +import Network.Wai (Middleware) +import Network.Wai.Handler.Warp (Port) +import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev) +import Protolude +import Safe (readMay) +import Servant (ServantErr) +import System.Environment (lookupEnv) +import System.Remote.Monitoring (forkServer, serverMetricStore, serverThreadId) + +-- | This type represents the effects we want to have for our application. +-- We wrap the standard Servant monad with 'ReaderT Config', which gives us +-- access to the application configuration using the 'MonadReader' +-- interface's 'ask' function. +-- +-- By encapsulating the effects in our newtype, we can add layers to the +-- monad stack without having to modify code that uses the current layout. +newtype AppT m a = AppT + { runApp :: ReaderT Config (ExceptT ServantErr m) a + } deriving ( Functor + , Applicative + , Monad + , MonadReader Config + , MonadError ServantErr + , MonadIO + ) + +type App = AppT IO + +-- | The Config for our application is (for now) the 'Environment' we're +-- running in and a Persistent 'ConnectionPool'. +data Config = Config + { configEnv :: Environment + , configMetrics :: Metrics + , configEkgServer :: ThreadId + , configLogEnv :: LogEnv + , configPort :: Port + } + +instance Monad m => MonadMetrics (AppT m) where + getMetrics = asks configMetrics + +-- | Katip instance for @AppT m@ +instance MonadIO m => Katip (AppT m) where + getLogEnv = asks configLogEnv + localLogEnv = panic "not implemented" + +-- | MonadLogger instance to use within @AppT m@ +instance MonadIO m => MonadLogger (AppT m) where + monadLoggerLog = adapt logMsg + +-- | MonadLogger instance to use in @makePool@ +instance MonadIO m => MonadLogger (KatipT m) where + monadLoggerLog = adapt logMsg + +-- | Right now, we're distinguishing between three environments. We could +-- also add a @Staging@ environment if we needed to. +data Environment + = Development + | Test + | Production + deriving (Eq, Show, Read) + +-- | This returns a 'Middleware' based on the environment that we're in. +setLogger :: Environment -> Middleware +setLogger Test = identity +setLogger Development = logStdoutDev +setLogger Production = logStdout + +-- | Web request logger (currently unimplemented and unused). For inspiration +-- see ApacheLogger from wai-logger package. +katipLogger :: LogEnv -> Middleware +katipLogger env app req respond = + runKatipT env $ do + logMsg "web" InfoS "todo: received some request" + -- todo: log proper request data + liftIO $ app req respond + +-- | The number of pools to use for a given environment. +envPool :: Environment -> Int +envPool Test = 1 +envPool Development = 1 +envPool Production = 8 + +-- | Allocates resources for 'Config' +acquire :: IO Config +acquire = do + port <- lookupSetting "PORT" 3001 + env <- lookupSetting "ENV" Development + logEnv <- defaultLogEnv + ekgServer <- forkServer "localhost" 8000 + let store = serverMetricStore ekgServer + metr <- M.initializeWith store + pure + Config + { configEnv = env + , configMetrics = metr + , configLogEnv = logEnv + , configPort = port + , configEkgServer = serverThreadId ekgServer + } + +-- | Looks up a setting in the environment, with a provided default, and +-- 'read's that information into the inferred type. +lookupSetting :: Read a => String -> a -> IO a +lookupSetting env def_ = do + maybeValue <- lookupEnv env + case maybeValue of + Nothing -> return def_ + Just str -> maybe (handleFailedRead str) return (readMay str) + where + handleFailedRead str = panic + $ mconcat ["Failed to read [[", pack str, "]] for environment variable ", pack env] diff --git a/Com/MusicMeetsComics/Server/Init.hs b/Com/MusicMeetsComics/Server/Init.hs new file mode 100644 index 0000000..7ad3ebf --- /dev/null +++ b/Com/MusicMeetsComics/Server/Init.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Server.Init where + +import qualified Com.MusicMeetsComics.Server.Config as Config +import Control.Concurrent (killThread) +import Control.Exception (bracket) +import qualified Control.Monad.Metrics as M +import qualified Katip +import Lens.Micro ((^.)) +import Network.Wai (Application, Middleware) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Metrics (metrics, registerWaiMetrics) +import Network.Wai.Middleware.Gzip +import Protolude +import qualified System.IO as IO + +-- | An action that creates a WAI 'Application' together with its resources, +-- runs it, and tears it down on exit +runApp :: (Config.Config -> Application) -> IO () +runApp app = bracket Config.acquire shutdownApp jog + where + say = IO.hPutStrLn IO.stderr + jog config = do + say $ "hero" + say $ "port: " ++ show (Config.configPort config) + run (Config.configPort config) =<< initialize app config + +-- | The 'initialize' function accepts the required environment information, +-- initializes the WAI 'Application' and returns it +initialize :: (Config.Config -> Application) -> Config.Config -> IO Application +initialize app cfg = do + waiMetrics <- registerWaiMetrics (Config.configMetrics cfg ^. M.metricsStore) + let logger = Config.setLogger (Config.configEnv cfg) + -- generateJavaScript + pure . logger . metrics waiMetrics . app $ cfg + +compress :: Middleware +compress = gzip def { gzipFiles = GzipCompress } + +-- | Takes care of cleaning up 'Config.Config' resources +shutdownApp :: Config.Config -> IO () +shutdownApp cfg = do + _ <- Katip.closeScribes (Config.configLogEnv cfg) + -- Monad.Metrics does not provide a function to destroy metrics store + -- so, it'll hopefully get torn down when async exception gets thrown + -- at metrics server process + killThread (Config.configEkgServer cfg) + pure () diff --git a/Com/MusicMeetsComics/Server/Logger.hs b/Com/MusicMeetsComics/Server/Logger.hs new file mode 100644 index 0000000..eb37ef6 --- /dev/null +++ b/Com/MusicMeetsComics/Server/Logger.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Com.MusicMeetsComics.Server.Logger + ( adapt + , defaultLogEnv + , logMsg + , runKatipT + , KatipT(..) + , Katip(..) + , LogEnv + , Severity(..) + ) where + +import Control.Monad.Logger +import qualified Control.Monad.Logger as Logger +import Katip +import Protolude +import qualified System.IO as IO +import qualified System.Log.FastLogger as FastLogger + +defaultLogEnv :: IO LogEnv +defaultLogEnv = do + handleScribe <- mkHandleScribe ColorIfTerminal IO.stdout DebugS V2 + env <- initLogEnv "hero" "production" + registerScribe "stdout" handleScribe defaultScribeSettings env + +fromLevel :: LogLevel -> Severity +fromLevel LevelDebug = DebugS +fromLevel LevelInfo = InfoS +fromLevel LevelWarn = WarningS +fromLevel LevelError = ErrorS +fromLevel (LevelOther _) = NoticeS + +-- | Transforms Katip logMsg into monadLoggerLog to be used inside +-- MonadLogger monad +adapt :: + (ToLogStr msg, Applicative m, Katip m) + => (Namespace -> Severity -> Katip.LogStr -> m ()) + -> Loc + -> LogSource + -> LogLevel + -> msg + -> m () +adapt f _ src lvl msg = f ns (fromLevel lvl) $ logStr' msg + where + ns = Namespace [src] + -- not sure how fast this is going to be + logStr' = Katip.logStr . FastLogger.fromLogStr . Logger.toLogStr |