blob: 1f5b90041415ba75b45f1058c2e625e618435d0a (
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
|
{-# 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 (Event, MonadWidget)
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 (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_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 = R.constDyn ""
, _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
|
