Show total incom by month in statistics

6 files changed, 66 insertions, 16 deletions

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)