From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- .stylish-haskell.yaml | 2 + client/client.cabal | 9 +++- client/src/Component/Button.hs | 2 - client/src/Component/Input.hs | 2 - client/src/Icon.hs | 2 - client/src/Main.hs | 9 ++-- client/src/Util/List.hs | 13 ++++++ client/src/View/App.hs | 24 +++++----- client/src/View/Header.hs | 26 +++++------ client/src/View/Payment.hs | 22 +++++----- client/src/View/Payment/Constants.hs | 2 +- client/src/View/Payment/Header.hs | 70 ++++++++++++++++++++++++++++++ client/src/View/Payment/Pages.hs | 8 ++-- client/src/View/Payment/Table.hs | 28 ++++++------ client/src/View/SignIn.hs | 32 ++++++-------- common/common.cabal | 26 ++++++----- common/src/Common/Message.hs | 12 ----- common/src/Common/Message/Key.hs | 2 +- common/src/Common/Message/Translation.hs | 12 +++-- common/src/Common/Model/Category.hs | 2 - common/src/Common/Model/CreateCategory.hs | 2 - common/src/Common/Model/CreateIncome.hs | 2 - common/src/Common/Model/CreatePayment.hs | 2 - common/src/Common/Model/Currency.hs | 2 - common/src/Common/Model/EditCategory.hs | 2 - common/src/Common/Model/EditIncome.hs | 2 - common/src/Common/Model/EditPayment.hs | 2 - common/src/Common/Model/Frequency.hs | 2 - common/src/Common/Model/Income.hs | 2 - common/src/Common/Model/Init.hs | 2 - common/src/Common/Model/InitResult.hs | 2 - common/src/Common/Model/Payment.hs | 2 - common/src/Common/Model/PaymentCategory.hs | 2 - common/src/Common/Model/SignIn.hs | 2 - common/src/Common/Model/User.hs | 2 - common/src/Common/Msg.hs | 13 ++++++ common/src/Common/View/Format.hs | 35 +++++++-------- server/server.cabal | 7 +-- server/src/Conf.hs | 2 - server/src/Controller/Category.hs | 7 +-- server/src/Controller/Income.hs | 7 +-- server/src/Controller/Index.hs | 15 +++---- server/src/Controller/Payment.hs | 2 - server/src/Controller/SignIn.hs | 15 +++---- server/src/Cookie.hs | 2 - server/src/Design/Dialog.hs | 2 - server/src/Design/Errors.hs | 2 - server/src/Design/Form.hs | 2 - server/src/Design/Global.hs | 2 - server/src/Design/Helper.hs | 2 - server/src/Design/Tooltip.hs | 2 - server/src/Design/View/Header.hs | 2 - server/src/Design/View/Payment.hs | 2 - server/src/Design/View/Payment/Header.hs | 2 - server/src/Design/View/Payment/Pages.hs | 2 - server/src/Design/View/Payment/Table.hs | 2 - server/src/Design/View/SignIn.hs | 2 - server/src/Design/View/Stat.hs | 2 - server/src/Design/View/Table.hs | 2 - server/src/Design/Views.hs | 2 - server/src/Job/Daemon.hs | 2 +- server/src/Job/Model.hs | 2 - server/src/Job/MonthlyPayment.hs | 2 +- server/src/Json.hs | 3 -- server/src/LoginSession.hs | 2 - server/src/Main.hs | 7 +-- server/src/MimeMail.hs | 2 - server/src/Model/Category.hs | 1 - server/src/Model/Frequency.hs | 3 -- server/src/Model/Income.hs | 1 - server/src/Model/Init.hs | 2 - server/src/Model/Payment.hs | 1 - server/src/Model/PaymentCategory.hs | 1 - server/src/Model/SignIn.hs | 2 - server/src/Model/User.hs | 1 - server/src/Secure.hs | 9 ++-- server/src/SendMail.hs | 2 - server/src/Util/Time.hs | 25 +++++++++++ server/src/Utils/Time.hs | 25 ----------- server/src/View/Mail/SignIn.hs | 19 ++++---- server/src/View/Mail/WeeklyReport.hs | 35 +++++++-------- server/src/View/Page.hs | 7 +-- 82 files changed, 293 insertions(+), 331 deletions(-) create mode 100644 client/src/Util/List.hs create mode 100644 client/src/View/Payment/Header.hs delete mode 100644 common/src/Common/Message.hs create mode 100644 common/src/Common/Msg.hs create mode 100644 server/src/Util/Time.hs delete mode 100644 server/src/Utils/Time.hs diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 3642d0e..a3f992d 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -28,3 +28,5 @@ newline: native language_extensions: - ExistentialQuantification - MultiParamTypeClasses + - OverloadedStrings + - RecursiveDo diff --git a/client/client.cabal b/client/client.cabal index ac74d9c..fdf764e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -13,9 +13,12 @@ Executable client Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 - Extensions: + + Default-extensions: ExistentialQuantification MultiParamTypeClasses + OverloadedStrings + RecursiveDo Build-depends: aeson @@ -32,10 +35,12 @@ Executable client Component.Button Component.Input Icon - Main + Util.List View.App View.Header View.Payment + View.Payment.Constants + View.Payment.Header View.Payment.Pages View.Payment.Table View.SignIn diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index c31cdc6..09c93cd 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Button ( ButtonIn(..) , buttonInDefault diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c3864b4..1923463 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Input ( InputIn(..) , InputOut(..) diff --git a/client/src/Icon.hs b/client/src/Icon.hs index cd5a0b4..fbf5388 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Icon ( clone , delete diff --git a/client/src/Main.hs b/client/src/Main.hs index cbc881c..d55eefe 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,9 +13,8 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult (InitEmpty)) +import qualified Common.Msg as Msg import qualified View.App as App @@ -27,7 +26,8 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" + initNode <- Dom.getElementById document ("init" :: Dom.JSString) + case initNode of Just node -> do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) @@ -36,4 +36,5 @@ readInit = do Nothing -> initParseError _ -> return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + + where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs new file mode 100644 index 0000000..4e22ba8 --- /dev/null +++ b/client/src/Util/List.hs @@ -0,0 +1,13 @@ +module Util.List + ( groupBy + ) where + +import Control.Arrow ((&&&)) +import Data.Function (on) +import qualified Data.List as L + +groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] +groupBy f = + map (f . head &&& id) + . L.groupBy ((==) `on` f) + . L.sortBy (compare `on` f) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 442fa3e..64ca303 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult (..)) +import Common.Model (InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -36,7 +32,7 @@ widget initResult = InitEmpty result -> SignIn.view result - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 7afd9bd..4c74383 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Header ( view , HeaderIn(..) , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg -import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -35,7 +31,7 @@ view headerIn = R.el "header" $ do R.divClass "title" $ - R.text $ Message.get Key.App_Title + R.text $ Msg.get Msg.App_Title signOut <- nameSignOut $ _headerIn_initResult headerIn diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f70c8cd..934f720 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment ( widget , PaymentIn(..) , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) -import qualified View.Payment.Table as Table +import View.Payment.Header (HeaderIn (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..)) +import qualified View.Payment.Table as Table data PaymentIn = PaymentIn { _paymentIn_init :: Init @@ -29,6 +28,9 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec + _ <- Header.widget $ HeaderIn + { _headerIn_init = _paymentIn_init $ paymentIn + } _ <- Table.widget $ TableIn { _tableIn_init = _paymentIn_init paymentIn , _tableIn_currentPage = _pagesOut_currentPage pagesOut diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs index ac2320a..028e328 100644 --- a/client/src/View/Payment/Constants.hs +++ b/client/src/View/Payment/Constants.hs @@ -3,4 +3,4 @@ module View.Payment.Constants ) where paymentsPerPage :: Int -paymentsPerPage = 8 +paymentsPerPage = 7 diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs new file mode 100644 index 0000000..67b4eb4 --- /dev/null +++ b/client/src/View/Payment/Header.hs @@ -0,0 +1,70 @@ +module View.Payment.Header + ( widget + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency (..), Init (..), + Payment (..), User (..), UserId) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data HeaderIn t = HeaderIn + { _headerIn_init :: Init + } + +data HeaderOut = HeaderOut + { + } + +widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget headerIn = + R.divClass "header" $ do + infos payments users currency + return $ HeaderOut {} + where init = _headerIn_init headerIn + payments = _init_payments init + users = _init_users init + currency = _init_currency init + +infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +infos payments users currency = + R.divClass "infos" $ do + R.elClass "span" "total" $ do + R.text . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) + R.elClass "span" "partition" . R.text $ + T.intercalate ", " + . map (\(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (Format.price currency userTotal) + ) + $ totalByUser + + where punctualPayments = filter ((==) Punctual . _payment_frequency) payments + paymentCount = length punctualPayments + total = sum . map _payment_cost $ punctualPayments + + totalByUser :: [(UserId, Int)] + totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ punctualPayments diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f96cb8e..81555ab 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Pages ( widget , PagesIn(..) @@ -11,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Frequency (..), Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -48,7 +45,8 @@ widget pagesIn = do { _pagesOut_currentPage = currentPage } - where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn + maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage pageEvent = R.switchPromptlyDyn . fmap R.leftmost range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 5c0b709..d8093a5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Table ( widget , TableIn(..) @@ -15,11 +12,11 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), +import Common.Model (Category (..), Frequency (..), + Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM +import qualified Common.Msg as Msg import qualified Common.Util.Text as T import qualified Common.View.Format as Format @@ -40,11 +37,11 @@ widget tableIn = do _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name + R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost + R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User + R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category + R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank @@ -58,10 +55,11 @@ widget tableIn = do getPaymentRange :: [Payment] -> Int -> [Payment] getPaymentRange payments currentPage = take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) - . reverse - . L.sortOn _payment_date - $ payments + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + . filter ((==) Punctual . _payment_frequency) + $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 1f5b900..69596d8 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn (SignIn)) +import Common.Model (SignIn (SignIn)) +import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..), InputIn (..), + InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -27,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button @@ -50,7 +46,7 @@ view result = button <- Component.button $ ButtonIn { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } diff --git a/common/common.cabal b/common/common.cabal index c3073d9..e4a9c59 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -13,6 +13,12 @@ Library Hs-source-dirs: src Default-language: Haskell2010 + Default-extensions: + DeriveGeneric + ExistentialQuantification + MultiParamTypeClasses + OverloadedStrings + Build-depends: aeson , base >=4.9 && <4.11 @@ -20,28 +26,28 @@ Library , time Exposed-modules: - Common.Message - Common.Message.Key Common.Model + Common.Msg Common.Util.Text Common.View.Format other-modules: + Common.Message.Key Common.Message.Lang Common.Message.Translation - Common.Model.PaymentCategory + Common.Model.Category Common.Model.CreateCategory - Common.Model.CreatePayment Common.Model.CreateIncome + Common.Model.CreatePayment + Common.Model.Currency Common.Model.EditCategory - Common.Model.EditPayment - Common.Model.InitResult Common.Model.EditIncome + Common.Model.EditPayment Common.Model.Frequency - Common.Model.Currency - Common.Model.Category - Common.Model.Payment Common.Model.Income - Common.Model.SignIn Common.Model.Init + Common.Model.InitResult + Common.Model.Payment + Common.Model.PaymentCategory + Common.Model.SignIn Common.Model.User diff --git a/common/src/Common/Message.hs b/common/src/Common/Message.hs deleted file mode 100644 index 745e457..0000000 --- a/common/src/Common/Message.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Common.Message - ( get - ) where - -import Data.Text (Text) - -import Common.Message.Key (Key) -import Common.Message.Lang (Lang (..)) -import qualified Common.Message.Translation as Translation - -get :: Key -> Text -get = Translation.get French diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 991c407..ad8a7f1 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -83,6 +83,7 @@ data Key = | Payment_Add | Payment_Balanced + | Payment_By Text Text | Payment_Category | Payment_CloneLong | Payment_CloneShort @@ -129,7 +130,6 @@ data Key = | Statistic_Title | Statistic_ByMonthsAndMean Text - | Statistic_By Text Text | Statistic_Total | WeeklyReport_Empty diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 16a56dd..0a6084d 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Common.Message.Translation ( get ) where @@ -359,6 +357,11 @@ m l Payment_Balanced = English -> "Payments are balanced." French -> "Les paiements sont équilibrés." +m l (Payment_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + m l Payment_Category = case l of English -> "Category" @@ -584,11 +587,6 @@ m l SignIn_ParseError = English -> "Error while reading initial data." French -> "Erreur lors de la lecture des données initiales." -m l (Statistic_By key value) = - case l of - English -> T.concat [ key, ": ", value ] - French -> T.concat [ key, " : ", value ] - m l (Statistic_ByMonthsAndMean amount) = case l of English -> diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index bbd3c33..db1da53 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Category ( CategoryId , Category(..) diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs index 11d84e9..51bd2a0 100644 --- a/common/src/Common/Model/CreateCategory.hs +++ b/common/src/Common/Model/CreateCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreateCategory ( CreateCategory(..) ) where diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs index 583ebbb..644a51c 100644 --- a/common/src/Common/Model/CreateIncome.hs +++ b/common/src/Common/Model/CreateIncome.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreateIncome ( CreateIncome(..) ) where diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index 7a283e5..8e2ab73 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreatePayment ( CreatePayment(..) ) where diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs index 6d74ea7..175aeba 100644 --- a/common/src/Common/Model/Currency.hs +++ b/common/src/Common/Model/Currency.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Currency ( Currency(..) ) where diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs index 5b08b86..8b9d9eb 100644 --- a/common/src/Common/Model/EditCategory.hs +++ b/common/src/Common/Model/EditCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditCategory ( EditCategory(..) ) where diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs index 867b406..0e65f12 100644 --- a/common/src/Common/Model/EditIncome.hs +++ b/common/src/Common/Model/EditIncome.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditIncome ( EditIncome(..) ) where diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs index 32228f0..d2c223f 100644 --- a/common/src/Common/Model/EditPayment.hs +++ b/common/src/Common/Model/EditPayment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditPayment ( EditPayment(..) ) where diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index 085163d..ee502e8 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Frequency ( Frequency(..) ) where diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs index 10b4cf2..0423704 100644 --- a/common/src/Common/Model/Income.hs +++ b/common/src/Common/Model/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Income ( IncomeId , Income(..) diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs index ae23bb5..68b3f5d 100644 --- a/common/src/Common/Model/Init.hs +++ b/common/src/Common/Model/Init.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Init ( Init(..) ) where diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 12be65a..542e6c7 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.InitResult ( InitResult(..) ) where diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 4741058..37a090d 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Payment ( PaymentId , Payment(..) diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs index 24cf9e1..2a559ce 100644 --- a/common/src/Common/Model/PaymentCategory.hs +++ b/common/src/Common/Model/PaymentCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.PaymentCategory ( PaymentCategoryId , PaymentCategory(..) diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs index baccd88..bfd7fbc 100644 --- a/common/src/Common/Model/SignIn.hs +++ b/common/src/Common/Model/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.SignIn ( SignIn(..) ) where diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs index e491c31..a30d104 100644 --- a/common/src/Common/Model/User.hs +++ b/common/src/Common/Model/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.User ( UserId , User(..) diff --git a/common/src/Common/Msg.hs b/common/src/Common/Msg.hs new file mode 100644 index 0000000..9e4cfe2 --- /dev/null +++ b/common/src/Common/Msg.hs @@ -0,0 +1,13 @@ +module Common.Msg + ( get + , Key(..) + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key (..)) +import Common.Message.Lang (Lang (..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs index 783ad67..0597d17 100644 --- a/common/src/Common/View/Format.hs +++ b/common/src/Common/View/Format.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Common.View.Format ( shortDay , longDay @@ -13,13 +11,12 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (Currency (..)) +import qualified Common.Msg as Msg shortDay :: Day -> Text shortDay date = - Message.get $ Key.Date_Short + Msg.get $ Msg.Date_Short day month (fromIntegral year) @@ -27,24 +24,24 @@ shortDay date = longDay :: Day -> Text longDay date = - Message.get $ Key.Date_Long + Msg.get $ Msg.Date_Long day - (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromMaybe "−" . fmap Msg.get . monthToKey $ month) (fromIntegral year) where (year, month, day) = toGregorian date - monthToKey 1 = Just Key.Month_January - monthToKey 2 = Just Key.Month_February - monthToKey 3 = Just Key.Month_March - monthToKey 4 = Just Key.Month_April - monthToKey 5 = Just Key.Month_May - monthToKey 6 = Just Key.Month_June - monthToKey 7 = Just Key.Month_July - monthToKey 8 = Just Key.Month_August - monthToKey 9 = Just Key.Month_September - monthToKey 10 = Just Key.Month_October - monthToKey 11 = Just Key.Month_November - monthToKey 12 = Just Key.Month_December + 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 diff --git a/server/server.cabal b/server/server.cabal index d30060b..e4a1730 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -13,9 +13,11 @@ Executable server Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 - Extensions: + + Default-extensions: ExistentialQuantification MultiParamTypeClasses + OverloadedStrings Build-depends: aeson @@ -86,7 +88,6 @@ Executable server Job.WeeklyReport Json LoginSession - Main MimeMail Model.Category Model.Frequency @@ -103,7 +104,7 @@ Executable server Resource Secure SendMail - Utils.Time + Util.Time Validation View.Mail.SignIn View.Mail.WeeklyReport diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 299f071..2422a93 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Conf ( get , Conf(..) diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index a646496..5565b43 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Category ( create , edit @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CategoryId, CreateCategory (..), EditCategory (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Category as Category @@ -50,5 +47,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index c42f6a7..19f0cfc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Income ( create , editOwn @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Income as Income @@ -45,5 +42,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index bf4859d..f05ce6f 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -10,10 +10,9 @@ import Network.HTTP.Types.Status (ok200) import Prelude hiding (error) import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key import Common.Model (InitResult (..), User (..)) +import Common.Msg (Key) +import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession @@ -31,7 +30,7 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey + return . InitEmpty . Left . Msg.get $ errorKey Right user -> liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do @@ -54,23 +53,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ Key.SignIn_LinkInvalid + return . Left $ Msg.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ Key.SignIn_LinkUsed + return . Left $ Msg.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ Key.SignIn_LinkExpired + return . Left $ Msg.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e4104eb..c6c874a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Payment ( list , create diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 5552781..cf92c9f 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.SignIn ( signIn ) where @@ -11,9 +9,8 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (SignIn (..)) +import qualified Common.Msg as Msg import Conf (Conf) import qualified Conf @@ -40,8 +37,8 @@ signIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs index 511dd42..f79a1fa 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Cookie ( makeSimpleCookie , setCookie diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 6759606..034a8b1 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Dialog ( design ) where diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 2c6c16b..9f435eb 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Errors ( design ) where diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index a4a1de0..be0e74f 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Form ( design ) where diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 1fe6a80..34d772e 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Global ( globalDesign ) where diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 0913511..9bf7878 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Helper ( clearFix , button diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 57aec33..eef804e 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Tooltip ( design ) where diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index d05f748..792d482 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Header ( design ) where diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 62f7061..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment ( design ) where diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index d87e95b..36bc8d9 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Header ( design ) where diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index f6660a1..2028c1b 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Pages ( design ) where diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index 243d7f4..26dc9ed 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Table ( design ) where diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 2b1252f..4d4be7b 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.SignIn ( design ) where diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index b10dd7b..4d7021e 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Stat ( design ) where diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index fd55656..cd406fc 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Table ( design ) where diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 1157b68..a73a1fa 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Views ( design ) where diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 26977d1..d8cd522 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -14,7 +14,7 @@ import Job.Model (actualizeLastCheck, actualizeLastExecution, import Job.MonthlyPayment (monthlyPayment) import Job.WeeklyReport (weeklyReport) import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index b90dca0..a5fa62b 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Job.Model ( Job(..) , getLastExecution diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 8cb1c27..ca7e007 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -8,7 +8,7 @@ import Common.Model (Frequency (..), Payment (..)) import qualified Model.Payment as Payment import qualified Model.Query as Query -import Utils.Time (timeToDay) +import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Json.hs b/server/src/Json.hs index eb5c572..6d40305 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - module Json ( jsonObject , jsonId diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index beca697..86f1329 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module LoginSession ( put , get diff --git a/server/src/Main.hs b/server/src/Main.hs index 5ac68db..d7b9b93 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - import Control.Applicative (liftA3) import Control.Monad.IO.Class (liftIO) @@ -9,6 +7,8 @@ import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static import Web.Scotty +import Common.Model (Frequency (..), Payment (..)) + import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income @@ -35,7 +35,8 @@ main = do time <- liftIO Time.getCurrentTime (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments + let punctualPayments = filter ((==) Punctual . _payment_frequency) payments + exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 7fe98ed..c994905 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module MimeMail ( -- * Datatypes Boundary (..) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index b972ebd..ee406bc 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index 41a325d..c29cf37 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index a69112a..a6174bc 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index c030c58..be44c72 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.Init ( getInit ) where diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index c1b109f..33551e5 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6d02136..c60c1a2 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 6f38fe7..0cc4a03 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.SignIn ( SignIn(..) , createSignInToken diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs index f17f545..8dc1fc8 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 88bdcda..6e5b998 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Secure ( loggedAction , getUserFromToken @@ -11,9 +9,8 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (User) +import qualified Common.Msg as Msg import qualified LoginSession import Model.Query (Query) @@ -32,10 +29,10 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized + html . fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden + html . fromStrict . Msg.get $ Msg.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index 959f21d..d00912f 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module SendMail ( sendMail ) where diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs new file mode 100644 index 0000000..3e0856d --- /dev/null +++ b/server/src/Util/Time.hs @@ -0,0 +1,25 @@ +module Util.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs deleted file mode 100644 index e1a94d3..0000000 --- a/server/src/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index d542fd8..22c3cb0 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -1,24 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User (..)) +import Common.Model (User (..)) +import qualified Common.Msg as Msg -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + , M.subject = Msg.get Msg.SignIn_MailTitle + , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url) } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index c0e89d5..4ad8b77 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.WeeklyReport ( mail ) where @@ -13,11 +11,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (Income (..), Payment (..), User (..), UserId) import qualified Common.Model as CM +import qualified Common.Msg as Msg import qualified Common.View.Format as Format import Conf (Conf) @@ -34,9 +31,9 @@ mail conf users payments incomes start end = { M.from = Conf.noReplyMail conf , M.to = map _user_email users , M.subject = T.concat - [ Message.get Key.App_Title + [ Msg.get Msg.App_Title , " − " - , Message.get Key.WeeklyReport_Title + , Msg.get Msg.WeeklyReport_Title ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -45,7 +42,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - Message.get Key.WeeklyReport_Empty + Msg.get Msg.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -56,17 +53,17 @@ paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = section sectionTitle sectionItems where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -76,17 +73,17 @@ incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = section sectionTitle sectionItems where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index ff7bdc7..27b4f26 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Page ( page ) where @@ -16,9 +14,8 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult) +import qualified Common.Msg as Msg import Design.Global (globalDesign) @@ -28,7 +25,7 @@ page initResult = H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) + H.title (toHtml $ Msg.get Msg.App_Title) script ! src "javascript/main.js" $ "" jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" -- cgit v1.2.3