summaryrefslogtreecommitdiff
path: root/Hero/Node.hs
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2022-07-18 22:09:58 -0400
committerBen Sima <ben@bsima.me>2022-07-19 09:22:58 -0400
commitbc9e5b0ea863a17537987faa5a72b00efc7767d1 (patch)
treea22df5a00c29f5612a5f6885b9e6bb9a7a56d420 /Hero/Node.hs
parentf034ad709ba0de5a2e5ec6be47523f595e381d7a (diff)
Upgrade nixpkgs, ghc923
I ended up deleting miso, and consequently all files under Hero/ and Miso/, because I couldn't get miso to build with GHC 9.2. Other things: - Niv has been wrapped by Biz/Bild/Deps.hs, so I can extend it to my liking. - Apply-refact is gone because I couldn't get it to build. - Disabled python stuff.
Diffstat (limited to 'Hero/Node.hs')
-rw-r--r--Hero/Node.hs248
1 files changed, 0 insertions, 248 deletions
diff --git a/Hero/Node.hs b/Hero/Node.hs
deleted file mode 100644
index 11190e7..0000000
--- a/Hero/Node.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Hero app frontend
---
--- : out mmc.js
-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
- ( AudioState (..),
- Comic (..),
- ComicReaderState (..),
- ComicReaderView (..),
- Form (..),
- LoginForm (..),
- Move (..),
- User (..),
- audioId,
- chooseExperienceLink,
- comicReaderFullLink,
- comicReaderSpreadLink,
- comicVideoLink,
- discoverLink,
- handlers,
- initForm,
- 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
-
--- | Entry point for a miso application
-main :: IO ()
-main = miso <| \currentURI -> App {model = initForm 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 -> Move
-keynav ks
- | 37 ∈ ks = PrevPage -- ←
- | 39 ∈ ks = NextPage -- →
- | 191 ∈ ks = Dumpform -- ?
- | 32 ∈ ks = ToggleAudio audioId -- SPC
- | otherwise = NoOp
-
-see :: Form -> View Move
-see form =
- case runRoute routes handlers uri form of
- Left _ -> the404 form
- 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 form, optionally introduces side effects
-move :: Move -> Form -> Effect Move Form
-move NoOp form = noEff form
-move Dumpform form =
- form <# do
- jslog <| ms <| Legacy.show form
- pure NoOp
-move (SelectExperience comic) form =
- form {cpState = ChooseExperience (comicId comic) 1}
- <# do pure <| ChangeURI <| chooseExperienceLink (comicId comic) 1
-move (StartReading comic) form =
- form {cpState = Reading Spread (comicId comic) 1}
- <# do pure <| ChangeURI <| comicReaderSpreadLink (comicId comic) 1
-move (StartWatching comic) form =
- form {cpState = Watching (comicId comic)}
- <# do pure <| ChangeURI <| comicVideoLink (comicId comic) 1
-move NextPage form = case cpState form of
- Reading Spread id pg ->
- form {cpState = Reading Spread id (pg + 2)} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id (pg + 2)
- Reading Full id pg ->
- form {cpState = Reading Full id (pg + 1)} <# do
- pure <| ChangeURI <| comicReaderFullLink id (pg + 1)
- Cover id ->
- form {cpState = Reading Spread id 1} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id 1
- _ -> noEff form
-move PrevPage form = case cpState form of
- Reading Spread id pg ->
- form {cpState = Reading Spread id (pg -2)} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id (pg -2)
- Reading Full id pg ->
- form {cpState = Reading Full id (pg -1)} <# do
- pure <| ChangeURI <| comicReaderFullLink id (pg -1)
- Cover _ -> noEff form
- _ -> noEff form
-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) form = form {user = newUser} <# pure NoOp
- where
- newUser = (user form) {userLibrary = newLib}
- newLib
- | c `elem` (userLibrary <| user form) =
- Alpha.filter (/= c) <| userLibrary <| user form
- | otherwise = c : (userLibrary <| user form)
-move (HandleURI u) form = form {uri = u} <# pure NoOp
-move (ChangeURI u) form =
- form <# do
- pushURI u
- pure NoOp
-move FetchComics form = form <# (SetComics <$> fetchComics)
-move (SetComics cs) form = noEff form {appComics = cs}
-move (ToggleAudio i) form =
- form {cpAudioState = newState} <# do
- el <- Document.getElementById i
- toggle el
- pure NoOp
- where
- (newState, toggle) = case cpAudioState form of
- Playing -> (Paused, Audio.pause)
- Paused -> (Playing, Audio.play)
-move ToggleFullscreen form =
- form {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 form 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) form =
- form {dMediaInfo = x}
- <# case x of
- Just Comic {comicId = id} ->
- pure <| ScrollIntoView <| "comic-" <> ms id
- Nothing ->
- pure NoOp
-move (ScrollIntoView id) form =
- form <# do
- jslog <| ms <| Legacy.show id
- scrollIntoView id
- pure NoOp
-move ValidateUserPassword form =
- batchEff
- form
- [doLogin, pure FetchComics, pure <| ChangeURI discoverLink]
- where
- doLogin = do
- user <- getValue =<< Document.getElementById "user"
- pass <- getValue =<< Document.getElementById "pass"
- sendLogin (ms user) (ms pass) +> \case
- Network.Success _ -> pure NoOp
- -- 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 ->
- json
- |> Aeson.eitherDecodeStrict
- |> either (Left <. ms) pure
- |> Network.fromEither
- |> pure
- 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 = True,
- Ajax.reqData = Ajax.NoData
- }
-
-sendLogin ::
- -- | User
- MisoString ->
- -- | Password
- MisoString ->
- 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 = True,
- Ajax.reqData =
- LoginForm (fromMisoString u) (fromMisoString p)
- |> Aeson.encode
- |> ms
- |> Ajax.StringData
- }