summaryrefslogtreecommitdiff
path: root/Hero/Client.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Client.hs')
-rw-r--r--Hero/Client.hs248
1 files changed, 0 insertions, 248 deletions
diff --git a/Hero/Client.hs b/Hero/Client.hs
deleted file mode 100644
index 5429855..0000000
--- a/Hero/Client.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# 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 Alpha
-import Biz.Auth as Auth
-import qualified Data.Aeson as Aeson
-import qualified Data.Set as Set
-import qualified GHC.Show as Legacy
-import GHCJS.Types (JSVal)
-import Hero.App
- ( Action (..),
- AudioState (..),
- Comic (..),
- ComicReaderState (..),
- ComicReaderView (..),
- LoginForm (..),
- Model (..),
- User (..),
- audioId,
- chooseExperienceLink,
- comicReaderFullLink,
- comicReaderSpreadLink,
- comicVideoLink,
- discoverLink,
- handlers,
- initModel,
- routes,
- the404,
- )
-import JavaScript.Web.XMLHttpRequest as Ajax
-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 = NoOp
- 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 -- ←
- | 39 ∈ ks = NextPage -- →
- | 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);"
- jslog :: MisoString -> IO ()
-
-foreign import javascript unsafe "$1.value"
- getValue :: JSVal -> IO MisoString
-
--- | Updates model, optionally introduces side effects
-move :: Action -> Model -> Effect Action Model
-move NoOp model = noEff model
-move DumpModel model = model <# do
- jslog $ 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
- jslog $ ms $ Legacy.show id
- scrollIntoView id
- pure NoOp
-move ValidateUserPassword model =
- batchEff
- model
- [doLogin, (SetComics </ fetchComics)]
- where
- doLogin = do
- jslog "starting doLogin"
- user <- getValue =<< Document.getElementById "user"
- pass <- getValue =<< Document.getElementById "pass"
- jslog "sending login"
- sendLogin (ms user) (ms pass) >>= \case
- Network.Success user -> do
- jslog "successful login"
- pure $ ChangeURI discoverLink
- -- TODO: handle these error cases
- Network.Loading -> pure NoOp
- Network.Failure _ -> pure NoOp
- Network.NotAsked -> pure NoOp
-
-fetchComics :: IO (Network.RemoteData MisoString [Comic])
-fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case
- Nothing ->
- pure $ Network.Failure "Could not fetch comics from server."
- Just json ->
- pure $ Network.fromEither
- $ either (Left . ms) pure
- $ Aeson.eitherDecodeStrict json
- where
- req =
- Ajax.Request
- { Ajax.reqMethod = Ajax.GET,
- Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
- Ajax.reqLogin = Nothing,
- Ajax.reqHeaders = [],
- Ajax.reqWithCredentials = False,
- Ajax.reqData = Ajax.NoData
- }
-
-sendLogin ::
- Auth.Username ->
- Auth.Password ->
- IO
- ( Network.RemoteData MisoString
- User
- )
-sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case
- Nothing ->
- pure $ Network.Failure "Could not send login request."
- Just json ->
- pure $ Network.fromEither
- $ either (Left . ms) pure
- $ Aeson.eitherDecodeStrict json
- where
- req =
- Ajax.Request
- { Ajax.reqMethod = Ajax.POST,
- Ajax.reqURI = "/auth",
- Ajax.reqLogin = Nothing, -- FIXME?
- Ajax.reqHeaders =
- [ ("Accept", "application/json"),
- ("Content-Type", "application/json")
- ],
- Ajax.reqWithCredentials = False,
- Ajax.reqData =
- LoginForm (fromMisoString u) (fromMisoString p)
- |> Aeson.encode
- |> ms
- |> Ajax.StringData
- }