Add Com.MusicMeetsComics

1 files changed, 174 insertions, 0 deletions

diff --git a/Com/MusicMeetsComics/Aero.hs b/Com/MusicMeetsComics/Aero.hs
new file mode 100644
index 0000000..26d8aaf
--- /dev/null
+++ b/Com/MusicMeetsComics/Aero.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Com.MusicMeetsComics.Aero where
+
+import           Com.MusicMeetsComics.App ( Action(..)
+                                          , Comic(..)
+                                          , ComicReaderState(..)
+                                          , ComicReaderView(..)
+                                          , Model(..)
+                                          , AudioState(..)
+                                          , audioId
+                                          , chooseExperienceLink
+                                          , comicPlayerSpreadLink
+                                          , comicPlayerFullLink
+                                          , comicVideoLink
+                                          , handlers
+                                          , initModel
+                                          , the404
+                                          , routes
+                                          )
+import qualified Com.Simatime.Network as Network
+import           Data.Aeson ( eitherDecodeStrict )
+import qualified Data.Set as Set
+import qualified GHC.Show as Legacy
+import           JavaScript.Web.XMLHttpRequest ( Request(..)
+                                               , Method(GET)
+                                               , RequestData(NoData)
+                                               , contents
+                                               , xhrByteString
+                                               )
+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           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 = FetchComics
+    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 -- ^ left arrow
+    | 39 ∈ ks = NextPage -- ^ right arrow
+    | 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);"
+  say :: MisoString -> IO ()
+
+-- | Updates model, optionally introduces side effects
+move :: Action -> Model -> Effect Action Model
+move NoOp      model = noEff model
+move DumpModel model = model <# do
+    say $ 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 $ comicPlayerSpreadLink (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 $ comicPlayerSpreadLink id (pg+2)
+    Reading Full id pg ->
+        model { cpState = Reading Full id (pg+1) } <# do
+        pure $ ChangeURI $ comicPlayerFullLink id (pg+1)
+    Cover id ->
+        model { cpState = Reading Spread id 1 } <# do
+        pure $ ChangeURI $ comicPlayerSpreadLink 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 $ comicPlayerSpreadLink id (pg-2)
+    Reading Full id pg ->
+        model { cpState = Reading Full id (pg-1) } <# do
+        pure $ ChangeURI $ comicPlayerFullLink id (pg-1)
+    Cover _ -> noEff model
+    _ -> noEff model
+move (ToggleZoom c pg) m = m { cpState = newState } <# do 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 comicPlayerSpreadLink)
+              Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink)
+              x -> (x, NoOp)
+move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp
+    where
+        newLib | c `elem` (userLibrary model) =
+                     Protolude.filter (/= c) $ userLibrary model
+               | otherwise = c : (userLibrary 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 } <# do
+    case x of
+        Just Comic {comicId = id} ->
+            pure $ ScrollIntoView $ "comic-" <> ms id
+        Nothing ->
+            pure NoOp
+move (ScrollIntoView id) model = model <# do
+    say $ ms $ Legacy.show id
+    scrollIntoView id
+    pure NoOp
+
+fetchComics :: IO (Network.RemoteData MisoString [Comic])
+fetchComics = do
+  mjson <- contents <$> xhrByteString req
+  case mjson of
+    Nothing   ->
+      pure $ Network.Failure "Could not fetch comics from server."
+    Just json -> pure $ Network.fromEither
+      $ either (Left . ms) pure
+      $ eitherDecodeStrict json
+ where
+  req = Request
+    { reqMethod = GET
+    , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding?
+    , reqLogin = Nothing
+    , reqHeaders = []
+    , reqWithCredentials = False
+    , reqData = NoData
+    }