aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Payer.hs20
-rw-r--r--src/server/Controller/Payment.hs8
-rw-r--r--src/server/Main.hs6
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Income.hs9
-rw-r--r--src/server/Model/Json/Income.hs18
-rw-r--r--src/server/Model/Json/Payer.hs22
-rw-r--r--src/server/Model/Json/TotalPayment.hs19
-rw-r--r--src/server/Model/Message/Translations.hs7
-rw-r--r--src/server/Model/Payer.hs46
-rw-r--r--src/server/Model/Payer/Income.hs22
-rw-r--r--src/server/Model/Payer/Payment.hs40
-rw-r--r--src/server/Model/Payment.hs20
-rw-r--r--src/server/MonthlyPaymentJob.hs16
-rw-r--r--src/server/Utils/Time.hs27
15 files changed, 216 insertions, 65 deletions
diff --git a/src/server/Controller/Payer.hs b/src/server/Controller/Payer.hs
new file mode 100644
index 0000000..70760ae
--- /dev/null
+++ b/src/server/Controller/Payer.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Controller.Payer
+ ( getPayers
+ ) where
+
+import Web.Scotty
+
+import Control.Monad.IO.Class (liftIO)
+
+import Model.Database
+import qualified Model.Payer as P
+
+import Secure (loggedAction)
+
+getPayers :: ActionM ()
+getPayers =
+ Secure.loggedAction (\_ ->
+ (liftIO $ runDb P.getPayers) >>= json
+ )
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 02c8a8e..ffb575c 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -5,7 +5,6 @@ module Controller.Payment
, getMonthlyPayments
, createPayment
, deletePayment
- , getTotalPayments
, getPaymentsCount
) where
@@ -26,6 +25,7 @@ import Json (jsonObject)
import Model.Database
import qualified Model.Payment as P
+import qualified Model.Payer as Payer
import Model.Frequency
import Model.Json.Number
import qualified Model.Json.PaymentId as JP
@@ -63,12 +63,6 @@ deletePayment paymentId =
jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)]
)
-getTotalPayments :: ActionM ()
-getTotalPayments =
- Secure.loggedAction (\_ -> do
- (liftIO . runDb $ P.getTotalPayments) >>= json
- )
-
getPaymentsCount :: ActionM ()
getPaymentsCount =
Secure.loggedAction (\_ -> do
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 71c4674..6a120d6 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -14,6 +14,7 @@ import Controller.Index
import Controller.SignIn
import Controller.Payment
import Controller.User
+import Controller.Payer
import Model.Database (runMigrations)
import Model.Frequency
@@ -74,5 +75,8 @@ main = do
paymentId <- param "id" :: ActionM Text
deletePayment paymentId
- get "/payments/total" getTotalPayments
get "/payments/count" getPaymentsCount
+
+ -- Payers
+
+ get "/payers" getPayers
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index f38379a..8d1da25 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -57,6 +57,7 @@ Income
userId UserId
creation UTCTime
amount Int
+ deriving Show
|]
type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index edf1c92..70b9149 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -1,5 +1,7 @@
module Model.Income
( getIncome
+ , getFirstIncome
+ , getIncomes
, setIncome
) where
@@ -15,6 +17,13 @@ getIncome :: UserId -> Persist (Maybe Income)
getIncome userId =
fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation]
+getIncomes :: Persist [Income]
+getIncomes = map entityVal <$> selectList [] []
+
+getFirstIncome :: UserId -> Persist (Maybe Income)
+getFirstIncome userId =
+ fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Asc IncomeCreation]
+
setIncome :: UserId -> Int -> Persist IncomeId
setIncome userId amount = do
now <- liftIO getCurrentTime
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
new file mode 100644
index 0000000..4549ca5
--- /dev/null
+++ b/src/server/Model/Json/Income.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Income
+ ( Income(..)
+ ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Time.Clock (UTCTime)
+
+data Income = Income
+ { creation :: UTCTime
+ , amount :: Int
+ } deriving (Show, Generic)
+
+instance FromJSON Income
+instance ToJSON Income
diff --git a/src/server/Model/Json/Payer.hs b/src/server/Model/Json/Payer.hs
new file mode 100644
index 0000000..2101e40
--- /dev/null
+++ b/src/server/Model/Json/Payer.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Payer
+ ( Payer(..)
+ ) where
+
+import GHC.Generics
+
+import Data.Aeson
+
+import Model.Database (UserId)
+import Model.Json.Income
+
+data Payer = Payer
+ { userId :: UserId
+ , preIncomePaymentSum :: Int
+ , postIncomePaymentSum :: Int
+ , incomes :: [Income]
+ } deriving (Show, Generic)
+
+instance FromJSON Payer
+instance ToJSON Payer
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
deleted file mode 100644
index 2b1cd06..0000000
--- a/src/server/Model/Json/TotalPayment.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.TotalPayment
- ( TotalPayment(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-
-import Model.Database (UserId)
-
-data TotalPayment = TotalPayment
- { userId :: UserId
- , totalPayment :: Int
- } deriving (Show, Generic)
-
-instance FromJSON TotalPayment
-instance ToJSON TotalPayment
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index a5de110..f594833 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -154,7 +154,7 @@ m l September =
m l October =
case l of
English -> "October"
- French -> "Octoble"
+ French -> "Octobre"
m l November =
case l of
@@ -233,9 +233,8 @@ m l Monthly =
m l SingularMonthlyCount =
T.concat
[ case l of
- English -> "{1} monthly payment of {2} "
- French -> "{1} paiement mensuel de {2} "
- , m l MoneySymbol
+ English -> "{1} monthly payment of {2}"
+ French -> "{1} paiement mensuel de {2}"
]
m l PluralMonthlyCount =
diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs
new file mode 100644
index 0000000..3893765
--- /dev/null
+++ b/src/server/Model/Payer.hs
@@ -0,0 +1,46 @@
+module Model.Payer
+ ( getPayers
+ )
+ where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (getCurrentTime)
+import Data.List (find)
+import Data.Maybe (fromMaybe, fromMaybe)
+
+import Database.Persist
+
+import Model.Database
+import Model.Payer.Payment (getTotalPaymentsBefore, getTotalPaymentsAfter)
+import Model.Payer.Income (incomeDefinedForAll)
+import Model.User (getUsers)
+import Model.Income (getIncomes)
+
+import qualified Model.Json.Payer as Json
+import qualified Model.Json.Income as Json
+
+getPayers :: Persist [Json.Payer]
+getPayers = do
+ userIds <- map entityKey <$> getUsers
+ incomes <- getIncomes
+ now <- liftIO getCurrentTime
+ incomeIsDefined <- fromMaybe now <$> incomeDefinedForAll
+ preIncomePaymentSums <- getTotalPaymentsBefore incomeIsDefined
+ postIncomePaymentSums <- getTotalPaymentsAfter incomeIsDefined
+ return $ map (getPayer incomes preIncomePaymentSums postIncomePaymentSums) userIds
+
+getPayer :: [Income] -> [(UserId, Int)] -> [(UserId, Int)] -> UserId -> Json.Payer
+getPayer incomes preIncomePaymentSums postIncomePaymentSums userId =
+ Json.Payer
+ { Json.userId = userId
+ , Json.preIncomePaymentSum = findOrDefault userId 0 preIncomePaymentSums
+ , Json.postIncomePaymentSum = findOrDefault userId 0 postIncomePaymentSums
+ , Json.incomes =
+ map (\income -> Json.Income (incomeCreation income) (incomeAmount income))
+ . filter ((==) userId . incomeUserId)
+ $ incomes
+ }
+
+findOrDefault :: (Eq a) => a -> b -> [(a, b)] -> b
+findOrDefault a b = fromMaybe b . fmap snd . find ((==) a . fst)
diff --git a/src/server/Model/Payer/Income.hs b/src/server/Model/Payer/Income.hs
new file mode 100644
index 0000000..f4bc9fd
--- /dev/null
+++ b/src/server/Model/Payer/Income.hs
@@ -0,0 +1,22 @@
+module Model.Payer.Income
+ ( incomeDefinedForAll
+ ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.List (sort)
+import Data.Maybe
+
+import Database.Persist
+
+import Model.Database
+import Model.User (getUsers)
+import Model.Income (getFirstIncome)
+
+incomeDefinedForAll :: Persist (Maybe UTCTime)
+incomeDefinedForAll = do
+ userIds <- map entityKey <$> getUsers
+ firstIncomes <- mapM getFirstIncome userIds
+ return $
+ if all isJust firstIncomes
+ then listToMaybe . reverse . sort . map incomeCreation . catMaybes $ firstIncomes
+ else Nothing
diff --git a/src/server/Model/Payer/Payment.hs b/src/server/Model/Payer/Payment.hs
new file mode 100644
index 0000000..6efc38d
--- /dev/null
+++ b/src/server/Model/Payer/Payment.hs
@@ -0,0 +1,40 @@
+module Model.Payer.Payment
+ ( getTotalPaymentsBefore
+ , getTotalPaymentsAfter
+ ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.Maybe (catMaybes)
+
+import Database.Persist
+import Database.Esqueleto
+import qualified Database.Esqueleto as E
+
+import Model.Database
+import Model.Frequency
+
+getTotalPaymentsBefore :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsBefore time =
+ getTotalPayments (\p -> p ^. PaymentCreation E.<. val time)
+
+getTotalPaymentsAfter :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsAfter time =
+ getTotalPayments (\p -> p ^. PaymentCreation E.>=. val time)
+
+getTotalPayments :: (SqlExpr (Entity Payment) -> SqlExpr (Value Bool)) -> Persist [(UserId, Int)]
+getTotalPayments paymentWhere = do
+ values <- select $
+ from $ \payment -> do
+ where_ (isNothing (payment ^. PaymentDeletedAt))
+ where_ (payment ^. PaymentFrequency E.==. val Punctual)
+ where_ (paymentWhere payment)
+ groupBy (payment ^. PaymentUserId)
+ return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
+ return $ catMaybes . map (unMaybe . unValueTuple) $ values
+
+unValueTuple :: (Value a, Value b) -> (a, b)
+unValueTuple (Value a, Value b) = (a, b)
+
+unMaybe :: (a, Maybe b) -> Maybe (a, b)
+unMaybe (a, Just b) = Just (a, b)
+unMaybe _ = Nothing
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 25b1bb7..233cafa 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -4,13 +4,11 @@ module Model.Payment
, getMonthlyPayments
, createPayment
, deleteOwnPayment
- , getTotalPayments
, getPaymentsCount
) where
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
-import Data.Maybe (catMaybes)
import Control.Monad.IO.Class (liftIO)
@@ -22,7 +20,6 @@ import qualified Database.Esqueleto as E
import Model.Database
import Model.Frequency
import qualified Model.Json.Payment as P
-import qualified Model.Json.TotalPayment as TP
getPunctualPayments :: Int -> Int -> Persist [P.Payment]
getPunctualPayments page perPage = do
@@ -80,23 +77,6 @@ deleteOwnPayment user paymentId = do
Nothing ->
return False
-getTotalPayments :: Persist [TP.TotalPayment]
-getTotalPayments = do
- values <- select $
- from $ \payment -> do
- where_ (isNothing (payment ^. PaymentDeletedAt))
- where_ (payment ^. PaymentFrequency E.==. val Punctual)
- groupBy (payment ^. PaymentUserId)
- return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
- return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
-
-getTotalPayment :: (UserId, Maybe Int) -> Maybe TP.TotalPayment
-getTotalPayment (userId, Just cost) = Just (TP.TotalPayment userId cost)
-getTotalPayment (_, Nothing) = Nothing
-
-unValueTuple :: (Value a, Value b) -> (a, b)
-unValueTuple (Value a, Value b) = (a, b)
-
getPaymentsCount :: Persist Int
getPaymentsCount =
unValue . head <$>
diff --git a/src/server/MonthlyPaymentJob.hs b/src/server/MonthlyPaymentJob.hs
index 1b331af..f5f6878 100644
--- a/src/server/MonthlyPaymentJob.hs
+++ b/src/server/MonthlyPaymentJob.hs
@@ -5,8 +5,6 @@ module MonthlyPaymentJob
import Control.Monad.IO.Class (liftIO)
import Data.Time.Clock
-import Data.Time.LocalTime
-import Data.Time.Calendar
import Database.Persist (entityVal, insert)
@@ -17,6 +15,8 @@ import Model.Payment (getMonthlyPayments)
import Model.JobKind
import Model.Frequency
+import Utils.Time (belongToCurrentMonth)
+
monthlyPaymentJobListener :: IO ()
monthlyPaymentJobListener =
let lastExecutionTooOld = fmap not . belongToCurrentMonth
@@ -24,18 +24,6 @@ monthlyPaymentJobListener =
msDelay = 1000000 * 60 * 60
in jobListener MonthlyPaymentJob lastExecutionTooOld runJob msDelay
-belongToCurrentMonth :: UTCTime -> IO Bool
-belongToCurrentMonth time = do
- month <- getLocalMonth time
- actualMonth <- getCurrentTime >>= getLocalMonth
- return (month == actualMonth)
-
-getLocalMonth :: UTCTime -> IO Int
-getLocalMonth time = do
- timeZone <- getCurrentTimeZone
- let (_, month, _) = toGregorian . localDay $ utcToLocalTime timeZone time
- return month
-
monthlyPaymentJob :: Persist ()
monthlyPaymentJob = do
monthlyPayments <- map entityVal <$> getMonthlyPayments
diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs
new file mode 100644
index 0000000..0d6ed73
--- /dev/null
+++ b/src/server/Utils/Time.hs
@@ -0,0 +1,27 @@
+module Utils.Time
+ ( belongToCurrentMonth
+ , getLocalDate
+ , Date(..)
+ ) where
+
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+
+belongToCurrentMonth :: UTCTime -> IO Bool
+belongToCurrentMonth time = do
+ timeMonth <- month <$> getLocalDate time
+ actualMonth <- month <$> (getCurrentTime >>= getLocalDate)
+ return (timeMonth == actualMonth)
+
+getLocalDate :: UTCTime -> IO Date
+getLocalDate time = do
+ timeZone <- getCurrentTimeZone
+ let (y, m, d) = toGregorian . localDay $ utcToLocalTime timeZone time
+ return (Date y m d)
+
+data Date = Date
+ { year :: Integer
+ , month :: Int
+ , day :: Int
+ }
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 20:10:17 +0000