diff options
24 files changed, 346 insertions, 434 deletions
diff --git a/client/client.cabal b/client/client.cabal index 75c2c1b..78ea7d3 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -61,7 +61,6 @@ Executable client Util.Ajax Util.Css Util.Either - Util.List Util.Reflex Util.Router Util.Validation @@ -76,8 +75,8 @@ Executable client View.Income.Table View.NotFound View.Payment.Form - View.Payment.Header - View.Payment.Init + View.Payment.HeaderForm + View.Payment.HeaderInfos View.Payment.Payment View.Payment.Reducer View.Payment.Table diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs deleted file mode 100644 index c8ca347..0000000 --- a/client/src/View/Payment/Header.hs +++ /dev/null @@ -1,187 +0,0 @@ -module View.Payment.Header - ( view - , In(..) - , Out(..) - ) where - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L hiding (groupBy) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import qualified Data.Time as Time -import qualified Data.Validation as V -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format - -import qualified Component.Button as Button -import qualified Component.Input as Input -import qualified Component.Modal as Modal -import qualified Component.Select as Select -import qualified Util.List as L -import qualified View.Payment.Form as Form -import View.Payment.Init (Init (..)) - -data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_payments :: Dynamic t [Payment] - , _in_searchPayments :: Dynamic t [Payment] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - } - -data Out t = Out - { _out_searchName :: Dynamic t Text - , _out_searchFrequency :: Dynamic t Frequency - , _out_addPayment :: Event t SavedPayment - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = - R.divClass "header" $ do - rec - addPayment <- - payerAndAdd - incomes - payments - users - categories - paymentCategories - currency - searchFrequency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_in_searchPayments input) users currency - - return $ Out - { _out_searchName = searchName - , _out_searchFrequency = searchFrequency - , _out_addPayment = addPayment - } - where - init = _in_init input - incomes = _init_incomes init - initPayments = _init_payments init - payments = _in_payments input - users = _init_users init - categories = _init_categories init - currency = _in_currency input - paymentCategories = _in_paymentCategories input - -payerAndAdd - :: forall t m. MonadWidget t m - => [Income] - -> Dynamic t [Payment] - -> [User] - -> [Category] - -> Dynamic t [PaymentCategory] - -> Currency - -> Dynamic t Frequency - -> m (Event t SavedPayment) -payerAndAdd incomes payments users categories paymentCategories currency frequency = do - time <- liftIO Time.getCurrentTime - R.divClass "payerAndAdd" $ do - - let exceedingPayers = - R.ffor payments $ \ps -> - CM.getExceedingPayers time users incomes $ - filter ((==) Punctual . _payment_frequency) ps - - R.divClass "exceedingPayers" $ - R.simpleList exceedingPayers $ \exceedingPayer -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.dynText . R.ffor exceedingPayer $ \ep -> - fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users - R.elClass "span" "amount" $ do - R.text "+ " - R.dynText . R.ffor exceedingPayer $ \ep -> - Format.price currency $ _exceedingPayer_amount ep - - addPayment <- Button._out_clic <$> - (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) - { Button._in_class = R.constDyn "addPayment" - }) - - Modal.view $ Modal.In - { Modal._in_show = addPayment - , Modal._in_content = \_ -> return (R.never, R.never) -- TODO - } - -searchLine - :: forall t m. MonadWidget t m - => Event t () - -> m (Dynamic t Text, Dynamic t Frequency) -searchLine reset = do - R.divClass "searchLine" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ reset) - R.never) - - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) - - return (searchName, searchFrequency) - -infos - :: forall t m. MonadWidget t m - => Dynamic t [Payment] - -> [User] - -> Currency -> m () -infos payments users currency = - R.divClass "infos" $ do - - R.elClass "span" "total" $ do - R.dynText $ do - ps <- payments - let paymentCount = length ps - total = sum . map _payment_cost $ ps - pure . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - - R.elClass "span" "partition" . R.dynText $ do - ps <- payments - let totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ ps - pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..07a6b81 --- /dev/null +++ b/client/src/View/Payment/HeaderForm.hs @@ -0,0 +1,78 @@ +module View.Payment.HeaderForm + ( view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, Currency, ExceedingPayer (..), + Frequency (..), Income (..), Payment (..), + PaymentCategory, SavedPayment (..), + User (..)) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.Select as Select +import qualified View.Payment.Form as Form + +data In t = In + { _in_reset :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: [PaymentCategory] + } + +data Out = Out + { _out_name :: Event t Text + , _out_frequency :: Event t Frequency + , _out_addPayment :: Event t SavedPayment + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + R.divClass "g-HeaderForm" $ do + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + addPaymentButton <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" + }) + + addPayment <- Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.New searchFrequency + } + } + + return $ Out + { _out_name = searchName + , _out_frequency = searchFrequency + , _out_addPayment = addPayment + } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..12facc4 --- /dev/null +++ b/client/src/View/Payment/HeaderInfos.hs @@ -0,0 +1,96 @@ +module View.Payment.HeaderInfos + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, ExceedingPayer (..), + Payment (..), PaymentHeader (..), + SavedPayment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data In t = In + { _in_users :: [User] + , _in_currency :: Currency + , _in_header :: PaymentHeader + , _in_paymentCount :: Int + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = + R.divClass "g-HeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) + + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) + + where + header = _in_header input + +exceedingPayers + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> [ExceedingPayer] + -> m () +exceedingPayers users currency payers = + R.divClass "g-HeaderInfos__ExceedingPayers" $ + flip mapM_ payers $ \payer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text $ + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount payer + +infos + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> Map UserId Int + -> Int + -> m () +infos users currency repartition paymentCount = + R.divClass "g-HeaderInfos__Repartition" $ do + + R.elClass "span" "total" $ do + R.text $ + Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency (M.foldl (+) 0 repartition)) + + R.elClass "span" "partition" . R.text $ + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . M.toList + $ repartition + in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs deleted file mode 100644 index d9f85c8..0000000 --- a/client/src/View/Payment/Init.hs +++ /dev/null @@ -1,13 +0,0 @@ -module View.Payment.Init - ( Init(..) - ) where - -import Common.Model (Category, Income, Payment, PaymentCategory, User) - -data Init = Init - { _init_users :: [User] - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - } deriving (Show) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index bf0186f..f47b627 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,29 +3,29 @@ module View.Payment.Payment , In(..) ) where -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User, UserId) -import qualified Common.Util.Text as T - -import qualified Component.Pages as Pages -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Reducer as Reducer -import qualified View.Payment.Table as Table +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderInfos as HeaderInfos +-- import qualified View.Payment.HeaderForm as HeaderForm +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId @@ -61,7 +61,14 @@ view input = do deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + HeaderInfos.view $ HeaderInfos.In + { HeaderInfos._in_users = _in_users input + , HeaderInfos._in_currency = _in_currency input + , HeaderInfos._in_header = header + , HeaderInfos._in_paymentCount = count + } + table <- Table.view $ Table.In { Table._in_users = _in_users input , Table._in_currentUser = _in_currentUser input diff --git a/common/common.cabal b/common/common.cabal index 4a6d728..75d6cc8 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -59,6 +59,7 @@ Library Common.Model.EditIncome Common.Model.EditIncomeForm Common.Model.EditPaymentForm + Common.Model.ExceedingPayer Common.Model.Frequency Common.Model.Income Common.Model.IncomeHeader @@ -67,4 +68,5 @@ Library Common.Model.InitResult Common.Model.Payer Common.Model.PaymentCategory + Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index bc626d5..fdeac36 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -10,6 +10,7 @@ import Common.Model.EditIncome as X import Common.Model.EditIncomeForm as X import Common.Model.EditPaymentForm as X import Common.Model.Email as X +import Common.Model.ExceedingPayer as X import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.IncomeHeader as X @@ -19,6 +20,7 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X +import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X import Common.Model.SavedPayment as X import Common.Model.SignInForm as X diff --git a/common/src/Common/Model/ExceedingPayer.hs b/common/src/Common/Model/ExceedingPayer.hs new file mode 100644 index 0000000..171b6ff --- /dev/null +++ b/common/src/Common/Model/ExceedingPayer.hs @@ -0,0 +1,16 @@ +module Common.Model.ExceedingPayer + ( ExceedingPayer(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Show, Generic) + +instance FromJSON ExceedingPayer +instance ToJSON ExceedingPayer diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs index 3c816c8..39a5788 100644 --- a/common/src/Common/Model/Payer.hs +++ b/common/src/Common/Model/Payer.hs @@ -1,19 +1,19 @@ module Common.Model.Payer - ( ExceedingPayer(..) - , getExceedingPayers + ( getExceedingPayers , useIncomesFrom , cumulativeIncomesSince ) where -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 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 (..)) -import Common.Model.User (User (..), UserId) +import Common.Model.ExceedingPayer (ExceedingPayer (..)) +import Common.Model.Income (Income (..)) +import Common.Model.Payment (Payment (..)) +import Common.Model.User (User (..), UserId) data Payer = Payer { _payer_userId :: UserId @@ -29,11 +29,6 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -data ExceedingPayer = ExceedingPayer - { _exceedingPayer_userId :: UserId - , _exceedingPayer_amount :: Int - } deriving (Show) - getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] getExceedingPayers currentTime users incomes payments = let userIds = map _user_id users diff --git a/common/src/Common/Model/PaymentHeader.hs b/common/src/Common/Model/PaymentHeader.hs new file mode 100644 index 0000000..a522cd8 --- /dev/null +++ b/common/src/Common/Model/PaymentHeader.hs @@ -0,0 +1,18 @@ +module Common.Model.PaymentHeader + ( PaymentHeader(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import GHC.Generics (Generic) + +import Common.Model.ExceedingPayer (ExceedingPayer) +import Common.Model.User (UserId) + +data PaymentHeader = PaymentHeader + { _paymentHeader_exceedingPayers :: [ExceedingPayer] + , _paymentHeader_repartition :: Map UserId Int + } deriving (Show, Generic) + +instance FromJSON PaymentHeader +instance ToJSON PaymentHeader diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 31039c7..76c7511 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -7,9 +7,11 @@ import GHC.Generics (Generic) import Common.Model.Payment (Payment) import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage - { _paymentPage_payments :: [Payment] + { _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] , _paymentPage_paymentCategories :: [PaymentCategory] , _paymentPage_totalCount :: Int } deriving (Show, Generic) 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) |