From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 27 Jan 2020 22:07:18 +0100
Subject: Show total incom by month in statistics

---
 client/src/View/Statistics/Statistics.hs | 54 +++++++++++++++++++++-----------
 common/common.cabal                      |  2 +-
 common/src/Common/Message/Key.hs         |  5 +--
 common/src/Common/Message/Translation.hs | 17 ++++++----
 common/src/Common/Model.hs               |  2 +-
 common/src/Common/Model/PaymentStats.hs  | 10 ------
 common/src/Common/Model/Stats.hs         | 23 ++++++++++++++
 server/server.cabal                      |  1 +
 server/src/Controller/Payment.hs         |  9 ------
 server/src/Controller/Statistics.hs      | 21 +++++++++++++
 server/src/Main.hs                       |  3 +-
 server/src/Persistence/Income.hs         | 13 +++++++-
 server/src/Statistics.hs                 | 35 ++++++++++++++++++---
 13 files changed, 141 insertions(+), 54 deletions(-)
 delete mode 100644 common/src/Common/Model/PaymentStats.hs
 create mode 100644 common/src/Common/Model/Stats.hs
 create mode 100644 server/src/Controller/Statistics.hs

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)
-- 
cgit v1.2.3