diff options
26 files changed, 596 insertions, 766 deletions
diff --git a/client/client.cabal b/client/client.cabal index 04c8543..75c2c1b 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -75,14 +75,10 @@ Executable client View.Income.Reducer View.Income.Table View.NotFound - View.Payment.Add - View.Payment.Clone - View.Payment.Delete - View.Payment.Edit View.Payment.Form View.Payment.Header View.Payment.Init - View.Payment.Pages View.Payment.Payment + View.Payment.Reducer View.Payment.Table View.SignIn diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b0533e2..08f2e74 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -72,7 +72,7 @@ view input = do let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn -- Delay the event in order to let time for the modal to disappear - R.delay (0.3 :: NominalDiffTime) content + R.delay (0.5 :: NominalDiffTime) content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 3b9ec24..2869c2d 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,7 +4,7 @@ module Component.Table , Out(..) ) where -import qualified Data.Map as M +import qualified Data.Map as M import Data.Text (Text) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a = In +data In m t h r a b c = In { _in_headerLabel :: h -> Text , _in_rows :: [r] - , _in_cell :: h -> r -> Text + , _in_cell :: h -> r -> m () , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m a - , _in_deleteModal :: r -> Modal.Content t m a + , _in_editModal :: r -> Modal.Content t m b + , _in_deleteModal :: r -> Modal.Content t m c , _in_isOwner :: r -> Bool } -data Out t a = Out +data Out t a b c = Out { _out_add :: Event t a - , _out_edit :: Event t a - , _out_delete :: Event t a + , _out_edit :: Event t b + , _out_delete :: Event t c } -view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) +view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) view input = R.divClass "table" $ do rec @@ -49,8 +49,7 @@ view input = R.divClass "row" $ do flip mapM_ [minBound..] $ \header -> R.divClass "cell" $ - R.text $ - _in_cell input header row + _in_cell input header row cloneButton <- R.divClass "cell button" $ diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d305d00..2b346af 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -58,15 +58,14 @@ widget initResult = signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case - RootRoute -> do - paymentInit <- Payment.init + RootRoute -> Payment.view $ Payment.In { Payment._in_currentUser = _init_currentUser init , Payment._in_currency = _init_currency init - , Payment._in_init = paymentInit + , Payment._in_users = _init_users init } - IncomeRoute -> do + IncomeRoute -> Income.view $ Income.In { Income._in_currentUser = _init_currentUser init , Income._in_currency = _init_currency init diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index a4f7de8..ff6e55e 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -27,7 +27,7 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Util.Ajax as Ajax -data In t = In +data In = In { _in_operation :: Operation } @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income view input cancel = do rec @@ -94,14 +94,14 @@ view input cancel = do amount = case op of - New -> "" - Clone income -> T.pack . show . _income_amount $ income - Edit income -> T.pack . show . _income_amount $ income + New -> "" + Clone i -> T.pack . show . _income_amount $ i + Edit i -> T.pack . show . _income_amount $ i date currentDay = case op of - Edit income -> _income_date income - _ -> currentDay + Edit i -> _income_date i + _ -> currentDay ajax = case op of @@ -115,5 +115,5 @@ view input cancel = do mkPayload = case op of - Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b - _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b + Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 32ab27b..c623acb 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -80,14 +80,14 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: [User] -> Currency -> Header -> Income -> Text +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m () cell users currency header income = case header of UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users DateHeader -> - Format.longDay . _income_date $ income + R.text . Format.longDay . _income_date $ income AmountHeader -> - Format.price currency . _income_amount $ income + R.text . Format.price currency . _income_amount $ income diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs deleted file mode 100644 index e983465..0000000 --- a/client/src/View/Payment/Add.hs +++ /dev/null @@ -1,55 +0,0 @@ -module View.Payment.Add - ( view - , In(..) - ) where - -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CreatePaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_frequency :: Dynamic t Frequency - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - frequency <- _in_frequency input - return $ Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_Add - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = "" - , Form._in_cost = "" - , Form._in_date = currentDay - , Form._in_category = -1 - , Form._in_frequency = frequency - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return (hide, addPayment) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs deleted file mode 100644 index 82b0c27..0000000 --- a/client/src/View/Payment/Clone.hs +++ /dev/null @@ -1,61 +0,0 @@ -module View.Payment.Clone - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - CreatePaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - form <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = currentDay - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> form) - clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form) - - return $ - ( hide - , clonePayment - ) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs deleted file mode 100644 index e5e7219..0000000 --- a/client/src/View/Payment/Delete.hs +++ /dev/null @@ -1,58 +0,0 @@ -module View.Payment.Delete - ( In(..) - , view - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data In t = In - { _in_payment :: Dynamic t Payment - } - -view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment -view input _ = - R.divClass "delete" $ do - R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm - - R.divClass "deleteContent" $ do - - (confirm, cancel) <- R.divClass "buttons" $ do - - cancel <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) - { Button._in_class = R.constDyn "undo" }) - - rec - confirm <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { Button._in_class = R.constDyn "confirm" - , Button._in_submit = True - , Button._in_waiting = waiting - }) - - let url = - R.ffor (_in_payment input) (\id -> - T.concat ["/api/payment/", T.pack . show $ _payment_id id] - ) - - (result, waiting) <- WaitFor.waitFor - (Ajax.delete url) - confirm - - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) - - return $ - ( R.leftmost [ cancel, () <$ confirm ] - , R.tag (R.current $ _in_payment input) confirm - ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs deleted file mode 100644 index 5cb4537..0000000 --- a/client/src/View/Payment/Edit.hs +++ /dev/null @@ -1,56 +0,0 @@ -module View.Payment.Edit - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - EditPaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_EditLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = _payment_date payment - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = EditPaymentForm (_payment_id payment) - , Form._in_ajax = Ajax.put - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return $ - ( hide - , editPayment - ) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 29768aa..99b0848 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,10 +1,12 @@ module View.Payment.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (ToJSON) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson import qualified Data.List as L import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M @@ -13,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -20,103 +23,98 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), Frequency (..), Payment (..), PaymentCategory (..), SavedPayment (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation + import qualified Component.Input as Input +import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select +import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_categories :: [Category] +data In = In + { _in_categories :: [Category] , _in_paymentCategories :: [PaymentCategory] - , _in_name :: Text - , _in_cost :: Text - , _in_date :: Day - , _in_category :: CategoryId - , _in_frequency :: Frequency - , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) + , _in_operation :: Operation } -data Out t = Out - { _output_hide :: Event t () - , _output_addPayment :: Event t SavedPayment - } +data Operation + = New Frequency + | Clone Payment + | Edit Payment -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view input cancel = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/payment" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _output_hide = ModalForm._out_hide modalForm - , _output_addPayment = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () - -> m (Dynamic t (Validation (NonEmpty Text) a)) + -> m (Dynamic t (Validation (NonEmpty Text) Value)) form reset confirm = do name <- Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Name - , Input._in_initialValue = _in_name input + , Input._in_initialValue = name , Input._in_validation = PaymentValidation.name }) - (_in_name input <$ reset) + (name <$ reset) confirm cost <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Cost - , Input._in_initialValue = _in_cost input + , Input._in_initialValue = cost , Input._in_validation = PaymentValidation.cost }) - (_in_cost input <$ reset) + (cost <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + d <- date date <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = initialDate + , Input._in_initialValue = d , Input._in_inputType = "date" , Input._in_hasResetButton = False , Input._in_validation = PaymentValidation.date }) - (initialDate <$ reset) + (d <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) $ \name -> - findCategory name (_in_paymentCategories input) + R.ffor (Input._out_raw name) findCategory category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category - , Select._in_initialValue = _in_category input + , Select._in_initialValue = category , Select._in_value = setCategory , Select._in_values = R.constDyn categories - , Select._in_reset = _in_category input <$ reset + , Select._in_reset = category <$ reset , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) , Select._in_validate = confirm }) @@ -126,12 +124,12 @@ view input = do c <- cost d <- date cat <- category - return ((_in_mkPayload input) + return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_in_frequency input)) + <*> V.Success frequency) frequencies = M.fromList @@ -142,7 +140,58 @@ view input = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) -findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId -findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + op = _in_operation input + + name = + case op of + New _ -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New _ -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New _ -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + category = + case op of + New _ -> -1 + Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + + frequency = + case op of + New f -> f + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New _ -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e + + findCategory :: Text -> Maybe CategoryId + findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 00987a3..c8ca347 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -32,7 +32,7 @@ import qualified Component.Input as Input import qualified Component.Modal as Modal import qualified Component.Select as Select import qualified Util.List as L -import qualified View.Payment.Add as Add +import qualified View.Payment.Form as Form import View.Payment.Init (Init (..)) data In t = In @@ -120,11 +120,7 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen Modal.view $ Modal.In { Modal._in_show = addPayment - , Modal._in_content = Add.view $ Add.In - { Add._in_categories = categories - , Add._in_paymentCategories = paymentCategories - , Add._in_frequency = frequency - } + , Modal._in_content = \_ -> return (R.never, R.never) -- TODO } searchLine diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs deleted file mode 100644 index 9a1902c..0000000 --- a/client/src/View/Payment/Pages.hs +++ /dev/null @@ -1,87 +0,0 @@ -module View.Payment.Pages - ( view - , In(..) - , Out(..) - ) where - -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Component.Button as Button - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon - -data In t = In - { _in_total :: Dynamic t Int - , _in_perPage :: Int - , _in_reset :: Event t () - } - -data Out t = Out - { _out_currentPage :: Dynamic t Int - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = do - currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - - return $ Out - { _out_currentPage = currentPage - } - - where - total = _in_total input - perPage = _in_perPage input - reset = _in_reset input - -pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) -pageButtons total perPage reset = do - R.divClass "pages" $ do - rec - currentPage <- R.holdDyn 1 . R.leftmost $ - [ firstPageClic - , previousPageClic - , pageClic - , nextPageClic - , lastPageClic - , 1 <$ reset - ] - - firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - - previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - - pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> - pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - - nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - - lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - - return currentPage - - where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switch . R.current . fmap R.leftmost - noCurrentPage = R.constDyn Nothing - -range :: Int -> Int -> [Int] -range currentPage maxPage = [start..end] - where sidePages = 2 - start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) - end = min maxPage (start + sidePages * 2) - -pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) -pageButton currentPage page content = do - clic <- Button._out_clic <$> (Button.view $ Button.In - { Button._in_class = do - cp <- currentPage - p <- page - if cp == Just p then "page current" else "page" - , Button._in_content = content - , Button._in_waiting = R.never - , Button._in_tabIndex = Nothing - , Button._in_submit = False - }) - return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index e72577f..bf0186f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,181 +1,218 @@ module View.Payment.Payment - ( init - , view + ( view , In(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, SavedPayment (..), User, - UserId) -import qualified Common.Util.Text as T - -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Pages as Pages -import qualified View.Payment.Table as Table - -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/deprecated/incomes" - categories <- AjaxUtil.getNow "api/categories" - paymentCategories <- AjaxUtil.getNow "api/paymentCategories" - return $ do - us <- users - ps <- payments - is <- incomes - cs <- categories - pcs <- paymentCategories - return $ Init <$> us <*> ps <*> is <*> cs <*> pcs - +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId + , _in_users :: [User] , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> - - R.elClass "main" "payment" $ do - rec - let addPayment = R.leftmost - [ Header._out_addPayment header - , Table._out_addPayment table - ] - - paymentsPerPage = 7 - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (Header._out_searchName header) - - let searchPayments = - getSearchPayments searchName (Header._out_searchFrequency header) payments - - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_payments = payments - , Header._in_searchPayments = searchPayments - , Header._in_paymentCategories = paymentCategories - } - - table <- Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_currentUser = _in_currentUser input - , Table._in_currentPage = Pages._out_currentPage pages - , Table._in_payments = searchPayments - , Table._in_perPage = paymentsPerPage - , Table._in_paymentCategories = paymentCategories - } - - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> searchPayments - , Pages._in_perPage = paymentsPerPage - , Pages._in_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ Header._out_addPayment header - ] - } - - pure () + + categoriesEvent <- (AjaxUtil.getNow "api/categories") + + R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + + rec + payments <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + currentPage <- R.holdDyn 1 newPage + -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + let headerAddPayment = R.never + tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_paymentCategories = paymentCategories + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } + + return ((), table, pages) + + return () return () -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -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) - )) + +-- view :: forall t m. MonadWidget t m => In t -> m () +-- view input = do +-- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> +-- +-- R.elClass "main" "payment" $ do +-- rec +-- let addPayment = R.leftmost +-- -- [ Header._out_addPayment header +-- [ Table2._out_addPayment table +-- ] +-- +-- paymentsPerPage = 7 +-- +-- payments <- reducePayments +-- (_init_payments init) +-- (_savedPayment_payment <$> addPayment) +-- (_savedPayment_payment <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- paymentCategories <- reducePaymentCategories +-- (_init_paymentCategories init) +-- payments +-- (_savedPayment_paymentCategory <$> addPayment) +-- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- -- (searchNameEvent, searchName) <- +-- -- debounceSearchName (Header._out_searchName header) +-- +-- -- let searchPayments = +-- -- getSearchPayments searchName (Header._out_searchFrequency header) payments +-- +-- -- header <- Header.view $ Header.In +-- -- { Header._in_init = init +-- -- , Header._in_currency = _in_currency input +-- -- , Header._in_payments = payments +-- -- , Header._in_searchPayments = searchPayments +-- -- , Header._in_paymentCategories = paymentCategories +-- -- } +-- +-- table <- Table2.view $ Table2.In +-- { Table2._in_init = init +-- , Table2._in_currency = _in_currency input +-- , Table2._in_currentUser = _in_currentUser input +-- , Table2._in_currentPage = Pages2._out_currentPage pages +-- , Table2._in_payments = payments +-- , Table2._in_perPage = paymentsPerPage +-- , Table2._in_paymentCategories = paymentCategories +-- } +-- +-- pages <- Pages2.view $ Pages2.In +-- { Pages2._in_total = length <$> payments +-- , Pages2._in_perPage = paymentsPerPage +-- , Pages2._in_reset = R.never +-- -- [ () <$ searchNameEvent +-- -- [ () <$ Header._out_addPayment header +-- -- ] +-- } +-- +-- pure () +-- +-- return () +-- +-- -- debounceSearchName +-- -- :: forall t m. MonadWidget t m +-- -- => Dynamic t Text +-- -- -> m (Event t Text, Dynamic t Text) +-- -- debounceSearchName searchName = do +-- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) +-- -- dynamic <- R.holdDyn "" event +-- -- return (event, dynamic) +-- +-- reducePayments +-- :: forall t m. MonadWidget t m +-- => [Payment] +-- -> Event t Payment -- add payment +-- -> Event t Payment -- edit payment +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [Payment]) +-- reducePayments initPayments addPayment editPayment deletePayment = +-- R.foldDyn id initPayments $ R.leftmost +-- [ (:) <$> addPayment +-- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) +-- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) +-- ] +-- +-- reducePaymentCategories +-- :: forall t m. MonadWidget t m +-- => [PaymentCategory] +-- -> Dynamic t [Payment] -- payments +-- -> Event t PaymentCategory -- add payment category +-- -> Event t PaymentCategory -- edit payment category +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [PaymentCategory]) +-- reducePaymentCategories +-- initPaymentCategories +-- payments +-- addPaymentCategory +-- editPaymentCategory +-- deletePayment +-- = +-- R.foldDyn id initPaymentCategories $ R.leftmost +-- [ (:) <$> addPaymentCategory +-- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) +-- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) +-- ] +-- where +-- deletePaymentName = +-- R.attachWithMaybe +-- (\ps p -> +-- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then +-- Nothing +-- else +-- Just (_payment_name p)) +-- (R.current payments) +-- deletePayment +-- lowerName = T.toLower . _payment_name +-- +-- -- 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/Reducer.hs b/client/src/View/Payment/Reducer.hs new file mode 100644 index 0000000..0c70f8a --- /dev/null +++ b/client/src/View/Payment/Reducer.hs @@ -0,0 +1,66 @@ +module View.Payment.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (PaymentPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_newPage :: Event t Int + , _in_currentPage :: Dynamic t Int + , _in_addPayment :: Event t a + , _in_editPayment :: Event t b + , _in_deletePayment :: Event t c + } + +data Action + = LoadPage Int + | GetResult (Either Text PaymentPage) + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer input = do + + postBuild <- R.getPostBuild + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_newPage input + , 1 <$ _in_addPayment input + , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) + , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.foldDyn + (\action _ -> case action of + LoadPage _ -> Loading + GetResult (Left err) -> Error err + GetResult (Right payments) -> Loaded payments + ) + Loading + (R.leftmost + [ LoadPage <$> loadPage + , GetResult <$> getResult + ]) + + where + pageUrl p = + "api/payments?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0793836..dde5168 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,209 +4,146 @@ module View.Payment.Table , Out(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Currency, - Frequency (Punctual), Payment (..), - PaymentCategory (..), SavedPayment, - User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified View.Payment.Clone as Clone -import qualified View.Payment.Delete as Delete -import qualified View.Payment.Edit as Edit -import View.Payment.Init (Init (..)) - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, Payment (..), + PaymentCategory (..), SavedPayment, + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form data In t = In - { _in_init :: Init - , _in_currency :: Currency + { _in_users :: [User] , _in_currentUser :: UserId - , _in_currentPage :: Dynamic t Int - , _in_payments :: Dynamic t [Payment] - , _in_perPage :: Int - , _in_paymentCategories :: Dynamic t [PaymentCategory] , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_paymentCategories :: [PaymentCategory] } data Out t = Out - { _out_addPayment :: Event t SavedPayment - , _out_editPayment :: Event t SavedPayment - , _out_deletePayment :: Event t Payment + { _out_add :: Event t SavedPayment + , _out_edit :: Event t SavedPayment + , _out_delete :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - R.divClass "table" $ do - - (addPayment, editPayment, deletePayment) <- 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 - R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User - R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category - R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - - result <- - (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) - - return $ - ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - ) - - ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ - R.text $ Msg.get Msg.Payment_Empty - - return $ Out - { _out_addPayment = addPayment - , _out_editPayment = editPayment - , _out_deletePayment = deletePayment - } - - where - init = _in_init input - currency = _in_currency input - currentUser = _in_currentUser input - currentPage = _in_currentPage input - payments = _in_payments input - paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage - paymentCategories = _in_paymentCategories input - -getPaymentRange :: Int -> [Payment] -> Int -> [Payment] -getPaymentRange perPage payments currentPage = - take perPage - . drop ((currentPage - 1) * perPage) - . reverse - . L.sortOn _payment_date - $ payments - -paymentRow - :: forall t m. MonadWidget t m - => Init - -> Currency - -> UserId - -> Dynamic t [PaymentCategory] - -> Dynamic t Payment - -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init currency currentUser paymentCategories payment = - R.divClass "row" $ do - - R.divClass "cell name" $ - R.dynText $ fmap _payment_name payment - - R.divClass "cell cost" $ - R.dynText $ fmap (Format.price currency . _payment_cost) payment - - let user = R.ffor payment (\p -> - CM.findUser (_payment_user p) (_init_users init)) - - R.divClass "cell user" $ - R.dynText $ flip fmap user $ \mbUser -> case mbUser of - Just u -> _user_name u - _ -> "" - - let category = do - p <- payment - pcs <- paymentCategories - return $ findCategory (_init_categories init) pcs (_payment_name p) - - R.divClass "cell category" $ do - - let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of - Just c -> M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - Nothing -> M.singleton "display" "none" - - R.elDynAttr "span" attrs $ - R.dynText $ R.ffor category $ \case - Just c -> _category_name c - _ -> "" - - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment - R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - - let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category - - clonePayment <- - R.divClass "cell button" $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.clone) - - paymentCloned <- - Modal.view $ Modal.In - { Modal._in_show = clonePayment - , Modal._in_content = - Clone.view $ Clone.In - { Clone._in_show = clonePayment - , Clone._in_categories = _init_categories init - , Clone._in_paymentCategories = paymentCategories - , Clone._in_payment = payment - , Clone._in_category = categoryId - } - } - let isFromCurrentUser = - R.ffor - payment - (\p -> _payment_user p == currentUser) - - editPayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.edit) - - paymentEdited <- - Modal.view $ Modal.In - { Modal._in_show = editPayment - , Modal._in_content = - Edit.view $ Edit.In - { Edit._in_show = editPayment - , Edit._in_categories = _init_categories init - , Edit._in_paymentCategories = paymentCategories - , Edit._in_payment = payment - , Edit._in_category = categoryId - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_paymentCategories input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Clone payment } - - deletePayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - (Button.defaultIn Icon.delete) - { Button._in_class = R.constDyn "deletePayment" - }) - - paymentDeleted <- - Modal.view $ Modal.In - { Modal._in_show = deletePayment - , Modal._in_content = - Delete.view $ Delete.In - { Delete._in_payment = payment - } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Edit payment } - - return $ (paymentCloned, paymentEdited, paymentDeleted) + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Payment_Name +headerLabel CostHeader = Msg.get Msg.Payment_Cost +headerLabel UserHeader = Msg.get Msg.Payment_User +headerLabel CategoryHeader = Msg.get Msg.Payment_Category +headerLabel DateHeader = Msg.get Msg.Payment_Date + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> [PaymentCategory] + -> Currency + -> Header + -> Payment + -> m () +cell users categories paymentCategories currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + findCategory categories paymentCategories (_payment_name payment) + + attrs = + case category of + Just c -> + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + + Nothing -> + M.singleton "display" "none" + in + R.elAttr "span" attrs $ + R.text $ + Maybe.fromMaybe "" (_category_name <$> category) + + DateHeader -> + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/common/common.cabal b/common/common.cabal index 651673f..4a6d728 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -67,3 +67,4 @@ Library Common.Model.InitResult Common.Model.Payer Common.Model.PaymentCategory + Common.Model.PaymentPage diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 313f26b..bc626d5 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -19,6 +19,7 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X +import Common.Model.PaymentPage as X import Common.Model.SavedPayment as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs new file mode 100644 index 0000000..31039c7 --- /dev/null +++ b/common/src/Common/Model/PaymentPage.hs @@ -0,0 +1,18 @@ +module Common.Model.PaymentPage + ( PaymentPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) + +data PaymentPage = PaymentPage + { _paymentPage_payments :: [Payment] + , _paymentPage_paymentCategories :: [PaymentCategory] + , _paymentPage_totalCount :: Int + } deriving (Show, Generic) + +instance FromJSON PaymentPage +instance ToJSON PaymentPage diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 30b63ff..01702cb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment - ( list + ( deprecatedList + , list , listPaymentCategories , create , edit @@ -15,6 +16,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), Payment (..), PaymentId, + PaymentPage (..), SavedPayment (..), User (..)) import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper @@ -27,12 +29,23 @@ import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure import qualified Validation.Payment as PaymentValidation -list :: ActionM () -list = +deprecatedList :: ActionM () +deprecatedList = Secure.loggedAction (\_ -> (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count + payments <- PaymentPersistence.listActivePage page perPage + paymentCategories <- PaymentCategoryPersistence.list + return $ PaymentPage payments paymentCategories count + ) >>= json + ) + listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 59e0e51..609d8fc 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -25,7 +25,6 @@ design = do ".title" <> ".item" ? headerPadding ".title" ? do - height (pct 100) textAlign (alignSide sideLeft) Media.mobile $ fontSize (px 22) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index a39276e..42c9621 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -13,7 +13,7 @@ import qualified Design.Helper as Helper design :: Css design = do let inputHeight = 50 - maxWidth (px 550) + width (px 350) sym2 padding (rem 0) (rem 2) marginTop (px 100) marginLeft auto diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 1c4e806..c77cb7c 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -67,6 +67,17 @@ design = do ".refund" & color Color.mossGreen + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + ".cell.button" & do position relative textAlign (alignSide sideCenter) diff --git a/server/src/Main.hs b/server/src/Main.hs index b2672e4..a4d8635 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -41,8 +41,13 @@ main = do S.get "/api/users"$ User.list - S.get "/api/payments" $ - Payment.list + S.get "/api/deprecated/payments" $ + Payment.deprecatedList + + S.get "/api/payments" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Payment.list page perPage S.post "/api/payment" $ S.jsonData >>= Payment.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 4ae3228..cb2ef10 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -60,9 +60,6 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) --- firstIncomeByUser --- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id; - create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index eb238d4..e01753f 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,8 +1,9 @@ module Persistence.Payment - ( Payment(..) + ( count , find , firstPunctualDay , listActive + , listActivePage , listPunctual , listActiveMonthlyOrderedByName , create @@ -54,6 +55,18 @@ instance ToRow InsertRow where , toField (_payment_createdAt p) ] +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + ) + find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do @@ -83,6 +96,16 @@ listActive = SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) +listActivePage :: Int -> Int -> Query [Payment] +listActivePage page perPage = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.query + conn + "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + listPunctual :: Query [Payment] listPunctual = Query (\conn -> do |