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/Component/Input.hs | 20 +++++----- client/src/Component/Modal.hs | 66 +++++++++++++++++++++----------- client/src/Component/Select.hs | 10 ++++- client/src/Icon.hs | 2 +- client/src/Main.hs | 5 ++- client/src/Util/Ajax.hs | 40 ++++++++++++-------- client/src/Util/Either.hs | 7 ++++ client/src/View/Payment.hs | 61 ++++++++++++++++++++++++++---- client/src/View/Payment/Add.hs | 39 ++++++++++++------- client/src/View/Payment/Delete.hs | 13 +++++-- client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++---------------- client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Table.hs | 29 ++++++++------ client/src/View/SignIn.hs | 10 ++--- common/common.cabal | 2 +- common/src/Common/Util/Time.hs | 6 +-- server/src/Controller/Payment.hs | 4 +- server/src/Design/Global.hs | 2 + server/src/Persistence/Payment.hs | 21 ++++++++--- 19 files changed, 278 insertions(+), 140 deletions(-) create mode 100644 client/src/Util/Either.hs diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c1eb4e8..57018a6 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -16,18 +16,16 @@ import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified Icon -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_hasResetButton :: Bool +data InputIn = InputIn + { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text } -defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn :: InputIn defaultInputIn = InputIn - { _inputIn_reset = R.never - , _inputIn_hasResetButton = True + { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" @@ -38,12 +36,16 @@ data InputOut t = InputOut , _inputOut_enter :: Event t () } -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = +input + :: forall t m a b. MonadWidget t m + => InputIn + -> Event t a -- reset + -> m (InputOut t) +input inputIn reset = R.divClass "textInput" $ do rec let resetValue = R.leftmost - [ fmap (const "") (_inputIn_reset inputIn) + [ fmap (const "") reset , fmap (const "") resetClic ] diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 72091c9..b86fee0 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -4,16 +4,18 @@ module Component.Modal , modal ) where -import Control.Monad (void) -import qualified Data.Map as M -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified GHCJS.DOM.Node as Node -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R -import qualified Reflex.Dom.Class as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Element as Element +import qualified GHCJS.DOM.Node as Node +import JSDOM.Types (JSString) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -28,20 +30,21 @@ data ModalOut a = 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 - ] + let showEvent = R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn + , False <$ curtainClick + ] - (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ 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) + showModal <- R.holdDyn False showEvent - body <- Dom.getBody - let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) - R.performEvent_ $ void `fmap` moveBackdrop + (elem, (curtainClick, content)) <- + R.buildElement "div" (getAttributes <$> showModal) $ 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) + + performShowEffects showEvent elem return $ ModalOut { _modalOut_content = content @@ -53,3 +56,24 @@ getAttributes show = [ ("style", if show then "display:block" else "display:none") , ("class", "modal") ] + +performShowEffects + :: forall t m a. MonadWidget t m + => Event t Bool + -> Element.Element + -> m () +performShowEffects showEvent elem = do + body <- Dom.getBody + + let showEffects = + flip fmap showEvent (\show -> do + if show + then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + Element.setClassName body ("" :: JSString) + ) + + R.performEvent_ $ void `fmap` showEffects diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 17a4958..7cb6726 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -6,13 +6,14 @@ module Component.Select import Data.Map (Map) import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, 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) + , _selectIn_reset :: Event t () } data SelectOut t a = SelectOut @@ -24,8 +25,13 @@ select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) + let initialValue = _selectIn_initialValue selectIn + value <- R._dropdown_value <$> - R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) return SelectOut { _selectOut_value = value diff --git a/client/src/Icon.hs b/client/src/Icon.hs index dae5e7f..1a45933 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -59,7 +59,7 @@ edit = loading :: forall t m. MonadWidget t m => m () loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank signOut :: forall t m. MonadWidget t m => m () diff --git a/client/src/Main.hs b/client/src/Main.hs index 6c048c6..d6f89cd 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -9,7 +9,8 @@ import qualified Data.Text.Encoding as T import qualified JSDOM as Dom import qualified JSDOM.Generated.HTMLElement as Dom import qualified JSDOM.Generated.NonElementParentNode as Dom -import JSDOM.Types (HTMLElement (..), JSM) +import JSDOM.Types (HTMLElement (..), JSM, + JSString) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) @@ -26,7 +27,7 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document ("init" :: Dom.JSString) + initNode <- Dom.getElementById document ("init" :: JSString) case initNode of Just node -> do diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 14675df..0d76638 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -3,32 +3,42 @@ module Util.Ajax , delete ) where -import Data.Aeson (ToJSON) -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), XhrResponse, - XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), + XhrResponse, XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson - :: forall t m a. (MonadWidget t m, ToJSON a) + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a - -> m (Event t (Either Text Text)) + -> m (Event t (Either Text b)) postJson url input = - fmap getResult <$> + fmap getJsonResult <$> R.performRequestAsync (R.postJson url <$> input) delete - :: forall t m. MonadWidget t m + :: forall t m a. (MonadWidget t m) => Dynamic t Text -> Event t () -> m (Event t (Either Text Text)) -delete url fire = - fmap getResult <$> - R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) +delete url fire = do + response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + return $ fmap getResult response + +getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a +getJsonResult response = + case getResult response of + Left l -> Left l + Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r) getResult :: XhrResponse -> Either Text Text getResult response = diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs new file mode 100644 index 0000000..2910d95 --- /dev/null +++ b/client/src/Util/Either.hs @@ -0,0 +1,7 @@ +module Util.Either + ( eitherToMaybe + ) where + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 42da8fb..5245e72 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,17 +4,20 @@ module View.Payment , PaymentOut(..) ) where +import Data.Text (Text) +import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Init (..)) - +import Common.Model (Frequency, Init (..), Payment (..), + PaymentId) +import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) +import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -32,21 +35,63 @@ widget paymentIn = do let init = _paymentIn_init paymentIn paymentsPerPage = 7 + payments <- getPayments + (_init_payments init) + (_headerOut_addedPayment header) + (_tableOut_deletedPayment table) + + let searchPayments = + getSearchPayments + (_headerOut_searchName header) + (_headerOut_searchFrequency header) + payments + header <- Header.widget $ HeaderIn { _headerIn_init = init + , _headerIn_searchPayments = searchPayments } - _ <- Table.widget $ TableIn + table <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = _headerOut_searchPayments header + , _tableIn_payments = searchPayments , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> _headerOut_searchPayments header + { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header + , _pagesIn_reset = R.leftmost $ + [ fmap (const ()) . R.updated . _headerOut_searchName $ header + , fmap (const ()) . _headerOut_addedPayment $ header + ] } pure $ PaymentOut {} + +getPayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment + -> Event t PaymentId + -> m (Dynamic t [Payment]) +getPayments initPayments addedPayment deletedPayment = + R.foldDyn id initPayments $ R.leftmost + [ flip fmap addedPayment (:) + , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + ] + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 8b1b56e..602f7f3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -10,12 +10,12 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import Component (ButtonIn (..), InputIn (..), @@ -23,48 +23,56 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data AddIn = AddIn +data AddIn t = AddIn { _addIn_categories :: [Category] + , _addIn_show :: Event t () } data AddOut t = AddOut - { _addOut_cancel :: Event t () + { _addOut_cancel :: Event t () + , _addOut_addedPayment :: Event t Payment } -view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view :: forall t m. MonadWidget t m => AddIn t -> 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 }) + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (_addIn_show addIn)) - cost <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (_addIn_show addIn)) currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - date <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False }) + (_addIn_show addIn)) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = 0 , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn }) let payment = CreatePayment @@ -74,7 +82,7 @@ view addIn = do <*> category <*> frequency - cancel <- R.divClass "buttons" $ do + (addedPayment, cancel) <- R.divClass "buttons" $ do rec validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -83,17 +91,20 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- WaitFor.waitFor + (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") validate payment - Component._buttonOut_clic <$> (Component.button $ + cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return AddOut { _addOut_cancel = cancel + , _addOut_addedPayment = addedPayment } where diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 03cf267..330ef9f 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,6 +4,7 @@ module View.Payment.Delete , DeleteOut(..) ) where +import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -13,6 +14,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil -- import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn @@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn } data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () + { _deleteOut_cancel :: Event t () + , _deleteOut_validate :: Event t PaymentId } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -30,7 +33,7 @@ view deleteIn = R.divClass "deleteContent" $ do - cancel <- R.divClass "buttons" $ do + (deletedPayment, cancel) <- R.divClass "buttons" $ do rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -41,7 +44,8 @@ view deleteIn = let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - Ajax.delete url confirm + + result <- Ajax.delete url confirm -- (_, waiting) <- WaitFor.waitFor -- (Ajax.delete "/payment") @@ -52,8 +56,9 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - return cancel + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut { _deleteOut_cancel = cancel + , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index be7f6d5..653df5e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,7 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Category, Currency, @@ -22,7 +22,6 @@ import Common.Model (Category, Currency, 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 (..), @@ -34,44 +33,47 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] } data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchPayments :: Dynamic t [Payment] + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchFrequency :: Dynamic t Frequency + , _headerOut_addedPayment :: Event t Payment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users categories currency - (searchName, searchFrequency) <- searchLine - let searchPayments = getSearchPayments searchName searchFrequency payments - infos searchPayments users currency + addedPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addedPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency + return $ HeaderOut { _headerOut_searchName = searchName - , _headerOut_searchPayments = searchPayments + , _headerOut_searchFrequency = searchFrequency + , _headerOut_addedPayment = addedPayment } where init = _headerIn_init headerIn incomes = _init_incomes init - payments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) payments + initPayments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments 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] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - pure $ flip filter payments (\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] -> [Category] -> Currency -> m () +payerAndAdd + :: forall t m. MonadWidget t m + => [Income] + -> [Payment] + -> [User] + -> [Category] + -> Currency + -> m (Event t Payment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- Component.modal $ ModalIn + modalOut <- fmap _modalOut_content . Component.modal $ ModalIn { _modalIn_show = addPaymentClic - , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + , _modalIn_hide = R.leftmost $ + [ _addOut_cancel modalOut + , fmap (const ()) . _addOut_addedPayment $ modalOut + ] + , _modalIn_content = Add.view $ AddIn + { _addIn_categories = categories + , _addIn_show = addPaymentClic + } } - return () + return (_addOut_addedPayment modalOut) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) -searchLine = do +searchLine + :: forall t m. MonadWidget t m + => Event t () + -> m (Dynamic t Text, Dynamic t Frequency) +searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Search_Name - }) + searchName <- _inputOut_value <$> (Component.input + ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + reset) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -118,7 +129,11 @@ searchLine = do return (searchName, searchFrequency) -infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () +infos + :: forall t m. MonadWidget t m + => Dynamic t [Payment] + -> [User] + -> Currency -> m () infos payments users currency = R.divClass "infos" $ do diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index d14b640..57d67ac 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -64,7 +64,7 @@ pageButtons total perPage reset = do return currentPage where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switchPromptlyDyn . fmap R.leftmost + pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 13cedda..ba16bf5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -9,11 +9,12 @@ 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 Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) + PaymentCategory (..), PaymentId, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -34,15 +35,15 @@ data TableIn t = TableIn , _tableIn_perPage :: Int } -data TableOut = TableOut - { +data TableOut t = TableOut + { _tableOut_deletedPayment :: Event t PaymentId } -widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut +widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - R.divClass "lines" $ do + deletedPayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -52,13 +53,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - _ <- R.simpleList paymentRange (paymentRow init) - return () + (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut {} + return $ TableOut + { _tableOut_deletedPayment = deletedPayment + } where init = _tableIn_init tableIn @@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) paymentRow init payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment @@ -117,10 +119,13 @@ paymentRow init payment = rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment - , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_hide = R.leftmost $ + [ _deleteOut_cancel . _modalOut_content $ modalOut + , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut + ] , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } - return () + return (_deleteOut_validate . _modalOut_content $ modalOut) 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 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)) diff --git a/common/common.cabal b/common/common.cabal index 151326a..78f2927 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Common.Model Common.Model.CreatePayment Common.Model.Payment + Common.Model.User Common.Msg Common.Util.Text Common.Util.Time @@ -52,4 +53,3 @@ Library Common.Model.Payer Common.Model.PaymentCategory Common.Model.SignIn - Common.Model.User diff --git a/common/src/Common/Util/Time.hs b/common/src/Common/Util/Time.hs index 9ab7ab5..6240720 100644 --- a/common/src/Common/Util/Time.hs +++ b/common/src/Common/Util/Time.hs @@ -16,9 +16,9 @@ timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time parseDay :: Text -> Maybe Day parseDay str = do - (d, m, y) <- - case T.splitOn str "/" of - [d, m, y] -> Just (d, m, y) + (y, m, d) <- + case T.splitOn "-" str of + [y, m, d] -> Just (y, m, d) _ -> Nothing d' <- T.readMaybe . T.unpack $ d m' <- T.readMaybe . T.unpack $ m diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 4edbf6a..fb7fcb2 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -12,8 +12,6 @@ import Web.Scotty import Common.Model (CreatePayment (..), EditPayment (..), PaymentId, User (..)) - -import qualified Json import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -34,7 +32,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do PaymentCategoryPersistence.save name category PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + ) >>= json Just validationError -> do status Status.badRequest400 diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 4da4ffb..de8dd61 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -29,6 +29,8 @@ global = do body ? do minWidth (px 320) fontFamily ["Cantarell"] [sansSerif] + ".modal" & + overflowY hidden Media.tablet $ do fontSize (px 15) button ? fontSize (px 15) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 32600d7..272cd39 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -92,18 +92,29 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = +create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment +create userId name cost date frequency = Query (\conn -> do - now <- getCurrentTime + time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?)" ]) - (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) - SQLite.lastInsertRowId conn + (userId, name, cost, date, FrequencyField frequency, time) + paymentId <- SQLite.lastInsertRowId conn + return $ Payment + { _payment_id = paymentId + , _payment_user = userId + , _payment_name = name + , _payment_cost = cost + , _payment_date = date + , _payment_frequency = frequency + , _payment_createdAt = time + , _payment_editedAt = Nothing + , _payment_deletedAt = Nothing + } ) createMany :: [Payment] -> Query () -- cgit v1.2.3