diff options
Diffstat (limited to 'Hero')
| -rw-r--r-- | Hero/Core.hs | 939 | ||||
| -rw-r--r-- | Hero/Host.hs | 395 | ||||
| -rw-r--r-- | Hero/Keep.hs | 109 | ||||
| -rw-r--r-- | Hero/Look.hs | 568 | ||||
| -rw-r--r-- | Hero/Look/Typography.hs | 84 | ||||
| -rw-r--r-- | Hero/Node.hs | 248 | ||||
| -rw-r--r-- | Hero/Pack.hs | 16 | ||||
| -rw-r--r-- | Hero/Prod.nix | 57 | ||||
| -rw-r--r-- | Hero/Service.nix | 88 |
9 files changed, 0 insertions, 2504 deletions
diff --git a/Hero/Core.hs b/Hero/Core.hs deleted file mode 100644 index 86b0638..0000000 --- a/Hero/Core.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.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.Quote -import Data.Text (Text) -import GHC.Generics (Generic) -import qualified GHC.Show as Legacy -import Hero.Look as Look -import Hero.Look.Typography -import qualified Hero.Pack as Pack -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 Move - - -- | Render a featured banner. - feature :: o -> User -> View Move - - -- | Media info view - info :: o -> User -> View Move - --- | 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 PageNumber - | PlayPause MisoString AudioState - | Arrow Move - --- | Class for defining general, widely used elements in the heroverse. -class Elemental v where el :: v -> View Move - --- 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 form) = - button_ - [ class_ "button is-large icon", - onClick <| ToggleAudio id - ] - [i_ [class_ <| "fa " <> icon] []] - where - icon = case form of - Paused -> "fa-play-circle" - Playing -> "fa-pause-circle" - el (Arrow act) = - button_ - [class_ "button is-large turn-page", onClick act] - [img_ [src_ <| ms <| Pack.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 <| Pack.icon <> "save.svg"], - span_ [] [text "saved"] - ] - else -- not in library - - a_ - [class_ "wrs-button", onClick <| ToggleInLibrary c] - [ img_ [src_ <| ms <| Pack.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 <| Pack.demo <> "library-add.png"]] - else -- not in library - - button_ - [ class_ "button is-large has-background-black-bis", - onClick <| ToggleInLibrary c - ] - [img_ [src_ <| ms <| Pack.demo <> "library-add.png"]] - el (ZoomIcon zform comic page) = - button_ - [ id_ "zoom-button", - class_ "button is-large", - onClick <| ToggleZoom comic page - ] - [ img_ [src_ <| ms <| Pack.demo <> "zoom.png"], - input_ - [ type_ "range", - min_ "0", - max_ "100", - disabled_ True, - value_ <| ms (show zform :: String), - class_ "ctrl", - id_ "zoom" - ], - label_ - [class_ "ctrl", Miso.for_ "zoom"] - [text <| ms <| (show zform :: String) ++ "%"] - ] - el (Read c) = - a_ - [class_ "wrs-button", onClick <| SelectExperience c] - [ img_ [src_ <| ms <| Pack.icon <> "read.svg"], - span_ [] [text "read"] - ] - el (Watch c) = - a_ - [class_ "wrs-button", onClick <| StartWatching c] - [ img_ [src_ <| ms <| Pack.icon <> "watch.svg"], - span_ [] [text "watch"] - ] - -data AudioState = Playing | Paused - deriving (Show, Eq) - -data ComicReaderState - = NotReading - | Cover ComicId - | ChooseExperience ComicId PageNumber - | Reading ComicReaderView ComicId PageNumber - | Watching ComicId - deriving (Show, Eq) - -findComic :: ComicId -> [Comic] -> Maybe Comic -findComic id = List.find (\c -> comicId c == id) - --- | Main form for the app. --- --- Try to prefix component-specific state with the component initials: 'd' for --- discover, 'cp' for comic player. -data Form = Form - { uri :: Api.URI, - appComics :: RemoteData MisoString [Comic], - user :: User, - dMediaInfo :: Maybe Comic, - cpState :: ComicReaderState, - cpAudioState :: AudioState, - magnification :: Magnification - } - deriving (Show, Eq) - -initForm :: Api.URI -> Form -initForm uri_ = - Form - { 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 PageNumber) - -type PageNumber = Int - -data Move - = NoOp - | -- comic player stuff - SelectExperience Comic - | StartReading Comic - | StartWatching Comic - | NextPage - | PrevPage - | ToggleZoom Comic PageNumber - | 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 - | Dumpform - deriving (Show, Eq) - -type AppRoutes = - Home - :<|> ComicCover - :<|> ComicReaderSpread - :<|> ComicReaderFull - :<|> ComicVideo - :<|> Discover - :<|> ChooseExperience - -handlers = - home - :<|> 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 Move --- proxy :: Proxy name --- proxy = Proxy name --- view :: form -> View Move --- link :: Api.URI - --- ** home - --- --- this is the unauthenticated page that you see when you first visit - -type Home = - View Move - -homeProxy :: Proxy Home -homeProxy = Proxy - -homeLink :: Api.URI -homeLink = linkURI <| Api.safeLink front homeProxy - where - front = Proxy :: Proxy Home - -home :: form -> View Move -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 Move - -loginProxy :: Proxy Login -loginProxy = Proxy - -loginLink :: Api.URI -loginLink = linkURI <| Api.safeLink pubRoutes loginProxy - -login :: form -> View Move -login _ = - template - "login" - [ div_ - [id_ "login-inner"] - [ img_ - [ class_ fadeIn, - src_ <| ms <| Pack.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 <| Pack.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 Move - -discoverLink :: Api.URI -discoverLink = linkURI <| Api.safeLink routes discoverProxy - -discoverProxy :: Proxy Discover -discoverProxy = Proxy - -discover :: Form -> View Move -discover form@Form {user = u} = - template - "discover" - [ topbar, - main_ [id_ "app-body"] <| case appComics form of - NotAsked -> [loading] - Loading -> [loading] - Failure _ -> [nocomics] - Success [] -> [nocomics] - Success (comic : rest) -> - [ feature comic u, - shelf "Recent Releases" (comic : rest), - maybeView (`info` u) <| dMediaInfo form - ], - appmenu, - discoverFooter - ] - -discoverFooter :: View Move -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 Dumpform] - [ a_ [class_ "social-icon", href_ "#"] [img_ [src_ <| ms <| Pack.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 <| Pack.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 <| Pack.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 <| Pack.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 - <| Pack.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 <| Pack.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 Move - -comicProxy :: Proxy ComicCover -comicProxy = Proxy - -comicCover :: ComicId -> Form -> View Move -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" PageNumber - :> "experience" - :> View Move - -chooseExperienceProxy :: Proxy ChooseExperience -chooseExperienceProxy = Proxy - -chooseExperienceLink :: ComicId -> PageNumber -> Api.URI -chooseExperienceLink id page = - linkURI <| Api.safeLink routes chooseExperienceProxy id page - -chooseExperiencePage :: Comic -> PageNumber -> Form -> View Move -chooseExperiencePage comic page form = - 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 form - ] - where - li c (name, artist, track) = - li_ - [onClick <| StartReading c] - [ div_ - [] - [ img_ [src_ <| ms <| Pack.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. -|] - --- ** comicReader - -data ComicReaderView = Spread | Full - deriving (Show, Eq) - -comicReader :: ComicId -> PageNumber -> Form -> View Move -comicReader _ _ form = case appComics form of - NotAsked -> loading - Loading -> loading - Failure _ -> nocomics - Success comics -> case cpState form of - NotReading -> template "comic-player" [text "error: not reading"] - Cover id -> viewOr404 comics comicSpread id 1 form - ChooseExperience id pg -> - viewOr404 comics chooseExperiencePage id pg form - Reading Spread id pg -> viewOr404 comics comicSpread id pg form - Reading Full id pg -> viewOr404 comics zoomScreen id pg form - Watching id -> viewOr404 comics comicVideo id 0 form - -zoomScreen :: Comic -> PageNumber -> Form -> View Move -zoomScreen comic page form = - template - "comic-player" - [ topbar, - main_ - [id_ "app-body"] - [ img_ - [ src_ comicImg, - class_ "comic-page-full" - ] - ], - comicControls comic page form - ] - where - comicImg = - ms Pack.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" - --- ** comicReaderSpread - -type ComicReaderSpread = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" PageNumber - :> View Move - -comicReaderSpreadProxy :: Proxy ComicReaderSpread -comicReaderSpreadProxy = Proxy - -comicReaderSpreadLink :: ComicId -> PageNumber -> Api.URI -comicReaderSpreadLink id page = - linkURI <| Api.safeLink routes comicReaderSpreadProxy id page - -comicSpread :: Comic -> PageNumber -> Form -> View Move -comicSpread comic page form = - 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 form - ] - where - comicImgLeft, comicImgRight :: MisoString - comicImgLeft = - ms Pack.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft page - <> ".png" - comicImgRight = - ms Pack.demo - <> ms (comicSlug comic) - <> "-" - <> padLeft (1 + page) - <> ".png" - -closeButton :: View Move -closeButton = - a_ - [id_ "close-button", onClick <| ChangeURI discoverLink] - [text "x"] - --- * comicReaderFull - -type ComicReaderFull = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" PageNumber - :> "full" - :> View Move - -comicReaderFullProxy :: Proxy ComicReaderFull -comicReaderFullProxy = Proxy - -comicReaderFullLink :: ComicId -> PageNumber -> Api.URI -comicReaderFullLink id page = - linkURI <| Api.safeLink routes comicReaderFullProxy id page - --- * comicVideo - -type ComicVideo = - "comic" - :> Api.Capture "id" ComicId - :> Api.Capture "page" PageNumber - :> "video" - :> View Move - -comicVideoProxy :: Proxy ComicVideo -comicVideoProxy = Proxy - -comicVideoLink :: ComicId -> PageNumber -> 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 -> PageNumber -> Form -> View Move -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 Move -mediaInfo Nothing _ = text "" -mediaInfo (Just comic) user = - div_ [class_ "media-info"] [info comic user] - -appmenu :: View Move -appmenu = aside_ [id_ "appmenu"] <| btn </ links - where - links = - -- these extra 'discoverLink's are just dummies - [ (discoverLink, "discover.svg", "discover"), - (discoverLink, "save.svg", "library"), - (discoverLink, "watch.svg", "videos"), - (comicLink "1", "read.svg", "comics"), - (discoverLink, "listen.svg", "music") - ] - btn (lnk, img, label) = - a_ - [ class_ "button", - onPreventClick <| ChangeURI lnk - ] - [ img_ [src_ <| ms <| Pack.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 Move -loading = div_ [class_ "loading"] [text "Loading..."] - -nocomics :: View Move -nocomics = div_ [class_ "loading"] [text "error: no comics found"] - -shelf :: IsMediaObject o => MisoString -> [o] -> View Move -shelf title comics = - div_ - [class_ "shelf"] - [ div_ [class_ "shelf-head"] [text title], - ul_ [class_ "shelf-body"] <| thumbnail </ comics - ] - -viewOr404 :: - [Comic] -> - (Comic -> PageNumber -> form -> View Move) -> - ComicId -> - PageNumber -> - form -> - View Move -viewOr404 comics f id pg form = - case findComic id comics of - Just c -> f c pg form - Nothing -> the404 form - -template :: MisoString -> [View Move] -> View Move -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 -> PageNumber -> Form -> View Move -comicControls comic page form = - footer_ - [id_ "app-foot", class_ "comic-controls"] - [ div_ - [ class_ "comic-nav-audio", - css flexCenter - ] - [ audio_ - [id_ audioId, loop_ True, crossorigin_ "anonymous"] - [source_ [src_ <| ms <| Pack.demo <> "stars-instrumental.mp3"]], - el <| PlayPause audioId <| cpAudioState form, - 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 form, - el <| ZoomIcon (magnification form) 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 Move -topbar = - header_ - [id_ "app-head", class_ "is-black", css euro] - [ a_ - [ class_ "button is-medium is-black", - onClick <| ChangeURI discoverLink - ] - [img_ [src_ <| ms <| Pack.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 Move] -> View Move -row = div_ [css <| Clay.display Clay.flex <> Clay.flexDirection Clay.row] - -column :: [View Move] -> View Move -column = div_ [css <| Clay.display Clay.flex <> Clay.flexDirection Clay.column] - --- | Links -the404 :: form -> View Move -the404 _ = template "404" [p_ [] [text "Not found"]] diff --git a/Hero/Host.hs b/Hero/Host.hs deleted file mode 100644 index 7cc5986..0000000 --- a/Hero/Host.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Hero web app --- --- : out mmc -module Hero.Host - ( main, - ) -where - -import Alpha -import Biz.App (CSS (..), Manifest (..)) -import qualified Biz.Cli as Cli -import qualified Biz.Log as Log -import Biz.Test ((@=?)) -import qualified Biz.Test as Test -import qualified Clay -import qualified Crypto.JOSE.JWK as Crypto -import Data.Acid (AcidState) -import qualified Data.Acid.Abstract as Acid -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import Hero.Core -import qualified Hero.Keep as Keep -import qualified Hero.Look as Look -import qualified Hero.Look.Typography as Typography -import qualified Hero.Pack as Pack -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 = Cli.main <| Cli.Plan help move test pure - -help :: Cli.Docopt -help = - [Cli.docopt| -mmc - -Usage: - mmc - mmc test -|] - -test :: Test.Tree -test = Test.group "Hero.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)] - -move :: Cli.Arguments -> IO () -move _ = 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) - Log.info ["!", "hero"] >> Log.br - Log.info ["port", show <| heroPort cfg] >> Log.br - Log.info ["keep", Text.pack <| heroKeep cfg] >> Log.br - Log.info ["node", Text.pack <| heroNode cfg] >> Log.br - Log.info ["skey", Text.pack <| heroSkey cfg] >> Log.br - let jwts = Auth.defaultJWTSettings skey - cs = - Auth.defaultCookieSettings - { -- uncomment this for insecure dev - Auth.cookieIsSecure = Auth.NotSecure, - Auth.cookieXsrfSetting = Nothing - } - ctx = cs :. jwts :. EmptyContext - proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie]) - 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 - pure - ( cfg, - serveWithContext - proxy - ctx - server, - keep - ) - shutdown :: App -> IO () - shutdown (_, _, keep) = do - Keep.close keep - pure () - -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/dev/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 Move - --- | These are the main app handlers, and should require authentication. -appHostHandlers :: User -> Server AppHostRoutes -appHostHandlers _ = - homeHandler - :<|> comicCoverHandler - :<|> comicPageHandler - :<|> comicPageFullHandler - :<|> comicVideoHandler - :<|> discoverHandler - :<|> chooseExperienceHandler - --- | Marketing pages -type PubHostRoutes = ToServerRoutes PubRoutes Templated Move - -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 authResult = case authResult of - Auth.Authenticated u -> f u - Auth.BadPassword -> Auth.throwAll err401 - Auth.NoSuchUser -> Auth.throwAll err406 - Auth.Indefinite -> Auth.throwAll err422 - -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 = - pure <. 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") -> - applyCreds <| User "ben@bsima.me" "ben" [] - (LoginForm "mcovino@heroprojects.io" "test") -> - 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 -> pure <| 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_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" - ] - L.link_ - [ L.rel_ "icon", - L.type_ "image/png", - L.sizes_ "32x32", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-32x32.png" - ] - L.link_ - [ L.rel_ "icon", - L.type_ "image/png", - L.sizes_ "16x16", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-16x16.png" - ] - L.link_ - [ L.rel_ "manifest", - L.href_ - <| Pack.cdnEdge - <> "/old-assets/images/favicons/manifest.json" - ] - L.link_ - [ L.rel_ "mask-icon", - L.href_ - <| Pack.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] - -handle404 :: Application -handle404 _ respond = - respond - <| responseLBS status404 [("Content-Type", "text/html")] - <| renderBS - <| toHtml - <| Templated - <| the404 - <| initForm 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 Move)) -homeHandler = pure <. Templated <. home <| initForm homeLink - -comicCoverHandler :: ComicId -> Handler (Templated (View Move)) -comicCoverHandler id = - pure <. Templated <. comicCover id <. initForm <| comicLink id - -comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicPageHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicReaderSpreadLink id n - -comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicPageFullHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicReaderFullLink id n - -comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -comicVideoHandler id n = - pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n - -discoverHandler :: Handler (Templated (View Move)) -discoverHandler = pure <. Templated <. discover <| initForm discoverLink - -chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) -chooseExperienceHandler id n = - pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n - -loginHandler :: Handler (Templated (View Move)) -loginHandler = pure <. Templated <. login <| initForm loginLink diff --git a/Hero/Keep.hs b/Hero/Keep.hs deleted file mode 100644 index 10ef732..0000000 --- a/Hero/Keep.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Hero.Keep - ( HeroKeep, - GetComics (..), - getComics, - NewComic (..), - newComic, - open, - close, - ) -where - -import Alpha -import Data.Acid (Update, makeAcidic) -import qualified Data.Acid as Acid -import Data.Data (Data, Typeable) -import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet) -import qualified Data.IxSet as IxSet -import Data.SafeCopy (base, deriveSafeCopy) -import qualified Data.Text as Text -import Hero.Core - --- * Keep - --- | Main database. -data HeroKeep = HeroKeep - { _comics :: IxSet Comic, - _users :: IxSet User - } - deriving (Data, Typeable) - -$(deriveSafeCopy 0 'base ''HeroKeep) - --- * Index @Comic@ - -$(deriveSafeCopy 0 'base ''Comic) - -$(deriveSafeCopy 0 'base ''User) - -$(deriveSafeCopy 0 'base ''ComicId) - -instance Indexable Comic where - empty = - ixSet - [ ixFun <| \c -> [comicId c], - ixFun <| \c -> [comicPages c], - ixFun <| \c -> [comicName c], - ixFun <| \c -> [comicIssue c], - ixFun <| \c -> [comicDescription c] - ] - -instance Indexable User where - empty = - ixSet - [ ixFun <| \u -> [userEmail u], - ixFun <| \u -> [userName u], - ixFun <| \u -> [userLibrary u] - ] - -newComic :: Comic -> Update HeroKeep Comic -newComic c = do - keep <- get - put <| keep {_comics = IxSet.insert c (_comics keep)} - pure c - -getComics :: Int -> Acid.Query HeroKeep [Comic] -getComics n = ask /> _comics /> IxSet.toList /> take n - --- * Opening the keep - -$(makeAcidic ''HeroKeep ['newComic, 'getComics]) - -initialHeroKeep :: HeroKeep -initialHeroKeep = - HeroKeep - { _comics = IxSet.fromList [theRed], - _users = - IxSet.fromList - [ User "a" "micheal" [], - User "b" "ben" [] - ] - } - where - theRed = - Comic - { comicId = "1", - comicPages = 42, - comicName = "The Red", - comicIssue = "1.0", - comicDescription = - Text.unlines - [ "In the future, a nuclear world war has changed the course", - "of history forever. A single government entity now presides", - "over what's left of the world, and prohibits certain content", - "that is deemed emotionall dangerous, or \"red\", in attempt", - "to maintain order and keep society working..." - ] - } - -open :: String -> IO (Acid.AcidState HeroKeep) -open dir = Acid.openLocalStateFrom dir initialHeroKeep - -close :: Acid.AcidState HeroKeep -> IO () -close = Acid.closeAcidState diff --git a/Hero/Look.hs b/Hero/Look.hs deleted file mode 100644 index e3958d5..0000000 --- a/Hero/Look.hs +++ /dev/null @@ -1,568 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -{- HLINT ignore "Use |>" -} - --- | Styles --- --- Eventually move make this mostly well-typed. Use this EDSL: --- http://fvisser.nl/clay/ -module Hero.Look where - -import Alpha hiding (rem, (**), (|>)) -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 qualified Data.Map as Map -import qualified Data.Text.Lazy as L -import Hero.Look.Typography as Typo -import Miso (Attribute, style_, (=:)) -import Miso.String (MisoString, toMisoString) - -main :: Css -main = do - -- bulma adjustments - input ? marginRight (px 10) <> marginBottom (px 10) - -- base - ".fixed" ? position fixed - ".clickable" ? clickable - ".row" ? centerJustify - a <> a # hover <> a # visited ? do - color white - textDecoration none - ".loading" ? do - centered - 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 - centered - height (vh 100) - "#login-inner" ? do - centered - 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 - ? 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 - centerJustify - 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 - justifyContent center - alignSelf flexStart - flexDirection column - 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 - centered - flexDirection column - 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 - -centered :: Css -centered = do - display flex - justifyContent center - alignItems center - alignSelf center - -centerJustify :: Css -centerJustify = do - display flex - alignItems center - justifyContent spaceBetween - -hide :: Css -hide = visibility hidden - -remove :: Css -remove = display none - -noBorder :: Css -noBorder = border none 0 transparent - -mobile :: Css -> Css -mobile = query Clay.all [Media.maxDeviceWidth (px 500)] - -desktop :: Css -> Css -desktop = query Clay.all [Media.minDeviceWidth (px 500)] - -rounded :: Css -rounded = borderRadius (px 30) (px 30) (px 30) (px 30) - -appmenuWidth :: Size LengthUnit -appmenuWidth = px 67 - -flexCenter :: Css -flexCenter = do - display flex - justifyContent center - justifyItems center - alignContent center - alignItems center - -blank :: Content -blank = stringContent "" - -divv :: Clay.Selector -divv = Clay.div - -marginAll :: Size a -> Css -marginAll x = margin x x x x - -marginX :: Size a -> Css -marginX n = marginLeft n <> marginRight n - -marginY :: Size a -> Css -marginY n = marginTop n <> marginBottom n - -clickable :: Css -clickable = cursor pointer - --- heroic colors --------------------------------------------------------------- - -hero :: Color -hero = rgb 241 32 32 -- #f12020 - -nite :: Color -nite = rgb 10 10 10 -- #0a0a0a - -grai :: Color -grai = rgb 221 221 221 -- #dddddd - --- runtime (client) style stuff ------------------------------------------------ - --- | Put 'Clay.Css' into a Miso-compatible style property. --- --- Allows us to use any amount of CSS written with Clay inlined in HTML or --- dynamically as JavaScript object properties. The implementation is a bit --- hacky, but works. -css :: Clay.Css -> Attribute action -css = Miso.style_ <. Map.fromList <. f <. Clay.renderWith Clay.htmlInline [] - where - f :: L.Text -> [(MisoString, MisoString)] - f t = - L.splitOn ";" t - <&> L.splitOn ":" - <&> \(x : y) -> (toMisoString x, toMisoString <| L.intercalate ":" y) - -inlineCss :: Css -> MisoString -inlineCss = toMisoString <. render - -type Style = Map MisoString MisoString - -red :: MisoString -red = "#f12020" - -bold :: Style -bold = "font-weight" =: "bold" - -condensed :: Style -condensed = "font-stretch" =: "condensed" - -expanded :: Style -expanded = "font-stretch" =: "expanded" - -uppercase :: Style -uppercase = "text-transform" =: "uppercase" - ---------------------------------------------------------------------------------- --- upstream this to Clay ---------------------------------------------------------------------------------- - -newtype JustifyItemsValue = JustifyItemsValue Value - deriving - ( Val, - Other, - Inherit, - Center, - FlexEnd, - FlexStart, - SpaceAround, - SpaceBetween - ) - -justifyItems :: JustifyItemsValue -> Css -justifyItems = Stylesheet.key "justify-items" diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs deleted file mode 100644 index 603e78b..0000000 --- a/Hero/Look/Typography.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Hero.Look.Typography where - -import Alpha -import Clay -import Clay.Stylesheet (key) -import Data.Semigroup ((<>)) -import qualified Hero.Pack as Pack - -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 Clay.lowercase - -upper = textTransform uppercase - --- | font sizing - --- | apparently "coat" is a synonym for "size" -coat :: Double -> Css -coat = fontSize <. Clay.rem - -fontRoot :: Text -fontRoot = Pack.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" - --- | font faces -fonts :: Css -fonts = - mconcat - <| mkEuro - </ [ ("-Reg.otf", OpenType, fontWeight normal <> fontStyle normal), - ("LTStd-Bold.otf", OpenType, thicc <> norm), - ("LTStd-Cn.otf", OpenType, slim <> norm), - ("LTStd-Ex2.otf", OpenType, wide <> norm), - ("LTStd-BoldCn.otf", OpenType, slim <> thicc), - ("LTStd-BoldEx2.otf", OpenType, wide <> thicc) - ] - where - mkEuro :: (Text, FontFaceFormat, Css) -> Css - mkEuro (sufx, fmt, extra) = - fontFace <| do - fontFamily ["Eurostile"] [] - fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) <| Just fmt] - extra - --- TODO: add the below to Clay.Font upstream - -newtype FontStretch = FontStretch Value - deriving (Val, Inherit, Normal, Other) - -expanded :: FontStretch -expanded = FontStretch "expanded" - -condensed :: FontStretch -condensed = FontStretch "condensed" - -fontStretch :: FontStretch -> Css -fontStretch = key "font-stretch" diff --git a/Hero/Node.hs b/Hero/Node.hs deleted file mode 100644 index 11190e7..0000000 --- a/Hero/Node.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Hero app frontend --- --- : out mmc.js -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 - ( AudioState (..), - Comic (..), - ComicReaderState (..), - ComicReaderView (..), - Form (..), - LoginForm (..), - Move (..), - User (..), - audioId, - chooseExperienceLink, - comicReaderFullLink, - comicReaderSpreadLink, - comicVideoLink, - discoverLink, - handlers, - initForm, - 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 - --- | Entry point for a miso application -main :: IO () -main = miso <| \currentURI -> App {model = initForm 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 -> Move -keynav ks - | 37 ∈ ks = PrevPage -- ← - | 39 ∈ ks = NextPage -- → - | 191 ∈ ks = Dumpform -- ? - | 32 ∈ ks = ToggleAudio audioId -- SPC - | otherwise = NoOp - -see :: Form -> View Move -see form = - case runRoute routes handlers uri form of - Left _ -> the404 form - 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 form, optionally introduces side effects -move :: Move -> Form -> Effect Move Form -move NoOp form = noEff form -move Dumpform form = - form <# do - jslog <| ms <| Legacy.show form - pure NoOp -move (SelectExperience comic) form = - form {cpState = ChooseExperience (comicId comic) 1} - <# do pure <| ChangeURI <| chooseExperienceLink (comicId comic) 1 -move (StartReading comic) form = - form {cpState = Reading Spread (comicId comic) 1} - <# do pure <| ChangeURI <| comicReaderSpreadLink (comicId comic) 1 -move (StartWatching comic) form = - form {cpState = Watching (comicId comic)} - <# do pure <| ChangeURI <| comicVideoLink (comicId comic) 1 -move NextPage form = case cpState form of - Reading Spread id pg -> - form {cpState = Reading Spread id (pg + 2)} <# do - pure <| ChangeURI <| comicReaderSpreadLink id (pg + 2) - Reading Full id pg -> - form {cpState = Reading Full id (pg + 1)} <# do - pure <| ChangeURI <| comicReaderFullLink id (pg + 1) - Cover id -> - form {cpState = Reading Spread id 1} <# do - pure <| ChangeURI <| comicReaderSpreadLink id 1 - _ -> noEff form -move PrevPage form = case cpState form of - Reading Spread id pg -> - form {cpState = Reading Spread id (pg -2)} <# do - pure <| ChangeURI <| comicReaderSpreadLink id (pg -2) - Reading Full id pg -> - form {cpState = Reading Full id (pg -1)} <# do - pure <| ChangeURI <| comicReaderFullLink id (pg -1) - Cover _ -> noEff form - _ -> noEff form -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) form = form {user = newUser} <# pure NoOp - where - newUser = (user form) {userLibrary = newLib} - newLib - | c `elem` (userLibrary <| user form) = - Alpha.filter (/= c) <| userLibrary <| user form - | otherwise = c : (userLibrary <| user form) -move (HandleURI u) form = form {uri = u} <# pure NoOp -move (ChangeURI u) form = - form <# do - pushURI u - pure NoOp -move FetchComics form = form <# (SetComics <$> fetchComics) -move (SetComics cs) form = noEff form {appComics = cs} -move (ToggleAudio i) form = - form {cpAudioState = newState} <# do - el <- Document.getElementById i - toggle el - pure NoOp - where - (newState, toggle) = case cpAudioState form of - Playing -> (Paused, Audio.pause) - Paused -> (Playing, Audio.play) -move ToggleFullscreen form = - form {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 form 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) form = - form {dMediaInfo = x} - <# case x of - Just Comic {comicId = id} -> - pure <| ScrollIntoView <| "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) form = - form <# do - jslog <| ms <| Legacy.show id - scrollIntoView id - pure NoOp -move ValidateUserPassword form = - batchEff - form - [doLogin, pure FetchComics, pure <| ChangeURI discoverLink] - where - doLogin = do - user <- getValue =<< Document.getElementById "user" - pass <- getValue =<< Document.getElementById "pass" - sendLogin (ms user) (ms pass) +> \case - Network.Success _ -> pure NoOp - -- 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 -> - json - |> Aeson.eitherDecodeStrict - |> either (Left <. ms) pure - |> Network.fromEither - |> pure - 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 = True, - Ajax.reqData = Ajax.NoData - } - -sendLogin :: - -- | User - MisoString -> - -- | Password - MisoString -> - 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 = True, - Ajax.reqData = - LoginForm (fromMisoString u) (fromMisoString p) - |> Aeson.encode - |> ms - |> Ajax.StringData - } diff --git a/Hero/Pack.hs b/Hero/Pack.hs deleted file mode 100644 index d5c3a35..0000000 --- a/Hero/Pack.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | A module to wrap the CDN and provide convient helper functions to assets. -module Hero.Pack where - -import Protolude - -cdnEdge :: Text -cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com" - -demo :: Text -demo = cdnEdge <> "/old-assets/demo/" - -icon :: Text -icon = cdnEdge <> "/icons/" diff --git a/Hero/Prod.nix b/Hero/Prod.nix deleted file mode 100644 index 3f2ced7..0000000 --- a/Hero/Prod.nix +++ /dev/null @@ -1,57 +0,0 @@ -{ bild ? import ../Biz/Bild.nix {} -, nixpkgs ? import ../Biz/Bild/Nixpkgs.nix -}: - -# Production server for herocomics.app - -bild.os { - imports = [ - ../Biz/OsBase.nix - ../Biz/Packages.nix - ../Biz/Users.nix - ./Service.nix - ]; - networking.hostName = "prod-herocomics"; - networking.domain = "herocomics.app"; - boot.loader.grub.device = "/dev/vda"; - fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; }; - networking = { - firewall.allowedTCPPorts = [ 22 80 443 ]; - nameservers = [ - "67.207.67.2" - "67.207.67.3" - ]; - defaultGateway = "138.68.40.1"; - defaultGateway6 = ""; - dhcpcd.enable = false; - usePredictableInterfaceNames = nixpkgs.lib.mkForce true; - interfaces = { - eth0 = { - ipv4.addresses = [ - { address="138.68.40.97"; prefixLength=21; } - { address="10.46.0.5"; prefixLength=16; } - ]; - ipv6.addresses = [ - { address="fe80::b063:c4ff:fee5:d636"; prefixLength=64; } - ]; - ipv4.routes = [ { address = "138.68.40.1"; prefixLength = 32; } ]; - ipv6.routes = [ { address = ""; prefixLength = 32; } ]; - }; - - }; - }; - - services = { - herocomics = { - enable = true; - port = 3000; - host = bild.ghc ./Host.hs; - node = bild.ghcjs ./Node.hs; - keep = "/var/lib/hero"; - }; - - udev.extraRules = '' - ATTR{address}=="b2:63:c4:e5:d6:36", NAME="eth0" - ''; - }; -} diff --git a/Hero/Service.nix b/Hero/Service.nix deleted file mode 100644 index 906d98e..0000000 --- a/Hero/Service.nix +++ /dev/null @@ -1,88 +0,0 @@ -{ options -, lib -, config -, pkgs -, ... -}: - -let - cfg = config.services.herocomics; -in -{ - options.services.herocomics = { - enable = lib.mkEnableOption "Enable the herocomics service"; - port = lib.mkOption { - type = lib.types.int; - default = 3000; - description = '' - The port on which herocomics-server will listen for incoming HTTP traffic. - ''; - }; - keep = lib.mkOption { - type = lib.types.path; - default = "/var/lib/hero"; - description = "herocomics-server database directory"; - }; - host = lib.mkOption { - type = lib.types.package; - description = "herocomics-server package to use"; - }; - node = lib.mkOption { - type = lib.types.package; - description = "herocomics-client package to use"; - }; - skey = lib.mkOption { - type = lib.types.path; - default = "/run/hero/skey"; - description = "where to store the signing key"; - }; - domain = lib.mkOption { - type = lib.types.str; - default = "herocomics.app"; - description = '' - Domain on which to bind herocomics-server. This is passed - to services.nginx.virtualHosts.<name> directly. - ''; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.herocomics = { - path = [ cfg.host ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.host}/bin/mmc - ''; - description = '' - Hero Comics app server - ''; - serviceConfig = { - KillSignal = "INT"; - Environment = [ - "HERO_NODE=${cfg.node}/static" - "HERO_PORT=${toString cfg.port}" - "HERO_KEEP=${cfg.keep}" - "HERO_SKEY=/run/hero/skey" - ]; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - services.nginx = { - enable = cfg.enable; - recommendedGzipSettings = true; - recommendedOptimisation = true; - recommendedProxySettings = true; - recommendedTlsSettings = true; - virtualHosts = { - "${cfg.domain}" = { - forceSSL = true; - enableACME = true; - locations."/" = { - proxyPass = "http://localhost:${toString cfg.port}"; - }; - }; - }; - }; - }; -} |