From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 20 Jan 2020 19:47:23 +0100
Subject: Show payment stats

---
 server/src/Controller/Payment.hs  |  9 +++++++++
 server/src/Design/View/Stat.hs    |  4 ++++
 server/src/Design/Views.hs        |  2 +-
 server/src/Main.hs                |  3 +++
 server/src/Persistence/Payment.hs | 19 +++++++++++++++++++
 server/src/Statistics.hs          | 34 ++++++++++++++++++++++++++++++++++
 server/src/View/Page.hs           |  1 +
 7 files changed, 71 insertions(+), 1 deletion(-)
 create mode 100644 server/src/Statistics.hs

(limited to 'server/src')

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