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/Design/View/Stat.hs4
-rw-r--r--server/src/Design/Views.hs2
-rw-r--r--server/src/Main.hs3
-rw-r--r--server/src/Persistence/Payment.hs19
-rw-r--r--server/src/Statistics.hs34
-rw-r--r--server/src/View/Page.hs1
7 files changed, 71 insertions, 1 deletions
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index d6aa34f..80c717f 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -4,6 +4,7 @@ module Controller.Payment
, edit
, delete
, searchCategory
+ , statistics
) where
import Control.Monad.IO.Class (liftIO)
@@ -30,6 +31,7 @@ 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 ()
@@ -114,3 +116,10 @@ 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/Design/View/Stat.hs b/server/src/Design/View/Stat.hs
index 4d7021e..2e4ecad 100644
--- a/server/src/Design/View/Stat.hs
+++ b/server/src/Design/View/Stat.hs
@@ -11,3 +11,7 @@ design = do
".exceedingPayers" ? ".userName" ? marginRight (px 5)
".mean" ? marginBottom (em 1.5)
+
+ ".g-Chart" ? do
+ width (pct 75)
+ sym2 margin (px 0) auto
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 270bb8e..4552796 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -22,7 +22,7 @@ design = do
header ? Header.design
Payment.design
".signIn" ? SignIn.design
- ".stat" ? Stat.design
+ Stat.design
".notfound" ? NotFound.design
Table.design
Pages.design
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 25fffb3..64de511 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -97,6 +97,9 @@ main = do
categoryId <- S.param "id"
Category.delete categoryId
+ S.get "/api/statistics" $ do
+ Payment.statistics
+
S.notFound $ do
S.status Status.ok200
Index.get conf
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index b3eb141..573d57f 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -2,6 +2,7 @@ module Persistence.Payment
( count
, find
, getRange
+ , listAllPunctual
, listActivePage
, listModifiedPunctualSince
, listActiveMonthlyOrderedByName
@@ -140,6 +141,24 @@ getRange =
]
)
+listAllPunctual :: Query [Payment]
+listAllPunctual =
+ Query (\conn ->
+ map (\(Row p) -> p) <$>
+ SQLite.queryNamed
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT"
+ , fields
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL AND frequency = :frequency"
+ , "ORDER BY date"
+ ])
+ [ ":frequency" := FrequencyField Punctual
+ ]
+ )
+
+
listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment]
listActivePage frequency page perPage search =
Query (\conn ->
diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs
new file mode 100644
index 0000000..371fba2
--- /dev/null
+++ b/server/src/Statistics.hs
@@ -0,0 +1,34 @@
+module Statistics
+ ( compute
+ ) where
+
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Time.Calendar as Calendar
+
+import Common.Model (Payment (..), PaymentStats)
+
+compute :: [Payment] -> PaymentStats
+compute payments =
+
+ M.toList $ foldl
+ (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m)
+ M.empty
+ payments
+
+ where
+
+ initMonthStats =
+ M.fromList
+ . map (\category -> (category, 0))
+ . L.nub
+ $ map _payment_category payments
+
+ alter p Nothing = Just (addPayment p initMonthStats)
+ alter p (Just monthStats) = Just (addPayment p monthStats)
+
+ addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats
+
+ startOfMonth day =
+ let (y, m, _) = Calendar.toGregorian day
+ in Calendar.fromGregorian y m 1
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index bac6b8a..ae7a266 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -26,6 +26,7 @@ page init =
meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0"
H.title (toHtml $ Msg.get Msg.App_Title)
script ! src "/javascript/main.js" $ ""
+ script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ ""
jsonScript "init" init
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css"