Show payment stats

20 files changed, 326 insertions, 44 deletions

diff --git a/client/client.cabal b/client/client.cabal
index 227aed2..cf2c5a1 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -86,3 +86,5 @@ Executable client
     View.Payment.Reducer
     View.Payment.Table
     View.SignIn
+    View.Statistics.Chart
+    View.Statistics.Statistics
diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs
index 63e5d10..f92e9be 100644
--- a/client/src/Model/Route.hs
+++ b/client/src/Model/Route.hs
@@ -6,5 +6,6 @@ data Route
   = RootRoute
   | IncomeRoute
   | CategoryRoute
+  | StatisticsRoute
   | NotFoundRoute
   deriving (Eq, Show)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index b0b89fb..71f0234 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,23 +2,24 @@ module View.App
   ( widget
   ) where
 
-import qualified Data.Text              as T
-import           Prelude                hiding (error, init)
-import           Reflex.Dom             (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Currency, Init (..), UserId)
-import qualified Common.Msg             as Msg
-
-import           Model.Route            (Route (..))
-import qualified Util.Reflex            as ReflexUtil
-import qualified Util.Router            as Router
-import qualified View.Category.Category as Category
-import qualified View.Header            as Header
-import qualified View.Income.Income     as Income
-import qualified View.NotFound          as NotFound
-import qualified View.Payment.Payment   as Payment
-import qualified View.SignIn            as SignIn
+import qualified Data.Text                  as T
+import           Prelude                    hiding (error, init)
+import           Reflex.Dom                 (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom                 as R
+
+import           Common.Model               (Currency, Init (..), UserId)
+import qualified Common.Msg                 as Msg
+
+import           Model.Route                (Route (..))
+import qualified Util.Reflex                as ReflexUtil
+import qualified Util.Router                as Router
+import qualified View.Category.Category     as Category
+import qualified View.Header                as Header
+import qualified View.Income.Income         as Income
+import qualified View.NotFound              as NotFound
+import qualified View.Payment.Payment       as Payment
+import qualified View.SignIn                as SignIn
+import qualified View.Statistics.Statistics as Statistics
 
 widget :: Maybe Init -> IO ()
 widget init =
@@ -77,6 +78,11 @@ signedWidget init route = do
         , Category._in_users = _init_users init
         }
 
+    StatisticsRoute ->
+      Statistics.view $ Statistics.In
+        { Statistics._in_currency = _init_currency init
+        }
+
     NotFoundRoute ->
       NotFound.view
 
@@ -95,5 +101,8 @@ getRoute = do
     ["category"] ->
       CategoryRoute
 
+    ["statistics"] ->
+      StatisticsRoute
+
     _ ->
       NotFoundRoute
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index f91c408..ff9f40a 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -67,6 +67,11 @@ links route = do
     (R.ffor route (attrs CategoryRoute))
     (Msg.get Msg.Category_Title)
 
+  Link.view
+    "/statistics"
+    (R.ffor route (attrs StatisticsRoute))
+    (Msg.get Msg.Statistics_Title)
+
   where
     attrs linkRoute currentRoute =
       M.singleton "class" $
diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs
new file mode 100644
index 0000000..63df2a1
--- /dev/null
+++ b/client/src/View/Statistics/Chart.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP           #-}
+{-# LANGUAGE JavaScriptFFI #-}
+
+module View.Statistics.Chart
+  ( view
+  , In(..)
+  , Dataset(..)
+  ) where
+
+import qualified Control.Concurrent                as Concurrent
+import           Control.Monad                     (void)
+import           Control.Monad.IO.Class            (liftIO)
+import           Data.Aeson                        ((.=))
+import qualified Data.Aeson                        as AE
+import qualified Data.Map                          as M
+import           Data.Text                         (Text)
+import           Language.Javascript.JSaddle       (JSString, JSVal)
+import qualified Language.Javascript.JSaddle.Value as JSValue
+import           Reflex.Dom                        (MonadWidget)
+import qualified Reflex.Dom                        as R
+-- import GHCJS.Foreign.Callback
+
+
+#ifdef __GHCJS__
+foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO ()
+#else
+drawChart = error "drawChart: only available from JavaScript"
+#endif
+
+data In = In
+  { _in_title    :: Text
+  , _in_labels   :: [Text]
+  , _in_datasets :: [Dataset]
+  }
+
+data Dataset = Dataset
+  { _dataset_label :: Text
+  , _dataset_data  :: [Int]
+  , _dataset_color :: Text
+  }
+
+view :: forall t m. MonadWidget t m => In -> m ()
+view input = do
+  R.divClass "g-Chart" $
+    R.elAttr "canvas" (M.singleton "id" "chart") $
+      R.blank
+
+  liftIO $ Concurrent.forkIO $ do
+    Concurrent.threadDelay 500000
+    config <- JSValue.valMakeJSON (configToJson input)
+    drawChart "chart" config
+
+  return ()
+
+configToJson (In title labels datasets) =
+  AE.object
+    [ "type" .= AE.String "line"
+    , "data" .=
+      AE.object
+        [ "labels" .= labels
+        , "datasets" .= map datasetToJson datasets
+        ]
+    , "options" .=
+      AE.object
+        [ "responsive" .= True
+        , "title" .=
+          AE.object
+            [ "display" .= True
+            , "text" .= title
+            ]
+        , "tooltips" .=
+          AE.object
+            [ "mode" .= AE.String "nearest"
+            , "intersect" .= False
+            ]
+        , "hover" .=
+          AE.object
+            [ "mode" .= AE.String "nearest"
+            , "intersect" .= True
+            ]
+        , "scales" .=
+          AE.object
+            [ "yAxes" .=
+              [ [ AE.object
+                  [ "ticks" .=
+                    AE.object
+                      [ "beginAtZero" .= True ]
+                  ]
+                ]
+              ]
+            ]
+        ]
+      ]
+
+datasetToJson (Dataset label data_ color) =
+  AE.object
+    [ "label" .= label
+    , "data" .= data_
+    , "fill" .= False
+    , "backgroundColor" .= color
+    , "borderColor" .= color
+    ]
diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs
new file mode 100644
index 0000000..71f93d4
--- /dev/null
+++ b/client/src/View/Statistics/Statistics.hs
@@ -0,0 +1,67 @@
+module View.Statistics.Statistics
+  ( view
+  , In(..)
+  ) where
+
+import           Control.Monad         (void)
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+import qualified Data.Text             as T
+import           Data.Time.Calendar    (Day)
+import qualified Data.Time.Calendar    as Calendar
+import           Loadable              (Loadable)
+import qualified Loadable
+import           Reflex.Dom            (Dynamic, MonadWidget)
+import qualified Reflex.Dom            as R
+import qualified Util.Ajax             as AjaxUtil
+import qualified View.Statistics.Chart as Chart
+
+import           Common.Model          (Category (..), Currency, PaymentStats)
+import qualified Common.Msg            as Msg
+import qualified Common.View.Format    as Format
+
+data In = In
+  { _in_currency    :: Currency
+  }
+
+view :: forall t m. MonadWidget t m => In -> m ()
+view input = do
+
+  categories <- AjaxUtil.getNow "api/allCategories"
+  statistics <- AjaxUtil.getNow "api/statistics"
+  let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics
+
+  R.divClass "withMargin" $
+    R.divClass "titleButton" $
+      R.el "h1" $
+        R.text $ Msg.get Msg.Statistics_Title
+
+  void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $
+    stats (_in_currency input)
+
+stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m ()
+stats currency (categories, stats) =
+  Chart.view $ Chart.In
+    { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth)
+    , Chart._in_labels = map (Format.monthAndYear . fst) stats
+    , Chart._in_datasets =
+      Chart.Dataset
+        { Chart._dataset_label = Msg.get Msg.Statistics_Total
+        , Chart._dataset_data  = totalSeries
+        , Chart._dataset_color = "#555555"
+        } : (map categoryDataset categories)
+    }
+
+  where
+    averageEachMonth =
+      Format.price currency $ sum totalSeries `div` length stats
+
+    totalSeries =
+      map (sum . map snd . M.toList . snd) stats
+
+    categoryDataset category =
+      Chart.Dataset
+        { Chart._dataset_label = _category_name category
+        , Chart._dataset_data  = map (M.findWithDefault 0 (_category_id category) . snd) stats
+        , Chart._dataset_color = _category_color category
+        }
diff --git a/common/common.cabal b/common/common.cabal
index d09e29b..020a987 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -69,3 +69,4 @@ Library
     Common.Model.Init
     Common.Model.PaymentHeader
     Common.Model.PaymentPage
+    Common.Model.PaymentStats
diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs
index b778a8f..9b60a16 100644
--- a/common/src/Common/Message/Key.hs
+++ b/common/src/Common/Message/Key.hs
@@ -122,9 +122,9 @@ data Key =
   | SignIn_EmailLabel
   | SignIn_PasswordLabel
 
-  | Statistic_Title
-  | Statistic_ByMonthsAndMean Text
-  | Statistic_Total
+  | Statistics_Title
+  | Statistics_ByMonthsAndMean Text
+  | Statistics_Total
 
   | WeeklyReport_Empty
   | WeeklyReport_IncomesCreated Int
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index e74c801..2640da3 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -532,19 +532,19 @@ m l SignIn_PasswordLabel =
     English -> "Password"
     French  -> "Mot de passe"
 
-m l (Statistic_ByMonthsAndMean amount) =
+m l (Statistics_ByMonthsAndMean amount) =
   case l of
     English ->
       T.concat [ "Payments by category by month months (", amount, "on average)" ]
     French  ->
       T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ]
 
-m l Statistic_Title =
+m l Statistics_Title =
   case l of
     English -> "Statistics"
     French  -> "Statistiques"
 
-m l Statistic_Total =
+m l Statistics_Total =
   case l of
     English -> "Total"
     French  -> "Total"
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index c11d6ef..319d109 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -21,5 +21,6 @@ import           Common.Model.Password           as X
 import           Common.Model.Payment            as X
 import           Common.Model.PaymentHeader      as X
 import           Common.Model.PaymentPage        as X
+import           Common.Model.PaymentStats       as X
 import           Common.Model.SignInForm         as X
 import           Common.Model.User               as X
diff --git a/common/src/Common/Model/PaymentStats.hs b/common/src/Common/Model/PaymentStats.hs
new file mode 100644
index 0000000..2dea640
--- /dev/null
+++ b/common/src/Common/Model/PaymentStats.hs
@@ -0,0 +1,10 @@
+module Common.Model.PaymentStats
+  ( PaymentStats
+  ) where
+
+import           Data.Map              (Map)
+import           Data.Time.Calendar    (Day)
+
+import           Common.Model.Category (CategoryId)
+
+type PaymentStats = [(Day, Map CategoryId Int)]
diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs
index 0597d17..5d879fa 100644
--- a/common/src/Common/View/Format.hs
+++ b/common/src/Common/View/Format.hs
@@ -3,15 +3,18 @@ module Common.View.Format
   , longDay
   , price
   , number
+  , monthAndYear
   ) where
 
-import           Data.List          (intersperse)
-import           Data.Maybe         (fromMaybe)
+import qualified Data.List          as L
+import qualified Data.Maybe         as Maybe
 import           Data.Text          (Text)
 import qualified Data.Text          as T
-import           Data.Time.Calendar (Day, toGregorian)
+import           Data.Time.Calendar (Day)
+import qualified Data.Time.Calendar as Calendar
 
 import           Common.Model       (Currency (..))
+import           Common.Msg         (Key)
 import qualified Common.Msg         as Msg
 
 shortDay :: Day -> Text
@@ -20,29 +23,38 @@ shortDay date =
     day
     month
     (fromIntegral year)
-  where (year, month, day) = toGregorian date
+  where (year, month, day) = Calendar.toGregorian date
 
 longDay :: Day -> Text
 longDay date =
   Msg.get $ Msg.Date_Long
     day
-    (fromMaybe "−" . fmap Msg.get . monthToKey $ month)
+    (Maybe.fromMaybe "−" . fmap Msg.get . monthToKey $ month)
     (fromIntegral year)
-  where (year, month, day) = toGregorian date
+  where (year, month, day) = Calendar.toGregorian date
 
-        monthToKey 1  = Just Msg.Month_January
-        monthToKey 2  = Just Msg.Month_February
-        monthToKey 3  = Just Msg.Month_March
-        monthToKey 4  = Just Msg.Month_April
-        monthToKey 5  = Just Msg.Month_May
-        monthToKey 6  = Just Msg.Month_June
-        monthToKey 7  = Just Msg.Month_July
-        monthToKey 8  = Just Msg.Month_August
-        monthToKey 9  = Just Msg.Month_September
-        monthToKey 10 = Just Msg.Month_October
-        monthToKey 11 = Just Msg.Month_November
-        monthToKey 12 = Just Msg.Month_December
-        monthToKey _  = Nothing
+monthAndYear :: Day -> Text
+monthAndYear date =
+  T.intercalate " "
+    [ Maybe.fromMaybe "" . fmap ((\t -> T.concat [t, " "]) . Msg.get) . monthToKey $ month
+    , T.pack . show $ year
+    ]
+  where (year, month, _) = Calendar.toGregorian date
+
+monthToKey :: Int -> Maybe Key
+monthToKey 1  = Just Msg.Month_January
+monthToKey 2  = Just Msg.Month_February
+monthToKey 3  = Just Msg.Month_March
+monthToKey 4  = Just Msg.Month_April
+monthToKey 5  = Just Msg.Month_May
+monthToKey 6  = Just Msg.Month_June
+monthToKey 7  = Just Msg.Month_July
+monthToKey 8  = Just Msg.Month_August
+monthToKey 9  = Just Msg.Month_September
+monthToKey 10 = Just Msg.Month_October
+monthToKey 11 = Just Msg.Month_November
+monthToKey 12 = Just Msg.Month_December
+monthToKey _  = Nothing
 
 price :: Currency -> Int -> Text
 price (Currency currency) amount = T.concat [ number amount, " ", currency ]
@@ -53,7 +65,7 @@ number n =
   . (++) (if n < 0 then "-" else "")
   . reverse
   . concat
-  . intersperse " "
+  . L.intersperse " "
   . group 3
   . reverse
   . show
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"