From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 18:04:58 +0100
Subject: Update table when adding or removing a payment

---
 client/src/Component/Input.hs     | 20 +++++-----
 client/src/Component/Modal.hs     | 66 +++++++++++++++++++++-----------
 client/src/Component/Select.hs    | 10 ++++-
 client/src/Icon.hs                |  2 +-
 client/src/Main.hs                |  5 ++-
 client/src/Util/Ajax.hs           | 40 ++++++++++++--------
 client/src/Util/Either.hs         |  7 ++++
 client/src/View/Payment.hs        | 61 ++++++++++++++++++++++++++----
 client/src/View/Payment/Add.hs    | 39 ++++++++++++-------
 client/src/View/Payment/Delete.hs | 13 +++++--
 client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++----------------
 client/src/View/Payment/Pages.hs  |  2 +-
 client/src/View/Payment/Table.hs  | 29 ++++++++------
 client/src/View/SignIn.hs         | 10 ++---
 common/common.cabal               |  2 +-
 common/src/Common/Util/Time.hs    |  6 +--
 server/src/Controller/Payment.hs  |  4 +-
 server/src/Design/Global.hs       |  2 +
 server/src/Persistence/Payment.hs | 21 ++++++++---
 19 files changed, 278 insertions(+), 140 deletions(-)
 create mode 100644 client/src/Util/Either.hs

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