WIP

1 files changed, 41 insertions, 57 deletions

diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 89be737..912aea2 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,11 +1,10 @@
 module View.SignIn
-  ( view
+  ( SignInMessage (..)
+  , view
   ) where
 
 import qualified Data.Either  as Either
-import           Data.Monoid  ((<>))
 import           Data.Text    (Text)
-import           Data.Time    (NominalDiffTime)
 import           Prelude      hiding (error)
 import           Reflex.Dom   (Event, MonadWidget)
 import qualified Reflex.Dom   as R
@@ -16,62 +15,47 @@ import qualified Common.Msg   as Msg
 import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
-
-view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
-view result =
-  R.divClass "signIn" $ do
-    rec
-      input <- Component.input $ InputIn
-        { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-        }
-
-      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-
-      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
-        [ fmap (const True) userWantsEmailValidation
-        , fmap (const False) signInResult
-        ]
-
-      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
-
-      let validatedEmail = R.tagPromptlyDyn
-            (_inputOut_value input)
-            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
-
-      let waiting = R.leftmost
-            [ fmap (const True) validatedEmail
-            , fmap (const False) signInResult
-            ]
-
-      button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn "validate"
-        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
-        , _buttonIn_waiting = waiting
-        }
-
-      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
-
-    showSignInResult result signInResult
-
-askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
-askSignIn email =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just key ->
-              if R._xhrResponse_status response == 200 then Right key else Left key
-            _ -> Left "NoKey"
-
-showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
-showSignInResult result signInResult = do
-  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+import qualified Util.Ajax    as Ajax
+import qualified Util.WaitFor as Util
+
+data SignInMessage =
+  SuccessMessage Text
+  | ErrorMessage Text
+  | EmptyMessage
+
+view :: forall t m. MonadWidget t m => SignInMessage -> m ()
+view signInMessage =
+  R.divClass "signIn" $
+    Component.form $ do
+      rec
+        input <- Component.input $ InputIn
+          { _inputIn_reset = R.ffilter Either.isRight signInResult
+          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
+          , _inputIn_initialValue = ""
+          }
+
+        button <- Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
+            { _buttonIn_class = R.constDyn "validate"
+            , _buttonIn_waiting = waiting
+            , _buttonIn_submit = True
+            }
+
+        (signInResult, waiting) <- Util.waitFor
+          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+          (_buttonOut_clic button)
+          (_inputOut_value input)
+
+      showSignInResult signInMessage 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
 
-  where showInitResult (Left error)           = showError error
-        showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing)        = R.blank
+  where showInitResult (SuccessMessage success) = showSuccess success
+        showInitResult (ErrorMessage error)     = showError error
+        showInitResult EmptyMessage             = R.blank
 
         showResult (Left error)    = showError error
         showResult (Right success) = showSuccess success