aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Income.hs28
-rw-r--r--src/server/Controller/Payment.hs6
-rw-r--r--src/server/Design/LoggedIn/Expandables.hs42
-rw-r--r--src/server/Main.hs12
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Income.hs36
-rw-r--r--src/server/Model/Message/Key.hs13
-rw-r--r--src/server/Model/Message/Translations.hs49
8 files changed, 86 insertions, 101 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-11 11:53:39 +0000