From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Oct 2018 17:57:58 +0100
Subject: Delete payment

---
 .tmuxinator.yml                          |  4 +-
 README.md                                |  2 -
 client/client.cabal                      |  6 ++-
 client/src/Component/Form.hs             |  2 +-
 client/src/Component/Modal.hs            | 33 ++++++++++------
 client/src/Component/Select.hs           |  2 +-
 client/src/Util/Ajax.hs                  | 67 ++++++++++++++++++++++++--------
 client/src/Util/Dom.hs                   | 36 ++++++++++++++---
 client/src/View/Payment/Add.hs           |  6 +--
 client/src/View/Payment/Delete.hs        | 40 +++++++++++--------
 client/src/View/Payment/Header.hs        |  4 +-
 client/src/View/Payment/Table.hs         |  2 +-
 client/src/View/SignIn.hs                |  6 +--
 common/common.cabal                      |  6 +--
 common/src/Common/Message/Key.hs         |  4 +-
 common/src/Common/Message/Translation.hs | 12 +++---
 common/src/Common/Model/CreatePayment.hs | 14 ++++++-
 default.nix                              |  4 +-
 server/server.cabal                      |  5 ++-
 server/src/Controller/Payment.hs         | 17 +++++---
 server/src/Design/Modal.hs               |  9 ++++-
 server/src/Design/View/Payment.hs        |  2 -
 server/src/Design/View/Payment/Delete.hs | 32 +++++++++++++++
 server/src/Main.hs                       |  6 +--
 server/src/Validation.hs                 | 23 -----------
 server/src/Validation/Atomic.hs          | 32 +++++++++++++++
 server/src/Validation/CreatePayment.hs   | 25 ++++++++++++
 27 files changed, 285 insertions(+), 116 deletions(-)
 create mode 100644 server/src/Design/View/Payment/Delete.hs
 delete mode 100644 server/src/Validation.hs
 create mode 100644 server/src/Validation/Atomic.hs
 create mode 100644 server/src/Validation/CreatePayment.hs

diff --git a/.tmuxinator.yml b/.tmuxinator.yml
index 1576496..2d52bb4 100644
--- a/.tmuxinator.yml
+++ b/.tmuxinator.yml
@@ -6,8 +6,8 @@ windows:
   - app:
       panes:
         - client:
-          - make clean-client watch-client
+          - make watch-client
         - server:
-          - make clean-server watch-server
+          - make watch-server
   - db:
     - sqlite3 database
diff --git a/README.md b/README.md
index 8a141e5..620dae6 100644
--- a/README.md
+++ b/README.md
@@ -75,9 +75,7 @@ TODO
 
 ### Code
 
-- modal as body child https://stackoverflow.com/questions/33711392/what-is-the-proper-way-in-reflex-dom-to-handle-a-modal-dialog
 - Move up element ids security (editOwn is actually at db level).
-- move persistence methods to a module.
 - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields)
 
 ### Tooling
diff --git a/client/client.cabal b/client/client.cabal
index 0aec05f..26ad2ec 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -10,7 +10,7 @@ Cabal-version:       >=1.10
 
 Executable client
   Main-Is:           Main.hs
-  Ghc-options:       -Wall -Werror
+  -- Ghc-options:       -Wall -Werror
   Hs-source-dirs:    src
   Default-language:  Haskell2010
 
@@ -22,10 +22,12 @@ Executable client
 
   Build-depends:
     aeson
-    , base >=4.9 && <4.11
+    , base >=4.9 && <5
     , bytestring
     , common
     , containers
+    , data-default
+    , ghcjs-dom-jsffi
     , jsaddle-dom
     , reflex-dom
     , text
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
index 0a89c6e..6ea02fa 100644
--- a/client/src/Component/Form.hs
+++ b/client/src/Component/Form.hs
@@ -6,7 +6,7 @@ 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 :: 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/Modal.hs b/client/src/Component/Modal.hs
index 1d70c90..72091c9 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,14 +1,19 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Component.Modal
   ( ModalIn(..)
   , ModalOut(..)
   , modal
   ) where
 
-import qualified Data.Map   as M
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom 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.Node   as Node
+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
 
 data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
@@ -29,16 +34,22 @@ modal modalIn = do
       , False <$ curtainClick
       ]
 
-    let attr = flip fmap showModal (\s -> M.fromList $
-          [ ("style", if s then "display:block" else "display:none")
-          , ("class", "modal")
-          ])
-
-    (curtainClick, content) <- R.elDynAttr "div" attr $ do
+    (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)
 
+  body <- Dom.getBody
+  let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn)
+  R.performEvent_ $ void `fmap` moveBackdrop
+
   return $ ModalOut
     { _modalOut_content = content
     }
+
+getAttributes :: Bool -> LM.Map Text Text
+getAttributes show =
+  M.fromList $
+    [ ("style", if show then "display:block" else "display:none")
+    , ("class", "modal")
+    ]
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 876548e..17a4958 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -19,7 +19,7 @@ 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 :: 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)
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 1e8e4c7..14675df 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,55 @@
 module Util.Ajax
-  ( post
+  ( postJson
+  , delete
   ) where
 
-import           Data.Aeson (ToJSON)
-import           Data.Text  (Text)
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+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
 
-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"
+postJson
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text Text))
+postJson url input =
+  fmap getResult <$>
+    R.performRequestAsync (R.postJson url <$> input)
+
+delete
+  :: forall t m. 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)
+
+getResult :: XhrResponse -> Either Text Text
+getResult response =
+  case R._xhrResponse_responseText response of
+    Just responseText ->
+      if R._xhrResponse_status response == 200
+        then Right responseText
+        else Left responseText
+    _ -> Left "NoKey"
+
+request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
+request method url sendData =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = sendData
+      }
+  in
+    R.xhrRequest method url config
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
index f3e9c88..55b8521 100644
--- a/client/src/Util/Dom.hs
+++ b/client/src/Util/Dom.hs
@@ -1,12 +1,31 @@
 module Util.Dom
-  ( divVisibleIf
+  ( divIfDyn
+  , divIfEvent
+  , divVisibleIf
   , divClassVisibleIf
+  , getBody
   ) where
 
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
+divIfDyn cond = divIfEvent (R.updated cond)
+
+divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+divIfEvent cond empty content =
+  R.widgetHold empty (flip fmap cond (\show ->
+    if show
+      then
+        content
+      else
+        empty))
 
 divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
 divVisibleIf cond content = divClassVisibleIf cond "" content
@@ -17,3 +36,10 @@ divClassVisibleIf cond className content =
     "div"
     (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
     content
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 5ff09dd..8b1b56e 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -23,7 +23,7 @@ import           Component              (ButtonIn (..), InputIn (..),
                                          SelectOut (..))
 import qualified Component              as Component
 import qualified Util.Ajax              as Ajax
-import qualified Util.WaitFor           as Util
+import qualified Util.WaitFor           as WaitFor
 
 data AddIn = AddIn
   { _addIn_categories :: [Category]
@@ -83,8 +83,8 @@ view addIn = do
               , _buttonIn_submit = True
               })
 
-          (_, waiting) <- Util.waitFor
-            (Ajax.post "/payment")
+          (_, waiting) <- WaitFor.waitFor
+            (Ajax.postJson "/payment")
             validate
             payment
 
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index a1be16d..03cf267 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,24 +4,27 @@ module View.Payment.Delete
   , 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
-  {}
+import qualified Data.Text            as T
+import           Reflex.Dom           (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom           as R
+
+import           Common.Model.Payment (PaymentId)
+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 WaitFor
+
+data DeleteIn t = DeleteIn
+  { _deleteIn_id :: Dynamic t PaymentId
+  }
 
 data DeleteOut t = DeleteOut
   { _deleteOut_cancel :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
-view _ =
+view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
+view deleteIn =
   R.divClass "delete" $ do
     R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
 
@@ -29,14 +32,19 @@ view _ =
 
       cancel <- R.divClass "buttons" $ do
         rec
-          _ <- Component._buttonOut_clic <$> (Component.button $
+          confirm <- 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")
+          let url = flip fmap (_deleteIn_id deleteIn) (\id ->
+                  T.concat ["/payment/", T.pack . show $ id]
+                )
+          Ajax.delete url confirm
+
+          -- (_, waiting) <- WaitFor.waitFor
+          --   (Ajax.delete "/payment")
           --   validate
           --   payment
 
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index fd46c25..be7f6d5 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do
               R.text "+ "
               R.text . Format.price currency $ _exceedingPayer_amount p
         )
-    addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn
+    addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
@@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do
       })
     rec
       modalOut <- Component.modal $ ModalIn
-        { _modalIn_show    = addPayment
+        { _modalIn_show    = addPaymentClic
         , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
         , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 23d7225..13cedda 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -118,7 +118,7 @@ paymentRow init payment =
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
         , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
-        , _modalIn_content = Delete.view (DeleteIn {})
+        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
         }
     return ()
 
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 21d0fcc..24e5be0 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -16,7 +16,7 @@ import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
 import qualified Util.Ajax    as Ajax
-import qualified Util.WaitFor as Util
+import qualified Util.WaitFor as WaitFor
 
 data SignInMessage =
   SuccessMessage Text
@@ -43,8 +43,8 @@ view signInMessage =
             , _buttonIn_submit = True
             }
 
-        (signInResult, waiting) <- Util.waitFor
-          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+        (signInResult, waiting) <- WaitFor.waitFor
+          (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email))
           (_buttonOut_clic button)
           (_inputOut_value input)
 
diff --git a/common/common.cabal b/common/common.cabal
index 6e5c8fb..151326a 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -21,12 +21,14 @@ Library
 
   Build-depends:
     aeson
-    , base >=4.9 && <4.11
+    , base >=4.9 && <5
     , text
     , time
 
   Exposed-modules:
     Common.Model
+    Common.Model.CreatePayment
+    Common.Model.Payment
     Common.Msg
     Common.Util.Text
     Common.Util.Time
@@ -39,7 +41,6 @@ Library
     Common.Model.Category
     Common.Model.CreateCategory
     Common.Model.CreateIncome
-    Common.Model.CreatePayment
     Common.Model.Currency
     Common.Model.EditCategory
     Common.Model.EditIncome
@@ -49,7 +50,6 @@ Library
     Common.Model.Init
     Common.Model.InitResult
     Common.Model.Payer
-    Common.Model.Payment
     Common.Model.PaymentCategory
     Common.Model.SignIn
     Common.Model.User
diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs
index a6828d5..6e5f246 100644
--- a/common/src/Common/Message/Key.hs
+++ b/common/src/Common/Message/Key.hs
@@ -38,8 +38,8 @@ data Key =
   | Error_SignOut
 
   | Form_AlreadyExists
-  | Form_CostMustNotBeNull
-  | Form_Empty
+  | Form_NonEmpty
+  | Form_NonNullNumber
   | Form_GreaterIntThan Int
   | Form_InvalidCategory
   | Form_InvalidColor
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index 5ea12ad..70eb978 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -157,16 +157,16 @@ m l Form_AlreadyExists =
     English -> "Dupplicate field"
     French  -> "Doublon"
 
-m l Form_CostMustNotBeNull =
-  case l of
-    English -> "Cost must not be zero"
-    French  -> "Le coût ne doît pas être nul"
-
-m l Form_Empty =
+m l Form_NonEmpty =
   case l of
     English -> "Required field"
     French  -> "Champ requis"
 
+m l Form_NonNullNumber =
+  case l of
+    English -> "Number must not be null"
+    French  -> "Le nombre ne doit pas être nul"
+
 m l (Form_GreaterIntThan number) =
   case l of
     English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ]
diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs
index cd0b01d..c61423c 100644
--- a/common/src/Common/Model/CreatePayment.hs
+++ b/common/src/Common/Model/CreatePayment.hs
@@ -1,5 +1,6 @@
 module Common.Model.CreatePayment
-  ( CreatePayment(..)
+  ( CreatePaymentError(..)
+  , CreatePayment(..)
   ) where
 
 import           Data.Aeson             (FromJSON, ToJSON)
@@ -10,6 +11,17 @@ import           GHC.Generics           (Generic)
 import           Common.Model.Category  (CategoryId)
 import           Common.Model.Frequency (Frequency)
 
+data CreatePaymentError = CreatePaymentError
+  { _createPaymentError_name      :: Maybe Text
+  , _createPaymentError_cost      :: Maybe Text
+  , _createPaymentError_date      :: Maybe Text
+  , _createPaymentError_category  :: Maybe Text
+  , _createPaymentError_frequency :: Maybe Text
+  } deriving (Show, Generic)
+
+instance FromJSON CreatePaymentError
+instance ToJSON CreatePaymentError
+
 data CreatePayment = CreatePayment
   { _createPayment_name      :: Text
   , _createPayment_cost      :: Int
diff --git a/default.nix b/default.nix
index 15dfdae..657de1b 100644
--- a/default.nix
+++ b/default.nix
@@ -6,9 +6,9 @@ let
     repo = "reflex-platform";
     rev = "504b0344dfa6d03e4c89cf70ab9792b0a1fa021b";
     sha256 = "01hvdwc6bw48falpha5kaq4p7w98hc804kkwrayipb5ld1snchpz";
+    # rev = "a457c21ceb32ea27f66f3fae930e5d8bf7ec768d";
+    # sha256 = "0drzvma2q809b6hafdlq4k23mnlbmy8ny5qz140ya76zizbq34vs";
   }) {};
-
-  buildInputs = [ pkgs.noDemon ];
 in
   reflex-platform.project ({ pkgs, ... }: {
     packages = {
diff --git a/server/server.cabal b/server/server.cabal
index 2bfd18d..2c6bef1 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -21,7 +21,7 @@ Executable server
 
   Build-depends:
     aeson
-    , base >=4.9 && <4.11
+    , base >=4.9 && <5
     , base64-bytestring
     , blaze-builder
     , blaze-html
@@ -103,7 +103,8 @@ Executable server
     Secure
     SendMail
     Util.Time
-    Validation
+    Validation.Atomic
+    Validation.CreatePayment
     View.Mail.SignIn
     View.Mail.WeeklyReport
     View.Page
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index e1936f0..4edbf6a 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -18,6 +18,7 @@ import qualified Model.Query                 as Query
 import qualified Persistence.Payment         as PaymentPersistence
 import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
 import qualified Secure
+import qualified Validation.CreatePayment    as CreatePaymentValidation
 
 list :: ActionM ()
 list =
@@ -26,12 +27,18 @@ list =
   )
 
 create :: CreatePayment -> ActionM ()
-create (CreatePayment name cost date category frequency) =
+create createPayment@(CreatePayment name cost date category frequency) =
   Secure.loggedAction (\user ->
-    (liftIO . Query.run $ do
-      PaymentCategoryPersistence.save name category
-      PaymentPersistence.create (_user_id user) name cost date frequency
-    ) >>= Json.jsonId
+    case CreatePaymentValidation.validate createPayment of
+      Nothing ->
+        (liftIO . Query.run $ do
+          PaymentCategoryPersistence.save name category
+          PaymentPersistence.create (_user_id user) name cost date frequency
+        ) >>= Json.jsonId
+      Just validationError ->
+        do
+          status Status.badRequest400
+          json validationError
   )
 
 editOwn :: EditPayment -> ActionM ()
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index ce427c0..2677fd8 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -2,9 +2,11 @@ module Design.Modal
   ( design
   ) where
 
-import           Data.Monoid ((<>))
-
 import           Clay
+import           Data.Monoid                ((<>))
+
+import qualified Design.View.Payment.Add    as Add
+import qualified Design.View.Payment.Delete as Delete
 
 design :: Css
 design = do
@@ -31,6 +33,9 @@ design = do
     sym borderRadius (px 5)
     boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
 
+    ".add" ? Add.design
+    ".delete" ? Delete.design
+
   ".paymentModal" & do
     ".radioGroup" ? ".title" ? display none
     ".selectInput" ? do
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 2102ff8..0d59fa0 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,7 +4,6 @@ module Design.View.Payment
 
 import           Clay
 
-import qualified Design.View.Payment.Add    as Add
 import qualified Design.View.Payment.Header as Header
 import qualified Design.View.Payment.Pages  as Pages
 import qualified Design.View.Payment.Table  as Table
@@ -12,6 +11,5 @@ import qualified Design.View.Payment.Table  as Table
 design :: Css
 design = do
   ".header" ? Header.design
-  ".add" ? Add.design
   ".table" ? Table.design
   ".pages" ? Pages.design
diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs
new file mode 100644
index 0000000..5597f5b
--- /dev/null
+++ b/server/src/Design/View/Payment/Delete.hs
@@ -0,0 +1,32 @@
+module Design.View.Payment.Delete
+  ( design
+  ) where
+
+import           Clay
+
+import qualified Design.Color     as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper    as Helper
+
+design :: Css
+design = do
+  ".deleteHeader" ? do
+    backgroundColor Color.chestnutRose
+    fontSize (px 18)
+    color Color.white
+    sym padding (px 20)
+    textAlign (alignSide sideCenter)
+    borderRadius (px 5) (px 5) (px 0) (px 0)
+
+  ".deleteContent" ? do
+    sym padding (px 20)
+
+    ".buttons" ? do
+      display flex
+      justifyContent spaceAround
+      marginTop (em 1.5)
+
+      ".confirm" ?
+        Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+      ".undo" ?
+        Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
diff --git a/server/src/Main.hs b/server/src/Main.hs
index e298a06..745071c 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -37,7 +37,7 @@ main = do
     S.put "/payment" $
       S.jsonData >>= Payment.editOwn
 
-    S.delete "/payment" $ do
+    S.delete "/payment/:id" $ do
       paymentId <- S.param "id"
       Payment.deleteOwn paymentId
 
@@ -47,7 +47,7 @@ main = do
     S.put "/income" $
       S.jsonData >>= Income.editOwn
 
-    S.delete "/income" $ do
+    S.delete "/income/:id" $ do
       incomeId <- S.param "id"
       Income.deleteOwn incomeId
 
@@ -57,6 +57,6 @@ main = do
     S.put "/category" $
       S.jsonData >>= Category.edit
 
-    S.delete "/category" $ do
+    S.delete "/category/:id" $ do
       categoryId <- S.param "id"
       Category.delete categoryId
diff --git a/server/src/Validation.hs b/server/src/Validation.hs
deleted file mode 100644
index fd739cd..0000000
--- a/server/src/Validation.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Validation
-  ( nonEmpty
-  , number
-  ) where
-
-import           Data.Text (Text)
-import qualified Data.Text as T
-
-nonEmpty :: Text -> Maybe Text
-nonEmpty str =
-  if T.null str
-   then Nothing
-   else Just str
-
-number :: (Int -> Bool) -> Text -> Maybe Int
-number numberForm str =
-  case reads (T.unpack str) :: [(Int, String)] of
-    (num, _) : _ ->
-      if numberForm num
-        then Just num
-        else Nothing
-    _ ->
-      Nothing
diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs
new file mode 100644
index 0000000..d15ad49
--- /dev/null
+++ b/server/src/Validation/Atomic.hs
@@ -0,0 +1,32 @@
+module Validation.Atomic
+  ( nonEmpty
+  , nonNullNumber
+  -- , number
+  ) where
+
+import           Data.Text  (Text)
+import qualified Data.Text  as T
+
+import qualified Common.Msg as Msg
+
+nonEmpty :: Text -> Maybe Text
+nonEmpty str =
+  if T.null str
+    then Just $ Msg.get Msg.Form_NonEmpty
+    else Nothing
+
+nonNullNumber :: Int -> Maybe Text
+nonNullNumber n =
+  if n == 0
+     then Just $ Msg.get Msg.Form_NonNullNumber
+    else Nothing
+
+-- number :: (Int -> Bool) -> Text -> Maybe Int
+-- number numberForm str =
+--   case reads (T.unpack str) :: [(Int, String)] of
+--     (num, _) : _ ->
+--       if numberForm num
+--         then Just num
+--         else Nothing
+--     _ ->
+--       Nothing
diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs
new file mode 100644
index 0000000..fbcdb7c
--- /dev/null
+++ b/server/src/Validation/CreatePayment.hs
@@ -0,0 +1,25 @@
+module Validation.CreatePayment
+  ( validate
+  ) where
+
+import           Data.Maybe                 (catMaybes)
+
+import           Common.Model.CreatePayment (CreatePayment (..),
+                                             CreatePaymentError (..))
+import qualified Validation.Atomic          as Atomic
+
+validate :: CreatePayment -> Maybe CreatePaymentError
+validate p =
+  if not . null . catMaybes $ [ nameError, costError ]
+    then Just createPaymentError
+    else Nothing
+  where
+    nameError = Atomic.nonEmpty . _createPayment_name $ p
+    costError = Atomic.nonNullNumber . _createPayment_cost $ p
+    createPaymentError = CreatePaymentError
+      { _createPaymentError_name      = nameError
+      , _createPaymentError_cost      = costError
+      , _createPaymentError_date      = Nothing
+      , _createPaymentError_category  = Nothing
+      , _createPaymentError_frequency = Nothing
+      }
-- 
cgit v1.2.3