path: root/Hero/Node.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Hero app frontend
--
-- : out mmc.js
--
-- : dep aeson
-- : dep clay
-- : dep containers
-- : dep miso
-- : dep protolude
-- : dep servant
-- : dep split
-- : 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
  ( 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 ::
  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 = True,
          Ajax.reqData =
            LoginForm (fromMisoString u) (fromMisoString p)
              |> Aeson.encode
              |> ms
              |> Ajax.StringData
        }