From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 8 Nov 2017 23:47:26 +0100
Subject: Use a better project structure

---
 client/src/View/SignIn.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)
 create mode 100644 client/src/View/SignIn.hs

(limited to 'client/src/View/SignIn.hs')

diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
new file mode 100644
index 0000000..e164ee7
--- /dev/null
+++ b/client/src/View/SignIn.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.SignIn
+  ( 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 (MonadWidget, Event)
+import qualified Reflex.Dom as R
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (SignIn(SignIn))
+
+import Component.Input (InputIn(..), InputOut(..))
+import Component.Button (ButtonIn(..), ButtonOut(..))
+import qualified Component.Button as Component
+import qualified Component.Input 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_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        }
+
+      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 = ""
+        , _buttonIn_content = R.text (Message.get Key.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 "/signIn" . 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
+  R.blank
+
+  where showInitResult (Left error) = showError error
+        showInitResult (Right (Just success)) = showSuccess success
+        showInitResult (Right Nothing) = R.blank
+
+        showResult (Left error) = showError error
+        showResult (Right success) = showSuccess success
+
+        showError = R.divClass "error" . R.text
+        showSuccess = R.divClass "success" . R.text
-- 
cgit v1.2.3