aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/client.cabal2
-rw-r--r--client/src/Model/Route.hs1
-rw-r--r--client/src/View/App.hs43
-rw-r--r--client/src/View/Header.hs5
-rw-r--r--client/src/View/Statistics/Chart.hs102
-rw-r--r--client/src/View/Statistics/Statistics.hs67
-rw-r--r--common/common.cabal1
-rw-r--r--common/src/Common/Message/Key.hs6
-rw-r--r--common/src/Common/Message/Translation.hs6
-rw-r--r--common/src/Common/Model.hs1
-rw-r--r--common/src/Common/Model/PaymentStats.hs10
-rw-r--r--common/src/Common/View/Format.hs52
-rw-r--r--server/server.cabal2
-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
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 09:52:27 +0000