From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- client/src/View/App.hs | 43 ++++++++----- client/src/View/Category/Category.hs | 92 ++++++++++++++++++++++++++ client/src/View/Category/Form.hs | 117 ++++++++++++++++++++++++++++++++++ client/src/View/Category/Reducer.hs | 59 +++++++++++++++++ client/src/View/Category/Table.hs | 91 ++++++++++++++++++++++++++ client/src/View/Header.hs | 5 ++ client/src/View/Income/Form.hs | 2 +- client/src/View/Income/Header.hs | 3 +- client/src/View/Income/Income.hs | 1 - client/src/View/Income/Init.hs | 11 ---- client/src/View/Income/Table.hs | 11 ++-- client/src/View/Payment/Form.hs | 2 +- client/src/View/Payment/HeaderForm.hs | 2 +- client/src/View/Payment/Payment.hs | 2 +- client/src/View/Payment/Table.hs | 30 ++++----- client/src/View/SignIn.hs | 2 +- 16 files changed, 413 insertions(+), 60 deletions(-) create mode 100644 client/src/View/Category/Category.hs create mode 100644 client/src/View/Category/Form.hs create mode 100644 client/src/View/Category/Reducer.hs create mode 100644 client/src/View/Category/Table.hs delete mode 100644 client/src/View/Income/Init.hs (limited to 'client/src/View') diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 2b346af..460d499 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,23 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), InitResult (..), - UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), InitResult (..), + UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -72,6 +73,13 @@ signedWidget init route = do , Income._in_users = _init_users init } + CategoryRoute -> + Category.view $ Category.In + { Category._in_currentUser = _init_currentUser init + , Category._in_currency = _init_currency init + , Category._in_users = _init_users init + } + NotFoundRoute -> NotFound.view @@ -87,5 +95,8 @@ getRoute = do ["income"] -> IncomeRoute + ["category"] -> + CategoryRoute + _ -> NotFoundRoute diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs new file mode 100644 index 0000000..77a331a --- /dev/null +++ b/client/src/View/Category/Category.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Category.Category + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, CategoryPage (..), Currency, + User, UserId) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Category.Form as Form +import qualified View.Category.Reducer as Reducer +import qualified View.Category.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + categoryPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addCategory = R.leftmost [ headerAddCategory, tableAddCategory ] + , Reducer._in_editCategory = editCategory + , Reducer._in_deleteCategory = deleteCategory + } + + let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddCategory <- eventFromResult $ (\(a, _, _) -> a) + tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading categoryPage $ + \(CategoryPage page categories count) -> do + header <- headerView + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_categories = categories + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () + +headerView :: forall t m. MonadWidget t m => m (Event t ()) +headerView = + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs new file mode 100644 index 0000000..d91fc2e --- /dev/null +++ b/client/src/View/Category/Form.hs @@ -0,0 +1,117 @@ +module View.Category.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Category as CategoryValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Category + | Edit Category + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/category" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + name <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Name + , Input._in_initialValue = name + , Input._in_validation = CategoryValidation.name + }) + (name <$ reset) + confirm) + + color <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Color + , Input._in_initialValue = color + , Input._in_inputType = "color" + , Input._in_hasResetButton = False + , Input._in_validation = CategoryValidation.color + }) + (color <$ reset) + confirm) + + return $ do + n <- name + c <- color + return . V.Success $ mkPayload n c + + op = _in_operation input + + name = + case op of + New -> "" + Clone c -> _category_name c + Edit c -> _category_name c + + color = + case op of + New -> "" + Clone c -> _category_color c + Edit c -> _category_color c + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Category_Edit + _ -> Msg.get Msg.Category_Add + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateCategoryForm a b diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs new file mode 100644 index 0000000..5ad0ddb --- /dev/null +++ b/client/src/View/Category/Reducer.hs @@ -0,0 +1,59 @@ +module View.Category.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 (CategoryPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addCategory :: Event t a + , _in_editCategory :: Event t b + , _in_deleteCategory :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addCategory input + , R.tag (R.current currentPage) (_in_editCategory input) + , R.tag (R.current currentPage) (_in_deleteCategory input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/categories?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs new file mode 100644 index 0000000..fbe76e9 --- /dev/null +++ b/client/src/View/Category/Table.hs @@ -0,0 +1,91 @@ +module View.Category.Table + ( view + , In(..) + , Out(..) + ) where + +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, 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 Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Category.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_categories input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Clone category + } + , Table._in_editModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Edit category + } + , Table._in_deleteModal = \category -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Category_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = const True + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | ColorHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Category_Name +headerLabel ColorHeader = Msg.get Msg.Category_Color + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m () +cell users currency header category = + case header of + NameHeader -> + R.text $ _category_name category + + ColorHeader -> + Tag.view $ Tag.In + { Tag._in_text = _category_name category + , Tag._in_color = _category_color category + } diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 3f58dd5..5910f52 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -63,6 +63,11 @@ links route = do (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) + Link.view + "/category" + (R.ffor route (attrs CategoryRoute)) + (Msg.get Msg.Category_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index ff6e55e..59f6a0d 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m view input cancel = do rec diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 9e1c5b6..a26e16a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -21,7 +21,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_users :: [User] @@ -30,7 +29,7 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income + { _out_add :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index e83ba80..7be8091 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -21,7 +21,6 @@ import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs deleted file mode 100644 index 4f3ef99..0000000 --- a/client/src/View/Income/Init.hs +++ /dev/null @@ -1,11 +0,0 @@ -module View.Income.Init - ( Init(..) - ) where - -import Common.Model (Income, Payment, User) - -data Init = Init - { _init_users :: [User] - , _init_incomes :: [Income] - , _init_payments :: [Payment] - } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c623acb..c7f172b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,7 +4,6 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -31,9 +30,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income - , _out_edit :: Event t Income - , _out_delete :: Event t Income + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -41,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input + , Table._in_rows = _in_incomes input , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In @@ -58,7 +57,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) e - return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 064b5b3..6c31fad 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -51,7 +51,7 @@ data Operation t | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m view input cancel = do rec let reset = R.leftmost diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 0ee0cd3..1915841 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -29,7 +29,7 @@ data In t = In data Out t = Out { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t Payment + , _out_addPayment :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 8d0fee1..26444d7 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -36,7 +36,7 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categories <- AjaxUtil.getNow "api/categories" + categories <- AjaxUtil.getNow "api/allCategories" R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f9215bc..6744d3a 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -21,6 +21,7 @@ import qualified Common.View.Format as Format import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table +import qualified Component.Tag as Tag import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form @@ -35,9 +36,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Payment - , _out_edit :: Event t Payment - , _out_delete :: Event t Payment + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -45,7 +46,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel (_in_frequency input) - , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_rows = _in_payments input , Table._in_cell = cell (_in_users input) @@ -71,7 +72,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) e - return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user } @@ -122,21 +123,12 @@ cell users categories frequency currency header payment = let category = L.find ((== (_payment_category payment)) . _category_id) categories - - 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) + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } DateHeader -> if frequency == Punctual then diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index a589fc3..0a3b576 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.post "/api/askSignIn") + (Ajax.postAndParseResult "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) -- cgit v1.2.3