diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/server.cabal | 1 | ||||
| -rw-r--r-- | server/src/Controller/Payment.hs | 9 | ||||
| -rw-r--r-- | server/src/Controller/Statistics.hs | 21 | ||||
| -rw-r--r-- | server/src/Main.hs | 3 | ||||
| -rw-r--r-- | server/src/Persistence/Income.hs | 13 | ||||
| -rw-r--r-- | server/src/Statistics.hs | 35 |
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) |