Show payment header infos

1 files changed, 37 insertions, 17 deletions

diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 01702cb..f685f2e 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,6 +1,5 @@
 module Controller.Payment
-  ( deprecatedList
-  , list
+  ( list
   , listPaymentCategories
   , create
   , edit
@@ -8,48 +7,69 @@ module Controller.Payment
   ) where
 
 import           Control.Monad.IO.Class      (liftIO)
+import qualified Data.Map                    as M
+import qualified Data.Time.Clock             as Clock
 import           Data.Validation             (Validation (Failure, Success))
 import qualified Network.HTTP.Types.Status   as Status
-import           Web.Scotty                  hiding (delete)
+import           Web.Scotty                  (ActionM)
+import qualified Web.Scotty                  as S
 
 import           Common.Model                (Category (..),
                                               CreatePaymentForm (..),
                                               EditPaymentForm (..),
-                                              Payment (..), PaymentId,
-                                              PaymentPage (..),
+                                              Frequency (Punctual),
+                                              Payment (..), PaymentHeader (..),
+                                              PaymentId, PaymentPage (..),
                                               SavedPayment (..), User (..))
+import qualified Common.Model                as CM
 import qualified Common.Msg                  as Msg
 import qualified Controller.Helper           as ControllerHelper
 import           Model.CreatePayment         (CreatePayment (..))
 import           Model.EditPayment           (EditPayment (..))
 import qualified Model.Query                 as Query
 import qualified Persistence.Category        as CategoryPersistence
+import qualified Persistence.Income          as IncomePersistence
 import qualified Persistence.Payment         as PaymentPersistence
 import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
+import qualified Persistence.User            as UserPersistence
 import qualified Secure
+import qualified Util.List                   as L
 import qualified Validation.Payment          as PaymentValidation
 
-deprecatedList :: ActionM ()
-deprecatedList =
-  Secure.loggedAction (\_ ->
-    (liftIO . Query.run $ PaymentPersistence.listActive) >>= json
-  )
-
 list :: Int -> Int -> ActionM ()
 list page perPage =
-  Secure.loggedAction (\_ ->
+  Secure.loggedAction (\_ -> do
+    currentTime <- liftIO Clock.getCurrentTime
     (liftIO . Query.run $ do
       count <- PaymentPersistence.count
       payments <- PaymentPersistence.listActivePage page perPage
       paymentCategories <- PaymentCategoryPersistence.list
-      return $ PaymentPage payments paymentCategories count
-    ) >>= json
+
+      users <- UserPersistence.list
+      incomes <- IncomePersistence.listAll
+      allPayments <- PaymentPersistence.listActive Punctual
+
+      let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments
+
+          repartition =
+            M.fromList
+              . map (\(u, xs) -> (u, sum . map snd $ xs))
+              . L.groupBy fst
+              . map (\p -> (_payment_user p, _payment_cost p))
+              $ allPayments
+
+          header = PaymentHeader
+            { _paymentHeader_exceedingPayers = exceedingPayers
+            , _paymentHeader_repartition     = repartition
+            }
+
+      return $ PaymentPage header payments paymentCategories count) >>= S.json
   )
 
 listPaymentCategories :: ActionM ()
 listPaymentCategories =
   Secure.loggedAction (\_ ->
-    (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json
+    (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json
   )
 
 create :: CreatePaymentForm -> ActionM ()
@@ -100,7 +120,7 @@ delete paymentId =
         _ ->
           return False
     if deleted then
-      status Status.ok200
+      S.status Status.ok200
     else
-      status Status.badRequest400
+      S.status Status.badRequest400
   )