aboutsummaryrefslogtreecommitdiff
path: root/server/src
diff options
context:
space:
mode:
Diffstat (limited to 'server/src')
-rw-r--r--server/src/Controller/Helper.hs17
-rw-r--r--server/src/Controller/Payment.hs73
-rw-r--r--server/src/Model/CreatePayment.hs16
-rw-r--r--server/src/Model/EditPayment.hs17
-rw-r--r--server/src/Validation/Atomic.hs32
-rw-r--r--server/src/Validation/CreatePayment.hs25
-rw-r--r--server/src/Validation/Payment.hs33
7 files changed, 123 insertions, 90 deletions
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)