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/client.cabal                   |   5 ++
 client/src/Component/ConfirmDialog.hs |   6 +-
 client/src/Component/Modal.hs         |   8 +--
 client/src/Component/ModalForm.hs     |  10 +--
 client/src/Component/Table.hs         |  18 +++---
 client/src/Component/Tag.hs           |  27 ++++++++
 client/src/Model/Route.hs             |   1 +
 client/src/Util/Ajax.hs               |  28 +++++++-
 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 +-
 24 files changed, 493 insertions(+), 83 deletions(-)
 create mode 100644 client/src/Component/Tag.hs
 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')

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)
-- 
cgit v1.2.3