aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/client/Main.elm14
-rw-r--r--src/client/Model/Payment.elm22
-rw-r--r--src/client/Model/View/LoggedView.elm8
-rw-r--r--src/client/Model/View/Payment/Add.elm6
-rw-r--r--src/client/ServerCommunication.elm9
-rw-r--r--src/client/Update.elm6
-rw-r--r--src/client/Update/Payment.elm2
-rw-r--r--src/client/View/Payments.elm2
-rw-r--r--src/client/View/Payments/Add.elm2
-rw-r--r--src/client/View/Payments/Monthly.elm24
-rw-r--r--src/client/View/Payments/Table.elm13
-rw-r--r--src/server/Controller/Payment.hs17
-rw-r--r--src/server/Design/Global.hs7
-rw-r--r--src/server/Main.hs7
-rw-r--r--src/server/Model/Database.hs3
-rw-r--r--src/server/Model/Frequency.hs19
-rw-r--r--src/server/Model/Json/TotalPayment.hs1
-rw-r--r--src/server/Model/Message/Key.hs2
-rw-r--r--src/server/Model/Message/Translations.hs10
-rw-r--r--src/server/Model/Payment.hs30
20 files changed, 149 insertions, 55 deletions
diff --git a/src/client/Main.elm b/src/client/Main.elm
index 368d930..3174ba6 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -57,9 +57,14 @@ port initView =
Just msg ->
Signal.send actions.address (SignInError msg)
Nothing ->
- Task.map5 GoLoggedView getUsers whoAmI getPayments getPaymentsCount getPayers
- |> flip Task.andThen (Signal.send actions.address)
- |> flip Task.onError (\_ -> Signal.send actions.address GoSignInView)
+ Task.andThen getUsers <| \users ->
+ Task.andThen whoAmI <| \me ->
+ Task.andThen getMonthlyPayments <| \monthlyPayments ->
+ Task.andThen getPayments <| \payments ->
+ Task.andThen getPaymentsCount <| \paymentsCount ->
+ Task.andThen getPayers <| \payers ->
+ Signal.send actions.address (GoLoggedView users me monthlyPayments payments paymentsCount payers)
+ |> flip Task.onError (\_ -> Signal.send actions.address GoSignInView)
getUsers : Task Http.Error Users
getUsers = Http.get usersDecoder "/users"
@@ -67,6 +72,9 @@ getUsers = Http.get usersDecoder "/users"
whoAmI : Task Http.Error UserId
whoAmI = Http.get ("id" := userIdDecoder) "/whoAmI"
+getMonthlyPayments : Task Http.Error Payments
+getMonthlyPayments = Http.get paymentsDecoder "/monthlyPayments"
+
getPayments : Task Http.Error Payments
getPayments = Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage)
diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm
index 4ae50de..313c6be 100644
--- a/src/client/Model/Payment.elm
+++ b/src/client/Model/Payment.elm
@@ -3,26 +3,22 @@ module Model.Payment
, Payments
, Payment
, PaymentId
- , PaymentWithId
, paymentsDecoder
- , removePayment
) where
import Date exposing (..)
import Json.Decode as Json exposing ((:=))
-import Dict exposing (..)
import Model.User exposing (UserId, userIdDecoder)
perPage : Int
perPage = 8
-type alias Payments = Dict PaymentId Payment
-
-type alias PaymentWithId = (PaymentId, Payment)
+type alias Payments = List Payment
type alias Payment =
- { creation : Date
+ { id : PaymentId
+ , creation : Date
, name : String
, cost : Int
, userId : UserId
@@ -31,15 +27,12 @@ type alias Payment =
type alias PaymentId = Int
paymentsDecoder : Json.Decoder Payments
-paymentsDecoder = Json.map Dict.fromList (Json.list paymentWithIdDecoder)
-
-paymentWithIdDecoder : Json.Decoder (PaymentId, Payment)
-paymentWithIdDecoder =
- paymentDecoder `Json.andThen` (\payment -> Json.map (\id -> (id, payment)) ("id" := paymentIdDecoder))
+paymentsDecoder = Json.list paymentDecoder
paymentDecoder : Json.Decoder Payment
paymentDecoder =
- Json.object4 Payment
+ Json.object5 Payment
+ ("id" := paymentIdDecoder)
("creation" := dateDecoder)
("name" := Json.string)
("cost" := Json.int)
@@ -50,6 +43,3 @@ paymentIdDecoder = Json.int
dateDecoder : Json.Decoder Date
dateDecoder = Json.customDecoder Json.string Date.fromString
-
-removePayment : Payments -> PaymentId -> Payments
-removePayment payments paymentId = Dict.remove paymentId payments
diff --git a/src/client/Model/View/LoggedView.elm b/src/client/Model/View/LoggedView.elm
index 35fd9e5..34a55a2 100644
--- a/src/client/Model/View/LoggedView.elm
+++ b/src/client/Model/View/LoggedView.elm
@@ -13,6 +13,7 @@ type alias LoggedView =
{ users : Users
, me : UserId
, add : AddPayment
+ , monthlyPayments : Payments
, payments : Payments
, paymentsCount : Int
, payers : Payers
@@ -20,11 +21,12 @@ type alias LoggedView =
, currentPage : Int
}
-initLoggedView : Users -> UserId -> Payments -> Int -> Payers -> LoggedView
-initLoggedView users me payments paymentsCount payers =
+initLoggedView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedView
+initLoggedView users me monthlyPayments payments paymentsCount payers =
{ users = users
, me = me
- , add = initAddPayment
+ , add = initAddPayment Punctual
+ , monthlyPayments = monthlyPayments
, payments = payments
, paymentsCount = paymentsCount
, payers = payers
diff --git a/src/client/Model/View/Payment/Add.elm b/src/client/Model/View/Payment/Add.elm
index da5d0f2..dc00e86 100644
--- a/src/client/Model/View/Payment/Add.elm
+++ b/src/client/Model/View/Payment/Add.elm
@@ -20,13 +20,13 @@ type alias AddPayment =
, frequency : Frequency
}
-initAddPayment : AddPayment
-initAddPayment =
+initAddPayment : Frequency -> AddPayment
+initAddPayment frequency =
{ name = ""
, nameError = Nothing
, cost = ""
, costError = Nothing
- , frequency = Punctual
+ , frequency = frequency
}
validateName : String -> Translations -> Result String String
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index c38805b..1f35fa1 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -13,6 +13,7 @@ import Date
import Model.Message exposing (messageDecoder)
import Model.User exposing (UserId)
import Model.Payment exposing (PaymentId, perPage, paymentsDecoder)
+import Model.View.Payment.Add exposing (Frequency)
import Update as U
import Update.SignIn exposing (..)
@@ -21,7 +22,7 @@ import Update.Payment as UP
type Communication =
NoCommunication
| SignIn String
- | AddPayment UserId String Int
+ | AddPayment UserId String Int Frequency
| DeletePayment PaymentId UserId Int Int
| UpdatePage Int
| SignOut
@@ -45,8 +46,8 @@ getRequest communication =
Nothing
SignIn login ->
Just (simple "post" ("/signIn?login=" ++ login))
- AddPayment userId paymentName cost ->
- Just (simple "post" ("/payment/add?name=" ++ paymentName ++ "&cost=" ++ (toString cost)))
+ AddPayment userId paymentName cost frequency ->
+ Just (simple "post" ("/payment/add?name=" ++ paymentName ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency)))
DeletePayment paymentId _ _ _ ->
Just (simple "post" ("payment/delete?id=" ++ (toString paymentId)))
UpdatePage page ->
@@ -75,7 +76,7 @@ serverResult communication response =
Task.succeed U.NoOp
SignIn login ->
Task.succeed (U.UpdateSignIn (ValidLogin login))
- AddPayment userId paymentName cost ->
+ AddPayment userId paymentName cost frequency ->
Http.send Http.defaultSettings (updatePageRequest 1)
|> Task.map (\response ->
if response.status == 200
diff --git a/src/client/Update.elm b/src/client/Update.elm
index d643d4e..08547e3 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -23,7 +23,7 @@ type Action =
| GoSignInView
| SignInError String
| UpdateSignIn SignInAction
- | GoLoggedView Users UserId Payments Int Payers
+ | GoLoggedView Users UserId Payments Payments Int Payers
| UpdatePayment PaymentAction
actions : Signal.Mailbox Action
@@ -38,8 +38,8 @@ updateModel action model =
{ model | currentTime <- time }
GoSignInView ->
{ model | view <- V.SignInView initSignInView }
- GoLoggedView users me payments paymentsCount payers ->
- { model | view <- V.LoggedView (initLoggedView users me payments paymentsCount payers) }
+ GoLoggedView users me monthlyPayments payments paymentsCount payers ->
+ { model | view <- V.LoggedView (initLoggedView users me monthlyPayments payments paymentsCount payers) }
SignInError msg ->
let signInView = { initSignInView | result <- Just (Err msg) }
in { model | view <- V.SignInView signInView }
diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm
index f063b4c..2cae679 100644
--- a/src/client/Update/Payment.elm
+++ b/src/client/Update/Payment.elm
@@ -34,7 +34,7 @@ updatePayment model action loggedView =
{ loggedView
| payments <- payments
, currentPage <- 1
- , add <- initAddPayment
+ , add <- initAddPayment loggedView.add.frequency
, payers <- updatePayers loggedView.payers userId cost
, paymentsCount <- loggedView.paymentsCount + 1
}
diff --git a/src/client/View/Payments.elm b/src/client/View/Payments.elm
index b51c9a0..ac19df7 100644
--- a/src/client/View/Payments.elm
+++ b/src/client/View/Payments.elm
@@ -11,6 +11,7 @@ import Model.View.LoggedView exposing (LoggedView)
import View.Payments.ExceedingPayer exposing (exceedingPayers)
import View.Payments.Add exposing (addPayment)
+import View.Payments.Monthly exposing (monthlyPayments)
import View.Payments.Table exposing (paymentsTable)
import View.Payments.Paging exposing (paymentsPaging)
@@ -20,6 +21,7 @@ renderPayments model loggedView =
[ class "payments" ]
[ exceedingPayers model loggedView
, addPayment model loggedView
+ , monthlyPayments model loggedView
, paymentsTable model loggedView
, paymentsPaging loggedView
]
diff --git a/src/client/View/Payments/Add.elm b/src/client/View/Payments/Add.elm
index 085b16d..a22c1f1 100644
--- a/src/client/View/Payments/Add.elm
+++ b/src/client/View/Payments/Add.elm
@@ -31,7 +31,7 @@ addPayment model loggedView =
[ class "add"
, case (validateName loggedView.add.name model.translations, validateCost loggedView.add.cost model.translations) of
(Ok name, Ok cost) ->
- onSubmitPrevDefault serverCommunications.address (SC.AddPayment loggedView.me name cost)
+ onSubmitPrevDefault serverCommunications.address (SC.AddPayment loggedView.me name cost loggedView.add.frequency)
(resName, resCost) ->
onSubmitPrevDefault actions.address (UpdatePayment <| UpdateAdd <| AddError (toMaybeError resName) (toMaybeError resCost))
]
diff --git a/src/client/View/Payments/Monthly.elm b/src/client/View/Payments/Monthly.elm
new file mode 100644
index 0000000..366af92
--- /dev/null
+++ b/src/client/View/Payments/Monthly.elm
@@ -0,0 +1,24 @@
+module View.Payments.Monthly
+ ( monthlyPayments
+ ) where
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.Events exposing (..)
+
+import Model exposing (Model)
+import Model.Payment exposing (Payments)
+import Model.View.LoggedView exposing (LoggedView)
+import Model.Translations exposing (getVarMessage)
+
+monthlyPayments : Model -> LoggedView -> Html
+monthlyPayments model loggedView =
+ div
+ [ class "monthlyPayments" ]
+ [ monthlyCount model loggedView.monthlyPayments ]
+
+monthlyCount : Model -> Payments -> Html
+monthlyCount model monthlyPayments =
+ let count = List.length monthlyPayments
+ key = if count > 1 then "PluralMonthlyCount" else "SingularMonthlyCount"
+ in text (getVarMessage [toString count] key model.translations)
diff --git a/src/client/View/Payments/Table.elm b/src/client/View/Payments/Table.elm
index 5374c44..4a1ed50 100644
--- a/src/client/View/Payments/Table.elm
+++ b/src/client/View/Payments/Table.elm
@@ -43,16 +43,15 @@ paymentsTable model loggedView =
paymentLines : Model -> LoggedView -> List Html
paymentLines model loggedView =
loggedView.payments
- |> Dict.toList
- |> List.sortBy (\(_, payment) -> Date.toTime payment.creation)
+ |> List.sortBy (Date.toTime << .creation)
|> List.reverse
|> List.map (paymentLine model loggedView)
-paymentLine : Model -> LoggedView -> PaymentWithId -> Html
-paymentLine model loggedView (id, payment) =
+paymentLine : Model -> LoggedView -> Payment -> Html
+paymentLine model loggedView payment =
a
- [ class ("row " ++ (if loggedView.edition == Just id then "edition" else ""))
- , onClick actions.address (UpdatePayment (ToggleEdit id))
+ [ class ("row " ++ (if loggedView.edition == Just payment.id then "edition" else ""))
+ , onClick actions.address (UpdatePayment (ToggleEdit payment.id))
]
[ div [ class "cell category" ] [ text payment.name ]
, div [ class "cell cost" ] [ text ((toString payment.cost) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ]
@@ -76,7 +75,7 @@ paymentLine model loggedView (id, payment) =
then
div
[ class "cell remove"
- , onClick serverCommunications.address (SC.DeletePayment id payment.userId payment.cost loggedView.currentPage)
+ , onClick serverCommunications.address (SC.DeletePayment payment.id payment.userId payment.cost loggedView.currentPage)
]
[ renderIcon "times" ]
else
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 0a40771..7944ecd 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -1,5 +1,6 @@
module Controller.Payment
( getPaymentsAction
+ , getMonthlyPaymentsAction
, createPaymentAction
, deletePaymentAction
, getTotalPaymentsAction
@@ -20,6 +21,7 @@ import qualified Secure
import Model.Database
import Model.Payment
+import Model.Frequency
import Model.Json.Message
import Model.Json.Number
import Model.Message
@@ -28,14 +30,19 @@ import Model.Message.Key (Key(PaymentNotDeleted))
getPaymentsAction :: Int -> Int -> ActionM ()
getPaymentsAction page perPage =
Secure.loggedAction (\_ -> do
- payments <- liftIO $ runDb (getPayments page perPage)
- json payments
+ (liftIO $ runDb (getPunctualPayments page perPage)) >>= json
)
-createPaymentAction :: Text -> Int -> ActionM ()
-createPaymentAction name cost =
+getMonthlyPaymentsAction :: ActionM ()
+getMonthlyPaymentsAction =
Secure.loggedAction (\user -> do
- _ <- liftIO . runDb $ createPayment (entityKey user) name cost
+ (liftIO $ runDb (getMonthlyPayments (entityKey user))) >>= json
+ )
+
+createPaymentAction :: Text -> Int -> Frequency -> ActionM ()
+createPaymentAction name cost frequency =
+ Secure.loggedAction (\user -> do
+ _ <- liftIO . runDb $ createPayment (entityKey user) name cost frequency
status ok200
)
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index e0cc244..0af071e 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -140,6 +140,13 @@ global = do
top (px (inputHeight + 10))
left (px 0)
+ ".monthlyPayments" ? do
+ width (pct 95)
+ margin (px 0) auto (px 45) auto
+ padding (px 10) (px 10) (px 10) (px 10)
+ backgroundColor C.lightGrey
+ borderRadius radius radius radius radius
+
".table" ? do
display D.table
width (pct 100)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 27908b4..c3d285e 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -13,6 +13,7 @@ import Controller.Payment
import Controller.User
import Model.Database (runMigrations)
+import Model.Frequency
import Config
@@ -54,10 +55,14 @@ main = do
perPage <- param "perPage" :: ActionM Int
getPaymentsAction page perPage
+ get "/monthlyPayments" $ do
+ getMonthlyPaymentsAction
+
post "/payment/add" $ do
name <- param "name" :: ActionM Text
cost <- param "cost" :: ActionM Int
- createPaymentAction name cost
+ frequency <- param "frequency" :: ActionM Frequency
+ createPaymentAction name cost frequency
post "/payment/delete" $ do
paymentId <- param "id" :: ActionM Text
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index a6ce4f4..d4a7d50 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -21,6 +21,8 @@ import Data.Int (Int64)
import Database.Persist.Sqlite
import Database.Persist.TH
+import Model.Frequency
+
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User
creation UTCTime
@@ -35,6 +37,7 @@ Payment
name Text
cost Int
deletedAt UTCTime Maybe
+ frequency Frequency
deriving Show
SignIn
token Text
diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs
new file mode 100644
index 0000000..2b747b7
--- /dev/null
+++ b/src/server/Model/Frequency.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Model.Frequency
+ ( Frequency(..)
+ ) where
+
+import Web.Scotty
+
+import Database.Persist.TH
+
+data Frequency =
+ Punctual
+ | Monthly
+ deriving (Eq, Show, Read)
+
+derivePersistField "Frequency"
+
+instance Parsable Frequency where parseParam = readEither
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
index 5ae68c9..2b1cd06 100644
--- a/src/server/Model/Json/TotalPayment.hs
+++ b/src/server/Model/Json/TotalPayment.hs
@@ -6,7 +6,6 @@ module Model.Json.TotalPayment
import GHC.Generics
-import Data.Text (Text)
import Data.Aeson
import Model.Database (UserId)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 8a37a2a..163a21f 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -54,5 +54,7 @@ data Key =
| MoneySymbol
| Punctual
| Monthly
+ | SingularMonthlyCount
+ | PluralMonthlyCount
deriving (Enum, Bounded, Show)
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index ec8cf19..501f00f 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -209,3 +209,13 @@ m l Monthly =
case l of
English -> "Monthly"
French -> "Mensuel"
+
+m l SingularMonthlyCount =
+ case l of
+ English -> "You have {1} monthly payment."
+ French -> "Vous avez {1} paiement mensuel."
+
+m l PluralMonthlyCount =
+ case l of
+ English -> "You have {1} monthly payments."
+ French -> "Vous avez {1} paiements mensuels."
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index d7632f0..381578a 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,5 +1,6 @@
module Model.Payment
- ( getPayments
+ ( getPunctualPayments
+ , getMonthlyPayments
, createPayment
, deleteOwnPayment
, getTotalPayments
@@ -18,25 +19,38 @@ import Database.Esqueleto
import qualified Database.Esqueleto as E
import Model.Database
+import Model.Frequency
import qualified Model.Json.Payment as P
import qualified Model.Json.TotalPayment as TP
-getPayments :: Int -> Int -> Persist [P.Payment]
-getPayments page perPage = do
+getPunctualPayments :: Int -> Int -> Persist [P.Payment]
+getPunctualPayments page perPage = do
xs <- select $
from $ \(payment `InnerJoin` user) -> do
on (payment ^. PaymentUserId E.==. user ^. UserId)
where_ (isNothing (payment ^. PaymentDeletedAt))
+ where_ (payment ^. PaymentFrequency E.==. val Punctual)
orderBy [desc (payment ^. PaymentCreation)]
limit . fromIntegral $ perPage
offset . fromIntegral $ (page - 1) * perPage
return (payment, user)
return (map getJsonPayment xs)
+getMonthlyPayments :: UserId -> Persist [P.Payment]
+getMonthlyPayments userId = do
+ xs <- select $
+ from $ \(payment `InnerJoin` user) -> do
+ on (payment ^. PaymentUserId E.==. user ^. UserId)
+ where_ (isNothing (payment ^. PaymentDeletedAt))
+ where_ (payment ^. PaymentFrequency E.==. val Monthly)
+ where_ (payment ^. PaymentUserId E.==. val userId)
+ orderBy [desc (payment ^. PaymentCreation)]
+ return (payment, user)
+ return (map getJsonPayment xs)
+
getJsonPayment :: (Entity Payment, Entity User) -> P.Payment
getJsonPayment (paymentEntity, userEntity) =
let payment = entityVal paymentEntity
- user = entityVal userEntity
in P.Payment
{ P.id = entityKey paymentEntity
, P.creation = paymentCreation payment
@@ -45,10 +59,10 @@ getJsonPayment (paymentEntity, userEntity) =
, P.userId = entityKey userEntity
}
-createPayment :: UserId -> Text -> Int -> Persist PaymentId
-createPayment userId name cost = do
+createPayment :: UserId -> Text -> Int -> Frequency -> Persist PaymentId
+createPayment userId name cost frequency = do
now <- liftIO getCurrentTime
- insert $ Payment userId now name cost Nothing
+ insert $ Payment userId now name cost Nothing frequency
deleteOwnPayment :: Entity User -> PaymentId -> Persist Bool
deleteOwnPayment user paymentId = do
@@ -71,6 +85,7 @@ getTotalPayments = do
from $ \(payment `InnerJoin` user) -> do
on (payment ^. PaymentUserId E.==. user ^. UserId)
where_ (isNothing (payment ^. PaymentDeletedAt))
+ where_ (payment ^. PaymentFrequency E.==. val Punctual)
groupBy (payment ^. PaymentUserId)
return (user ^. UserId, sum_ (payment ^. PaymentCost))
return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
@@ -88,4 +103,5 @@ getPaymentsCount =
(select $
from $ \payment -> do
where_ (isNothing (payment ^. PaymentDeletedAt))
+ where_ (payment ^. PaymentFrequency E.==. val Punctual)
return countRows) :: Persist Int
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:05:41 +0000