diff options
author | Ben Sima <ben@bsima.me> | 2022-07-18 22:09:58 -0400 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2022-07-19 09:22:58 -0400 |
commit | bc9e5b0ea863a17537987faa5a72b00efc7767d1 (patch) | |
tree | a22df5a00c29f5612a5f6885b9e6bb9a7a56d420 /Hero/Node.hs | |
parent | f034ad709ba0de5a2e5ec6be47523f595e381d7a (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.hs | 248 |
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 - } |