diff options
Diffstat (limited to 'Hero')
| -rw-r--r-- | Hero/Core.hs | 67 | ||||
| -rw-r--r-- | Hero/Host.hs | 157 | ||||
| -rw-r--r-- | Hero/Keep.hs | 40 | ||||
| -rw-r--r-- | Hero/Look.hs | 93 | ||||
| -rw-r--r-- | Hero/Look/Typography.hs | 2 | ||||
| -rw-r--r-- | Hero/Node.hs | 136 | ||||
| -rw-r--r-- | Hero/Part.hs | 2 |
7 files changed, 255 insertions, 242 deletions
diff --git a/Hero/Core.hs b/Hero/Core.hs index 8f865da..86b0638 100644 --- a/Hero/Core.hs +++ b/Hero/Core.hs @@ -77,12 +77,11 @@ comicSlug Comic {..} = snake comicName <> "-" <> comicIssue -- * user -data User - = User - { userEmail :: Text, - userName :: Text, - userLibrary :: [Comic] - } +data User = User + { userEmail :: Text, + userName :: Text, + userLibrary :: [Comic] + } deriving (Show, Eq, Generic, Data, Ord) instance Semigroup User where @@ -158,7 +157,7 @@ instance Elemental Button where [ img_ [src_ <| ms <| Pack.icon <> "save.svg"], span_ [] [text "saved"] ] - else-- not in library + else -- not in library a_ [class_ "wrs-button", onClick <| ToggleInLibrary c] @@ -173,7 +172,7 @@ instance Elemental Button where onClick <| ToggleInLibrary c ] [img_ [src_ <| ms <| Pack.demo <> "library-add.png"]] - else-- not in library + else -- not in library button_ [ class_ "button is-large has-background-black-bis", @@ -231,16 +230,15 @@ findComic id = List.find (\c -> comicId c == id) -- -- 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 - } +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 @@ -323,6 +321,7 @@ pubRoutes :: Proxy PubRoutes pubRoutes = Proxy -- * pages + -- -- TODO: consider making a typeclass, something like: -- @@ -334,6 +333,7 @@ pubRoutes = Proxy -- link :: Api.URI -- ** home + -- -- this is the unauthenticated page that you see when you first visit @@ -481,15 +481,14 @@ discoverFooter = -- ** comic -data Comic - = Comic - { comicId :: ComicId, - comicPages :: Integer, - comicName :: Text, - -- | Ideally this would be a dynamic number-like type - comicIssue :: Text, - comicDescription :: Text - } +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 @@ -534,11 +533,11 @@ instance IsMediaObject Comic where <| Pack.demo <> comicSlug comic <> "-logo.png" ] ], - div_ [class_ "comic-action-menu"] <| - el </ [Watch comic, Read comic, Save comic lib], + div_ [class_ "comic-action-menu"] + <| el </ [Watch comic, Read comic, Save comic lib], p_ [class_ "description"] - [ text . ms <| comicDescription comic + [ text <. ms <| comicDescription comic ] ] ] @@ -800,7 +799,7 @@ comicVideo _ _ _ = ] ] --- * general page components & utils +-- * general page components |> utils -- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' maybeView :: (a -> View action) -> Maybe a -> View action @@ -899,9 +898,9 @@ comicControls comic page form = ] ] where - leftPage = ms . Legacy.show <| page - rightPage = ms . Legacy.show <| 1 + page - totalpages = ms . Legacy.show <| comicPages comic + leftPage = ms <. Legacy.show <| page + rightPage = ms <. Legacy.show <| 1 + page + totalpages = ms <. Legacy.show <| comicPages comic topbar :: View Move topbar = diff --git a/Hero/Host.hs b/Hero/Host.hs index d547fa5..9d10f02 100644 --- a/Hero/Host.hs +++ b/Hero/Host.hs @@ -9,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Hero web app @@ -83,57 +82,59 @@ main = bracket startup shutdown run where run (cfg, app, _) = Warp.run (heroPort cfg) app prn = IO.hPutStrLn IO.stderr - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right cfg -> - do - keep <- Keep.open (heroKeep cfg) - skey <- upsertKey (heroSkey cfg) - say "hero" - prn <| "port: " ++ show (heroPort cfg) - prn <| "keep: " ++ heroKeep cfg - prn <| "node: " ++ heroNode cfg - prn <| "skey: " ++ heroSkey cfg - let jwts = Auth.defaultJWTSettings skey - cs = - Auth.defaultCookieSettings - { -- 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 - return - ( cfg, - serveWithContext - proxy - ctx - server, - keep - ) + startup = + Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right cfg -> + do + keep <- Keep.open (heroKeep cfg) + skey <- upsertKey (heroSkey cfg) + say "hero" + prn <| "port: " ++ show (heroPort cfg) + prn <| "keep: " ++ heroKeep cfg + prn <| "node: " ++ heroNode cfg + prn <| "skey: " ++ heroSkey cfg + let jwts = Auth.defaultJWTSettings skey + cs = + Auth.defaultCookieSettings + { -- 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 + return + ( cfg, + serveWithContext + proxy + ctx + server, + keep + ) shutdown :: App -> IO () shutdown (_, _, keep) = do Keep.close keep return () upsertKey :: FilePath -> IO Crypto.JWK -upsertKey fp = Directory.doesFileExist fp >>= \exists -> - if exists - then Auth.readKey fp - else Auth.writeKey fp >> Auth.readKey fp +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: -- @@ -150,13 +151,12 @@ upsertKey fp = Directory.doesFileExist fp >>= \exists -> -- | 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 - } +data Config = Config + { heroPort :: Warp.Port, + heroNode :: FilePath, + heroKeep :: FilePath, + heroSkey :: FilePath + } deriving (Generic, Show) instance Envy.DefConfig Config where @@ -206,12 +206,13 @@ type CssRoute = "css" :> "main.css" :> Get '[CSS] Text cssHandlers :: Server CssRoute cssHandlers = - return . Lazy.toStrict . Clay.render <| Typography.main <> Look.main + return <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main type AuthRoute = "auth" :> ReqBody '[JSON] LoginForm - :> Post '[JSON] + :> Post + '[JSON] ( Headers '[ Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie @@ -291,37 +292,37 @@ instance L.ToHtml a => L.ToHtml (Templated a) where L.link_ [ L.rel_ "apple-touch-icon", L.sizes_ "180x180", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" + 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.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.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.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.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"] @@ -373,30 +374,30 @@ 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 +homeHandler = pure <. Templated <. home <| initForm homeLink comicCoverHandler :: ComicId -> Handler (Templated (View Move)) comicCoverHandler id = - pure . Templated . comicCover id . initForm <| comicLink 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 + 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 + 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 + pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n discoverHandler :: Handler (Templated (View Move)) -discoverHandler = pure . Templated . discover <| initForm discoverLink +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 + pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n loginHandler :: Handler (Templated (View Move)) -loginHandler = pure . Templated . login <| initForm loginLink +loginHandler = pure <. Templated <. login <| initForm loginLink diff --git a/Hero/Keep.hs b/Hero/Keep.hs index 72bd6c2..744313b 100644 --- a/Hero/Keep.hs +++ b/Hero/Keep.hs @@ -16,11 +16,11 @@ module Hero.Keep where import Alpha -import qualified Data.Acid as Acid import Data.Acid (Update, makeAcidic) +import qualified Data.Acid as Acid import Data.Data (Data, Typeable) -import qualified Data.IxSet as IxSet 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 @@ -28,11 +28,10 @@ import Hero.Core -- * Keep -- | Main database. -data HeroKeep - = HeroKeep - { _comics :: (IxSet Comic), - _users :: (IxSet User) - } +data HeroKeep = HeroKeep + { _comics :: IxSet Comic, + _users :: IxSet User + } deriving (Data, Typeable) $(deriveSafeCopy 0 'base ''HeroKeep) @@ -48,25 +47,25 @@ $(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] + [ 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] + [ 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)} + put <| keep {_comics = IxSet.insert c (_comics keep)} return c getComics :: Int -> Acid.Query HeroKeep [Comic] @@ -80,10 +79,11 @@ initialHeroKeep :: HeroKeep initialHeroKeep = HeroKeep { _comics = IxSet.fromList [theRed], - _users = IxSet.fromList - [ User "a" "micheal" [], - User "b" "ben" [] - ] + _users = + IxSet.fromList + [ User "a" "micheal" [], + User "b" "ben" [] + ] } where theRed = diff --git a/Hero/Look.hs b/Hero/Look.hs index 03f64b3..e3958d5 100644 --- a/Hero/Look.hs +++ b/Hero/Look.hs @@ -2,12 +2,15 @@ {-# 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 @@ -16,9 +19,8 @@ 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 (Attribute, style_, (=:)) import Miso.String (MisoString, toMisoString) -import Protolude hiding ((&), (**), rem) main :: Css main = do @@ -33,8 +35,8 @@ main = do textDecoration none ".loading" ? do centered - height $ vh 100 - width $ vw 100 + height <| vh 100 + width <| vw 100 -- animations ".grow" ? do transition "all" (sec 0.2) easeInOut (sec 0.2) @@ -51,13 +53,13 @@ main = do forwards keyframes "blur" - [ (0, Clay.filter $ blur (px 0)), - (50, Clay.filter $ blur (px 0)), - (100, Clay.filter $ blur (px 10)) + [ (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 + mobile <| do overflowX hidden width (vw 100) -- general app wrapper stuf @@ -85,19 +87,19 @@ main = do borderBottom solid (px 3) grai wide top (px 0) - mobile $ noBorder <> width (vw 100) + mobile <| noBorder <> width (vw 100) "#app-body" ? do display flex - desktop $ width (vw 93) + 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 + marginY <| px 74 + mobile <| flexDirection column + "#discover #app-body" ? do desktop <| marginLeft appmenuWidth "#app-head-right" ? do display flex justifyContent spaceBetween @@ -137,7 +139,7 @@ main = do zIndex 1 height (vh 100) width (px 400) - mobile $ width (vw 90) + mobile <| width (vw 90) "#login" ** ".help" ** a ? do color white display flex @@ -159,17 +161,17 @@ main = do euro <> wide flexCenter width (pct 100) - desktop $ marginLeft appmenuWidth <> height (vh 90) - mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) + 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 + mobile <| coat 0.8 p ? do thicc <> coat 0.8 <> textAlign center maxWidth (px 900) marginAll (rem 1) - mobile $ coat 0.6 + mobile <| coat 0.6 ul ? do display flex flexDirection row @@ -181,7 +183,7 @@ main = do display flex flexDirection column textAlign center - mobile $ coat 0.6 + mobile <| coat 0.6 coat 0.8 <> clickable divv <? do position relative @@ -207,7 +209,7 @@ main = do justifyContent center alignItems center display flex - ".comic-video" |> iframe ? do + ".comic-video" & iframe ? do position absolute height (pct 93) width (pct 100) @@ -219,8 +221,8 @@ main = do fontSize z lineHeight z let m = 24 :: Double - top $ px $ navbarHeight + m - left $ px m + top <| px <| navbarHeight + m + left <| px m zIndex 999 -- zoom button and slider "#zoom-button" ? do @@ -229,15 +231,15 @@ main = do let sliderYY = 250 euro <> wide input ? do - transform $ Clay.rotate (deg (-90)) + transform <| Clay.rotate (deg (-90)) margin 0 0 (px sliderYY) 0 position absolute - height $ px sliderY - width $ px 200 + height <| px sliderY + width <| px 200 hide label ? do coat 0.9 - marginBottom $ px $ 2 * sliderYY + marginBottom <| px <| 2 * sliderYY position absolute hide ":hover" & ".ctrl" ? visibility visible @@ -252,7 +254,7 @@ main = do borderBottom solid (px 1) white flexDirection row centerJustify - mobile $ do + mobile <| do margin (rem 2) 0 (rem 2) 0 padding 0 0 0 (rem 0) noBorder @@ -263,7 +265,7 @@ main = do display flex flexDirection row divv # lastChild <? paddingLeft (rem 1) - mobile $ do + mobile <| do width (vw 90) -- this line can be commented if you want to center the meta img ? width (px 150) order (-1) @@ -271,7 +273,7 @@ main = do ".media-info-summary" ? do Flexbox.flex 2 1 (px 0) paddingRight (rem 3) - mobile $ do + mobile <| do marginAll (rem 1) padding 0 0 0 (rem 0) ".media-info-actions" ? do @@ -280,7 +282,7 @@ main = do display flex flexDirection column justifyContent spaceAround - mobile $ do + mobile <| do maxWidth (vw 100) flexDirection row order 1 @@ -308,8 +310,8 @@ main = do a |> img ? do width (px 22) height (px 22) - desktop $ a |> span ? remove - mobile $ do + desktop <| a |> span ? remove + mobile <| do order 2 flexDirection row position fixed @@ -329,14 +331,14 @@ main = do flexDirection column Typo.euro height (px 411) - mobile $ do + mobile <| do padding (px 0) 0 0 0 margin 0 0 (px 50) 0 after & do display block position relative - background $ - linearGradient + background + <| linearGradient (straight sideTop) [ (setA 0 nite, pct 0), (nite, pct 100) @@ -356,13 +358,13 @@ main = do position relative minHeight (px 411) minWidth (px 1214) - mobile $ marginLeft (px (-310)) + 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 + mobile <| do marginTop (px 200) alignItems center display flex @@ -382,7 +384,7 @@ main = do fontSize (rem 0.8) fontVariant smallCaps euro <> thicc <> wide - mobile $ do + mobile <| do height (px 26) width (px 100) margin 0 (px 5) 0 (px 5) @@ -393,7 +395,7 @@ main = do img ? do marginRight (px 7) height (px 15) - mobile $ height (px 10) + mobile <| height (px 10) -- ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left") -- shelving @@ -402,7 +404,7 @@ main = do flexDirection column justifyContent flexStart alignItems flexStart - mobile $ do + mobile <| do padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) width (vw 100) ".comic" ? do @@ -518,15 +520,16 @@ grai = rgb 221 221 221 -- #dddddd -- 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 [] +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) + f t = + L.splitOn ";" t + <&> L.splitOn ":" + <&> \(x : y) -> (toMisoString x, toMisoString <| L.intercalate ":" y) inlineCss :: Css -> MisoString -inlineCss = toMisoString . render +inlineCss = toMisoString <. render type Style = Map MisoString MisoString diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs index 7c28f21..603e78b 100644 --- a/Hero/Look/Typography.hs +++ b/Hero/Look/Typography.hs @@ -44,7 +44,7 @@ upper = textTransform uppercase -- | apparently "coat" is a synonym for "size" coat :: Double -> Css -coat = fontSize . Clay.rem +coat = fontSize <. Clay.rem fontRoot :: Text fontRoot = Pack.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" diff --git a/Hero/Node.hs b/Hero/Node.hs index 70b8217..38f540d 100644 --- a/Hero/Node.hs +++ b/Hero/Node.hs @@ -26,13 +26,13 @@ import qualified Data.Set as Set import qualified GHC.Show as Legacy import GHCJS.Types (JSVal) import Hero.Core - ( Move (..), - AudioState (..), + ( AudioState (..), Comic (..), ComicReaderState (..), ComicReaderView (..), - LoginForm (..), Form (..), + LoginForm (..), + Move (..), User (..), audioId, chooseExperienceLink, @@ -57,7 +57,7 @@ import Protolude -- | Entry point for a miso application main :: IO () -main = miso $ \currentURI -> App {model = initForm currentURI, ..} +main = miso <| \currentURI -> App {model = initForm currentURI, ..} where update = move view = see @@ -97,38 +97,42 @@ foreign import javascript unsafe "$1.value" -- | 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 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) + pure <| ChangeURI <| comicReaderSpreadLink id (pg + 2) Reading Full id pg -> form {cpState = Reading Full id (pg + 1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg + 1) + pure <| ChangeURI <| comicReaderFullLink id (pg + 1) Cover id -> form {cpState = Reading Spread id 1} <# do - pure $ ChangeURI $ comicReaderSpreadLink id 1 + 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) + pure <| ChangeURI <| comicReaderSpreadLink id (pg -2) Reading Full id pg -> form {cpState = Reading Full id (pg -1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg -1) + 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 + 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) @@ -138,45 +142,50 @@ move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp where newUser = (user form) {userLibrary = newLib} newLib - | c `elem` (userLibrary $ user form) = - Protolude.filter (/= c) $ userLibrary $ user form - | otherwise = c : (userLibrary $ user form) + | c `elem` (userLibrary <| user form) = + Protolude.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 (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 +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 +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 (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 @@ -193,15 +202,16 @@ move ValidateUserPassword form = 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 +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 @@ -217,16 +227,18 @@ sendLogin :: Auth.Username -> Auth.Password -> IO - ( Network.RemoteData MisoString + ( 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 +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 diff --git a/Hero/Part.hs b/Hero/Part.hs index fb34fff..4244721 100644 --- a/Hero/Part.hs +++ b/Hero/Part.hs @@ -1,3 +1 @@ module Hero.Part () where - - |