blob: e164ee744f1bd0f20f391882ed4e7bd7bfaaddfd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
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
|
