summaryrefslogtreecommitdiff
path: root/Hero/Node.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Node.hs')
-rw-r--r--Hero/Node.hs248
1 files changed, 248 insertions, 0 deletions
diff --git a/Hero/Node.hs b/Hero/Node.hs
new file mode 100644
index 0000000..e32cd59
--- /dev/null
+++ b/Hero/Node.hs
@@ -0,0 +1,248 @@
+{-# 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.Node 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.Core
+ ( 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
+ }
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 07:53:19 +0000