aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal5
-rw-r--r--client/src/Component/ConfirmDialog.hs6
-rw-r--r--client/src/Component/Modal.hs8
-rw-r--r--client/src/Component/ModalForm.hs10
-rw-r--r--client/src/Component/Table.hs18
-rw-r--r--client/src/Component/Tag.hs27
-rw-r--r--client/src/Model/Route.hs1
-rw-r--r--client/src/Util/Ajax.hs28
-rw-r--r--client/src/View/App.hs43
-rw-r--r--client/src/View/Category/Category.hs92
-rw-r--r--client/src/View/Category/Form.hs117
-rw-r--r--client/src/View/Category/Reducer.hs59
-rw-r--r--client/src/View/Category/Table.hs91
-rw-r--r--client/src/View/Header.hs5
-rw-r--r--client/src/View/Income/Form.hs2
-rw-r--r--client/src/View/Income/Header.hs3
-rw-r--r--client/src/View/Income/Income.hs1
-rw-r--r--client/src/View/Income/Init.hs11
-rw-r--r--client/src/View/Income/Table.hs11
-rw-r--r--client/src/View/Payment/Form.hs2
-rw-r--r--client/src/View/Payment/HeaderForm.hs2
-rw-r--r--client/src/View/Payment/Payment.hs2
-rw-r--r--client/src/View/Payment/Table.hs30
-rw-r--r--client/src/View/SignIn.hs2
24 files changed, 493 insertions, 83 deletions
diff --git a/client/client.cabal b/client/client.cabal
index 78ea7d3..227aed2 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -56,6 +56,7 @@ Executable client
Component.Pages
Component.Select
Component.Table
+ Component.Tag
Loadable
Model.Route
Util.Ajax
@@ -73,6 +74,10 @@ Executable client
View.Income.Income
View.Income.Reducer
View.Income.Table
+ View.Category.Form
+ View.Category.Category
+ View.Category.Reducer
+ View.Category.Table
View.NotFound
View.Payment.Form
View.Payment.HeaderForm
diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs
index 50e30ed..cf26593 100644
--- a/client/src/Component/ConfirmDialog.hs
+++ b/client/src/Component/ConfirmDialog.hs
@@ -13,12 +13,12 @@ import qualified Component.Modal as Modal
import qualified Util.Either as EitherUtil
import qualified Util.WaitFor as WaitFor
-data In t m a = In
+data In t m = In
{ _in_header :: Text
- , _in_confirm :: Event t () -> m (Event t a)
+ , _in_confirm :: Event t () -> m (Event t ())
}
-view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a
+view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m
view input _ =
R.divClass "confirm" $ do
R.divClass "confirmHeader" $
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 08f2e74..46d3f64 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -20,14 +20,14 @@ import qualified Reflex.Dom.Class as R
import qualified Util.Reflex as ReflexUtil
-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
-type Content t m a = Event t () -> m (Event t (), Event t a)
+type Content t m = Event t () -> m (Event t (), Event t ())
-data In t m a = In
+data In t m = In
{ _in_show :: Event t ()
- , _in_content :: Content t m a
+ , _in_content :: Content t m
}
-view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a)
+view :: forall t m a. MonadWidget t m => In t m -> m (Event t ())
view input = do
rec
let show = Show <$ (_in_show input)
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
index f5bf287..c56ff88 100644
--- a/client/src/Component/ModalForm.hs
+++ b/client/src/Component/ModalForm.hs
@@ -20,20 +20,20 @@ import qualified Util.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
import qualified Util.WaitFor as WaitFor
-data In m t a b e = In
+data In m t a e = In
{ _in_headerLabel :: Text
, _in_form :: m (Dynamic t (Validation e a))
- , _in_ajax :: Event t a -> m (Event t (Either Text b))
+ , _in_ajax :: Event t a -> m (Event t (Either Text ()))
}
-data Out t a = Out
+data Out t = Out
{ _out_hide :: Event t ()
, _out_cancel :: Event t ()
, _out_confirm :: Event t ()
- , _out_validate :: Event t a
+ , _out_validate :: Event t ()
}
-view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b)
+view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t)
view input =
R.divClass "form" $ do
R.divClass "formHeader" $
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 2869c2d..f82cfa6 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -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 b c = In
+data In m t h r = In
{ _in_headerLabel :: h -> Text
, _in_rows :: [r]
, _in_cell :: h -> r -> m ()
- , _in_cloneModal :: r -> Modal.Content t m a
- , _in_editModal :: r -> Modal.Content t m b
- , _in_deleteModal :: r -> Modal.Content t m c
+ , _in_cloneModal :: r -> Modal.Content t m
+ , _in_editModal :: r -> Modal.Content t m
+ , _in_deleteModal :: r -> Modal.Content t m
, _in_isOwner :: r -> Bool
}
-data Out t a b c = Out
- { _out_add :: Event t a
- , _out_edit :: Event t b
- , _out_delete :: Event t c
+data Out t = Out
+ { _out_add :: Event t ()
+ , _out_edit :: Event t ()
+ , _out_delete :: Event t ()
}
-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 :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t)
view input =
R.divClass "table" $ do
rec
diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs
new file mode 100644
index 0000000..f75b8d3
--- /dev/null
+++ b/client/src/Component/Tag.hs
@@ -0,0 +1,27 @@
+module Component.Tag
+ ( In(..)
+ , view
+ ) where
+
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+data In = In
+ { _in_text :: Text
+ , _in_color :: Text
+ }
+
+view :: forall t m a. MonadWidget t m => In -> m ()
+view input =
+ R.elAttr "span" attrs $
+ R.text $ _in_text input
+
+ where
+ attrs =
+ M.fromList
+ [ ("class", "tag")
+ , ("style", T.concat [ "background-color: ", _in_color input ])
+ ]
diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs
index 420fe05..63e5d10 100644
--- a/client/src/Model/Route.hs
+++ b/client/src/Model/Route.hs
@@ -5,5 +5,6 @@ module Model.Route
data Route
= RootRoute
| IncomeRoute
+ | CategoryRoute
| NotFoundRoute
deriving (Eq, Show)
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index dc56701..dcfd402 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -2,7 +2,9 @@ module Util.Ajax
( getNow
, get
, post
+ , postAndParseResult
, put
+ , putAndParseResult
, delete
) where
@@ -42,20 +44,38 @@ get url =
R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
post
+ :: forall t m a. (MonadWidget t m, ToJSON a)
+ => Text
+ -> Event t a
+ -> m (Event t (Either Text ()))
+post url input =
+ fmap checkResult <$>
+ R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+postAndParseResult
:: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
=> Text
-> Event t a
-> m (Event t (Either Text b))
-post url input =
+postAndParseResult url input =
fmap getJsonResult <$>
R.performRequestAsync (jsonRequest "POST" url <$> input)
put
+ :: forall t m a. (MonadWidget t m, ToJSON a)
+ => Text
+ -> Event t a
+ -> m (Event t (Either Text ()))
+put url input =
+ fmap checkResult <$>
+ R.performRequestAsync (jsonRequest "PUT" url <$> input)
+
+putAndParseResult
:: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
=> Text
-> Event t a
-> m (Event t (Either Text b))
-put url input =
+putAndParseResult url input =
fmap getJsonResult <$>
R.performRequestAsync (jsonRequest "PUT" url <$> input)
@@ -69,6 +89,10 @@ delete url fire = do
(R.performRequestAsync $
R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
+checkResult :: XhrResponse -> Either Text ()
+checkResult response =
+ () <$ getResult response
+
getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
getJsonResult response =
case getResult response of
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)