From ddc9b826bdc568004451fb14b458476e4c7e5061 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sun, 19 Jul 2020 21:21:03 -0700 Subject: hero: rename stuff to new structure Working toward https://github.com/bsima/biz/issues/5 --- Hero/Client.hs | 248 --------------------------------------------------------- 1 file changed, 248 deletions(-) delete mode 100644 Hero/Client.hs (limited to 'Hero/Client.hs') 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 >= \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 - } -- cgit v1.2.3