Show payment header infos

11 files changed, 88 insertions, 188 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
   )
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 4020eb0..1195e10 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -3,11 +3,9 @@ module Design.Modal
   ) where
 
 import           Clay
-import           Data.Monoid                ((<>))
+import           Data.Monoid              ((<>))
 
-import qualified Design.View.Payment.Add    as Add
-import qualified Design.View.Payment.Delete as Delete
-import qualified Design.View.Payment.Form   as Form
+import qualified Design.View.Payment.Form as Form
 
 design :: Css
 design = do
@@ -47,9 +45,7 @@ design = do
     sym borderRadius (px 5)
     boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
 
-    ".add" ? Add.design
     ".form" ? Form.design
-    ".delete" ? Delete.design
 
   ".paymentModal" & do
     ".radioGroup" ? ".title" ? display none
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 0d59fa0..27b4ef3 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -5,11 +5,7 @@ module Design.View.Payment
 import           Clay
 
 import qualified Design.View.Payment.Header as Header
-import qualified Design.View.Payment.Pages  as Pages
-import qualified Design.View.Payment.Table  as Table
 
 design :: Css
 design = do
-  ".header" ? Header.design
-  ".table" ? Table.design
-  ".pages" ? Pages.design
+  ".g-HeaderInfos" ? Header.design
diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs
deleted file mode 100644
index f3d7e3f..0000000
--- a/server/src/Design/View/Payment/Delete.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Design.View.Payment.Delete
-  ( design
-  ) where
-
-import           Clay
-
-import qualified Design.Color     as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper    as Helper
-
-design :: Css
-design = do
-  ".deleteHeader" ? do
-    backgroundColor Color.chestnutRose
-    fontSize (px 18)
-    color Color.white
-    sym padding (px 20)
-    textAlign (alignSide sideCenter)
-    borderRadius (px 5) (px 5) (px 0) (px 0)
-
-  ".deleteContent" ? do
-    sym padding (px 20)
-
-    ".buttons" ? do
-      display flex
-      justifyContent spaceAround
-      marginTop (em 1.5)
-
-      ".confirm" ?
-        Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
-      ".undo" ?
-        Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
-
-      (".confirm" <> ".undo") ?
-        width (px 90)
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 9111374..49c1a09 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -8,45 +8,36 @@ import           Clay
 
 import qualified Design.Color     as Color
 import qualified Design.Constants as Constants
-import qualified Design.Helper    as Helper
 import qualified Design.Media     as Media
 
 design :: Css
 design = do
-  Media.desktop $ marginBottom (em 3)
-  Media.mobileTablet $ marginBottom (em 2)
+  Media.desktop $ marginBottom (em 2)
+  Media.mobileTablet $ marginBottom (em 1)
   marginLeft (pct Constants.blockPercentMargin)
   marginRight (pct Constants.blockPercentMargin)
 
-  ".payerAndAdd" ? do
-    Media.tabletDesktop $ display flex
+  ".g-HeaderInfos__ExceedingPayers" ? do
+    backgroundColor Color.mossGreen
+    borderRadius (px 5) (px 5) (px 5) (px 5)
+    color Color.white
+    lineHeight (px Constants.inputHeight)
+    paddingLeft (px 10)
+    paddingRight (px 10)
     marginBottom (em 1)
 
-    ".exceedingPayers" ? do
-      backgroundColor Color.mossGreen
-      borderRadius (px 5) (px 5) (px 5) (px 5)
-      color Color.white
-      lineHeight (px Constants.inputHeight)
-      paddingLeft (px 10)
-      paddingRight (px 10)
+    Media.mobile $ do
+      textAlign (alignSide sideCenter)
 
-      Media.tabletDesktop $ do
-        "flex-grow" -: "1"
-        marginRight (px 15)
+    ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
 
-      Media.mobile $ do
-        marginBottom (em 1)
-        textAlign (alignSide sideCenter)
-
-      ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
-
-      ".userName" ? marginRight (px 8)
+    ".userName" ? marginRight (px 8)
 
-    ".addPayment" ? do
-      Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
-      Media.mobile $ width (pct 100)
+  -- ".addPayment" ? do
+  --   Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+  --   Media.mobile $ width (pct 100)
 
-  ".searchLine" ? do
+  ".g-HeaderForm" ? do
     marginBottom (em 1)
     Media.mobile $ textAlign (alignSide sideCenter)
 
@@ -62,7 +53,7 @@ design = do
     ".selectInput" ? do
       Media.tabletDesktop $ display inlineBlock
 
-  ".infos" ? do
+  ".g-HeaderInfos__Repartition" ? do
     Media.tabletDesktop $ lineHeight (px Constants.inputHeight)
     Media.mobile $ lineHeight (px 25)
 
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
deleted file mode 100644
index 2028c1b..0000000
--- a/server/src/Design/View/Payment/Pages.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module Design.View.Payment.Pages
-  ( design
-  ) where
-
-import           Clay
-
-import qualified Design.Color     as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper    as Helper
-import qualified Design.Media     as Media
-
-design :: Css
-design = do
-  display flex
-  justifyContent center
-
-  Media.desktop $ do
-    padding (px 40) (px 30) (px 30) (px 30)
-
-  Media.tablet $ do
-    padding (px 30) (px 30) (px 30) (px 30)
-
-  Media.mobile $ do
-    padding (px 20) (px 0) (px 20) (px 0)
-    lineHeight (px 40)
-
-  svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
-
-  ".page" ? do
-    display inlineBlock
-    fontWeight bold
-
-    Media.desktop $ do
-      Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken
-
-    Media.tabletDesktop $ do
-      border solid (px 2) Color.dustyGray
-      marginRight (px 10)
-
-    Media.tablet $ do
-      Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken
-      fontSize (px 15)
-
-    Media.mobile $ do
-      Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken
-      fontSize (px 12)
-      border solid (px 1) Color.dustyGray
-      marginRight (px 5)
-
-    ":not(.current)" & cursor pointer
-
-    ".current" & do
-      borderColor Color.chestnutRose
-      color Color.chestnutRose
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
deleted file mode 100644
index 67828c9..0000000
--- a/server/src/Design/View/Payment/Table.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Design.View.Payment.Table
-  ( design
-  ) where
-
-import           Clay
-
-import qualified Design.Media as Media
-
-design :: Css
-design = do
-  ".cell" ? do
-    ".name" & do
-      Media.tabletDesktop $ width (pct 30)
-
-    ".cost" & do
-      Media.tabletDesktop $ width (pct 10)
-
-    ".user" & do
-      Media.tabletDesktop $ width (pct 15)
-
-    ".category" & do
-      Media.tabletDesktop $ width (pct 10)
-
-    ".date" & do
-      Media.tabletDesktop $ width (pct 15)
-      Media.desktop $ do
-        ".shortDate" ? display none
-        ".longDate" ? display inline
-      Media.tablet $ do
-        ".shortDate" ? display inline
-        ".longDate" ? display none
-      Media.mobile $ do
-        ".shortDate" ? display none
-        ".longDate" ? display inline
-        marginBottom (em 0.5)
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 5c9e307..d36a728 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -20,7 +20,7 @@ import qualified Design.View.Table         as Table
 design :: Css
 design = do
   header ? Header.design
-  ".payment" ? Payment.design
+  Payment.design
   ".signIn" ? SignIn.design
   ".stat" ? Stat.design
   ".notfound" ? NotFound.design
diff --git a/server/src/Main.hs b/server/src/Main.hs
index a4d8635..5068d10 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -41,9 +41,6 @@ main = do
     S.get "/api/users"$
       User.list
 
-    S.get "/api/deprecated/payments" $
-      Payment.deprecatedList
-
     S.get "/api/payments" $ do
       page <- S.param "page"
       perPage <- S.param "perPage"
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index e01753f..7835c98 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -89,11 +89,14 @@ firstPunctualDay =
         (Only (FrequencyField Punctual))
   )
 
-listActive :: Query [Payment]
-listActive =
+listActive :: Frequency -> Query [Payment]
+listActive frequency =
   Query (\conn -> do
     map (\(Row p) -> p) <$>
-      SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
+      SQLite.query
+        conn
+        "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?"
+        (Only (FrequencyField frequency))
   )
 
 listActivePage :: Int -> Int -> Query [Payment]
@@ -102,8 +105,16 @@ listActivePage page perPage =
     map (\(Row p) -> p) <$>
       SQLite.query
         conn
-        "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?"
-        (perPage, (page - 1) * perPage)
+        (SQLite.Query $ T.intercalate " "
+          [ "SELECT *"
+          , "FROM payment"
+          , "WHERE deleted_at IS NULL AND frequency = ?"
+          , "ORDER BY date DESC"
+          , "LIMIT ?"
+          , "OFFSET ?"
+          ]
+        )
+        (FrequencyField Punctual, perPage, (page - 1) * perPage)
   )
 
 listPunctual :: Query [Payment]
diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs
new file mode 100644
index 0000000..4e22ba8
--- /dev/null
+++ b/server/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)