From 8cd63a64abafe21378c35c2489d49f24c9ece3c9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 4 Apr 2016 01:27:36 +0200 Subject: Add income list CRUD in user page --- src/server/Controller/Income.hs | 28 +++++++++++++++--- src/server/Controller/Payment.hs | 6 ++-- src/server/Design/LoggedIn/Expandables.hs | 42 +++----------------------- src/server/Main.hs | 12 ++++++-- src/server/Model/Database.hs | 1 + src/server/Model/Income.hs | 36 +++++++++++++++-------- src/server/Model/Message/Key.hs | 13 ++++---- src/server/Model/Message/Translations.hs | 49 ++++++++++--------------------- 8 files changed, 86 insertions(+), 101 deletions(-) (limited to 'src/server') diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 51861d3..4474d51 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -2,21 +2,29 @@ module Controller.Income ( getIncomes - , setIncome + , addIncome + , deleteOwnIncome ) where import Web.Scotty +import Network.HTTP.Types.Status (ok200, badRequest400) + import Control.Monad.IO.Class (liftIO) import Database.Persist +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Time.Clock (UTCTime) + import qualified Secure import Json (jsonId) import Model.Database import qualified Model.Income as Income +import qualified Model.Message.Key as Key getIncomes :: ActionM () getIncomes = @@ -24,8 +32,20 @@ getIncomes = (liftIO $ map Income.getJsonIncome <$> runDb Income.getIncomes) >>= json ) -setIncome :: Int -> ActionM () -setIncome amount = +addIncome :: UTCTime -> Int -> ActionM () +addIncome creation amount = + Secure.loggedAction (\user -> + (liftIO . runDb $ Income.addIncome (entityKey user) creation amount) >>= jsonId + ) + +deleteOwnIncome :: Text -> ActionM () +deleteOwnIncome incomeId = Secure.loggedAction (\user -> do - (liftIO . runDb $ Income.setIncome (entityKey user) amount) >>= jsonId + deleted <- liftIO . runDb $ Income.deleteOwnIncome user (textToKey incomeId) + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.pack . show $ Key.IncomeNotDeleted ) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 204794a..7e8d0a3 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -3,7 +3,7 @@ module Controller.Payment ( getPayments , createPayment - , deletePayment + , deleteOwnPayment ) where import Web.Scotty @@ -46,8 +46,8 @@ createPayment name cost frequency = jsonObject [("id", Json.Number . fromIntegral . keyToInt64 $ paymentId)] ) -deletePayment :: Text -> ActionM () -deletePayment paymentId = +deleteOwnPayment :: Text -> ActionM () +deleteOwnPayment paymentId = Secure.loggedAction (\user -> do deleted <- liftIO . runDb $ P.deleteOwnPayment user (textToKey paymentId) if deleted diff --git a/src/server/Design/LoggedIn/Expandables.hs b/src/server/Design/LoggedIn/Expandables.hs index 8ef42cd..a3be877 100644 --- a/src/server/Design/LoggedIn/Expandables.hs +++ b/src/server/Design/LoggedIn/Expandables.hs @@ -4,8 +4,8 @@ module Design.LoggedIn.Expandables ( expandablesDesign ) where -import Data.Monoid ((<>)) - +-- import Data.Monoid ((<>)) +-- import Clay import Design.Color as C @@ -22,42 +22,8 @@ expandablesDesign = right blockPadding bottom (px 2) - ".monthlyPayments" ? do - expandBlock C.blue C.white (px inputHeight) - - ".account" ? do - expandBlock C.green C.white (px inputHeight) - - ".header" |> ".exceedingPayer" ? do - lineHeight (px inputHeight) - ".userName" ? marginRight (px 10) - - ".income" ? do - backgroundColor C.lightGrey - padding (px 0) (px 20) (px 0) (px 20) - position relative - lineHeight (px rowHeightPx) - - input ? do - defaultInput inputHeight - marginLeft (px 20) - marginTop (px (-5)) - width (px 100) - - button ? do - marginLeft (px 20) - paddingLeft (px 15) - paddingRight (px 15) - marginTop (px (-5)) - - ".validateIncomeEdition" <> ".editIncomeEdition" ? - defaultButton C.red C.white (px inputHeight) focusLighten - - ".undoIncomeEdition" ? - defaultButton C.blue C.white (px inputHeight) focusLighten + ".monthlyPayments" ? expandBlock C.blue C.white (px inputHeight) - ".error" ? do - color C.redError - lineHeight (px 30) + ".account" ? expandBlock C.green C.white (px inputHeight) ".detail" |> ".header" ? borderRadius radius radius 0 0 diff --git a/src/server/Main.hs b/src/server/Main.hs index c6e930a..0642288 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -11,6 +11,7 @@ import MonthlyPaymentJob (monthlyPaymentJobListener) import Data.Text (Text) import qualified Data.Text.IO as T +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Controller.Index import Controller.SignIn @@ -62,14 +63,21 @@ api conf = do -- Users get "/api/users" getUsers + get "/api/whoAmI" whoAmI -- Incomes get "/api/incomes" getIncomes + post "/api/income" $ do + creation <- param "creation" :: ActionM Int amount <- param "amount" :: ActionM Int - setIncome amount + addIncome (posixSecondsToUTCTime $ (fromIntegral creation) / 1000) amount + + delete "/api/income/delete" $ do + incomeId <- param "id" :: ActionM Text + deleteOwnIncome incomeId -- Payments @@ -83,4 +91,4 @@ api conf = do post "/api/payment/delete" $ do paymentId <- param "id" :: ActionM Text - deletePayment paymentId + deleteOwnPayment paymentId diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 58160c3..0915afe 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -57,6 +57,7 @@ Income userId UserId creation UTCTime amount Int + deletedAt UTCTime Maybe deriving Show |] diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index 2177617..c0cac45 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,11 +1,11 @@ module Model.Income ( getJsonIncome - , getFirstIncome , getIncomes - , setIncome + , addIncome + , deleteOwnIncome ) where -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) import Control.Monad.IO.Class (liftIO) @@ -20,13 +20,23 @@ getJsonIncome incomeEntity = where income = entityVal incomeEntity getIncomes :: Persist [Entity Income] -getIncomes = selectList [] [] - -getFirstIncome :: UserId -> Persist (Maybe Income) -getFirstIncome userId = - fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Asc IncomeCreation] - -setIncome :: UserId -> Int -> Persist IncomeId -setIncome userId amount = do - now <- liftIO getCurrentTime - insert (Income userId now amount) +getIncomes = selectList [IncomeDeletedAt ==. Nothing] [] + +addIncome :: UserId -> UTCTime -> Int -> Persist IncomeId +addIncome userId creation amount = do + insert (Income userId creation amount Nothing) + +deleteOwnIncome :: Entity User -> IncomeId -> Persist Bool +deleteOwnIncome user incomeId = do + mbIncome <- get incomeId + case mbIncome of + Just income -> + if incomeUserId income == entityKey user + then do + now <- liftIO getCurrentTime + update incomeId [IncomeDeletedAt =. Just now] + return True + else + return False + Nothing -> + return False diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index 8f5cf2a..9d1c053 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -51,9 +51,8 @@ data Key = | CategoryRequired | CostRequired - | IncomeRequired - | IncomeMustBeNonNullNumber - | IncomeMustBePositiveNumber + | DateValidationError + | IncomeValidationError -- Payments @@ -66,12 +65,10 @@ data Key = -- Income + | AddIncome + | Incomes | Income - | NoIncome - | Edit - | Validate - | Undo - | NewIncome + | IncomeNotDeleted -- Http error diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index f41a417..9db4a76 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -198,17 +198,12 @@ m l CostRequired = English -> "Type a positive cost." French -> "Entre un coût positif." -m l IncomeRequired = +m l DateValidationError = case l of - English -> "Type an income." - French -> "Entre un revenu." + English -> "The date must be day/month/year" + French -> "La date doit avoir la forme jour/mois/année" -m l IncomeMustBeNonNullNumber = - case l of - English -> "The income must be a non-null integer." - French -> "Le revenu doit être un entier non nul." - -m l IncomeMustBePositiveNumber = +m l IncomeValidationError = case l of English -> "The income must be a positive integer." French -> "Le revenu doit être un entier positif." @@ -251,37 +246,25 @@ m l PluralMonthlyCount = -- Income -m l Income = - T.concat - [ case l of - English -> "Monthly net income: {1}" - French -> "Revenu mensuel net : {1}" - ] - -m l NoIncome = +m l AddIncome = case l of - English -> "Income not given" - French -> "Revenu non renseigné" + English -> "Add a monthly net income" + French -> "Ajouter un revenu mensuel net" -m l Edit = +m l Incomes = case l of - English -> "Edit" - French -> "Éditer" + English -> "Monthly net incomes" + French -> "Revenus mensuels nets" -m l Validate = - case l of - English -> "Validate" - French -> "Valider" - -m l Undo = +m l Income = case l of - English -> "Undo" - French -> "Annuler" + English -> "Monthly net income: {1}" + French -> "Revenu mensuel net : {1}" -m l NewIncome = +m l IncomeNotDeleted = case l of - English -> "New income" - French -> "Nouveau revenu" + English -> "The income could not have been deleted." + French -> "Le revenu n'a pas pu être supprimé." -- Http error -- cgit v1.2.3