From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- client/client.cabal | 2 + client/src/Model/Route.hs | 1 + client/src/View/App.hs | 43 +++++++------ client/src/View/Header.hs | 5 ++ client/src/View/Statistics/Chart.hs | 102 +++++++++++++++++++++++++++++++ client/src/View/Statistics/Statistics.hs | 67 ++++++++++++++++++++ common/common.cabal | 1 + common/src/Common/Message/Key.hs | 6 +- common/src/Common/Message/Translation.hs | 6 +- common/src/Common/Model.hs | 1 + common/src/Common/Model/PaymentStats.hs | 10 +++ common/src/Common/View/Format.hs | 52 ++++++++++------ server/server.cabal | 2 + 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 + 20 files changed, 326 insertions(+), 44 deletions(-) create mode 100644 client/src/View/Statistics/Chart.hs create mode 100644 client/src/View/Statistics/Statistics.hs create mode 100644 common/src/Common/Model/PaymentStats.hs create mode 100644 server/src/Statistics.hs 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" -- cgit v1.2.3