diff options
Diffstat (limited to 'Hero/Client.hs')
| -rw-r--r-- | Hero/Client.hs | 188 |
1 files changed, 188 insertions, 0 deletions
diff --git a/Hero/Client.hs b/Hero/Client.hs new file mode 100644 index 0000000..9a8fa02 --- /dev/null +++ b/Hero/Client.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 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 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 + } |