Show payment stats

8 files changed, 73 insertions, 1 deletions

diff --git a/server/server.cabal b/server/server.cabal
index 7ef5328..4f513f4 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -38,6 +38,7 @@ Executable server
     , filepath
     , http-conduit
     , http-types
+    , jsaddle
     , mime-mail
     , monad-logger
     , mtl
@@ -119,6 +120,7 @@ Executable server
     Resource
     Secure
     SendMail
+    Statistics
     Util.Time
     Validation.Category
     Validation.Income
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"