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 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- client/src/View/SignIn.hs | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index e164ee7..70c6b1f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# 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 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 as Message import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) +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 +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 = @@ -75,11 +73,11 @@ showSignInResult result signInResult = do _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error + where showInitResult (Left error) = showError error showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + showInitResult (Right Nothing) = R.blank - showResult (Left error) = showError error + showResult (Left error) = showError error showResult (Right success) = showSuccess success showError = R.divClass "error" . R.text -- cgit v1.2.3 From 42e94a45e26f40edc3ad71b1e77a4bf47c13fd3d Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 15 Nov 2017 23:50:44 +0100 Subject: Add dynamic pages --- client/src/View/SignIn.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 70c6b1f..1f5b900 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -49,7 +49,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.text (Message.get Key.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- client/src/View/SignIn.hs | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 1f5b900..69596d8 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,25 +1,21 @@ -{-# 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 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 Common.Model (SignIn (SignIn)) +import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +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 = @@ -27,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button @@ -50,7 +46,7 @@ view result = button <- Component.button $ ButtonIn { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3 From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- client/src/View/SignIn.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 69596d8..be6b152 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -23,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- client/src/View/SignIn.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index be6b152..89be737 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -45,7 +45,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "validate" , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } @@ -57,7 +57,7 @@ view result = 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 + where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email getResult response = case R._xhrResponse_responseText response of Just key -> -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- client/src/View/SignIn.hs | 98 ++++++++++++++++++++--------------------------- 1 file changed, 41 insertions(+), 57 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 89be737..912aea2 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,11 +1,10 @@ module View.SignIn - ( view + ( SignInMessage (..) + , 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 @@ -16,62 +15,47 @@ import qualified Common.Msg as Msg 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_label = Msg.get Msg.SignIn_EmailLabel - } - - 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 "validate" - , _buttonIn_content = R.text (Msg.get Msg.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 "/askSignIn" . 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 +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +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 $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_initialValue = "" + } + + button <- Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) + { _buttonIn_class = R.constDyn "validate" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + } + + (signInResult, waiting) <- Util.waitFor + (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (_buttonOut_clic button) + (_inputOut_value input) + + 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 (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = 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 -- cgit v1.2.3 From df83b634006c699cfa1e921bf74ce951a906a62f Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Jun 2018 22:02:00 +0200 Subject: Use date input type --- client/src/View/SignIn.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 912aea2..21d0fcc 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -30,8 +30,10 @@ view signInMessage = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_hasResetButton = True , _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_initialValue = "" + , _inputIn_inputType = "text" } button <- Component.button $ -- cgit v1.2.3 From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Oct 2018 17:57:58 +0100 Subject: Delete payment --- client/src/View/SignIn.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 21d0fcc..24e5be0 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -16,7 +16,7 @@ import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -43,8 +43,8 @@ view signInMessage = , _buttonIn_submit = True } - (signInResult, waiting) <- Util.waitFor - (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (signInResult, waiting) <- WaitFor.waitFor + (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) (_buttonOut_clic button) (_inputOut_value input) -- cgit v1.2.3 From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- client/src/View/SignIn.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 24e5be0..7f53299 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -28,13 +28,9 @@ view signInMessage = R.divClass "signIn" $ Component.form $ do rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_hasResetButton = True - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_initialValue = "" - , _inputIn_inputType = "text" - } + input <- (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) + (R.ffilter Either.isRight signInResult)) button <- Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) -- cgit v1.2.3 From b5244184920b4d7a8d64eada2eca21e9a6ea2df9 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:44:12 +0100 Subject: Use waitfor with delete confirm button --- client/src/View/SignIn.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 7f53299..428997e 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -41,8 +41,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (_buttonOut_clic button) - (_inputOut_value input) + (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) showSignInResult signInMessage signInResult -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- client/src/View/SignIn.hs | 48 +++++++++++++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 18 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 428997e..6fbf6d6 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -3,20 +3,24 @@ module View.SignIn , view ) where -import qualified Data.Either as Either -import Data.Text (Text) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +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 (SignIn (SignIn)) -import qualified Common.Msg as Msg +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.WaitFor as WaitFor +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 @@ -29,19 +33,27 @@ view signInMessage = Component.form $ do rec input <- (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) - (R.ffilter Either.isRight signInResult)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_validation = SignInValidation.email + }) + (const "" <$> R.ffilter Either.isRight signInResult) + validate) - button <- Component.button $ + 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 - (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) + (Ajax.postJson "/askSignIn") + (ValidationUtil.fireMaybe + ((\f -> const f <$> SignInValidation.signIn f) <$> form) + validate) showSignInResult signInMessage signInResult -- cgit v1.2.3 From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 21:31:27 +0200 Subject: Add smooth transitions to modal show and hide --- client/src/View/SignIn.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 6fbf6d6..f8b985f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -37,7 +37,7 @@ view signInMessage = { _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_validation = SignInValidation.email }) - (const "" <$> R.ffilter Either.isRight signInResult) + ("" <$ R.ffilter Either.isRight signInResult) validate) validate <- _buttonOut_clic <$> (Component.button $ @@ -52,7 +52,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (Ajax.postJson "/askSignIn") (ValidationUtil.fireMaybe - ((\f -> const f <$> SignInValidation.signIn f) <$> form) + ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) showSignInResult signInMessage signInResult -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- client/src/View/SignIn.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index f8b985f..8c248bd 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/askSignIn") + (Ajax.postJson "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- client/src/View/SignIn.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 8c248bd..4fe495b 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/api/askSignIn") + (Ajax.post "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From 613ffccac4b3ab25c6d4c631fab757da0b35acf6 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 22:26:38 +0200 Subject: Harmonize view component code style --- client/src/View/SignIn.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 4fe495b..a589fc3 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -15,9 +15,9 @@ 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 Component.Button as Button +import qualified Component.Form as Form +import qualified Component.Input as Input import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor @@ -30,24 +30,24 @@ data SignInMessage = view :: forall t m. MonadWidget t m => SignInMessage -> m () view signInMessage = R.divClass "signIn" $ - Component.form $ do + Form.view $ do rec - input <- (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_validation = SignInValidation.email + input <- (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_EmailLabel + , Input._in_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 + validate <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.SignIn_Button)) + { Button._in_class = R.constDyn "validate" + , Button._in_waiting = waiting + , Button._in_submit = True }) - let form = SignInForm <$> _inputOut_raw input + let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor (Ajax.post "/api/askSignIn") -- cgit v1.2.3 From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- client/src/View/SignIn.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index a589fc3..0a3b576 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.post "/api/askSignIn") + (Ajax.postAndParseResult "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- client/src/View/SignIn.hs | 71 ++++++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 31 deletions(-) (limited to 'client/src/View/SignIn.hs') diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 0a3b576..e68755f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,17 +1,16 @@ module View.SignIn - ( SignInMessage (..) - , view + ( view + , Out(..) ) 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 qualified Data.Validation as V import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (SignInForm (SignInForm)) +import Common.Model (Init, SignInForm (SignInForm)) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -22,22 +21,32 @@ 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 +data Out t = Out + { _out_success :: Event t Init + } -view :: forall t m. MonadWidget t m => SignInMessage -> m () -view signInMessage = - R.divClass "signIn" $ +view :: forall t m. MonadWidget t m => m (Out t) +view = do + signInResult <- R.divClass "signIn" $ Form.view $ do rec - input <- (Input.view + let resetForm = ("" <$ R.ffilter Either.isRight signInResult) + + email <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.SignIn_EmailLabel , Input._in_validation = SignInValidation.email }) - ("" <$ R.ffilter Either.isRight signInResult) + resetForm + validate) + + password <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_PasswordLabel + , Input._in_validation = SignInValidation.password + , Input._in_inputType = "password" + }) + resetForm validate) validate <- Button._out_clic <$> (Button.view $ @@ -47,27 +56,27 @@ view signInMessage = , Button._in_submit = True }) - let form = SignInForm <$> Input._out_raw input + let form = do + e <- email + p <- password + return . V.Success $ SignInForm e p (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postAndParseResult "/api/askSignIn") - (ValidationUtil.fireMaybe - ((\f -> f <$ SignInValidation.signIn f) <$> form) - validate) + (Ajax.postAndParseResult "/api/signIn") + (ValidationUtil.fireValidation form validate) - showSignInResult signInMessage signInResult + showSignInResult 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 + return signInResult - where showInitResult (SuccessMessage success) = showSuccess success - showInitResult (ErrorMessage error) = showError error - showInitResult EmptyMessage = R.blank + return $ Out + { _out_success = R.filterRight signInResult + } - showResult (Left error) = showError error - showResult (Right success) = showSuccess success +showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m () +showSignInResult signInResult = do + _ <- R.widgetHold R.blank $ showResult <$> signInResult + R.blank - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text + where showResult (Left error) = R.divClass "error" . R.text $ error + showResult (Right _) = R.blank -- cgit v1.2.3