aboutsummaryrefslogtreecommitdiff
path: root/server/src
diff options
context:
space:
mode:
Diffstat (limited to 'server/src')
-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
5 files changed, 65 insertions, 16 deletions
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)