1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Hero app frontend
--
-- : exe mmc.js
--
-- : dep aeson
-- : dep clay
-- : dep containers
-- : dep miso
-- : dep protolude
-- : dep servant
-- : dep split
-- : dep string-quote
-- : dep text
-- : dep ghcjs-base
module Hero.Client where
import Data.Aeson (eitherDecodeStrict)
import qualified Data.Set as Set
import qualified GHC.Show as Legacy
import Hero.App
( Action (..),
AudioState (..),
Comic (..),
ComicReaderState (..),
ComicReaderView (..),
Model (..),
User (..),
audioId,
chooseExperienceLink,
comicReaderFullLink,
comicReaderSpreadLink,
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 qualified Network.RemoteData as Network
import Protolude
-- | Entry point for a miso application
main :: IO ()
main = miso $ \currentURI -> App {model = initModel currentURI, ..}
where
update = move
view = see
subs =
[ uriSub HandleURI,
keyboardSub keynav
]
events = defaultEvents
initialAction = FetchComics
mountPoint = Nothing
(∈) :: Ord a => a -> Set a -> Bool
(∈) = Set.member
-- | Keyboard navigation - maps keys to actions.
keynav :: Set Int -> Action
keynav ks
| 37 ∈ ks = PrevPage -- left arrow
| 39 ∈ ks = NextPage -- right arrow
| 191 ∈ ks = DumpModel -- ?
| 32 ∈ ks = ToggleAudio audioId -- SPC
| otherwise = NoOp
see :: Model -> View Action
see model =
case runRoute routes handlers uri model of
Left _ -> the404 model
Right v -> v
-- | Console-logging
foreign import javascript unsafe "console.log($1);"
say :: MisoString -> IO ()
-- | Updates model, optionally introduces side effects
move :: Action -> Model -> Effect Action Model
move NoOp model = noEff model
move DumpModel model = model <# do
say $ ms $ Legacy.show model
pure NoOp
move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1}
<# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1
move (StartReading comic) model = model {cpState = Reading Spread (comicId comic) 1}
<# do pure $ ChangeURI $ comicReaderSpreadLink (comicId comic) 1
move (StartWatching comic) model = model {cpState = Watching (comicId comic)}
<# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1
move NextPage model = case cpState model of
Reading Spread id pg ->
model {cpState = Reading Spread id (pg + 2)} <# do
pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2)
Reading Full id pg ->
model {cpState = Reading Full id (pg + 1)} <# do
pure $ ChangeURI $ comicReaderFullLink id (pg + 1)
Cover id ->
model {cpState = Reading Spread id 1} <# do
pure $ ChangeURI $ comicReaderSpreadLink id 1
_ -> noEff model
move PrevPage model = case cpState model of
Reading Spread id pg ->
model {cpState = Reading Spread id (pg -2)} <# do
pure $ ChangeURI $ comicReaderSpreadLink id (pg -2)
Reading Full id pg ->
model {cpState = Reading Full id (pg -1)} <# do
pure $ ChangeURI $ comicReaderFullLink id (pg -1)
Cover _ -> noEff model
_ -> noEff model
move (ToggleZoom c pg) m = m {cpState = newState} <# pure act
where
goto lnk = ChangeURI $ lnk (comicId c) pg
reading v = Reading v (comicId c) pg
(newState, act) = case cpState m of
Reading Full _ _ -> (reading Spread, goto comicReaderSpreadLink)
Reading Spread _ _ -> (reading Full, goto comicReaderFullLink)
x -> (x, NoOp)
move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp
where
newUser = (user model) { userLibrary = newLib }
newLib
| c `elem` (userLibrary $ user model) =
Protolude.filter (/= c) $ userLibrary $ user model
| otherwise = c : (userLibrary $ user model)
move (HandleURI u) model = model {uri = u} <# pure NoOp
move (ChangeURI u) model = model <# do
pushURI u
pure NoOp
move FetchComics model = model <# (SetComics <$> fetchComics)
move (SetComics cs) model = noEff model {appComics = cs}
move (ToggleAudio i) model = model {cpAudioState = newState} <# do
el <- Document.getElementById i
toggle el
pure NoOp
where
(newState, toggle) = case cpAudioState model of
Playing -> (Paused, Audio.pause)
Paused -> (Playing, Audio.play)
move ToggleFullscreen model = model {cpState = newState} <# do
el <- Document.querySelector "body"
-- TODO: check Document.fullscreenEnabled
-- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled
_ <- toggle el
pure NoOp
where
(toggle, newState) = case cpState model of
Reading Full c n -> (const Fullscreen.exit, Reading Full c n)
Reading Spread c n -> (Fullscreen.request, Reading Spread c n)
-- otherwise, do nothing:
x -> (pure, x)
move (SetMediaInfo x) model = model {dMediaInfo = x}
<# case x of
Just Comic {comicId = id} ->
pure $ ScrollIntoView $ "comic-" <> ms id
Nothing ->
pure NoOp
move (ScrollIntoView id) model = model <# do
say $ ms $ Legacy.show id
scrollIntoView id
pure NoOp
fetchComics :: IO (Network.RemoteData MisoString [Comic])
fetchComics = do
mjson <- contents <$> xhrByteString req
case mjson of
Nothing ->
pure $ Network.Failure "Could not fetch comics from server."
Just json ->
pure $ Network.fromEither
$ either (Left . ms) pure
$ eitherDecodeStrict json
where
req =
Request
{ reqMethod = GET,
reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
reqLogin = Nothing,
reqHeaders = [],
reqWithCredentials = False,
reqData = NoData
}
|
