From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Nov 2019 07:59:41 +0100 Subject: Show payment header infos --- server/server.cabal | 5 +-- server/src/Controller/Payment.hs | 54 ++++++++++++++++++++++---------- server/src/Design/Modal.hs | 8 ++--- server/src/Design/View/Payment.hs | 6 +--- server/src/Design/View/Payment/Delete.hs | 35 --------------------- server/src/Design/View/Payment/Header.hs | 45 +++++++++++--------------- server/src/Design/View/Payment/Pages.hs | 54 -------------------------------- server/src/Design/View/Payment/Table.hs | 35 --------------------- server/src/Design/Views.hs | 2 +- server/src/Main.hs | 3 -- server/src/Persistence/Payment.hs | 21 ++++++++++--- server/src/Util/List.hs | 13 ++++++++ 12 files changed, 89 insertions(+), 192 deletions(-) delete mode 100644 server/src/Design/View/Payment/Delete.hs delete mode 100644 server/src/Design/View/Payment/Pages.hs delete mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Util/List.hs (limited to 'server') diff --git a/server/server.cabal b/server/server.cabal index b170a18..b4d9e08 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -80,12 +80,8 @@ Executable server Design.View.NotFound Design.View.Pages Design.View.Payment - Design.View.Payment.Add - Design.View.Payment.Delete Design.View.Payment.Form Design.View.Payment.Header - Design.View.Payment.Pages - Design.View.Payment.Table Design.View.SignIn Design.View.Stat Design.View.Table @@ -117,6 +113,7 @@ Executable server Resource Secure SendMail + Util.List Util.Time Validation.Income Validation.Payment 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) -- cgit v1.2.3