Add income list CRUD in user page

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