Sign in with email and password

6 files changed, 100 insertions, 107 deletions

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 6faecef..153a61b 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -22,7 +22,7 @@ data In t m = In
   , _in_submit   :: Bool
   }
 
-defaultIn :: MonadWidget t m => m () -> In t m
+defaultIn :: forall t m. MonadWidget t m => m () -> In t m
 defaultIn content = In
   { _in_class    = R.constDyn ""
   , _in_content  = content
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d6f89cd..c71b0f0 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -14,7 +14,7 @@ import           JSDOM.Types                          (HTMLElement (..), JSM,
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import           Common.Model                         (InitResult (InitError))
+import           Common.Model                         (Init)
 import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
@@ -24,7 +24,7 @@ main = do
   initResult <- readInit
   App.widget initResult
 
-readInit :: JSM InitResult
+readInit :: JSM (Maybe Init)
 readInit = do
   document <- Dom.currentDocumentUnchecked
   initNode <- Dom.getElementById document ("init" :: JSString)
@@ -34,8 +34,6 @@ readInit = do
       text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
       return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
         Just init -> init
-        Nothing   -> initParseError
+        Nothing   -> Nothing
     _ ->
-      return initParseError
-
-  where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
+      return Nothing
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index f9545a4..50f2468 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -3,7 +3,6 @@ module Util.Validation
   , toMaybe
   , maybeError
   , fireValidation
-  , fireMaybe
   ) where
 
 import           Control.Monad      (join)
@@ -35,13 +34,3 @@ fireValidation value validate =
   R.fmapMaybe
     (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
-
-fireMaybe
-  :: forall t a b. Reflex t
-  => Dynamic t (Maybe a)
-  -> Event t b
-  -> Event t a
-fireMaybe value validate =
-  R.fmapMaybe
-    id
-    (R.tag (R.current value) validate)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 460d499..b0b89fb 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -4,14 +4,14 @@ module View.App
 
 import qualified Data.Text              as T
 import           Prelude                hiding (error, init)
-import           Reflex.Dom             (Dynamic, MonadWidget)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, Init (..), InitResult (..),
-                                         UserId)
+import           Common.Model           (Currency, Init (..), UserId)
 import qualified Common.Msg             as Msg
 
 import           Model.Route            (Route (..))
+import qualified Util.Reflex            as ReflexUtil
 import qualified Util.Router            as Router
 import qualified View.Category.Category as Category
 import qualified View.Header            as Header
@@ -20,43 +20,40 @@ import qualified View.NotFound          as NotFound
 import qualified View.Payment.Payment   as Payment
 import qualified View.SignIn            as SignIn
 
-widget :: InitResult -> IO ()
-widget initResult =
+widget :: Maybe Init -> IO ()
+widget init =
   R.mainWidget $ R.divClass "app" $ do
 
     route <- getRoute
 
-    header <- Header.view $ Header.In
-      { Header._in_initResult = initResult
-      , Header._in_isInitSuccess =
-        case initResult of
-          InitSuccess _ -> True
-          _             -> False
-      , Header._in_route = route
-      }
-
-    let signOut =
-          Header._out_signOut header
-
-        mainContent =
-          case initResult of
-            InitSuccess init ->
-              signedWidget init route
-
-            InitEmpty ->
-              SignIn.view SignIn.EmptyMessage
+    rec
+      header <- Header.view $ Header.In
+        { Header._in_init = initState
+        , Header._in_route = route
+        }
 
-            InitError error ->
-              SignIn.view (SignIn.ErrorMessage error)
+      initState <-
+        R.foldDyn
+          const
+          init
+          (R.leftmost $
+            [ initEvent
+            , Nothing <$ (Header._out_signOut header)
+            ])
 
-        signOutContent =
-          SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+      initEvent <-
+        (R.dyn . R.ffor initState $ \case
+          Nothing -> do
+            signIn <- SignIn.view
+            return (Just <$> SignIn._out_success signIn)
 
-    _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
+          Just i -> do
+            signedWidget i route
+            return R.never) >>= ReflexUtil.flatten
 
-    R.blank
+    return ()
 
-signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute ->
@@ -85,7 +82,7 @@ signedWidget init route = do
 
   return ()
 
-getRoute :: MonadWidget t m => m (Dynamic t Route)
+getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route)
 getRoute = do
   r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never
   return . R.ffor r $ \case
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 5910f52..f91c408 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -6,6 +6,7 @@ module View.Header
 
 import           Data.Map         (Map)
 import qualified Data.Map         as M
+import qualified Data.Maybe       as Maybe
 import           Data.Text        (Text)
 import qualified Data.Text        as T
 import           Data.Time        (NominalDiffTime)
@@ -13,7 +14,7 @@ import           Prelude          hiding (error, init)
 import           Reflex.Dom       (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom       as R
 
-import           Common.Model     (Init (..), InitResult (..), User (..))
+import           Common.Model     (Init (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
 import qualified Component.Button as Button
@@ -24,9 +25,8 @@ import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
 data In t = In
-  { _in_initResult    :: InitResult
-  , _in_isInitSuccess :: Bool
-  , _in_route         :: Dynamic t Route
+  { _in_init  :: Dynamic t (Maybe Init)
+  , _in_route :: Dynamic t Route
   }
 
 data Out t = Out
@@ -40,12 +40,11 @@ view input =
     R.divClass "title" $
       R.text $ Msg.get Msg.App_Title
 
+    let showLinks = Maybe.isJust <$> _in_init input
+
     signOut <- R.el "div" $ do
-      rec
-        showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
-        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
-        signOut <- nameSignOut $ _in_initResult input
-      return signOut
+      ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
+      (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten
 
     return $ Out
       { _out_signOut = signOut
@@ -76,23 +75,24 @@ links route = do
           , ("current", linkRoute == currentRoute)
           ]
 
-nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
-nameSignOut initResult = case initResult of
-  InitSuccess init -> do
-    rec
-      attr <- R.holdDyn
-        (M.singleton "class" "nameSignOut")
-        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
-
-      signOut <- R.elDynAttr "nameSignOut" attr $ do
-        case CM.findUser (_init_currentUser init) (_init_users init) of
-          Just user -> R.divClass "name" $ R.text (_user_name user)
-          Nothing   -> R.blank
-        signOutButton
-
-    return signOut
-  _ ->
-    return R.never
+nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ())
+nameSignOut init =
+  case init of
+    Just init -> do
+      rec
+        attr <- R.holdDyn
+          (M.singleton "class" "nameSignOut")
+          (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+        signOut <- R.elDynAttr "nameSignOut" attr $ do
+          case CM.findUser (_init_currentUser init) (_init_users init) of
+            Just user -> R.divClass "name" $ R.text (_user_name user)
+            Nothing   -> R.blank
+          signOutButton
+
+      return signOut
+    _ ->
+      return R.never
 
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 0a3b576..e68755f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,17 +1,16 @@
 module View.SignIn
-  ( SignInMessage (..)
-  , view
+  ( view
+  , Out(..)
   ) where
 
 import qualified Data.Either              as Either
 import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
-import           Data.Validation          (Validation)
-import           Prelude                  hiding (error)
+import qualified Data.Validation          as V
 import           Reflex.Dom               (Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
-import           Common.Model             (SignInForm (SignInForm))
+import           Common.Model             (Init, SignInForm (SignInForm))
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.SignIn as SignInValidation
 
@@ -22,22 +21,32 @@ import qualified Util.Ajax                as Ajax
 import qualified Util.Validation          as ValidationUtil
 import qualified Util.WaitFor             as WaitFor
 
-data SignInMessage =
-  SuccessMessage Text
-  | ErrorMessage Text
-  | EmptyMessage
+data Out t = Out
+  { _out_success       :: Event t Init
+  }
 
-view :: forall t m. MonadWidget t m => SignInMessage -> m ()
-view signInMessage =
-  R.divClass "signIn" $
+view :: forall t m. MonadWidget t m => m (Out t)
+view = do
+  signInResult <- R.divClass "signIn" $
     Form.view $ do
       rec
-        input <- (Input.view
+        let resetForm = ("" <$ R.ffilter Either.isRight signInResult)
+
+        email <- Input._out_raw <$> (Input.view
           (Input.defaultIn
             { Input._in_label = Msg.get Msg.SignIn_EmailLabel
             , Input._in_validation = SignInValidation.email
             })
-          ("" <$ R.ffilter Either.isRight signInResult)
+          resetForm
+          validate)
+
+        password <- Input._out_raw <$> (Input.view
+          (Input.defaultIn
+            { Input._in_label = Msg.get Msg.SignIn_PasswordLabel
+            , Input._in_validation = SignInValidation.password
+            , Input._in_inputType = "password"
+            })
+          resetForm
           validate)
 
         validate <- Button._out_clic <$> (Button.view $
@@ -47,27 +56,27 @@ view signInMessage =
             , Button._in_submit = True
             })
 
-        let form = SignInForm <$> Input._out_raw input
+        let form = do
+              e <- email
+              p <- password
+              return . V.Success $ SignInForm e p
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postAndParseResult "/api/askSignIn")
-          (ValidationUtil.fireMaybe
-            ((\f -> f <$ SignInValidation.signIn f) <$> form)
-            validate)
+          (Ajax.postAndParseResult "/api/signIn")
+          (ValidationUtil.fireValidation form validate)
 
-      showSignInResult signInMessage signInResult
+      showSignInResult signInResult
 
-showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
-showSignInResult signInMessage signInResult = do
-  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
-  R.blank
+      return signInResult
 
-  where showInitResult (SuccessMessage success) = showSuccess success
-        showInitResult (ErrorMessage error)     = showError error
-        showInitResult EmptyMessage             = R.blank
+  return $ Out
+    { _out_success = R.filterRight signInResult
+    }
 
-        showResult (Left error)    = showError error
-        showResult (Right success) = showSuccess success
+showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m ()
+showSignInResult signInResult = do
+  _ <- R.widgetHold R.blank $ showResult <$> signInResult
+  R.blank
 
-        showError = R.divClass "error" . R.text
-        showSuccess = R.divClass "success" . R.text
+  where showResult (Left error) = R.divClass "error" . R.text $ error
+        showResult (Right _)    = R.blank