blob: f8b985fcdc13e1dc42968fb77be0182f9fba9968 (
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
|
module View.SignIn
( SignInMessage (..)
, view
) where
import qualified Data.Either as Either
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Validation (Validation)
import Prelude hiding (error)
import Reflex.Dom (Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (SignInForm (SignInForm))
import qualified Common.Msg as Msg
import qualified Common.Validation.SignIn as SignInValidation
import Component (ButtonIn (..), ButtonOut (..),
InputIn (..), InputOut (..))
import qualified Component as Component
import qualified Util.Ajax as Ajax
import qualified Util.Validation as ValidationUtil
import qualified Util.WaitFor as WaitFor
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
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.SignIn_EmailLabel
, _inputIn_validation = SignInValidation.email
})
("" <$ R.ffilter Either.isRight signInResult)
validate)
validate <- _buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
{ _buttonIn_class = R.constDyn "validate"
, _buttonIn_waiting = waiting
, _buttonIn_submit = True
})
let form = SignInForm <$> _inputOut_raw input
(signInResult, waiting) <- WaitFor.waitFor
(Ajax.postJson "/askSignIn")
(ValidationUtil.fireMaybe
((\f -> f <$ SignInValidation.signIn f) <$> form)
validate)
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 (SuccessMessage success) = showSuccess success
showInitResult (ErrorMessage error) = showError error
showInitResult EmptyMessage = R.blank
showResult (Left error) = showError error
showResult (Right success) = showSuccess success
showError = R.divClass "error" . R.text
showSuccess = R.divClass "success" . R.text
|
