aboutsummaryrefslogtreecommitdiff
path: root/client/src/View
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View')
-rw-r--r--client/src/View/App.hs87
-rw-r--r--client/src/View/Header.hs65
-rw-r--r--client/src/View/NotFound.hs20
-rw-r--r--client/src/View/Payment.hs9
-rw-r--r--client/src/View/Payment/Delete.hs2
-rw-r--r--client/src/View/Payment/Form.hs2
-rw-r--r--client/src/View/SignIn.hs2
7 files changed, 139 insertions, 48 deletions
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 6435297..d853c7e 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,41 +2,84 @@ module View.App
( widget
) where
-import Prelude hiding (error, init)
-import qualified Reflex.Dom as R
+import qualified Data.Text as T
+import Prelude hiding (error, init)
+import Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
-import Common.Model (InitResult (..))
-import qualified Common.Msg as Msg
+import Common.Model (Init, InitResult (..))
+import qualified Common.Msg as Msg
-import View.Header (HeaderIn (..))
-import qualified View.Header as Header
-import View.Payment (PaymentIn (..))
-import qualified View.Payment as Payment
-import qualified View.SignIn as SignIn
+import Model.Route (Route (..))
+import qualified Util.Router as Router
+import View.Header (HeaderIn (..))
+import qualified View.Header as Header
+import qualified View.NotFound as NotFound
+import View.Payment (PaymentIn (..))
+import qualified View.Payment as Payment
+import qualified View.SignIn as SignIn
widget :: InitResult -> IO ()
widget initResult =
R.mainWidget $ R.divClass "app" $ do
+ route <- getRoute
+
headerOut <- Header.view $ HeaderIn
{ _headerIn_initResult = initResult
+ , _headerIn_isInitSuccess =
+ case initResult of
+ InitSuccess _ -> True
+ _ -> False
+ , _headerIn_route = route
}
- let signOut = Header._headerOut_signOut headerOut
+ let signOut =
+ Header._headerOut_signOut headerOut
+
+ mainContent =
+ case initResult of
+ InitSuccess init ->
+ signedWidget init route
+
+ InitEmpty ->
+ SignIn.view SignIn.EmptyMessage
- initialContent = case initResult of
- InitSuccess initSuccess -> do
- _ <- Payment.widget $ PaymentIn
- { _paymentIn_init = initSuccess
- }
- return ()
- InitEmpty ->
- SignIn.view SignIn.EmptyMessage
- InitError error ->
- SignIn.view (SignIn.ErrorMessage error)
+ InitError error ->
+ SignIn.view (SignIn.ErrorMessage error)
- signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+ signOutContent =
+ SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
- _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+ _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
R.blank
+
+signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget init route = do
+ R.dyn . R.ffor route $ \case
+ RootRoute ->
+ Payment.widget $ PaymentIn
+ { _paymentIn_init = init
+ }
+
+ IncomeRoute ->
+ R.el "div" $ R.text "Incomes"
+
+ NotFoundRoute ->
+ NotFound.view
+
+ return ()
+
+getRoute :: 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
+ [""] ->
+ RootRoute
+
+ ["income"] ->
+ IncomeRoute
+
+ _ ->
+ NotFoundRoute
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 8f1fb78..9a4de89 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -4,40 +4,73 @@ module View.Header
, HeaderOut(..)
) where
-import qualified Data.Map as M
-import Data.Time (NominalDiffTime)
-import Prelude hiding (error, init)
-import Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Init (..), InitResult (..), User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Component as Component
-import Component.Button (ButtonIn (..))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
+import Prelude hiding (error, init)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Init (..), InitResult (..), User (..))
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import Component (ButtonIn (..))
+import qualified Component as Component
import qualified Icon
+import Model.Route (Route (..))
+import qualified Util.Css as CssUtil
+import qualified Util.Reflex as ReflexUtil
-data HeaderIn = HeaderIn
- { _headerIn_initResult :: InitResult
+data HeaderIn t = HeaderIn
+ { _headerIn_initResult :: InitResult
+ , _headerIn_isInitSuccess :: Bool
+ , _headerIn_route :: Dynamic t Route
}
data HeaderOut t = HeaderOut
{ _headerOut_signOut :: Event t ()
}
-view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t)
view headerIn =
R.el "header" $ do
R.divClass "title" $
R.text $ Msg.get Msg.App_Title
- signOut <- nameSignOut $ _headerIn_initResult headerIn
+ signOut <- R.el "div" $ do
+ rec
+ showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut)
+ ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn)
+ signOut <- nameSignOut $ _headerIn_initResult headerIn
+ return signOut
return $ HeaderOut
{ _headerOut_signOut = signOut
}
+links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
+links route = do
+ Component.link
+ "/"
+ (R.ffor route (attrs RootRoute))
+ (Msg.get Msg.Payment_Title)
+
+ Component.link
+ "/income"
+ (R.ffor route (attrs IncomeRoute))
+ (Msg.get Msg.Income_Title)
+
+ where
+ attrs linkRoute currentRoute =
+ M.singleton "class" $
+ CssUtil.classes
+ [ ("item", True)
+ , ("current", linkRoute == currentRoute)
+ ]
+
nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
nameSignOut initResult = case initResult of
(InitSuccess init) -> do
@@ -76,5 +109,5 @@ signOutButton = do
where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
askSignOut signOut =
fmap getResult <$> R.performRequestAsync xhrRequest
- where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+ where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut
getResult = (== 200) . R._xhrResponse_status
diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs
new file mode 100644
index 0000000..1d4e477
--- /dev/null
+++ b/client/src/View/NotFound.hs
@@ -0,0 +1,20 @@
+module View.NotFound
+ ( view
+ ) where
+
+import qualified Data.Map as M
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import qualified Component as Component
+
+view :: forall t m. MonadWidget t m => m ()
+view =
+ R.divClass "notfound" $ do
+ R.text (Msg.get Msg.NotFound_Message)
+
+ Component.link
+ "/"
+ (R.constDyn $ M.singleton "class" "link")
+ (Msg.get Msg.NotFound_LinkMessage)
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f2a5071..1072a5e 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,7 +1,6 @@
module View.Payment
( widget
, PaymentIn(..)
- , PaymentOut(..)
) where
import Data.Text (Text)
@@ -26,11 +25,7 @@ data PaymentIn = PaymentIn
{ _paymentIn_init :: Init
}
-data PaymentOut = PaymentOut
- {
- }
-
-widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
+widget :: forall t m. MonadWidget t m => PaymentIn -> m ()
widget paymentIn = do
R.elClass "main" "payment" $ do
rec
@@ -86,7 +81,7 @@ widget paymentIn = do
]
}
- pure $ PaymentOut {}
+ pure ()
debounceSearchName
:: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index e7e319e..521c1a7 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -44,7 +44,7 @@ view input _ =
let url =
R.ffor (_input_payment input) (\id ->
- T.concat ["/payment/", T.pack . show $ _payment_id id]
+ T.concat ["/api/payment/", T.pack . show $ _payment_id id]
)
(result, waiting) <- WaitFor.waitFor
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 187b64b..7819836 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -143,7 +143,7 @@ view input = do
})
(addPayment, waiting) <- WaitFor.waitFor
- (ajax "/payment")
+ (ajax "/api/payment")
(ValidationUtil.fireValidation payment confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 20:44:26 +0000