aboutsummaryrefslogtreecommitdiff
path: root/src/client/View/SignIn.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/client/View/SignIn.hs')
-rw-r--r--src/client/View/SignIn.hs86
1 files changed, 0 insertions, 86 deletions
diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs
deleted file mode 100644
index e164ee7..0000000
--- a/src/client/View/SignIn.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# 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