Sign in with email and password

1 files changed, 40 insertions, 31 deletions

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