Use common payment validation in the backend

Remove deprecated backend validation

8 files changed, 128 insertions, 92 deletions

diff --git a/server/server.cabal b/server/server.cabal
index 3c1c770..ea7ebed 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -50,6 +50,7 @@ Executable server
     , transformers
     , unordered-containers
     , uuid
+    , validation
     , wai
     , wai-extra
     , wai-middleware-static
@@ -57,6 +58,7 @@ Executable server
   other-modules:
     Conf
     Controller.Category
+    Controller.Helper
     Controller.Income
     Controller.Index
     Controller.Payment
@@ -90,6 +92,8 @@ Executable server
     Job.WeeklyReport
     Json
     LoginSession
+    Model.CreatePayment
+    Model.EditPayment
     Model.IncomeResource
     Model.Mail
     Model.PaymentResource
@@ -107,8 +111,7 @@ Executable server
     Secure
     SendMail
     Util.Time
-    Validation.Atomic
-    Validation.CreatePayment
+    Validation.Payment
     View.Mail.SignIn
     View.Mail.WeeklyReport
     View.Page
diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs
new file mode 100644
index 0000000..fd0d2bb
--- /dev/null
+++ b/server/src/Controller/Helper.hs
@@ -0,0 +1,17 @@
+module Controller.Helper
+  ( jsonOrBadRequest
+  ) where
+
+import           Data.Aeson                (ToJSON)
+import           Data.Text                 (Text)
+import qualified Data.Text.Lazy            as LT
+import qualified Network.HTTP.Types.Status as Status
+import           Web.Scotty                (ActionM)
+import qualified Web.Scotty                as S
+
+jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM ()
+jsonOrBadRequest (Left message) = do
+  S.status Status.badRequest400
+  S.text (LT.fromStrict message)
+jsonOrBadRequest (Right a) =
+  S.json a
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 38c1c19..ba9d1ba 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -6,18 +6,25 @@ module Controller.Payment
   ) where
 
 import           Control.Monad.IO.Class      (liftIO)
+import           Data.Validation             (Validation (Failure, Success))
 import qualified Network.HTTP.Types.Status   as Status
 import           Web.Scotty                  hiding (delete)
 
-import           Common.Model                (CreatePayment (..),
-                                              EditPayment (..), Payment (..),
-                                              PaymentId, SavedPayment (..),
-                                              User (..))
+import           Common.Model                (Category (..),
+                                              CreatePaymentForm (..),
+                                              EditPaymentForm (..),
+                                              Payment (..), PaymentId,
+                                              SavedPayment (..), User (..))
+import qualified Common.Msg                  as Msg
+import qualified Controller.Helper           as ControllerHelper
+import           Model.CreatePayment         (CreatePayment (..))
+import           Model.EditPayment           (EditPayment (..))
 import qualified Model.Query                 as Query
+import qualified Persistence.Category        as CategoryPersistence
 import qualified Persistence.Payment         as PaymentPersistence
 import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
 import qualified Secure
-import qualified Validation.CreatePayment    as CreatePaymentValidation
+import qualified Validation.Payment          as PaymentValidation
 
 list :: ActionM ()
 list =
@@ -25,39 +32,39 @@ list =
     (liftIO . Query.run $ PaymentPersistence.listActive) >>= json
   )
 
-create :: CreatePayment -> ActionM ()
-create createPayment@(CreatePayment name cost date category frequency) =
+create :: CreatePaymentForm -> ActionM ()
+create form =
   Secure.loggedAction (\user ->
-    case CreatePaymentValidation.validate createPayment of
-      Nothing ->
-        (liftIO . Query.run $ do
+    (liftIO . Query.run $ do
+      cs <- map _category_id <$> CategoryPersistence.list
+      case PaymentValidation.createPayment cs form of
+        Success (CreatePayment name cost date category frequency) -> do
           pc <- PaymentCategoryPersistence.save name category
           p <- PaymentPersistence.create (_user_id user) name cost date frequency
-          return $ SavedPayment p pc
-        ) >>= json
-      Just validationError ->
-        do
-          status Status.badRequest400
-          json validationError
+          return . Right $ SavedPayment p pc
+        Failure validationError ->
+          return $ Left validationError
+    ) >>= ControllerHelper.jsonOrBadRequest
   )
 
-edit :: EditPayment -> ActionM ()
-edit (EditPayment paymentId name cost date category frequency) =
-  Secure.loggedAction (\user -> do
-    result <- liftIO . Query.run $ do
-      editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
-      case editedPayment of
-        Just (old, new) -> do
-          pc <- PaymentCategoryPersistence.save name category
-          PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
-          return $ Just (new, pc)
-        Nothing ->
-          return Nothing
-    case result of
-      Just (p, pc) ->
-        json $ SavedPayment p pc
-      Nothing ->
-        status Status.badRequest400
+edit :: EditPaymentForm -> ActionM ()
+edit form =
+  Secure.loggedAction (\user ->
+    (liftIO . Query.run $ do
+      cs <- map _category_id <$> CategoryPersistence.list
+      case PaymentValidation.editPayment cs form of
+        Success (EditPayment paymentId name cost date category frequency) -> do
+          editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
+          case editedPayment of
+            Just (old, new) -> do
+              pc <- PaymentCategoryPersistence.save name category
+              PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
+              return . Right $ SavedPayment new pc
+            Nothing ->
+              return . Left $ Msg.get Msg.Error_PaymentEdit
+        Failure validationError ->
+          return $ Left validationError
+    ) >>= ControllerHelper.jsonOrBadRequest
   )
 
 delete :: PaymentId -> ActionM ()
diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs
new file mode 100644
index 0000000..b25d2a4
--- /dev/null
+++ b/server/src/Model/CreatePayment.hs
@@ -0,0 +1,16 @@
+module Model.CreatePayment
+  ( CreatePayment(..)
+  ) where
+
+import           Data.Text          (Text)
+import           Data.Time.Calendar (Day)
+
+import           Common.Model       (CategoryId, Frequency)
+
+data CreatePayment = CreatePayment
+  { _createPayment_name      :: Text
+  , _createPayment_cost      :: Int
+  , _createPayment_date      :: Day
+  , _createPayment_category  :: CategoryId
+  , _createPayment_frequency :: Frequency
+  } deriving (Show)
diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs
new file mode 100644
index 0000000..ac4c906
--- /dev/null
+++ b/server/src/Model/EditPayment.hs
@@ -0,0 +1,17 @@
+module Model.EditPayment
+  ( EditPayment(..)
+  ) where
+
+import           Data.Text          (Text)
+import           Data.Time.Calendar (Day)
+
+import           Common.Model       (CategoryId, Frequency, PaymentId)
+
+data EditPayment = EditPayment
+  { _editPayment_id        :: PaymentId
+  , _editPayment_name      :: Text
+  , _editPayment_cost      :: Int
+  , _editPayment_date      :: Day
+  , _editPayment_category  :: CategoryId
+  , _editPayment_frequency :: Frequency
+  } deriving (Show)
diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs
deleted file mode 100644
index 7a7351a..0000000
--- a/server/src/Validation/Atomic.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-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
deleted file mode 100644
index fbcdb7c..0000000
--- a/server/src/Validation/CreatePayment.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-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
-      }
diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs
new file mode 100644
index 0000000..20e370e
--- /dev/null
+++ b/server/src/Validation/Payment.hs
@@ -0,0 +1,33 @@
+module Validation.Payment
+  ( createPayment
+  , editPayment
+  ) where
+
+import           Data.Text                 (Text)
+import           Data.Validation           (Validation)
+import qualified Data.Validation           as V
+
+import           Common.Model              (CategoryId, CreatePaymentForm (..),
+                                            EditPaymentForm (..))
+import qualified Common.Validation.Payment as PaymentValidation
+import           Model.CreatePayment       (CreatePayment (..))
+import           Model.EditPayment         (EditPayment (..))
+
+createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment
+createPayment categories form =
+  CreatePayment
+    <$> PaymentValidation.name (_createPaymentForm_name form)
+    <*> PaymentValidation.cost (_createPaymentForm_cost form)
+    <*> PaymentValidation.date (_createPaymentForm_date form)
+    <*> PaymentValidation.category categories (_createPaymentForm_category form)
+    <*> V.Success (_createPaymentForm_frequency form)
+
+editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment
+editPayment categories form =
+  EditPayment
+    <$> V.Success (_editPaymentForm_id form)
+    <*> PaymentValidation.name (_editPaymentForm_name form)
+    <*> PaymentValidation.cost (_editPaymentForm_cost form)
+    <*> PaymentValidation.date (_editPaymentForm_date form)
+    <*> PaymentValidation.category categories (_editPaymentForm_category form)
+    <*> V.Success (_editPaymentForm_frequency form)