aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal7
-rw-r--r--client/src/Component.hs2
-rw-r--r--client/src/Component/Button.hs41
-rw-r--r--client/src/Component/Form.hs12
-rw-r--r--client/src/Component/Input.hs27
-rw-r--r--client/src/Component/Modal.hs24
-rw-r--r--client/src/Component/Select.hs32
-rw-r--r--client/src/Main.hs4
-rw-r--r--client/src/Util/Ajax.hs20
-rw-r--r--client/src/Util/WaitFor.hs18
-rw-r--r--client/src/View/App.hs8
-rw-r--r--client/src/View/Header.hs13
-rw-r--r--client/src/View/Payment/Add.hs104
-rw-r--r--client/src/View/Payment/Delete.hs51
-rw-r--r--client/src/View/Payment/Header.hs33
-rw-r--r--client/src/View/Payment/Pages.hs2
-rw-r--r--client/src/View/Payment/Table.hs48
-rw-r--r--client/src/View/SignIn.hs98
18 files changed, 417 insertions, 127 deletions
diff --git a/client/client.cabal b/client/client.cabal
index 1064e7d..0aec05f 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -33,13 +33,20 @@ Executable client
other-modules:
Component.Button
+ Component.Form
Component.Input
Component.Modal
+ Component.Select
Icon
+ Util.Ajax
+ Util.Dom
Util.List
+ Util.WaitFor
View.App
View.Header
View.Payment
+ View.Payment.Add
+ View.Payment.Delete
View.Payment.Header
View.Payment.Pages
View.Payment.Table
diff --git a/client/src/Component.hs b/client/src/Component.hs
index dea384e..7b87a75 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -1,5 +1,7 @@
module Component (module X) where
import Component.Button as X
+import Component.Form as X
import Component.Input as X
import Component.Modal as X
+import Component.Select as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 3ee9561..bf604f1 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -2,10 +2,11 @@ module Component.Button
( ButtonIn(..)
, ButtonOut(..)
, button
- , buttonInDefault
+ , defaultButtonIn
) where
import qualified Data.Map as M
+import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import Reflex.Dom (Dynamic, Event, MonadWidget)
@@ -14,22 +15,36 @@ import qualified Reflex.Dom as R
import qualified Icon
data ButtonIn t m = ButtonIn
- { _buttonIn_class :: Dynamic t Text
- , _buttonIn_content :: m ()
- , _buttonIn_waiting :: Event t Bool
+ { _buttonIn_class :: Dynamic t Text
+ , _buttonIn_content :: m ()
+ , _buttonIn_waiting :: Event t Bool
+ , _buttonIn_tabIndex :: Maybe Int
+ , _buttonIn_submit :: Bool
}
-buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m
-buttonInDefault = ButtonIn
- { _buttonIn_class = R.constDyn ""
- , _buttonIn_content = R.blank
- , _buttonIn_waiting = R.never
+defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m
+defaultButtonIn content = ButtonIn
+ { _buttonIn_class = R.constDyn ""
+ , _buttonIn_content = content
+ , _buttonIn_waiting = R.never
+ , _buttonIn_tabIndex = Nothing
+ , _buttonIn_submit = False
}
+-- defaultButtonIn :: MonadWidget t m => ButtonIn t m
+-- defaultButtonIn = ButtonIn
+-- { _buttonIn_class = R.constDyn ""
+-- , _buttonIn_content = R.blank
+-- , _buttonIn_waiting = R.never
+-- , _buttonIn_tabIndex = Nothing
+-- , _buttonIn_submit = False
+-- }
+
data ButtonOut t = ButtonOut
{ _buttonOut_clic :: Event t ()
}
+
button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
button buttonIn = do
dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
@@ -37,9 +52,11 @@ button buttonIn = do
let attr = do
buttonClass <- _buttonIn_class buttonIn
waiting <- dynWaiting
- return $ if waiting
- then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])]
- else M.fromList [("type", "button"), ("class", buttonClass)]
+ return . M.fromList . catMaybes $
+ [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button")
+ , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn
+ , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ])
+ ]
(e, _) <- R.elDynAttr' "button" attr $ do
Icon.loading
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
new file mode 100644
index 0000000..0a89c6e
--- /dev/null
+++ b/client/src/Component/Form.hs
@@ -0,0 +1,12 @@
+module Component.Form
+ ( form
+ ) where
+
+import qualified Data.Map as M
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+form :: forall t m a. (MonadWidget t m) => m a -> m a
+form content =
+ R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
+ content
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 24aac22..92f8ec9 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -2,12 +2,14 @@ module Component.Input
( InputIn(..)
, InputOut(..)
, input
+ , defaultInputIn
) where
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
-import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~))
+import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&),
+ (.~))
import qualified Reflex.Dom as R
import Component.Button (ButtonIn (..), ButtonOut (..))
@@ -15,8 +17,16 @@ import qualified Component.Button as Button
import qualified Icon
data InputIn t a b = InputIn
- { _inputIn_reset :: Event t a
- , _inputIn_label :: Text
+ { _inputIn_reset :: Event t a
+ , _inputIn_label :: Text
+ , _inputIn_initialValue :: Text
+ }
+
+defaultInputIn :: (Reflex t) => InputIn t a b
+defaultInputIn = InputIn
+ { _inputIn_reset = R.never
+ , _inputIn_label = ""
+ , _inputIn_initialValue = ""
}
data InputOut t = InputOut
@@ -41,14 +51,15 @@ input inputIn =
textInput <- R.textInput $ R.def
& R.attributes .~ attributes
& R.setValue .~ resetValue
+ & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
R.el "label" $ R.text (_inputIn_label inputIn)
- reset <- Button.button $ ButtonIn
- { _buttonIn_class = R.constDyn "reset"
- , _buttonIn_content = Icon.cross
- , _buttonIn_waiting = R.never
- }
+ reset <- Button.button $
+ (Button.defaultButtonIn Icon.cross)
+ { _buttonIn_class = R.constDyn "reset"
+ , _buttonIn_tabIndex = Just (-1)
+ }
let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index bfb5e02..1d70c90 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -10,18 +10,22 @@ import qualified Data.Map as M
import Reflex.Dom (Event, MonadWidget)
import qualified Reflex.Dom as R
-data ModalIn t m = ModalIn
+data ModalIn t m a = ModalIn
{ _modalIn_show :: Event t ()
- , _modalIn_content :: m ()
+ , _modalIn_hide :: Event t ()
+ , _modalIn_content :: m a
}
-data ModalOut = ModalOut {}
+data ModalOut a = ModalOut
+ { _modalOut_content :: a
+ }
-modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut
+modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a)
modal modalIn = do
rec
showModal <- R.holdDyn False $ R.leftmost
[ True <$ _modalIn_show modalIn
+ , False <$ _modalIn_hide modalIn
, False <$ curtainClick
]
@@ -30,9 +34,11 @@ modal modalIn = do
, ("class", "modal")
])
- curtainClick <- R.elDynAttr "div" attr $ do
- (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank
- R.divClass "content" $ _modalIn_content modalIn
- return $ R.domEvent R.Click curtain
+ (curtainClick, content) <- R.elDynAttr "div" attr $ do
+ (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
+ cont <- R.divClass "modalContent" $ _modalIn_content modalIn
+ return (R.domEvent R.Click curtain, cont)
- return $ ModalOut {}
+ return $ ModalOut
+ { _modalOut_content = content
+ }
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
new file mode 100644
index 0000000..876548e
--- /dev/null
+++ b/client/src/Component/Select.hs
@@ -0,0 +1,32 @@
+module Component.Select
+ ( SelectIn(..)
+ , SelectOut(..)
+ , select
+ ) where
+
+import Data.Map (Map)
+import Data.Text (Text)
+import Reflex.Dom (Dynamic, MonadWidget, Reflex)
+import qualified Reflex.Dom as R
+
+data (Reflex t) => SelectIn t a = SelectIn
+ { _selectIn_label :: Text
+ , _selectIn_initialValue :: a
+ , _selectIn_values :: Dynamic t (Map a Text)
+ }
+
+data SelectOut t a = SelectOut
+ { _selectOut_value :: Dynamic t a
+ }
+
+select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a)
+select selectIn =
+ R.divClass "selectInput" $ do
+ R.el "label" $ R.text (_selectIn_label selectIn)
+
+ value <- R._dropdown_value <$>
+ R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def
+
+ return SelectOut
+ { _selectOut_value = value
+ }
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d55eefe..6c048c6 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -13,7 +13,7 @@ import JSDOM.Types (HTMLElement (..), JSM)
import qualified JSDOM.Types as Dom
import Prelude hiding (error, init)
-import Common.Model (InitResult (InitEmpty))
+import Common.Model (InitResult (InitError))
import qualified Common.Msg as Msg
import qualified View.App as App
@@ -37,4 +37,4 @@ readInit = do
_ ->
return initParseError
- where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError)
+ where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
new file mode 100644
index 0000000..1e8e4c7
--- /dev/null
+++ b/client/src/Util/Ajax.hs
@@ -0,0 +1,20 @@
+module Util.Ajax
+ ( post
+ ) where
+
+import Data.Aeson (ToJSON)
+import Data.Text (Text)
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
+post url input =
+ fmap getResult <$> R.performRequestAsync xhrRequest
+ where xhrRequest = R.postJson url <$> input
+ getResult response =
+ case R._xhrResponse_responseText response of
+ Just responseText ->
+ if R._xhrResponse_status response == 200
+ then Right responseText
+ else Left responseText
+ _ -> Left "NoKey"
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
new file mode 100644
index 0000000..0175c95
--- /dev/null
+++ b/client/src/Util/WaitFor.hs
@@ -0,0 +1,18 @@
+module Util.WaitFor
+ ( waitFor
+ ) where
+
+import Data.Time (NominalDiffTime)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+waitFor
+ :: forall t m a b. MonadWidget t m
+ => (Event t a -> m (Event t b))
+ -> Event t ()
+ -> Dynamic t a
+ -> m (Event t b, Event t Bool)
+waitFor op start input = do
+ result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+ let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+ return (result, waiting)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 64ca303..9aa6c57 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -29,10 +29,12 @@ widget initResult =
{ _paymentIn_init = initSuccess
}
return ()
- InitEmpty result ->
- SignIn.view result
+ InitEmpty ->
+ SignIn.view SignIn.EmptyMessage
+ InitError error ->
+ SignIn.view (SignIn.ErrorMessage error)
- signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
+ signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
_ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 4c74383..8f1fb78 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -13,9 +13,8 @@ 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 qualified Component.Button as Component
import qualified Icon
data HeaderIn = HeaderIn
@@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of
signOutButton :: forall t m. MonadWidget t m => m (Event t ())
signOutButton = do
rec
- signOut <- Component.button $ ButtonIn
- { Component._buttonIn_class = R.constDyn "signOut item"
- , Component._buttonIn_content = Icon.signOut
- , Component._buttonIn_waiting = waiting
- }
+ signOut <- Component.button $
+ (Component.defaultButtonIn Icon.signOut)
+ { _buttonIn_class = R.constDyn "signOut item"
+ , _buttonIn_waiting = waiting
+ }
let signOutClic = Component._buttonOut_clic signOut
waiting = R.leftmost
[ fmap (const True) signOutClic
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
new file mode 100644
index 0000000..2eaec0f
--- /dev/null
+++ b/client/src/View/Payment/Add.hs
@@ -0,0 +1,104 @@
+module View.Payment.Add
+ ( view
+ , AddIn(..)
+ , AddOut(..)
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import qualified Data.Text as T
+import qualified Data.Time.Clock as Time
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+import qualified Text.Read as T
+
+import Common.Model (Category (..), CreatePayment (..),
+ Frequency (..))
+import qualified Common.Msg as Msg
+import qualified Common.Util.Time as Time
+import qualified Common.View.Format as Format
+import Component (ButtonIn (..), InputIn (..),
+ InputOut (..), SelectIn (..),
+ SelectOut (..))
+import qualified Component as Component
+import qualified Util.Ajax as Ajax
+import qualified Util.WaitFor as Util
+
+data AddIn = AddIn
+ { _addIn_categories :: [Category]
+ }
+
+data AddOut t = AddOut
+ { _addOut_cancel :: Event t ()
+ }
+
+view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t)
+view addIn = do
+ R.divClass "add" $ do
+ R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
+
+ R.divClass "addContent" $ do
+ name <- _inputOut_value <$> (Component.input $
+ Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+
+ cost <- _inputOut_value <$> (Component.input $
+ Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+
+ currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+
+ date <- _inputOut_value <$> (Component.input $
+ Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Cost
+ , _inputIn_initialValue = Format.shortDay currentDay
+ })
+
+ frequency <- _selectOut_value <$> (Component.select $ SelectIn
+ { _selectIn_label = Msg.get Msg.Payment_Frequency
+ , _selectIn_initialValue = Punctual
+ , _selectIn_values = R.constDyn frequencies
+ })
+
+ category <- _selectOut_value <$> (Component.select $ SelectIn
+ { _selectIn_label = Msg.get Msg.Payment_Category
+ , _selectIn_initialValue = 0
+ , _selectIn_values = R.constDyn categories
+ })
+
+ let payment = CreatePayment
+ <$> name
+ <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
+ <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
+ <*> category
+ <*> frequency
+
+ cancel <- R.divClass "buttons" $ do
+ rec
+ validate <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { _buttonIn_class = R.constDyn "confirm"
+ , _buttonIn_waiting = waiting
+ , _buttonIn_submit = True
+ })
+
+ (_, waiting) <- Util.waitFor
+ (Ajax.post "/payment")
+ validate
+ payment
+
+ Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { _buttonIn_class = R.constDyn "undo" })
+
+ return AddOut
+ { _addOut_cancel = cancel
+ }
+
+ where
+ frequencies = M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
+
+ categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
+ (_category_id c, _category_name c)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
new file mode 100644
index 0000000..a1be16d
--- /dev/null
+++ b/client/src/View/Payment/Delete.hs
@@ -0,0 +1,51 @@
+module View.Payment.Delete
+ ( view
+ , DeleteIn(..)
+ , DeleteOut(..)
+ ) where
+
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import Component (ButtonIn (..), ButtonOut (..))
+import qualified Component as Component
+-- import qualified Util.Ajax as Ajax
+-- import qualified Util.WaitFor as Util
+
+data DeleteIn = DeleteIn
+ {}
+
+data DeleteOut t = DeleteOut
+ { _deleteOut_cancel :: Event t ()
+ }
+
+view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
+view _ =
+ R.divClass "delete" $ do
+ R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
+
+ R.divClass "deleteContent" $ do
+
+ cancel <- R.divClass "buttons" $ do
+ rec
+ _ <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { _buttonIn_class = R.constDyn "confirm"
+ , _buttonIn_submit = True
+ })
+
+ -- (_, waiting) <- Util.waitFor
+ -- (Ajax.post "/payment")
+ -- validate
+ -- payment
+
+ cancel <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { _buttonIn_class = R.constDyn "undo" })
+
+ return cancel
+
+ return DeleteOut
+ { _deleteOut_cancel = cancel
+ }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index a694136..d01dec6 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -16,9 +16,10 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (Currency, ExceedingPayer (..),
- Frequency (..), Income (..), Init (..),
- Payment (..), User (..))
+import Common.Model (Category, Currency,
+ ExceedingPayer (..), Frequency (..),
+ Income (..), Init (..), Payment (..),
+ User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.Util.Text as T
@@ -26,9 +27,11 @@ import qualified Common.View.Format as Format
import Component (ButtonIn (..), ButtonOut (..),
InputIn (..), InputOut (..),
- ModalIn (..))
+ ModalIn (..), ModalOut (..))
import qualified Component as Component
import qualified Util.List as L
+import View.Payment.Add (AddIn (..), AddOut (..))
+import qualified View.Payment.Add as Add
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
@@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
- payerAndAdd incomes punctualPayments users currency
+ payerAndAdd incomes punctualPayments users categories currency
(searchName, searchFrequency) <- searchLine
let searchPayments = getSearchPayments searchName searchFrequency payments
infos searchPayments users currency
@@ -56,6 +59,7 @@ widget headerIn =
payments = _init_payments init
punctualPayments = filter ((==) Punctual . _payment_frequency) payments
users = _init_users init
+ categories = _init_categories init
currency = _init_currency init
getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
@@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do
n <- name
f <- frequency
pure $ flip filter payments (\p ->
- ( T.search n (_payment_name p)
+ ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
&& (_payment_frequency p == f)
))
-payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
-payerAndAdd incomes payments users currency = do
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd incomes payments users categories currency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
R.divClass "exceedingPayers" $
@@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do
{ _buttonIn_class = R.constDyn "addPayment"
, _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
, _buttonIn_waiting = R.never
+ , _buttonIn_tabIndex = Nothing
+ , _buttonIn_submit = False
})
- _ <- Component.modal $ ModalIn
- { _modalIn_show = addPayment
- , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement"
- }
+ rec
+ modalOut <- Component.modal $ ModalIn
+ { _modalIn_show = addPayment
+ , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
+ , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+ }
return ()
searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
@@ -99,6 +107,7 @@ searchLine = do
searchName <- _inputOut_value <$> (Component.input $ InputIn
{ _inputIn_reset = R.never
, _inputIn_label = Msg.get Msg.Search_Name
+ , _inputIn_initialValue = ""
})
let frequencies = M.fromList
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 55ceb9f..d14b640 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -82,5 +82,7 @@ pageButton currentPage page content = do
if cp == Just p then "page current" else "page"
, _buttonIn_content = content
, _buttonIn_waiting = R.never
+ , _buttonIn_tabIndex = Nothing
+ , _buttonIn_submit = False
})
return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index a49be5c..23d7225 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,23 +4,28 @@ module View.Payment.Table
, TableOut(..)
) where
-import qualified Data.List as L
-import qualified Data.Map as M
-import Data.Text (Text)
-import qualified Data.Text as T
-import Prelude hiding (init)
-import Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Category (..), Init (..), Payment (..),
- PaymentCategory (..), User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Common.Util.Text as T
-import qualified Common.View.Format as Format
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Prelude hiding (init)
+import Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Category (..), Init (..), Payment (..),
+ PaymentCategory (..), User (..))
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.Util.Text as T
+import qualified Common.View.Format as Format
+import Component (ButtonIn (..), ButtonOut (..),
+ ModalIn (..), ModalOut (..))
+import qualified Component as Component
+import View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+import qualified View.Payment.Delete as Delete
import qualified Icon
-import qualified Util.Dom as Dom
+import qualified Util.Dom as Dom
data TableIn t = TableIn
{ _tableIn_init :: Init
@@ -105,8 +110,17 @@ paymentRow init payment =
M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")]
R.elDynAttr "div" modifyAttrs $
R.el "button" $ Icon.edit
- R.elDynAttr "div" modifyAttrs $
- R.el "button" $ Icon.delete
+ deletePayment <- R.elDynAttr "div" modifyAttrs $
+ _buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn Icon.delete)
+ { _buttonIn_class = R.constDyn "deletePayment" })
+ rec
+ modalOut <- Component.modal $ ModalIn
+ { _modalIn_show = deletePayment
+ , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+ , _modalIn_content = Delete.view (DeleteIn {})
+ }
+ return ()
findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
findCategory categories paymentCategories paymentName = do
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 16:25:53 +0000