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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Com.MusicMeetsComics.Aero where
import Com.MusicMeetsComics.App ( Action(..)
, Comic(..)
, ComicReaderState(..)
, ComicReaderView(..)
, Model(..)
, AudioState(..)
, audioId
, chooseExperienceLink
, comicPlayerSpreadLink
, comicPlayerFullLink
, comicVideoLink
, handlers
, initModel
, the404
, routes
)
import qualified Com.Simatime.Network as Network
import Data.Aeson ( eitherDecodeStrict )
import qualified Data.Set as Set
import qualified GHC.Show as Legacy
import JavaScript.Web.XMLHttpRequest ( Request(..)
, Method(GET)
, RequestData(NoData)
, contents
, xhrByteString
)
import Miso
import Miso.Effect.DOM (scrollIntoView)
import qualified Miso.FFI.Audio as Audio
import qualified Miso.FFI.Document as Document
import qualified Miso.FFI.Fullscreen as Fullscreen
import Miso.String
import Protolude
-- | Entry point for a miso application
main :: IO ()
main = miso $ \currentURI -> App { model = initModel currentURI, .. }
where
update = move
view = see
subs = [ uriSub HandleURI
, keyboardSub keynav
]
events = defaultEvents
initialAction = FetchComics
mountPoint = Nothing
(∈) :: Ord a => a -> Set a -> Bool
(∈) = Set.member
-- | Keyboard navigation - maps keys to actions.
keynav :: Set Int -> Action
keynav ks
| 37 ∈ ks = PrevPage -- ^ left arrow
| 39 ∈ ks = NextPage -- ^ right arrow
| 191 ∈ ks = DumpModel -- ^ ?
| 32 ∈ ks = ToggleAudio audioId -- ^ SPC
| otherwise = NoOp
see :: Model -> View Action
see model =
case runRoute routes handlers uri model of
Left _ -> the404 model
Right v -> v
-- | Console-logging
foreign import javascript unsafe "console.log($1);"
say :: MisoString -> IO ()
-- | Updates model, optionally introduces side effects
move :: Action -> Model -> Effect Action Model
move NoOp model = noEff model
move DumpModel model = model <# do
say $ ms $ Legacy.show model
pure NoOp
move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 }
<# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1
move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 }
<# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1
move (StartWatching comic) model = model { cpState = Watching (comicId comic) }
<# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1
move NextPage model = case cpState model of
Reading Spread id pg ->
model { cpState = Reading Spread id (pg+2) } <# do
pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2)
Reading Full id pg ->
model { cpState = Reading Full id (pg+1) } <# do
pure $ ChangeURI $ comicPlayerFullLink id (pg+1)
Cover id ->
model { cpState = Reading Spread id 1 } <# do
pure $ ChangeURI $ comicPlayerSpreadLink id 1
_ -> noEff model
move PrevPage model = case cpState model of
Reading Spread id pg ->
model { cpState = Reading Spread id (pg-2) } <# do
pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2)
Reading Full id pg ->
model { cpState = Reading Full id (pg-1) } <# do
pure $ ChangeURI $ comicPlayerFullLink id (pg-1)
Cover _ -> noEff model
_ -> noEff model
move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act
where
goto lnk = ChangeURI $ lnk (comicId c) pg
reading v = Reading v (comicId c) pg
(newState, act) = case cpState m of
Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink)
Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink)
x -> (x, NoOp)
move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp
where
newLib | c `elem` (userLibrary model) =
Protolude.filter (/= c) $ userLibrary model
| otherwise = c : (userLibrary model)
move (HandleURI u) model = model { uri = u } <# pure NoOp
move (ChangeURI u) model = model <# do
pushURI u
pure NoOp
move FetchComics model = model <# (SetComics <$> fetchComics)
move (SetComics cs) model = noEff model { appComics = cs }
move (ToggleAudio i ) model = model { cpAudioState = newState } <# do
el <- Document.getElementById i
toggle el
pure NoOp
where
(newState, toggle) = case cpAudioState model of
Playing -> (Paused, Audio.pause)
Paused -> (Playing, Audio.play)
move ToggleFullscreen model = model { cpState = newState } <# do
el <- Document.querySelector "body"
-- TODO: check Document.fullscreenEnabled
-- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled
_ <- toggle el
pure NoOp
where
(toggle, newState) = case cpState model of
Reading Full c n -> (const Fullscreen.exit, Reading Full c n)
Reading Spread c n -> (Fullscreen.request, Reading Spread c n)
-- otherwise, do nothing:
x -> (pure, x)
move (SetMediaInfo x) model = model { dMediaInfo = x } <# do
case x of
Just Comic {comicId = id} ->
pure $ ScrollIntoView $ "comic-" <> ms id
Nothing ->
pure NoOp
move (ScrollIntoView id) model = model <# do
say $ ms $ Legacy.show id
scrollIntoView id
pure NoOp
fetchComics :: IO (Network.RemoteData MisoString [Comic])
fetchComics = do
mjson <- contents <$> xhrByteString req
case mjson of
Nothing ->
pure $ Network.Failure "Could not fetch comics from server."
Just json -> pure $ Network.fromEither
$ either (Left . ms) pure
$ eitherDecodeStrict json
where
req = Request
{ reqMethod = GET
, reqURI = "/api/comic" -- FIXME: can we replace this hardcoding?
, reqLogin = Nothing
, reqHeaders = []
, reqWithCredentials = False
, reqData = NoData
}
|
