diff options
Diffstat (limited to 'client/src/View')
| -rw-r--r-- | client/src/View/App.hs | 61 | ||||
| -rw-r--r-- | client/src/View/Header.hs | 52 | ||||
| -rw-r--r-- | client/src/View/SignIn.hs | 71 |
3 files changed, 95 insertions, 89 deletions
diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 460d499..b0b89fb 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -4,14 +4,14 @@ module View.App import qualified Data.Text as T import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Init (..), InitResult (..), - UserId) +import Common.Model (Currency, Init (..), UserId) import qualified Common.Msg as Msg import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil import qualified Util.Router as Router import qualified View.Category.Category as Category import qualified View.Header as Header @@ -20,43 +20,40 @@ import qualified View.NotFound as NotFound import qualified View.Payment.Payment as Payment import qualified View.SignIn as SignIn -widget :: InitResult -> IO () -widget initResult = +widget :: Maybe Init -> IO () +widget init = R.mainWidget $ R.divClass "app" $ do route <- getRoute - header <- Header.view $ Header.In - { Header._in_initResult = initResult - , Header._in_isInitSuccess = - case initResult of - InitSuccess _ -> True - _ -> False - , Header._in_route = route - } - - let signOut = - Header._out_signOut header - - mainContent = - case initResult of - InitSuccess init -> - signedWidget init route - - InitEmpty -> - SignIn.view SignIn.EmptyMessage + rec + header <- Header.view $ Header.In + { Header._in_init = initState + , Header._in_route = route + } - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + initState <- + R.foldDyn + const + init + (R.leftmost $ + [ initEvent + , Nothing <$ (Header._out_signOut header) + ]) - signOutContent = - SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + initEvent <- + (R.dyn . R.ffor initState $ \case + Nothing -> do + signIn <- SignIn.view + return (Just <$> SignIn._out_success signIn) - _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) + Just i -> do + signedWidget i route + return R.never) >>= ReflexUtil.flatten - R.blank + return () -signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> @@ -85,7 +82,7 @@ signedWidget init route = do return () -getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route) getRoute = do r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never return . R.ffor r $ \case diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 5910f52..f91c408 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -6,6 +6,7 @@ module View.Header import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime) @@ -13,7 +14,7 @@ import Prelude hiding (error, init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..), InitResult (..), User (..)) +import Common.Model (Init (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -24,9 +25,8 @@ import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon data In t = In - { _in_initResult :: InitResult - , _in_isInitSuccess :: Bool - , _in_route :: Dynamic t Route + { _in_init :: Dynamic t (Maybe Init) + , _in_route :: Dynamic t Route } data Out t = Out @@ -40,12 +40,11 @@ view input = R.divClass "title" $ R.text $ Msg.get Msg.App_Title + let showLinks = Maybe.isJust <$> _in_init input + signOut <- R.el "div" $ do - rec - showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut) - ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) - signOut <- nameSignOut $ _in_initResult input - return signOut + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten return $ Out { _out_signOut = signOut @@ -76,23 +75,24 @@ links route = do , ("current", linkRoute == currentRoute) ] -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - InitSuccess init -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case CM.findUser (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never +nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ()) +nameSignOut init = + case init of + Just init -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do 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 |