aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--client/client.cabal1
-rw-r--r--client/src/Util/Date.hs12
-rw-r--r--client/src/View/Income/Header.hs4
-rw-r--r--common/src/Common/Model/IncomeHeader.hs12
-rw-r--r--common/src/Common/Model/Payer.hs71
-rw-r--r--server/src/Controller/Income.hs4
-rw-r--r--server/src/Persistence/Payment.hs16
7 files changed, 64 insertions, 56 deletions
diff --git a/client/client.cabal b/client/client.cabal
index cac06d5..04c8543 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -60,7 +60,6 @@ Executable client
Model.Route
Util.Ajax
Util.Css
- Util.Date
Util.Either
Util.List
Util.Reflex
diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs
deleted file mode 100644
index 8fad881..0000000
--- a/client/src/Util/Date.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Util.Date
- ( utcToLocalDay
- ) where
-
-import Data.Time.Calendar (Day)
-import Data.Time.Clock (UTCTime)
-import qualified Data.Time.LocalTime as LocalTime
-
-utcToLocalDay :: UTCTime -> IO Day
-utcToLocalDay time = do
- timezone <- LocalTime.getCurrentTimeZone
- return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 8451ee4..9e1c5b6 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -20,7 +20,6 @@ import qualified Common.View.Format as Format
import qualified Component.Button as Button
import qualified Component.Modal as Modal
-import qualified Util.Date as DateUtil
import qualified View.Income.Form as Form
import View.Income.Init (Init (..))
@@ -48,8 +47,7 @@ view input =
R.el "div" $ do
R.el "h1" $ do
- day <- liftIO $ DateUtil.utcToLocalDay since
- R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
+ R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since))
R.el "ul" $
flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) ->
diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs
index a1defdf..87c7aae 100644
--- a/common/src/Common/Model/IncomeHeader.hs
+++ b/common/src/Common/Model/IncomeHeader.hs
@@ -2,15 +2,15 @@ module Common.Model.IncomeHeader
( IncomeHeader(..)
) where
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Map (Map)
-import Data.Time.Clock (UTCTime)
-import GHC.Generics (Generic)
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Map (Map)
+import Data.Time.Calendar (Day)
+import GHC.Generics (Generic)
-import Common.Model.User (UserId)
+import Common.Model.User (UserId)
data IncomeHeader = IncomeHeader
- { _incomeHeader_since :: Maybe UTCTime
+ { _incomeHeader_since :: Maybe Day
, _incomeHeader_byUser :: Map UserId Int
} deriving (Show, Generic)
diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs
index 40228d5..3c816c8 100644
--- a/common/src/Common/Model/Payer.hs
+++ b/common/src/Common/Model/Payer.hs
@@ -9,6 +9,7 @@ import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Data.Time (NominalDiffTime, UTCTime (..))
import qualified Data.Time as Time
+import Data.Time.Calendar (Day)
import Common.Model.Income (Income (..))
import Common.Model.Payment (Payment (..))
@@ -36,10 +37,11 @@ data ExceedingPayer = ExceedingPayer
getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer]
getExceedingPayers currentTime users incomes payments =
let userIds = map _user_id users
- payers = getPayers currentTime userIds incomes payments
+ payers = getPayers userIds incomes payments
exceedingPayersOnPreIncome =
exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
- mbSince = useIncomesFrom userIds incomes payments
+ firstPayment = safeHead . List.sort . map _payment_date $ payments
+ mbSince = useIncomesFrom userIds incomes firstPayment
in case mbSince of
Just since ->
let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
@@ -54,25 +56,30 @@ getExceedingPayers currentTime users incomes payments =
_ ->
exceedingPayersOnPreIncome
-useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime
-useIncomesFrom userIds incomes payments =
- let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
- mbIncomeTime = incomeDefinedForAll userIds incomes
- in case (firstPaymentTime, mbIncomeTime) of
- (Just t1, Just t2) -> Just (max t1 t2)
- _ -> Nothing
+useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day
+useIncomesFrom userIds incomes firstPayment =
+ case (firstPayment, incomeDefinedForAll userIds incomes) of
+ (Just d1, Just d2) -> Just (max d1 d2)
+ _ -> Nothing
-paymentTime :: Payment -> UTCTime
-paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
+dayUTCTime :: Day -> UTCTime
+dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
-getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer]
-getPayers currentTime userIds incomes payments =
+getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer]
+getPayers userIds incomes payments =
let incomesDefined = incomeDefinedForAll userIds incomes
in flip map userIds (\userId -> Payer
{ _payer_userId = userId
, _payer_preIncomePayments =
totalPayments
- (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined))
+ (\p ->
+ case incomesDefined of
+ Just d ->
+ _payment_date p < d
+
+ Nothing ->
+ True
+ )
userId
payments
, _payer_postIncomePayments =
@@ -80,7 +87,7 @@ getPayers currentTime userIds incomes payments =
(\p ->
case incomesDefined of
Nothing -> False
- Just t -> paymentTime p >= t
+ Just t -> _payment_date p >= t
)
userId
payments
@@ -104,7 +111,7 @@ exceedingPayersFromAmounts userAmounts =
$ userAmounts
where mbMinAmount = safeMinimum . map snd $ userAmounts
-getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
+getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer
getPostPaymentPayer currentTime since payer =
PostPaymentPayer
{ _postPaymentPayer_userId = _payer_userId payer
@@ -120,35 +127,35 @@ getFinalDiff maxRatio payer =
truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
in postIncomeDiff + _postPaymentPayer_preIncomePayments payer
-incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime
+incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
incomeDefinedForAll userIds incomes =
let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
- firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes
+ firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes
in if all Maybe.isJust firstIncomes
- then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes
+ then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
else Nothing
-cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int
+cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int
cumulativeIncomesSince currentTime since incomes =
getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
-getOrderedIncomesSince :: UTCTime -> [Income] -> [Income]
-getOrderedIncomesSince time incomes =
- let mbStarterIncome = getIncomeAt time incomes
- orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes
+getOrderedIncomesSince :: Day -> [Income] -> [Income]
+getOrderedIncomesSince since incomes =
+ let mbStarterIncome = getIncomeAt since incomes
+ orderedIncomesSince = filter (\income -> _income_date income >= since) incomes
in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
-getIncomeAt :: UTCTime -> [Income] -> Maybe Income
-getIncomeAt time incomes =
+getIncomeAt :: Day -> [Income] -> Maybe Income
+getIncomeAt day incomes =
case incomes of
[x] ->
- if incomeTime x < time
- then Just $ x { _income_date = utctDay time }
+ if _income_date x < day
+ then Just $ x { _income_date = day }
else Nothing
x1 : x2 : xs ->
- if incomeTime x1 < time && incomeTime x2 >= time
- then Just $ x1 { _income_date = utctDay time }
- else getIncomeAt time (x2 : xs)
+ if _income_date x1 < day && _income_date x2 >= day
+ then Just $ x1 { _income_date = day }
+ else getIncomeAt day (x2 : xs)
[] ->
Nothing
@@ -171,7 +178,7 @@ getIncomesWithDuration currentTime incomes =
(Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs))
incomeTime :: Income -> UTCTime
-incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date
+incomeTime = dayUTCTime . _income_date
durationIncome :: (NominalDiffTime, Int) -> Int
durationIncome (duration, income) =
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 4a41bd3..127e3b3 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -37,11 +37,11 @@ list page perPage =
count <- IncomePersistence.count
users <- UserPersistence.list
- allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all
+ firstPayment <- PaymentPersistence.firstPunctualDay
allIncomes <- IncomePersistence.listAll
let since =
- CM.useIncomesFrom (map _user_id users) allIncomes allPayments
+ CM.useIncomesFrom (map _user_id users) allIncomes firstPayment
let byUser =
case since of
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index bcd7eb8..eb238d4 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,6 +1,7 @@
module Persistence.Payment
( Payment(..)
, find
+ , firstPunctualDay
, listActive
, listPunctual
, listActiveMonthlyOrderedByName
@@ -60,6 +61,21 @@ find paymentId =
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
)
+data DayRow = DayRow Day
+
+instance FromRow DayRow where
+ fromRow = DayRow <$> SQLite.field
+
+firstPunctualDay :: Query (Maybe Day)
+firstPunctualDay =
+ Query (\conn -> do
+ fmap (\(DayRow d) -> d) . listToMaybe <$>
+ SQLite.query
+ conn
+ "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1"
+ (Only (FrequencyField Punctual))
+ )
+
listActive :: Query [Payment]
listActive =
Query (\conn -> do
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 13:20:48 +0000