From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Jan 2018 12:13:09 +0100
Subject: WIP

---
 client/src/Component.hs           |   2 +
 client/src/Component/Button.hs    |  41 ++++++++++-----
 client/src/Component/Form.hs      |  12 +++++
 client/src/Component/Input.hs     |  27 +++++++---
 client/src/Component/Modal.hs     |  24 +++++----
 client/src/Component/Select.hs    |  32 ++++++++++++
 client/src/Main.hs                |   4 +-
 client/src/Util/Ajax.hs           |  20 ++++++++
 client/src/Util/WaitFor.hs        |  18 +++++++
 client/src/View/App.hs            |   8 +--
 client/src/View/Header.hs         |  13 +++--
 client/src/View/Payment/Add.hs    | 104 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Delete.hs |  51 +++++++++++++++++++
 client/src/View/Payment/Header.hs |  33 +++++++-----
 client/src/View/Payment/Pages.hs  |   2 +
 client/src/View/Payment/Table.hs  |  48 +++++++++++-------
 client/src/View/SignIn.hs         |  98 +++++++++++++++--------------------
 17 files changed, 410 insertions(+), 127 deletions(-)
 create mode 100644 client/src/Component/Form.hs
 create mode 100644 client/src/Component/Select.hs
 create mode 100644 client/src/Util/Ajax.hs
 create mode 100644 client/src/Util/WaitFor.hs
 create mode 100644 client/src/View/Payment/Add.hs
 create mode 100644 client/src/View/Payment/Delete.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index dea384e..7b87a75 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -1,5 +1,7 @@
 module Component (module X) where
 
 import           Component.Button as X
+import           Component.Form   as X
 import           Component.Input  as X
 import           Component.Modal  as X
+import           Component.Select as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 3ee9561..bf604f1 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -2,10 +2,11 @@ module Component.Button
   ( ButtonIn(..)
   , ButtonOut(..)
   , button
-  , buttonInDefault
+  , defaultButtonIn
   ) where
 
 import qualified Data.Map   as M
+import           Data.Maybe (catMaybes)
 import           Data.Text  (Text)
 import qualified Data.Text  as T
 import           Reflex.Dom (Dynamic, Event, MonadWidget)
@@ -14,22 +15,36 @@ import qualified Reflex.Dom as R
 import qualified Icon
 
 data ButtonIn t m = ButtonIn
-  { _buttonIn_class   :: Dynamic t Text
-  , _buttonIn_content :: m ()
-  , _buttonIn_waiting :: Event t Bool
+  { _buttonIn_class    :: Dynamic t Text
+  , _buttonIn_content  :: m ()
+  , _buttonIn_waiting  :: Event t Bool
+  , _buttonIn_tabIndex :: Maybe Int
+  , _buttonIn_submit   :: Bool
   }
 
-buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m
-buttonInDefault = ButtonIn
-  { _buttonIn_class = R.constDyn ""
-  , _buttonIn_content = R.blank
-  , _buttonIn_waiting = R.never
+defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m
+defaultButtonIn content = ButtonIn
+  { _buttonIn_class    = R.constDyn ""
+  , _buttonIn_content  = content
+  , _buttonIn_waiting  = R.never
+  , _buttonIn_tabIndex = Nothing
+  , _buttonIn_submit   = False
   }
 
+-- defaultButtonIn :: MonadWidget t m => ButtonIn t m
+-- defaultButtonIn = ButtonIn
+--   { _buttonIn_class    = R.constDyn ""
+--   , _buttonIn_content  = R.blank
+--   , _buttonIn_waiting  = R.never
+--   , _buttonIn_tabIndex = Nothing
+--   , _buttonIn_submit   = False
+--   }
+
 data ButtonOut t = ButtonOut
   { _buttonOut_clic :: Event t ()
   }
 
+
 button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
 button buttonIn = do
   dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
@@ -37,9 +52,11 @@ button buttonIn = do
   let attr = do
         buttonClass <- _buttonIn_class buttonIn
         waiting <- dynWaiting
-        return $ if waiting
-          then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])]
-          else M.fromList [("type", "button"), ("class", buttonClass)]
+        return . M.fromList . catMaybes $
+          [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button")
+          , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn
+          , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ])
+          ]
 
   (e, _) <- R.elDynAttr' "button" attr $ do
     Icon.loading
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
new file mode 100644
index 0000000..0a89c6e
--- /dev/null
+++ b/client/src/Component/Form.hs
@@ -0,0 +1,12 @@
+module Component.Form
+  ( form
+  ) where
+
+import qualified Data.Map   as M
+import           Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+form :: forall t m a. (MonadWidget t m) => m a -> m a
+form content =
+  R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
+    content
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 24aac22..92f8ec9 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -2,12 +2,14 @@ module Component.Input
   ( InputIn(..)
   , InputOut(..)
   , input
+  , defaultInputIn
   ) where
 
 import qualified Data.Map         as M
 import           Data.Text        (Text)
 import qualified Data.Text        as T
-import           Reflex.Dom       (Dynamic, Event, MonadWidget, (&), (.~))
+import           Reflex.Dom       (Dynamic, Event, MonadWidget, Reflex, (&),
+                                   (.~))
 import qualified Reflex.Dom       as R
 
 import           Component.Button (ButtonIn (..), ButtonOut (..))
@@ -15,8 +17,16 @@ import qualified Component.Button as Button
 import qualified Icon
 
 data InputIn t a b = InputIn
-  { _inputIn_reset :: Event t a
-  , _inputIn_label :: Text
+  { _inputIn_reset        :: Event t a
+  , _inputIn_label        :: Text
+  , _inputIn_initialValue :: Text
+  }
+
+defaultInputIn :: (Reflex t) => InputIn t a b
+defaultInputIn = InputIn
+  { _inputIn_reset        = R.never
+  , _inputIn_label        = ""
+  , _inputIn_initialValue = ""
   }
 
 data InputOut t = InputOut
@@ -41,14 +51,15 @@ input inputIn =
       textInput <- R.textInput $ R.def
         & R.attributes .~ attributes
         & R.setValue .~ resetValue
+        & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
 
       R.el "label" $ R.text (_inputIn_label inputIn)
 
-      reset <- Button.button $ ButtonIn
-        { _buttonIn_class   = R.constDyn "reset"
-        , _buttonIn_content = Icon.cross
-        , _buttonIn_waiting = R.never
-        }
+      reset <- Button.button $
+        (Button.defaultButtonIn Icon.cross)
+          { _buttonIn_class   = R.constDyn "reset"
+          , _buttonIn_tabIndex = Just (-1)
+          }
 
     let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
 
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index bfb5e02..1d70c90 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -10,18 +10,22 @@ import qualified Data.Map   as M
 import           Reflex.Dom (Event, MonadWidget)
 import qualified Reflex.Dom as R
 
-data ModalIn t m = ModalIn
+data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
-  , _modalIn_content :: m ()
+  , _modalIn_hide    :: Event t ()
+  , _modalIn_content :: m a
   }
 
-data ModalOut = ModalOut {}
+data ModalOut a = ModalOut
+  { _modalOut_content :: a
+  }
 
-modal :: forall t m. MonadWidget t m => ModalIn t m -> m 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
       ]
 
@@ -30,9 +34,11 @@ modal modalIn = do
           , ("class", "modal")
           ])
 
-    curtainClick <- R.elDynAttr "div" attr $ do
-      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank
-      R.divClass "content" $ _modalIn_content modalIn
-      return $ R.domEvent R.Click curtain
+    (curtainClick, content) <- R.elDynAttr "div" attr $ 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)
 
-  return $ ModalOut {}
+  return $ ModalOut
+    { _modalOut_content = content
+    }
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
new file mode 100644
index 0000000..876548e
--- /dev/null
+++ b/client/src/Component/Select.hs
@@ -0,0 +1,32 @@
+module Component.Select
+  ( SelectIn(..)
+  , SelectOut(..)
+  , select
+  ) where
+
+import           Data.Map   (Map)
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, 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)
+  }
+
+data SelectOut t a = SelectOut
+  { _selectOut_value :: Dynamic t a
+  }
+
+select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a)
+select selectIn =
+  R.divClass "selectInput" $ do
+    R.el "label" $ R.text (_selectIn_label selectIn)
+
+    value <- R._dropdown_value <$>
+      R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def
+
+    return SelectOut
+      { _selectOut_value = value
+      }
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d55eefe..6c048c6 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -13,7 +13,7 @@ import           JSDOM.Types                          (HTMLElement (..), JSM)
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import           Common.Model                         (InitResult (InitEmpty))
+import           Common.Model                         (InitResult (InitError))
 import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
@@ -37,4 +37,4 @@ readInit = do
     _ ->
       return initParseError
 
-  where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError)
+  where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
new file mode 100644
index 0000000..1e8e4c7
--- /dev/null
+++ b/client/src/Util/Ajax.hs
@@ -0,0 +1,20 @@
+module Util.Ajax
+  ( post
+  ) where
+
+import           Data.Aeson (ToJSON)
+import           Data.Text  (Text)
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
+post url input =
+  fmap getResult <$> R.performRequestAsync xhrRequest
+  where xhrRequest = R.postJson url <$> input
+        getResult response =
+          case R._xhrResponse_responseText response of
+            Just responseText ->
+              if R._xhrResponse_status response == 200
+                then Right responseText
+                else Left responseText
+            _ -> Left "NoKey"
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
new file mode 100644
index 0000000..0175c95
--- /dev/null
+++ b/client/src/Util/WaitFor.hs
@@ -0,0 +1,18 @@
+module Util.WaitFor
+  ( waitFor
+  ) where
+
+import           Data.Time  (NominalDiffTime)
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+waitFor
+  :: forall t m a b. MonadWidget t m
+  => (Event t a -> m (Event t b))
+  -> Event t ()
+  -> Dynamic t a
+  -> m (Event t b, Event t Bool)
+waitFor op start input = do
+  result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+  let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+  return (result, waiting)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 64ca303..9aa6c57 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -29,10 +29,12 @@ widget initResult =
               { _paymentIn_init = initSuccess
               }
             return ()
-          InitEmpty result ->
-            SignIn.view result
+          InitEmpty ->
+            SignIn.view SignIn.EmptyMessage
+          InitError error ->
+            SignIn.view (SignIn.ErrorMessage error)
 
-        signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
+        signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
 
     _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
 
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 4c74383..8f1fb78 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -13,9 +13,8 @@ import qualified Reflex.Dom       as R
 import           Common.Model     (Init (..), InitResult (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
-
+import qualified Component        as Component
 import           Component.Button (ButtonIn (..))
-import qualified Component.Button as Component
 import qualified Icon
 
 data HeaderIn = HeaderIn
@@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
   rec
-    signOut <- Component.button $ ButtonIn
-      { Component._buttonIn_class = R.constDyn "signOut item"
-      , Component._buttonIn_content = Icon.signOut
-      , Component._buttonIn_waiting = waiting
-      }
+    signOut <- Component.button $
+      (Component.defaultButtonIn Icon.signOut)
+        { _buttonIn_class = R.constDyn "signOut item"
+        , _buttonIn_waiting = waiting
+        }
     let signOutClic = Component._buttonOut_clic signOut
         waiting = R.leftmost
           [ fmap (const True) signOutClic
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
new file mode 100644
index 0000000..2eaec0f
--- /dev/null
+++ b/client/src/View/Payment/Add.hs
@@ -0,0 +1,104 @@
+module View.Payment.Add
+  ( view
+  , AddIn(..)
+  , AddOut(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Map               as M
+import qualified Data.Maybe             as Maybe
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (Event, MonadWidget)
+import qualified Reflex.Dom             as R
+import qualified Text.Read              as T
+
+import           Common.Model           (Category (..), CreatePayment (..),
+                                         Frequency (..))
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as Time
+import qualified Common.View.Format     as Format
+import           Component              (ButtonIn (..), InputIn (..),
+                                         InputOut (..), SelectIn (..),
+                                         SelectOut (..))
+import qualified Component              as Component
+import qualified Util.Ajax              as Ajax
+import qualified Util.WaitFor           as Util
+
+data AddIn = AddIn
+  { _addIn_categories :: [Category]
+  }
+
+data AddOut t = AddOut
+  { _addOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => AddIn -> 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 })
+
+      cost <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+
+      currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+
+      date <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Cost
+          , _inputIn_initialValue = Format.shortDay currentDay
+          })
+
+      frequency <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Frequency
+        , _selectIn_initialValue = Punctual
+        , _selectIn_values = R.constDyn frequencies
+        })
+
+      category <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Category
+        , _selectIn_initialValue = 0
+        , _selectIn_values = R.constDyn categories
+        })
+
+      let payment = CreatePayment
+            <$> name
+            <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
+            <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
+            <*> category
+            <*> frequency
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          validate <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_waiting = waiting
+              , _buttonIn_submit = True
+              })
+
+          (_, waiting) <- Util.waitFor
+            (Ajax.post "/payment")
+            validate
+            payment
+
+        Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+      return AddOut
+        { _addOut_cancel = cancel
+        }
+
+  where
+    frequencies = M.fromList
+      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+      ]
+
+    categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
+      (_category_id c, _category_name c)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
new file mode 100644
index 0000000..a1be16d
--- /dev/null
+++ b/client/src/View/Payment/Delete.hs
@@ -0,0 +1,51 @@
+module View.Payment.Delete
+  ( view
+  , DeleteIn(..)
+  , DeleteOut(..)
+  ) where
+
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import           Component  (ButtonIn (..), ButtonOut (..))
+import qualified Component  as Component
+-- import qualified Util.Ajax              as Ajax
+-- import qualified Util.WaitFor           as Util
+
+data DeleteIn = DeleteIn
+  {}
+
+data DeleteOut t = DeleteOut
+  { _deleteOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
+view _ =
+  R.divClass "delete" $ do
+    R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
+
+    R.divClass "deleteContent" $ do
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          _ <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_submit = True
+              })
+
+          -- (_, waiting) <- Util.waitFor
+          --   (Ajax.post "/payment")
+          --   validate
+          --   payment
+
+        cancel <- Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+        return cancel
+
+      return DeleteOut
+        { _deleteOut_cancel = cancel
+        }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index a694136..d01dec6 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -16,9 +16,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, ExceedingPayer (..),
-                                         Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..))
+import           Common.Model           (Category, Currency,
+                                         ExceedingPayer (..), Frequency (..),
+                                         Income (..), Init (..), Payment (..),
+                                         User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Text       as T
@@ -26,9 +27,11 @@ import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
                                          InputIn (..), InputOut (..),
-                                         ModalIn (..))
+                                         ModalIn (..), ModalOut (..))
 import qualified Component              as Component
 import qualified Util.List              as L
+import           View.Payment.Add       (AddIn (..), AddOut (..))
+import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
   { _headerIn_init :: Init
@@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes punctualPayments users currency
+    payerAndAdd incomes punctualPayments users categories currency
     (searchName, searchFrequency)  <- searchLine
     let searchPayments = getSearchPayments searchName searchFrequency payments
     infos searchPayments users currency
@@ -56,6 +59,7 @@ widget headerIn =
     payments = _init_payments init
     punctualPayments = filter ((==) Punctual . _payment_frequency) payments
     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]
@@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do
   n <- name
   f <- frequency
   pure $ flip filter payments (\p ->
-    (  T.search n (_payment_name 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] -> Currency -> m ()
-payerAndAdd incomes payments users currency = do
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
     R.divClass "exceedingPayers" $
@@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
+      , _buttonIn_tabIndex = Nothing
+      , _buttonIn_submit = False
       })
-    _ <- Component.modal $ ModalIn
-      { _modalIn_show    = addPayment
-      , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement"
-      }
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = addPayment
+        , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+        }
     return ()
 
 searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
@@ -99,6 +107,7 @@ searchLine = do
     searchName <- _inputOut_value <$> (Component.input $ InputIn
       { _inputIn_reset = R.never
       , _inputIn_label = Msg.get Msg.Search_Name
+      , _inputIn_initialValue = ""
       })
 
     let frequencies = M.fromList
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 55ceb9f..d14b640 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -82,5 +82,7 @@ pageButton currentPage page content = do
         if cp == Just p then "page current" else "page"
     , _buttonIn_content = content
     , _buttonIn_waiting = R.never
+    , _buttonIn_tabIndex = Nothing
+    , _buttonIn_submit = False
     })
   return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index a49be5c..23d7225 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,23 +4,28 @@ module View.Payment.Table
   , TableOut(..)
   ) where
 
-import qualified Data.List          as L
-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 qualified Reflex.Dom         as R
-
-import           Common.Model       (Category (..), Init (..), Payment (..),
-                                     PaymentCategory (..), 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 qualified Data.List           as L
+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 qualified Reflex.Dom          as R
+
+import           Common.Model        (Category (..), Init (..), Payment (..),
+                                      PaymentCategory (..), 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 (..),
+                                      ModalIn (..), ModalOut (..))
+import qualified Component           as Component
+import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+import qualified View.Payment.Delete as Delete
 
 import qualified Icon
-import qualified Util.Dom           as Dom
+import qualified Util.Dom            as Dom
 
 data TableIn t = TableIn
   { _tableIn_init        :: Init
@@ -105,8 +110,17 @@ paymentRow init payment =
           M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")]
     R.elDynAttr "div" modifyAttrs $
       R.el "button" $ Icon.edit
-    R.elDynAttr "div" modifyAttrs $
-      R.el "button" $ Icon.delete
+    deletePayment <- R.elDynAttr "div" modifyAttrs $
+      _buttonOut_clic <$> (Component.button $
+        (Component.defaultButtonIn Icon.delete)
+          { _buttonIn_class = R.constDyn "deletePayment" })
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = deletePayment
+        , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Delete.view (DeleteIn {})
+        }
+    return ()
 
 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 89be737..912aea2 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,11 +1,10 @@
 module View.SignIn
-  ( view
+  ( SignInMessage (..)
+  , view
   ) where
 
 import qualified Data.Either  as Either
-import           Data.Monoid  ((<>))
 import           Data.Text    (Text)
-import           Data.Time    (NominalDiffTime)
 import           Prelude      hiding (error)
 import           Reflex.Dom   (Event, MonadWidget)
 import qualified Reflex.Dom   as R
@@ -16,62 +15,47 @@ import qualified Common.Msg   as Msg
 import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
-
-view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
-view result =
-  R.divClass "signIn" $ do
-    rec
-      input <- Component.input $ InputIn
-        { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-        }
-
-      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-
-      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
-        [ fmap (const True) userWantsEmailValidation
-        , fmap (const False) signInResult
-        ]
-
-      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
-
-      let validatedEmail = R.tagPromptlyDyn
-            (_inputOut_value input)
-            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
-
-      let waiting = R.leftmost
-            [ fmap (const True) validatedEmail
-            , fmap (const False) signInResult
-            ]
-
-      button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn "validate"
-        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
-        , _buttonIn_waiting = waiting
-        }
-
-      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
-
-    showSignInResult result signInResult
-
-askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
-askSignIn email =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just key ->
-              if R._xhrResponse_status response == 200 then Right key else Left key
-            _ -> Left "NoKey"
-
-showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
-showSignInResult result signInResult = do
-  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+import qualified Util.Ajax    as Ajax
+import qualified Util.WaitFor as Util
+
+data SignInMessage =
+  SuccessMessage Text
+  | ErrorMessage Text
+  | EmptyMessage
+
+view :: forall t m. MonadWidget t m => SignInMessage -> m ()
+view signInMessage =
+  R.divClass "signIn" $
+    Component.form $ do
+      rec
+        input <- Component.input $ InputIn
+          { _inputIn_reset = R.ffilter Either.isRight signInResult
+          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
+          , _inputIn_initialValue = ""
+          }
+
+        button <- Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
+            { _buttonIn_class = R.constDyn "validate"
+            , _buttonIn_waiting = waiting
+            , _buttonIn_submit = True
+            }
+
+        (signInResult, waiting) <- Util.waitFor
+          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+          (_buttonOut_clic button)
+          (_inputOut_value input)
+
+      showSignInResult signInMessage signInResult
+
+showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
+showSignInResult signInMessage signInResult = do
+  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
   R.blank
 
-  where showInitResult (Left error)           = showError error
-        showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing)        = R.blank
+  where showInitResult (SuccessMessage success) = showSuccess success
+        showInitResult (ErrorMessage error)     = showError error
+        showInitResult EmptyMessage             = R.blank
 
         showResult (Left error)    = showError error
         showResult (Right success) = showSuccess success
-- 
cgit v1.2.3