aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/src/View/Statistics/Statistics.hs54
-rw-r--r--common/common.cabal2
-rw-r--r--common/src/Common/Message/Key.hs5
-rw-r--r--common/src/Common/Message/Translation.hs17
-rw-r--r--common/src/Common/Model.hs2
-rw-r--r--common/src/Common/Model/PaymentStats.hs10
-rw-r--r--common/src/Common/Model/Stats.hs23
-rw-r--r--server/server.cabal1
-rw-r--r--server/src/Controller/Payment.hs9
-rw-r--r--server/src/Controller/Statistics.hs21
-rw-r--r--server/src/Main.hs3
-rw-r--r--server/src/Persistence/Income.hs13
-rw-r--r--server/src/Statistics.hs35
13 files changed, 141 insertions, 54 deletions
diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs
index 71f93d4..d931b2b 100644
--- a/client/src/View/Statistics/Statistics.hs
+++ b/client/src/View/Statistics/Statistics.hs
@@ -16,7 +16,8 @@ import qualified Reflex.Dom as R
import qualified Util.Ajax as AjaxUtil
import qualified View.Statistics.Chart as Chart
-import Common.Model (Category (..), Currency, PaymentStats)
+import Common.Model (Category (..), Currency, Income,
+ MonthStats (..), Stats, User (..))
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
@@ -27,41 +28,58 @@ data In = In
view :: forall t m. MonadWidget t m => In -> m ()
view input = do
+ users <- AjaxUtil.getNow "api/users"
categories <- AjaxUtil.getNow "api/allCategories"
statistics <- AjaxUtil.getNow "api/statistics"
- let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics
+
+ let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics
R.divClass "withMargin" $
R.divClass "titleButton" $
R.el "h1" $
R.text $ Msg.get Msg.Statistics_Title
- void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $
+ void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $
stats (_in_currency input)
-stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m ()
-stats currency (categories, stats) =
+stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m ()
+stats currency (users, categories, stats) =
Chart.view $ Chart.In
- { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth)
- , Chart._in_labels = map (Format.monthAndYear . fst) stats
- , Chart._in_datasets =
- Chart.Dataset
- { Chart._dataset_label = Msg.get Msg.Statistics_Total
- , Chart._dataset_data = totalSeries
- , Chart._dataset_color = "#555555"
- } : (map categoryDataset categories)
+ { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome)
+ , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats
+ , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories)
}
where
- averageEachMonth =
- Format.price currency $ sum totalSeries `div` length stats
+ averageIncome =
+ Format.price currency $ sum totalIncomes `div` length stats
+
+ totalIncomeDataset =
+ Chart.Dataset
+ { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes
+ , Chart._dataset_data = totalIncomes
+ , Chart._dataset_color = "#222222"
+ }
+
+ totalIncomes =
+ map (sum . map snd . M.toList . _monthStats_incomeByUser) stats
+
+ averagePayment =
+ Format.price currency $ sum totalPayments `div` length stats
+
+ totalPaymentDataset =
+ Chart.Dataset
+ { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments
+ , Chart._dataset_data = totalPayments
+ , Chart._dataset_color = "#555555"
+ }
- totalSeries =
- map (sum . map snd . M.toList . snd) stats
+ totalPayments =
+ map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats
categoryDataset category =
Chart.Dataset
{ Chart._dataset_label = _category_name category
- , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats
+ , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats
, Chart._dataset_color = _category_color category
}
diff --git a/common/common.cabal b/common/common.cabal
index 020a987..dffc8d0 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -69,4 +69,4 @@ Library
Common.Model.Init
Common.Model.PaymentHeader
Common.Model.PaymentPage
- Common.Model.PaymentStats
+ Common.Model.Stats
diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs
index 9b60a16..f3b0837 100644
--- a/common/src/Common/Message/Key.hs
+++ b/common/src/Common/Message/Key.hs
@@ -123,8 +123,9 @@ data Key =
| SignIn_PasswordLabel
| Statistics_Title
- | Statistics_ByMonthsAndMean Text
- | Statistics_Total
+ | Statistics_ByMonthsAndMean Text Text
+ | Statistics_TotalPayments
+ | Statistics_TotalIncomes
| WeeklyReport_Empty
| WeeklyReport_IncomesCreated Int
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index 2640da3..4ba9ffc 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -532,22 +532,27 @@ m l SignIn_PasswordLabel =
English -> "Password"
French -> "Mot de passe"
-m l (Statistics_ByMonthsAndMean amount) =
+m l (Statistics_ByMonthsAndMean paymentMean incomeMean ) =
case l of
English ->
- T.concat [ "Payments by category by month months (", amount, "on average)" ]
+ T.concat [ "Payments by category (mean ", paymentMean, ") and income (mean ", incomeMean, ") by month" ]
French ->
- T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ]
+ T.concat [ "Paiements par catégorie (moy. ", paymentMean, ") et revenu (moy. ", incomeMean, ") par mois" ]
m l Statistics_Title =
case l of
English -> "Statistics"
French -> "Statistiques"
-m l Statistics_Total =
+m l Statistics_TotalPayments =
case l of
- English -> "Total"
- French -> "Total"
+ English -> "Payment total"
+ French -> "Total des payment"
+
+m l Statistics_TotalIncomes =
+ case l of
+ English -> "Income total"
+ French -> "Total des revenus"
m l WeeklyReport_Empty =
case l of
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index 319d109..979d876 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -21,6 +21,6 @@ import Common.Model.Password as X
import Common.Model.Payment as X
import Common.Model.PaymentHeader as X
import Common.Model.PaymentPage as X
-import Common.Model.PaymentStats as X
import Common.Model.SignInForm as X
+import Common.Model.Stats as X
import Common.Model.User as X
diff --git a/common/src/Common/Model/PaymentStats.hs b/common/src/Common/Model/PaymentStats.hs
deleted file mode 100644
index 2dea640..0000000
--- a/common/src/Common/Model/PaymentStats.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Common.Model.PaymentStats
- ( PaymentStats
- ) where
-
-import Data.Map (Map)
-import Data.Time.Calendar (Day)
-
-import Common.Model.Category (CategoryId)
-
-type PaymentStats = [(Day, Map CategoryId Int)]
diff --git a/common/src/Common/Model/Stats.hs b/common/src/Common/Model/Stats.hs
new file mode 100644
index 0000000..86e6ab9
--- /dev/null
+++ b/common/src/Common/Model/Stats.hs
@@ -0,0 +1,23 @@
+module Common.Model.Stats
+ ( Stats
+ , MonthStats(..)
+ ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Map (Map)
+import Data.Time.Calendar (Day)
+import GHC.Generics (Generic)
+
+import Common.Model.Category (CategoryId)
+import Common.Model.User (UserId)
+
+type Stats = [MonthStats]
+
+data MonthStats = MonthStats
+ { _monthStats_start :: Day
+ , _monthStats_paymentsByCategory :: Map CategoryId Int
+ , _monthStats_incomeByUser :: Map UserId Int
+ } deriving (Eq, Show, Generic)
+
+instance FromJSON MonthStats
+instance ToJSON MonthStats
diff --git a/server/server.cabal b/server/server.cabal
index 4f513f4..5427385 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -65,6 +65,7 @@ Executable server
Controller.Income
Controller.Index
Controller.Payment
+ Controller.Statistics
Controller.User
Cookie
Design.Appearing
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 80c717f..d6aa34f 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -4,7 +4,6 @@ module Controller.Payment
, edit
, delete
, searchCategory
- , statistics
) where
import Control.Monad.IO.Class (liftIO)
@@ -31,7 +30,6 @@ import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
-import qualified Statistics
import qualified Validation.Payment as PaymentValidation
list :: Frequency -> Int -> Int -> Text -> ActionM ()
@@ -116,10 +114,3 @@ searchCategory paymentName =
(liftIO $ Query.run (PaymentPersistence.searchCategory paymentName))
>>= S.json
)
-
-statistics :: ActionM ()
-statistics =
- Secure.loggedAction (\_ -> do
- payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual
- S.json (Statistics.compute payments)
- )
diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs
new file mode 100644
index 0000000..500c93c
--- /dev/null
+++ b/server/src/Controller/Statistics.hs
@@ -0,0 +1,21 @@
+module Controller.Statistics
+ ( paymentsAndIncomes
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+import qualified Model.Query as Query
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Secure
+import qualified Statistics
+
+paymentsAndIncomes :: ActionM ()
+paymentsAndIncomes =
+ Secure.loggedAction (\_ -> do
+ payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual
+ incomes <- liftIO $ Query.run IncomePersistence.listAll
+ S.json (Statistics.paymentsAndIncomes payments incomes)
+ )
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 64de511..659a0fa 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -13,6 +13,7 @@ import qualified Controller.Category as Category
import qualified Controller.Income as Income
import qualified Controller.Index as Index
import qualified Controller.Payment as Payment
+import qualified Controller.Statistics as Statistics
import qualified Controller.User as User
import qualified Design.Global as Design
import Job.Daemon (runDaemons)
@@ -98,7 +99,7 @@ main = do
Category.delete categoryId
S.get "/api/statistics" $ do
- Payment.statistics
+ Statistics.paymentsAndIncomes
S.notFound $ do
S.status Status.ok200
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index 76cb952..1b5364c 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,5 +1,6 @@
module Persistence.Income
- ( count
+ ( listAll
+ , count
, list
, listModifiedSince
, create
@@ -43,6 +44,16 @@ data CountRow = CountRow Int
instance FromRow CountRow where
fromRow = CountRow <$> SQLite.field
+listAll :: Query [Income]
+listAll =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query_
+ conn
+ "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC"
+ )
+
+
count :: Query Int
count =
Query (\conn ->
diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs
index 371fba2..e463aac 100644
--- a/server/src/Statistics.hs
+++ b/server/src/Statistics.hs
@@ -1,23 +1,44 @@
module Statistics
- ( compute
+ ( paymentsAndIncomes
) where
+import Control.Arrow ((&&&))
import qualified Data.List as L
+import Data.Map (Map)
import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
import qualified Data.Time.Calendar as Calendar
-import Common.Model (Payment (..), PaymentStats)
+import Common.Model (Income (..), MonthStats (..), Payment (..),
+ Stats)
-compute :: [Payment] -> PaymentStats
-compute payments =
+paymentsAndIncomes :: [Payment] -> [Income] -> Stats
+paymentsAndIncomes payments incomes =
- M.toList $ foldl
+ map toMonthStat . M.toList $ foldl
(\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m)
M.empty
payments
where
+ toMonthStat (start, paymentsByCategory) =
+ MonthStats start paymentsByCategory (incomesAt start)
+
+ incomesAt day =
+ M.map (incomeAt day) lastToFirstIncomesByUser
+
+ incomeAt day lastToFirstIncome =
+ Maybe.maybe 0 _income_amount
+ . Maybe.listToMaybe
+ . dropWhile (\i -> _income_date i > day)
+ $ lastToFirstIncome
+
+ lastToFirstIncomesByUser =
+ M.map (reverse . L.sortOn _income_date)
+ . groupBy _income_userId
+ $ incomes
+
initMonthStats =
M.fromList
. map (\category -> (category, 0))
@@ -32,3 +53,7 @@ compute payments =
startOfMonth day =
let (y, m, _) = Calendar.toGregorian day
in Calendar.fromGregorian y m 1
+
+groupBy :: Ord k => (a -> k) -> [a] -> Map k [a]
+groupBy key =
+ M.fromListWith (++) . map (key &&& pure)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 14:38:59 +0000