summaryrefslogtreecommitdiff
path: root/Hero/Client.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Client.hs')
-rw-r--r--Hero/Client.hs259
1 files changed, 133 insertions, 126 deletions
diff --git a/Hero/Client.hs b/Hero/Client.hs
index 9a8fa02..0472d48 100644
--- a/Hero/Client.hs
+++ b/Hero/Client.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
+
-- | Hero app frontend
--
-- : exe mmc.js
@@ -17,52 +18,55 @@
-- : dep ghcjs-base
module Hero.Client where
-import Hero.App ( Action(..)
- , Comic(..)
- , ComicReaderState(..)
- , ComicReaderView(..)
- , Model(..)
- , AudioState(..)
- , audioId
- , chooseExperienceLink
- , comicPlayerSpreadLink
- , comicPlayerFullLink
- , comicVideoLink
- , handlers
- , initModel
- , the404
- , routes
- )
-import qualified Network.RemoteData as Network
-import Data.Aeson ( eitherDecodeStrict )
+import 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 Hero.App
+ ( Action (..),
+ AudioState (..),
+ Comic (..),
+ ComicReaderState (..),
+ ComicReaderView (..),
+ Model (..),
+ audioId,
+ chooseExperienceLink,
+ comicPlayerFullLink,
+ comicPlayerSpreadLink,
+ comicVideoLink,
+ handlers,
+ initModel,
+ routes,
+ the404,
+ )
+import JavaScript.Web.XMLHttpRequest
+ ( Method (GET),
+ Request (..),
+ 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
+import Miso.String
+import qualified Network.RemoteData as Network
+import Protolude
-- | Entry point for a miso application
main :: IO ()
-main = miso $ \currentURI -> App { model = initModel currentURI, .. }
+main = miso $ \currentURI -> App {model = initModel currentURI, ..}
where
- update = move
- view = see
- subs = [ uriSub HandleURI
- , keyboardSub keynav
- ]
- events = defaultEvents
+ update = move
+ view = see
+ subs =
+ [ uriSub HandleURI,
+ keyboardSub keynav
+ ]
+ events = defaultEvents
initialAction = FetchComics
- mountPoint = Nothing
+ mountPoint = Nothing
(∈) :: Ord a => a -> Set a -> Bool
(∈) = Set.member
@@ -70,17 +74,17 @@ main = miso $ \currentURI -> App { model = initModel currentURI, .. }
-- | 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
+ | 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
+ case runRoute routes handlers uri model of
+ Left _ -> the404 model
+ Right v -> v
-- | Console-logging
foreign import javascript unsafe "console.log($1);"
@@ -88,101 +92,104 @@ foreign import javascript unsafe "console.log($1);"
-- | Updates model, optionally introduces side effects
move :: Action -> Model -> Effect Action Model
-move NoOp model = noEff 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
+ 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
+ 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
+ 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
+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
+ (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
+ 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 ->
+ 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
- }
+ 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
+ }
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 16:25:53 +0000