Fetch the first payment date instead of every payment to get cumulative income

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