1 files changed, 84 insertions, 30 deletions

diff --git a/Hero/Client.hs b/Hero/Client.hs
index 2b222bd..06a7eab 100644
--- a/Hero/Client.hs
+++ b/Hero/Client.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -18,9 +19,12 @@
 -- : dep ghcjs-base
 module Hero.Client where
 
+import Alpha
+import Biz.Auth as Auth
 import Data.Aeson (eitherDecodeStrict)
 import qualified Data.Set as Set
 import qualified GHC.Show as Legacy
+import GHCJS.Types (JSVal)
 import Hero.App
   ( Action (..),
     AudioState (..),
@@ -34,18 +38,13 @@ import Hero.App
     comicReaderFullLink,
     comicReaderSpreadLink,
     comicVideoLink,
+    discoverLink,
     handlers,
     initModel,
     routes,
     the404,
   )
-import JavaScript.Web.XMLHttpRequest
-  ( Method (GET),
-    Request (..),
-    RequestData (NoData),
-    contents,
-    xhrByteString,
-  )
+import JavaScript.Web.XMLHttpRequest as Ajax
 import Miso
 import Miso.Effect.DOM (scrollIntoView)
 import qualified Miso.FFI.Audio as Audio
@@ -66,7 +65,7 @@ main = miso $ \currentURI -> App {model = initModel currentURI, ..}
         keyboardSub keynav
       ]
     events = defaultEvents
-    initialAction = FetchComics
+    initialAction = NoOp
     mountPoint = Nothing
 
 (∈) :: Ord a => a -> Set a -> Bool
@@ -75,8 +74,8 @@ main = miso $ \currentURI -> App {model = initModel currentURI, ..}
 -- | Keyboard navigation - maps keys to actions.
 keynav :: Set Int -> Action
 keynav ks
-  | 37 ∈ ks = PrevPage -- left arrow
-  | 39 ∈ ks = NextPage -- right arrow
+  | 37 ∈ ks = PrevPage -- ←
+  | 39 ∈ ks = NextPage -- →
   | 191 ∈ ks = DumpModel -- ?
   | 32 ∈ ks = ToggleAudio audioId -- SPC
   | otherwise = NoOp
@@ -89,13 +88,16 @@ see model =
 
 -- | Console-logging
 foreign import javascript unsafe "console.log($1);"
-  say :: MisoString -> IO ()
+  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
-  say $ ms $ Legacy.show model
+  jslog $ ms $ Legacy.show model
   pure NoOp
 move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1}
   <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1
@@ -133,7 +135,7 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act
       x -> (x, NoOp)
 move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp
   where
-    newUser = (user model) { userLibrary = newLib }
+    newUser = (user model) {userLibrary = newLib}
     newLib
       | c `elem` (userLibrary $ user model) =
         Protolude.filter (/= c) $ userLibrary $ user model
@@ -171,27 +173,79 @@ move (SetMediaInfo x) model = model {dMediaInfo = x}
     Nothing ->
       pure NoOp
 move (ScrollIntoView id) model = model <# do
-  say $ ms $ Legacy.show id
+  jslog $ ms $ Legacy.show id
   scrollIntoView id
   pure NoOp
+move ValidateUserPassword model =
+  batchEff
+    model
+    [doLogin, (SetComics </ fetchComics)]
+  where
+    doLogin = do
+      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 = 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
+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
+      $ 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
+      $ eitherDecodeStrict json
   where
     req =
-      Request
-        { reqMethod = GET,
-          reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
-          reqLogin = Nothing,
-          reqHeaders = [],
-          reqWithCredentials = False,
-          reqData = NoData
+      Ajax.Request
+        { Ajax.reqMethod = Ajax.POST,
+          Ajax.reqURI = "/login-hook",
+          Ajax.reqLogin = Nothing, -- FIXME
+          Ajax.reqHeaders =
+            [ ("Accept", "application/json"),
+              ("Content-Type", "application/json")
+            ],
+          Ajax.reqWithCredentials = False,
+          -- TODO: make this use Aeson
+          Ajax.reqData =
+            Ajax.StringData $
+              Miso.String.concat
+                [ "{\"loginEmail\": \"",
+                  u,
+                  "\", \"loginPass\": \"",
+                  p,
+                  "\"}"
+                ]
         }