{-# 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 Com.MusicMeetsComics.Client 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 }