path: root/Hero/Client.hs

{-# 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
        }