From d9df5c3fcffe12aac239b58ccf2fd82c19c3be62 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Jan 2016 23:37:14 +0100 Subject: Validate add payment server side --- src/server/Controller/Payment.hs | 18 ++++++++++++------ src/server/Design/LoggedIn/Table.hs | 1 + src/server/Main.hs | 2 +- src/server/Model/Database.hs | 3 +++ src/server/Model/Json/PaymentId.hs | 17 ----------------- src/server/Model/Payment.hs | 31 +++++++++++++++++++++++++++---- src/server/Validation.hs | 23 +++++++++++++++++++++++ 7 files changed, 67 insertions(+), 28 deletions(-) delete mode 100644 src/server/Model/Json/PaymentId.hs create mode 100644 src/server/Validation.hs (limited to 'src/server') diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d2a9258..e94b300 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -10,23 +10,24 @@ module Controller.Payment import Web.Scotty -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (ok200, badRequest400) import Database.Persist import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Aeson.Types as Json import qualified Secure -import Json (jsonError) +import Json (jsonObject, jsonError) import Model.Database import qualified Model.Payment as P import Model.Frequency import Model.Json.Number -import qualified Model.Json.PaymentId as JP import Model.Message import Model.Message.Key (Key(PaymentNotDeleted)) @@ -42,11 +43,16 @@ getMonthlyPayments = (liftIO $ runDb (P.getUserMonthlyPayments (entityKey user))) >>= json ) -createPayment :: Text -> Int -> Frequency -> ActionM () +createPayment :: Text -> Text -> Frequency -> ActionM () createPayment name cost frequency = Secure.loggedAction (\user -> do - paymentId <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency - json (JP.PaymentId paymentId) + creationResult <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency + case creationResult of + Left errors -> do + status badRequest400 + jsonObject . map (\(a, b) -> (a, Json.String . T.pack . show $ b)) $ errors + Right paymentId -> + jsonObject [("id", Json.Number . fromIntegral . keyToInt64 $ paymentId)] ) deletePayment :: Text -> ActionM () diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs index d9fc318..e5ed4bf 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/src/server/Design/LoggedIn/Table.hs @@ -91,6 +91,7 @@ tableDesign = textAlign (alignSide sideCenter) button ? do defaultButton C.red C.white (px rowHeightPx) focusLighten + borderRadius (px 0) (px 0) (px 0) (px 0) position absolute top (px 0) right (px 0) diff --git a/src/server/Main.hs b/src/server/Main.hs index 9f21873..e5d8cca 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -61,7 +61,7 @@ main = do post "/payment/add" $ do name <- param "name" :: ActionM Text - cost <- param "cost" :: ActionM Int + cost <- param "cost" :: ActionM Text frequency <- param "frequency" :: ActionM Frequency createPayment name cost frequency diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 67cc8b3..a98e69a 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -69,3 +69,6 @@ runMigrations = runDb $ runMigration migrateAll textToKey :: (ToBackendKey SqlBackend a) => Text -> Key a textToKey text = toSqlKey (read (unpack text) :: Int64) + +keyToInt64 :: (ToBackendKey SqlBackend a) => Key a -> Int64 +keyToInt64 = fromSqlKey diff --git a/src/server/Model/Json/PaymentId.hs b/src/server/Model/Json/PaymentId.hs deleted file mode 100644 index 3cbeb3c..0000000 --- a/src/server/Model/Json/PaymentId.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentId - ( PaymentId(..) - ) where - -import Data.Aeson -import GHC.Generics - -import qualified Model.Database as D - -data PaymentId = PaymentId - { id :: D.PaymentId - } deriving (Show, Generic) - -instance FromJSON PaymentId -instance ToJSON PaymentId diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index de4a759..404b143 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Model.Payment ( getPunctualPayments , getUserMonthlyPayments @@ -8,16 +10,21 @@ module Model.Payment ) where import Data.Text (Text) +import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) +import Data.Either (lefts) import Control.Monad.IO.Class (liftIO) import Database.Persist import qualified Database.Persist as P +import qualified Validation + import Model.Database import Model.Frequency import qualified Model.Json.Payment as P +import qualified Model.Message.Key as K getPunctualPayments :: Persist [P.Payment] getPunctualPayments = @@ -50,10 +57,26 @@ getJsonPayment paymentEntity = , P.userId = paymentUserId payment } -createPayment :: UserId -> Text -> Int -> Frequency -> Persist PaymentId -createPayment userId name cost frequency = do - now <- liftIO getCurrentTime - insert $ Payment userId now name cost Nothing frequency +createPayment :: UserId -> Text -> Text -> Frequency -> Persist (Either [(Text, K.Key)] PaymentId) +createPayment userId name cost frequency = + case validatePayment name cost of + Left err -> + return . Left $ err + Right (validatedName, validatedCost) -> do + now <- liftIO getCurrentTime + Right <$> insert (Payment userId now validatedName validatedCost Nothing frequency) + +validatePayment :: Text -> Text -> Either [(Text, K.Key)] (Text, Int) +validatePayment name cost = + let eitherName = Validation.nonEmpty K.CategoryRequired name + eitherCost = Validation.nonEmpty K.CostRequired cost >>= Validation.number K.CostRequired (/= 0) + in case (eitherName, eitherCost) of + (Right validatedName, Right validatedCost) -> + Right (validatedName, validatedCost) + _ -> + let nameErrors = map (\x -> ("name", x)) $ lefts [eitherName] + costErrors = map (\x -> ("cost", x)) $ lefts [eitherCost] + in Left (nameErrors ++ costErrors) deleteOwnPayment :: Entity User -> PaymentId -> Persist Bool deleteOwnPayment user paymentId = do diff --git a/src/server/Validation.hs b/src/server/Validation.hs new file mode 100644 index 0000000..9035be7 --- /dev/null +++ b/src/server/Validation.hs @@ -0,0 +1,23 @@ +module Validation + ( nonEmpty + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +nonEmpty :: a -> Text -> Either a Text +nonEmpty x str = + if T.null str + then Left x + else Right str + +number :: x -> (Int -> Bool) -> Text -> Either x Int +number x numberForm str = + case reads (T.unpack str) :: [(Int, String)] of + (number, _) : _ -> + if numberForm number + then Right number + else Left x + _ -> + Left x -- cgit v1.2.3