diff options
39 files changed, 636 insertions, 722 deletions
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index f57b99c..2b9008a 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -16,6 +16,7 @@ data Loadable t = Loading | Error Text | Loaded t + deriving Show instance Functor Loadable where fmap f Loading = Loading @@ -46,6 +47,6 @@ fromEvent = Loading view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) -view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing +view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing view _ (Error e) = R.text e >> return Nothing view f (Loaded x) = Just <$> f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 47f4f3c..dc56701 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -16,6 +16,7 @@ import qualified Data.Map.Lazy as LM import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Time.Clock (NominalDiffTime) import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, XhrRequest, XhrRequestConfig (..), XhrResponse, @@ -28,7 +29,9 @@ import qualified Loadable getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) getNow url = do postBuild <- R.getPostBuild - get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent + get (url <$ postBuild) + >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise + >>= Loadable.fromEvent get :: forall t m a. (MonadWidget t m, FromJSON a) diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs index 2910d95..e76bc8a 100644 --- a/client/src/Util/Either.hs +++ b/client/src/Util/Either.hs @@ -2,6 +2,6 @@ module Util.Either ( eitherToMaybe ) where -eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe :: forall a b. Either a b -> Maybe b eitherToMaybe (Right b) = Just b eitherToMaybe _ = Nothing diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/client/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -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) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99b0848..6c3c1e8 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -4,6 +4,7 @@ module View.Payment.Form , Operation(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value) import qualified Data.Aeson as Aeson @@ -13,6 +14,7 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Clock @@ -25,9 +27,7 @@ import qualified Text.Read as T import Common.Model (Category (..), CategoryId, CreatePaymentForm (..), EditPaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation @@ -37,20 +37,20 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil -data In = In - { _in_categories :: [Category] - , _in_paymentCategories :: [PaymentCategory] - , _in_operation :: Operation +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t } -data Operation - = New Frequency +data Operation t + = New (Dynamic t Frequency) | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment view input cancel = do rec let reset = R.leftmost @@ -105,9 +105,10 @@ view input cancel = do (d <$ reset) confirm) - let setCategory = - R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) findCategory + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category @@ -124,12 +125,13 @@ view input cancel = do c <- cost d <- date cat <- category + f <- frequency return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success frequency) + <*> V.Success f) frequencies = M.fromList @@ -140,6 +142,12 @@ view input cancel = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) + category = + case op of + New _ -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + op = _in_operation input name = @@ -162,17 +170,11 @@ view input cancel = do Clone p -> currentDay Edit p -> _payment_date p - category = - case op of - New _ -> -1 - Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - frequency = case op of New f -> f - Clone p -> _payment_frequency p - Edit p -> _payment_frequency p + Clone p -> R.constDyn $ _payment_frequency p + Edit p -> R.constDyn $ _payment_frequency p headerLabel = case op of @@ -189,9 +191,3 @@ view input cancel = do case op of Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e - - findCategory :: Text -> Maybe CategoryId - findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) - $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 07a6b81..c8ca4d9 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -1,5 +1,7 @@ module View.Payment.HeaderForm ( view + , In(..) + , Out(..) ) where import qualified Data.Map as M @@ -8,10 +10,8 @@ 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 Common.Model (Category, Currency, Frequency (..), + Income (..), Payment (..), User (..)) import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -21,39 +21,43 @@ 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] + { _in_reset :: Event t () + , _in_categories :: [Category] } -data Out = Out - { _out_name :: Event t Text +data Out t = Out + { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t SavedPayment + , _out_addPayment :: Event t Payment } 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) +view input = + R.divClass "g-PaymentHeaderForm" $ do - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] + (searchName, frequency) <- R.el "div" $ do - 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 - }) + 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) + ] + + frequency <- 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, frequency) addPaymentButton <- Button._out_clic <$> (Button.view $ @@ -66,13 +70,12 @@ view input = do , 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 + , Form._in_operation = Form.New frequency } } return $ Out - { _out_name = searchName - , _out_frequency = searchFrequency + { _out_search = R.updated searchName + , _out_frequency = R.updated frequency , _out_addPayment = addPayment } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs index 12facc4..f84ee1f 100644 --- a/client/src/View/Payment/HeaderInfos.hs +++ b/client/src/View/Payment/HeaderInfos.hs @@ -16,13 +16,11 @@ import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Payment (..), PaymentHeader (..), - SavedPayment (..), User (..), UserId) + 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 @@ -32,17 +30,17 @@ data In t = In 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) + R.divClass "g-PaymentHeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) - infos - (_in_users input) - (_in_currency input) - (_paymentHeader_repartition header) - (_in_paymentCount input) + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) where header = _in_header input @@ -54,7 +52,7 @@ exceedingPayers -> [ExceedingPayer] -> m () exceedingPayers users currency payers = - R.divClass "g-HeaderInfos__ExceedingPayers" $ + R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $ flip mapM_ payers $ \payer -> R.elClass "span" "exceedingPayer" $ do R.elClass "span" "userName" $ @@ -72,7 +70,7 @@ infos -> Int -> m () infos users currency repartition paymentCount = - R.divClass "g-HeaderInfos__Repartition" $ do + R.divClass "g-PaymentHeaderInfos__Repartition" $ do R.elClass "span" "total" $ do R.text $ diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index f47b627..6bc1614 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,6 +3,7 @@ module View.Payment.Payment , In(..) ) where +import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -12,9 +13,8 @@ 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) + Payment (..), PaymentId, + PaymentPage (..), User, UserId) import qualified Common.Util.Text as T import qualified Component.Pages as Pages @@ -22,8 +22,8 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderForm as HeaderForm 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 @@ -36,15 +36,16 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categoriesEvent <- (AjaxUtil.getNow "api/categories") + categories <- AjaxUtil.getNow "api/categories" - R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec payments <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage - , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + { Reducer._in_page = page + , Reducer._in_search = HeaderForm._out_search form + , Reducer._in_frequency = HeaderForm._out_frequency form + , Reducer._in_addPayment = addPayment , Reducer._in_editPayment = editPayment , Reducer._in_deletePayment = deletePayment } @@ -52,16 +53,25 @@ view input = do let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - currentPage <- R.holdDyn 1 newPage - -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) - let headerAddPayment = R.never + let addPayment = + R.leftmost + [ tableAddPayment + , HeaderForm._out_addPayment form + ] + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + form <- HeaderForm.view $ HeaderForm.In + { HeaderForm._in_reset = () <$ addPayment + , HeaderForm._in_categories = categories + } + + result <- R.dyn . R.ffor payments $ + Loadable.view $ \(PaymentPage page header payments count) -> do + HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input , HeaderInfos._in_currency = _in_currency input @@ -75,13 +85,12 @@ view input = do , Table._in_categories = categories , Table._in_currency = _in_currency input , Table._in_payments = payments - , Table._in_paymentCategories = paymentCategories } pages <- Pages.view $ Pages.In { Pages._in_total = R.constDyn count , Pages._in_perPage = Reducer.perPage - , Pages._in_page = p + , Pages._in_page = page } return ((), table, pages) @@ -89,137 +98,3 @@ view input = do return () return () - - --- view :: forall t m. MonadWidget t m => In t -> m () --- view input = do --- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> --- --- R.elClass "main" "payment" $ do --- rec --- let addPayment = R.leftmost --- -- [ Header._out_addPayment header --- [ Table2._out_addPayment table --- ] --- --- paymentsPerPage = 7 --- --- payments <- reducePayments --- (_init_payments init) --- (_savedPayment_payment <$> addPayment) --- (_savedPayment_payment <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- paymentCategories <- reducePaymentCategories --- (_init_paymentCategories init) --- payments --- (_savedPayment_paymentCategory <$> addPayment) --- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- -- (searchNameEvent, searchName) <- --- -- debounceSearchName (Header._out_searchName header) --- --- -- let searchPayments = --- -- getSearchPayments searchName (Header._out_searchFrequency header) payments --- --- -- header <- Header.view $ Header.In --- -- { Header._in_init = init --- -- , Header._in_currency = _in_currency input --- -- , Header._in_payments = payments --- -- , Header._in_searchPayments = searchPayments --- -- , Header._in_paymentCategories = paymentCategories --- -- } --- --- table <- Table2.view $ Table2.In --- { Table2._in_init = init --- , Table2._in_currency = _in_currency input --- , Table2._in_currentUser = _in_currentUser input --- , Table2._in_currentPage = Pages2._out_currentPage pages --- , Table2._in_payments = payments --- , Table2._in_perPage = paymentsPerPage --- , Table2._in_paymentCategories = paymentCategories --- } --- --- pages <- Pages2.view $ Pages2.In --- { Pages2._in_total = length <$> payments --- , Pages2._in_perPage = paymentsPerPage --- , Pages2._in_reset = R.never --- -- [ () <$ searchNameEvent --- -- [ () <$ Header._out_addPayment header --- -- ] --- } --- --- pure () --- --- return () --- --- -- debounceSearchName --- -- :: forall t m. MonadWidget t m --- -- => Dynamic t Text --- -- -> m (Event t Text, Dynamic t Text) --- -- debounceSearchName searchName = do --- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) --- -- dynamic <- R.holdDyn "" event --- -- return (event, dynamic) --- --- reducePayments --- :: forall t m. MonadWidget t m --- => [Payment] --- -> Event t Payment -- add payment --- -> Event t Payment -- edit payment --- -> Event t Payment -- delete payment --- -> m (Dynamic t [Payment]) --- reducePayments initPayments addPayment editPayment deletePayment = --- R.foldDyn id initPayments $ R.leftmost --- [ (:) <$> addPayment --- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) --- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) --- ] --- --- reducePaymentCategories --- :: forall t m. MonadWidget t m --- => [PaymentCategory] --- -> Dynamic t [Payment] -- payments --- -> Event t PaymentCategory -- add payment category --- -> Event t PaymentCategory -- edit payment category --- -> Event t Payment -- delete payment --- -> m (Dynamic t [PaymentCategory]) --- reducePaymentCategories --- initPaymentCategories --- payments --- addPaymentCategory --- editPaymentCategory --- deletePayment --- = --- R.foldDyn id initPaymentCategories $ R.leftmost --- [ (:) <$> addPaymentCategory --- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) --- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) --- ] --- where --- deletePaymentName = --- R.attachWithMaybe --- (\ps p -> --- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then --- Nothing --- else --- Just (_payment_name p)) --- (R.current payments) --- deletePayment --- lowerName = T.toLower . _payment_name --- --- -- getSearchPayments --- -- :: forall t. Reflex t --- -- => Dynamic t Text --- -- -> Dynamic t Frequency --- -- -> Dynamic t [Payment] --- -- -> Dynamic t [Payment] --- -- getSearchPayments name frequency payments = do --- -- n <- name --- -- f <- frequency --- -- ps <- payments --- -- pure $ flip filter ps (\p -> --- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) --- -- && (_payment_frequency p == f) --- -- )) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0c70f8a..0b6c041 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -2,14 +2,16 @@ module View.Payment.Reducer ( perPage , reducer , In(..) + , Params(..) ) where import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (PaymentPage) +import Common.Model (Frequency (..), PaymentPage) import Loadable (Loadable (..)) import qualified Loadable as Loadable @@ -19,48 +21,99 @@ perPage :: Int perPage = 7 data In t a b c = In - { _in_newPage :: Event t Int - , _in_currentPage :: Dynamic t Int + { _in_page :: Event t Int + , _in_search :: Event t Text + , _in_frequency :: Event t Frequency , _in_addPayment :: Event t a , _in_editPayment :: Event t b , _in_deletePayment :: Event t c } data Action - = LoadPage Int + = LoadPage | GetResult (Either Text PaymentPage) +data Params = Params + { _params_page :: Int + , _params_search :: Text + , _params_frequency :: Frequency + } deriving (Show) + +initParams = Params 1 "" Punctual + +data Msg + = Page Int + | Search Text + | Frequency Common.Model.Frequency + | ResetSearch + deriving Show + reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) reducer input = do postBuild <- R.getPostBuild - let loadPage = + debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input) + + params <- R.foldDynMaybe + (\msg params -> case msg of + Page page -> + Just $ params { _params_page = page } + + Search "" -> + if _params_search params == "" then + Nothing + + else + Just $ initParams { _params_frequency = _params_frequency params } + + Search search -> + Just $ params { _params_search = search, _params_page = _params_page initParams } + + Frequency frequency -> + Just $ params { _params_frequency = frequency } + + ResetSearch -> + Just $ initParams { _params_frequency = _params_frequency params } + ) + initParams + (R.leftmost + [ Page <$> _in_page input + , Search <$> debouncedSearch + , Frequency <$> _in_frequency input + , ResetSearch <$ _in_addPayment input + ]) + + let paramsEvent = R.leftmost - [ 1 <$ postBuild - , _in_newPage input - , 1 <$ _in_addPayment input - , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) - , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + [ initParams <$ postBuild + , R.updated params + , R.tag (R.current params) (_in_editPayment input) + , R.tag (R.current params) (_in_deletePayment input) ] - getResult <- AjaxUtil.get $ fmap pageUrl loadPage + getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) + R.foldDyn (\action _ -> case action of - LoadPage _ -> Loading + LoadPage -> Loading GetResult (Left err) -> Error err GetResult (Right payments) -> Loaded payments ) Loading (R.leftmost - [ LoadPage <$> loadPage + [ LoadPage <$ paramsEvent , GetResult <$> getResult ]) where - pageUrl p = + pageUrl (Params page search frequency) = "api/payments?page=" - <> (T.pack . show $ p) + <> (T.pack . show $ page) <> "&perPage=" <> (T.pack . show $ perPage) + <> "&search=" + <> search + <> "&frequency=" + <> (T.pack $ show frequency) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index dde5168..59ac890 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,7 +13,6 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Currency, Payment (..), - PaymentCategory (..), SavedPayment, User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,17 +25,16 @@ import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form data In t = In - { _in_users :: [User] - , _in_currentUser :: UserId - , _in_categories :: [Category] - , _in_currency :: Currency - , _in_payments :: [Payment] - , _in_paymentCategories :: [PaymentCategory] + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] } data Out t = Out - { _out_add :: Event t SavedPayment - , _out_edit :: Event t SavedPayment + { _out_add :: Event t Payment + , _out_edit :: Event t Payment , _out_delete :: Event t Payment } @@ -50,18 +48,15 @@ view input = do cell (_in_users input) (_in_categories input) - (_in_paymentCategories input) (_in_currency input) , Table._in_cloneModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Clone payment } , Table._in_editModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Edit payment } , Table._in_deleteModal = \payment -> @@ -101,12 +96,11 @@ cell :: forall t m. MonadWidget t m => [User] -> [Category] - -> [PaymentCategory] -> Currency -> Header -> Payment -> m () -cell users categories paymentCategories currency header payment = +cell users categories currency header payment = case header of NameHeader -> R.text $ _payment_name payment @@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment = CategoryHeader -> let category = - findCategory categories paymentCategories (_payment_name payment) + L.find ((== (_payment_category payment)) . _category_id) categories attrs = case category of @@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment = R.elClass "span" "longDate" $ R.text . Format.longDay . _payment_date $ payment - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== T.toLower paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/common/common.cabal b/common/common.cabal index 75d6cc8..17a0ee1 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -35,7 +35,6 @@ Library Common.Model.CreatePaymentForm Common.Model.Email Common.Model.Payment - Common.Model.SavedPayment Common.Model.SignInForm Common.Model.User Common.Msg @@ -66,7 +65,5 @@ Library Common.Model.IncomePage Common.Model.Init Common.Model.InitResult - Common.Model.Payer - Common.Model.PaymentCategory Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 25e9f4b..a86a371 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -702,7 +702,7 @@ m l WeeklyReport_Title = m l NotFound_Message = case l of English -> "There is nothing here!" - French -> "Vous vous êtes perdu." + French -> "Il n’y a rien à voir ici." m l NotFound_LinkMessage = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index fdeac36..00d30f6 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -17,11 +17,8 @@ import Common.Model.IncomeHeader as X import Common.Model.IncomePage as X import Common.Model.Init as X 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 import Common.Model.User as X diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 37a090d..c232fc7 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -10,6 +10,7 @@ import Data.Time (UTCTime) import Data.Time.Calendar (Day) import GHC.Generics (Generic) +import Common.Model.Category (CategoryId) import Common.Model.Frequency import Common.Model.User (UserId) @@ -21,6 +22,7 @@ data Payment = Payment , _payment_name :: Text , _payment_cost :: Int , _payment_date :: Day + , _payment_category :: CategoryId , _payment_frequency :: Frequency , _payment_createdAt :: UTCTime , _payment_editedAt :: Maybe UTCTime diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs deleted file mode 100644 index 2a559ce..0000000 --- a/common/src/Common/Model/PaymentCategory.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 76c7511..3b18bb6 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -2,18 +2,17 @@ module Common.Model.PaymentPage ( PaymentPage(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.PaymentHeader (PaymentHeader) +import Common.Model.Payment (Payment) +import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage - { _paymentPage_header :: PaymentHeader - , _paymentPage_payments :: [Payment] - , _paymentPage_paymentCategories :: [PaymentCategory] - , _paymentPage_totalCount :: Int + { _paymentPage_page :: Int + , _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] + , _paymentPage_totalCount :: Int } deriving (Show, Generic) instance FromJSON PaymentPage diff --git a/common/src/Common/Model/SavedPayment.hs b/common/src/Common/Model/SavedPayment.hs deleted file mode 100644 index f45c479..0000000 --- a/common/src/Common/Model/SavedPayment.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.SavedPayment - ( SavedPayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) - -data SavedPayment = SavedPayment - { _savedPayment_payment :: Payment - , _savedPayment_paymentCategory :: PaymentCategory - } deriving (Show, Generic) - -instance FromJSON SavedPayment -instance ToJSON SavedPayment diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index d7f1db4..0f9c187 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,6 +1,7 @@ module Common.Util.Text ( search , formatSearch + , unaccent ) where import Data.Text (Text) diff --git a/default.nix b/default.nix index 977af02..7969fc7 100644 --- a/default.nix +++ b/default.nix @@ -4,6 +4,8 @@ let reflex-platform = import (pkgs.fetchFromGitHub { owner = "reflex-frp"; repo = "reflex-platform"; + + # Mon Jul 29 15:48:55 2019 -0400 rev = "51e02339704b7502e63bccf10a72fa4dda744b17"; sha256 = "1mkimidf755968xzbm3z222xgpdvgg6xmmrfppv1hw0rap5w53iw"; }) {}; diff --git a/server/migrations/2.sql b/server/migrations/2.sql index 1c829ec..efed046 100644 --- a/server/migrations/2.sql +++ b/server/migrations/2.sql @@ -21,3 +21,24 @@ DELETE FROM payment_category WHERE name NOT IN (SELECT DISTINCT lower(name) FROM payment); + +-- Add category id to payment table + +PRAGMA foreign_keys = 0; + +ALTER TABLE payment ADD COLUMN "category" INTEGER NOT NULL REFERENCES "category" DEFAULT -1; + +PRAGMA foreign_keys = 1; + +UPDATE + payment +SET + category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) +WHERE + EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) + +DELETE FROM payment WHERE category = -1; + +-- Remove + +DROP TABLE payment_category diff --git a/server/server.cabal b/server/server.cabal index b4d9e08..7056b3f 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -81,7 +81,8 @@ Executable server Design.View.Pages Design.View.Payment Design.View.Payment.Form - Design.View.Payment.Header + Design.View.Payment.HeaderForm + Design.View.Payment.HeaderInfos Design.View.SignIn Design.View.Stat Design.View.Table @@ -104,16 +105,15 @@ Executable server Model.Query Model.SignIn Model.UUID + Payer Persistence.Category Persistence.Frequency Persistence.Income Persistence.Payment - Persistence.PaymentCategory Persistence.User Resource Secure SendMail - Util.List Util.Time Validation.Income Validation.Payment diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index e536caa..8fbc8c8 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -5,19 +5,18 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty hiding (delete) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) -import qualified Common.Msg as Msg +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) +import qualified Common.Msg as Msg -import Json (jsonId) -import qualified Model.Query as Query -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Secure list :: ActionM () @@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId - if null paymentCategories - then CategoryPersistence.delete categoryId - else return False + -- TODO: delete only if no payment has this category + CategoryPersistence.delete categoryId if deleted then status ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 127e3b3..75d0133 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,6 +1,5 @@ module Controller.Income ( list - , deprecatedList , create , edit , delete @@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), Income (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) -import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query +import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -37,18 +36,18 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - firstPayment <- PaymentPersistence.firstPunctualDay - allIncomes <- IncomePersistence.listAll + paymentRange <- PaymentPersistence.getRange + allIncomes <- IncomePersistence.listAll -- TODO optimize let since = - CM.useIncomesFrom (map _user_id users) allIncomes firstPayment + Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) let byUser = case since of Just s -> M.fromList . flip map users $ \user -> ( _user_id user - , CM.cumulativeIncomesSince currentTime s $ + , Payer.cumulativeIncomesSince currentTime s $ filter ((==) (_user_id user) . _income_userId) allIncomes ) @@ -59,12 +58,6 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.listAll) >>= json - ) - create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f685f2e..d4d086e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,75 +1,70 @@ module Controller.Payment ( list - , listPaymentCategories , create , edit , delete + , searchCategory ) 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 (ActionM) -import qualified Web.Scotty as S +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (Category (..), - CreatePaymentForm (..), - EditPaymentForm (..), - 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 Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +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 Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Util.List as L -import qualified Validation.Payment as PaymentValidation +import qualified Validation.Payment as PaymentValidation -list :: Int -> Int -> ActionM () -list page perPage = +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = Secure.loggedAction (\_ -> do currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do - count <- PaymentPersistence.count - payments <- PaymentPersistence.listActivePage page perPage - paymentCategories <- PaymentCategoryPersistence.list + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll - allPayments <- PaymentPersistence.listActive Punctual + incomes <- IncomePersistence.listAll -- TODO optimize + + paymentRange <- PaymentPersistence.getRange + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty - let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - repartition = - M.fromList - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ allPayments + let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers - , _paymentHeader_repartition = repartition + , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage header payments paymentCategories count) >>= S.json - ) - -listPaymentCategories :: ActionM () -listPaymentCategories = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json + return $ PaymentPage page header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -78,10 +73,8 @@ create form = (liftIO . Query.run $ do cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.createPayment cs form of - Success (CreatePayment name cost date category frequency) -> do - pc <- PaymentCategoryPersistence.save name category - p <- PaymentPersistence.create (_user_id user) name cost date frequency - return . Right $ SavedPayment p pc + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -94,14 +87,11 @@ edit form = cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return . Right $ SavedPayment new pc - Nothing -> - return . Left $ Msg.get Msg.Error_PaymentEdit + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + if Maybe.isJust editedPayment then + return . Right $ editedPayment + else + return . Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -109,18 +99,13 @@ edit form = delete :: PaymentId -> ActionM () delete paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ do - payment <- PaymentPersistence.find paymentId - case payment of - Just p | _payment_user p == _user_id user -> do - PaymentPersistence.delete (_user_id user) paymentId - PaymentCategoryPersistence.deleteIfUnused (_payment_name p) - return True - _ -> - return False - if deleted then - S.status Status.ok200 - else - S.status Status.badRequest400 + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json ) diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 506343d..5713bfe 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -77,7 +77,6 @@ design = do backgroundColor transparent ".selectInput" ? do - marginBottom (em 2) ".label" ? do color Color.silver diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 27b4ef3..d563f5d 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,8 +4,10 @@ module Design.View.Payment import Clay -import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.HeaderForm as HeaderForm +import qualified Design.View.Payment.HeaderInfos as HeaderInfos design :: Css design = do - ".g-HeaderInfos" ? Header.design + HeaderForm.design + HeaderInfos.design diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..6081443 --- /dev/null +++ b/server/src/Design/View/Payment/HeaderForm.hs @@ -0,0 +1,40 @@ +module Design.View.Payment.HeaderForm + ( 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 + + ".g-PaymentHeaderForm" ? do + marginBottom (em 2) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + display flex + justifyContent spaceBetween + alignItems center + Media.mobile $ flexDirection column + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock + Media.mobile $ marginBottom (em 2) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + flexShrink 0 diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/HeaderInfos.hs index 49c1a09..acb393b 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/HeaderInfos.hs @@ -1,4 +1,4 @@ -module Design.View.Payment.Header +module Design.View.Payment.HeaderInfos ( design ) where @@ -12,12 +12,14 @@ import qualified Design.Media as Media design :: Css design = do - Media.desktop $ marginBottom (em 2) - Media.mobileTablet $ marginBottom (em 1) - marginLeft (pct Constants.blockPercentMargin) - marginRight (pct Constants.blockPercentMargin) - ".g-HeaderInfos__ExceedingPayers" ? do + ".g-PaymentHeaderInfos" ? do + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + + ".g-PaymentHeaderInfos__ExceedingPayers" ? do backgroundColor Color.mossGreen borderRadius (px 5) (px 5) (px 5) (px 5) color Color.white @@ -33,27 +35,7 @@ design = do ".userName" ? marginRight (px 8) - -- ".addPayment" ? do - -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - -- Media.mobile $ width (pct 100) - - ".g-HeaderForm" ? do - marginBottom (em 1) - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".selectInput" ? do - Media.tabletDesktop $ display inlineBlock - - ".g-HeaderInfos__Repartition" ? do + ".g-PaymentHeaderInfos__Repartition" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) Media.mobile $ lineHeight (px 25) diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 1a478dc..34bbd3a 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do now <- getCurrentTime + case mbLastExecution of - Nothing -> return () + Nothing -> + return () + Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list - _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) + (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + return () + return now diff --git a/server/src/Main.hs b/server/src/Main.hs index 5068d10..f4d75a0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -42,9 +42,15 @@ main = do User.list S.get "/api/payments" $ do + frequency <- S.param "frequency" page <- S.param "page" perPage <- S.param "perPage" - Payment.list page perPage + search <- S.param "search" + Payment.list (read frequency) page perPage search + + S.get "/api/payment/category" $ do + name <- S.param "name" + Payment.searchCategory name S.post "/api/payment" $ S.jsonData >>= Payment.create @@ -61,9 +67,6 @@ main = do perPage <- S.param "perPage" Income.list page perPage - S.get "/api/deprecated/incomes" $ do - Income.deprecatedList - S.post "/api/income" $ S.jsonData >>= Income.create @@ -74,9 +77,6 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/paymentCategories" $ - Payment.listPaymentCategories - S.get "/api/categories" $ Category.list diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 0cc4a03..bcdce61 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -7,7 +7,7 @@ module Model.SignIn ) where import Data.Int (Int64) -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (UTCTime) @@ -47,7 +47,7 @@ createSignInToken signInEmail = getSignIn :: Text -> Query (Maybe SignIn) getSignIn signInToken = Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) ) signInTokenToUsed :: SignInId -> Query () diff --git a/common/src/Common/Model/Payer.hs b/server/src/Payer.hs index 39a5788..d913afe 100644 --- a/common/src/Common/Model/Payer.hs +++ b/server/src/Payer.hs @@ -1,19 +1,19 @@ -module Common.Model.Payer +module Payer ( 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 Data.Map (Map) +import qualified Data.Map as M +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.ExceedingPayer (ExceedingPayer (..)) -import Common.Model.Income (Income (..)) -import Common.Model.Payment (Payment (..)) -import Common.Model.User (User (..), UserId) +import Common.Model (ExceedingPayer (..), Income (..), + User (..), UserId) data Payer = Payer { _payer_userId :: UserId @@ -29,13 +29,12 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] -getExceedingPayers currentTime users incomes payments = +getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] +getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = let userIds = map _user_id users - payers = getPayers userIds incomes payments + payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition exceedingPayersOnPreIncome = exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - firstPayment = safeHead . List.sort . map _payment_date $ payments mbSince = useIncomesFrom userIds incomes firstPayment in case mbSince of Just since -> @@ -60,35 +59,15 @@ useIncomesFrom userIds incomes firstPayment = dayUTCTime :: Day -> UTCTime dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) -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 -> - case incomesDefined of - Just d -> - _payment_date p < d - - Nothing -> - True - ) - userId - payments - , _payer_postIncomePayments = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> _payment_date p >= t - ) - userId - payments - , _payer_incomes = filter ((==) userId . _income_userId) incomes - } - ) +getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition + , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] exceedingPayersFromAmounts userAmounts = @@ -125,9 +104,9 @@ getFinalDiff maxRatio payer = incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day incomeDefinedForAll userIds incomes = let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes + firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes + then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes else Nothing cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int @@ -182,10 +161,6 @@ durationIncome (duration, income) = nominalDay :: NominalDiffTime nominalDay = 86400 -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - safeMinimum :: (Ord a) => [a] -> Maybe a safeMinimum [] = Nothing safeMinimum xs = Just . minimum $ xs @@ -193,10 +168,3 @@ safeMinimum xs = Just . minimum $ xs safeMaximum :: (Ord a) => [a] -> Maybe a safeMaximum [] = Nothing safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 2afe5db..00cf0a5 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -5,7 +5,7 @@ module Persistence.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) @@ -48,9 +48,9 @@ create categoryName categoryColor = edit :: CategoryId -> Text -> Text -> Query Bool edit categoryId categoryName categoryColor = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute @@ -65,9 +65,9 @@ edit categoryId categoryName categoryColor = delete :: CategoryId -> Query Bool delete categoryId = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cb2ef10..ba7ad19 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -2,17 +2,22 @@ module Persistence.Income ( count , list , listAll + , listModifiedSince , create , edit , delete + , definedForAll ) where -import Data.Maybe (listToMaybe) +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id, until) import Common.Model (Income (..), IncomeId, PaymentId, UserId) @@ -31,15 +36,15 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -data Count = Count Int +data CountRow = CountRow Int -instance FromRow Count where - fromRow = Count <$> SQLite.field +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field count :: Query Int count = Query (\conn -> - (\[Count n] -> n) <$> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" ) @@ -60,6 +65,23 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) +listModifiedSince :: UTCTime -> Query [Income] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM income" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) + ) + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do @@ -83,7 +105,7 @@ create userId date amount = edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> + mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> @@ -114,3 +136,26 @@ delete userId paymentId = "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data UserDayRow = UserDayRow (UserId, Day) + +instance FromRow UserDayRow where + fromRow = do + user <- SQLite.field + day <- SQLite.field + return $ UserDayRow (user, day) + +definedForAll :: [UserId] -> Query (Maybe Day) +definedForAll users = + Query (\conn -> + (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$> + SQLite.query_ + conn + "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;" + ) + where + fromRows rows = + if L.sort users == L.sort (map fst rows) then + Maybe.listToMaybe . L.sort . map snd $ rows + else + Nothing diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 7835c98..f75925d 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,33 +1,57 @@ module Persistence.Payment ( count , find - , firstPunctualDay - , listActive + , getRange , listActivePage - , listPunctual + , listModifiedSince , listActiveMonthlyOrderedByName , create , createMany , edit , delete + , searchCategory + , repartition + , getPreAndPostPaymentRepartition ) where -import Data.Maybe (listToMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only), ToRow) import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.ToField (ToField (toField)) -import Prelude hiding (id) +import Prelude hiding (id, until) -import Common.Model (Frequency (..), Payment (..), - PaymentId, UserId) +import Common.Model (CategoryId, Frequency (..), + Payment (..), PaymentId, + User (..), UserId) import Model.Query (Query (Query)) import Persistence.Frequency (FrequencyField (..)) +import qualified Persistence.Income as IncomePersistence + + + +fields :: Text +fields = T.intercalate "," $ + [ "id" + , "user_id" + , "name" + , "cost" + , "date" + , "category" + , "frequency" + , "created_at" + , "edited_at" + , "deleted_at" + ] newtype Row = Row Payment @@ -38,6 +62,7 @@ instance FromRow Row where SQLite.field <*> SQLite.field <*> SQLite.field <*> + SQLite.field <*> (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> SQLite.field <*> SQLite.field <*> @@ -51,6 +76,7 @@ instance ToRow InsertRow where , toField (_payment_name p) , toField (_payment_cost p) , toField (_payment_date p) + , toField (_payment_category p) , toField (FrequencyField (_payment_frequency p)) , toField (_payment_createdAt p) ] @@ -60,73 +86,94 @@ data Count = Count Int instance FromRow Count where fromRow = Count <$> SQLite.field -count :: Query Int -count = +count :: Frequency -> Text -> Query Int +count frequency search = Query (\conn -> (\[Count n] -> n) <$> - SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT COUNT(*)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + ]) + (FrequencyField frequency, "%" <> search <> "%") ) find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do - fmap (\(Row p) -> p) . listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.query + conn + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?") + (Only paymentId) ) -data DayRow = DayRow Day +data RangeRow = RangeRow (Day, Day) -instance FromRow DayRow where - fromRow = DayRow <$> SQLite.field +instance FromRow RangeRow where + fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field -firstPunctualDay :: Query (Maybe Day) -firstPunctualDay = +getRange :: Query (Maybe (Day, Day)) +getRange = Query (\conn -> do - fmap (\(DayRow d) -> d) . listToMaybe <$> + fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1" + (SQLite.Query $ T.intercalate " " + [ "SELECT MIN(date), MAX(date)" + , "FROM payment" + , "WHERE" + , "frequency = ?" + , "AND deleted_at IS NULL" + ]) (Only (FrequencyField Punctual)) ) -listActive :: Frequency -> Query [Payment] -listActive frequency = - Query (\conn -> do - map (\(Row p) -> p) <$> - SQLite.query - conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?" - (Only (FrequencyField frequency)) - ) - -listActivePage :: Int -> Int -> Query [Payment] -listActivePage page perPage = +listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] +listActivePage frequency page perPage search = Query (\conn -> map (\(Row p) -> p) <$> SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" , "ORDER BY date DESC" , "LIMIT ?" , "OFFSET ?" ] ) - (FrequencyField Punctual, perPage, (page - 1) * perPage) + (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage) ) -listPunctual :: Query [Payment] -listPunctual = - Query (\conn -> do - map (\(Row p) -> p) <$> +listModifiedSince :: UTCTime -> Query [Payment] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> SQLite.query conn - (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") - (Only (FrequencyField Punctual)) + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM payment" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) ) + listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = Query (\conn -> do @@ -134,7 +181,8 @@ listActiveMonthlyOrderedByName = SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" , "WHERE deleted_at IS NULL AND frequency = ?" , "ORDER BY name DESC" @@ -142,17 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment -create userId name cost date frequency = +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create userId name cost date category frequency = Query (\conn -> do time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, FrequencyField frequency, time) + (userId, name, cost, date, category, FrequencyField frequency, time) paymentId <- SQLite.lastInsertRowId conn return $ Payment { _payment_id = paymentId @@ -160,6 +208,7 @@ create userId name cost date frequency = , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = time , _payment_editedAt = Nothing @@ -173,19 +222,19 @@ createMany payments = SQLite.executeMany conn (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) -edit userId paymentId name cost date frequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and user_id = ?" + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) case mbPayment of Just payment -> do @@ -200,6 +249,7 @@ edit userId paymentId name cost date frequency = , " name = ?," , " cost = ?," , " date = ?," + , " category = ?," , " frequency = ?" , "WHERE" , " id = ?" @@ -209,16 +259,18 @@ edit userId paymentId name cost date frequency = , name , cost , date + , category , FrequencyField frequency , paymentId , userId ) - return . Just . (,) payment $ Payment + return . Just $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = _payment_createdAt payment , _payment_editedAt = Just now @@ -236,3 +288,59 @@ delete userId paymentId = "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data CategoryIdRow = CategoryIdRow CategoryId + +instance FromRow CategoryIdRow where + fromRow = CategoryIdRow <$> SQLite.field + +searchCategory :: Text -> Query (Maybe CategoryId) +searchCategory paymentName = + Query (\conn -> + fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> + SQLite.query + conn + "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (Only $ "%" <> paymentName <> "%") + ) + +data UserCostRow = UserCostRow (UserId, Int) + +instance FromRow UserCostRow where + fromRow = do + user <- SQLite.field + cost <- SQLite.field + return $ UserCostRow (user, cost) + +repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) +repartition frequency search from to = + Query (\conn -> + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT user_id, SUM(cost)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + , "AND date >= ?" + , "AND date < ?" + , "GROUP BY user_id" + ]) + (FrequencyField frequency, "%" <> search <> "%", from, to) + ) + +getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) +getPreAndPostPaymentRepartition paymentRange users = do + case paymentRange of + Just (from, to) -> do + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + (,) + <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll)) + <*> (case incomeDefinedForAll of + Just d -> repartition Punctual "" d (Calendar.addDays 1 to) + Nothing -> return M.empty) + + Nothing -> + return (M.empty, M.empty) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs deleted file mode 100644 index 46be7f5..0000000 --- a/server/src/Persistence/PaymentCategory.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Persistence.PaymentCategory - ( list - , listByCategory - , save - , deleteIfUnused - ) where - -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) - -import Model.Query (Query (Query)) - -newtype Row = Row PaymentCategory - -instance FromRow Row where - fromRow = Row <$> (PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field) - -list :: Query [PaymentCategory] -list = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query_ conn "SELECT * from payment_category" - ) - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query PaymentCategory -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only formattedNewName)) - case paymentCategory of - Just pc -> - do - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formattedNewName) - return $ PaymentCategory - (_paymentCategory_id pc) - formattedNewName - categoryId - (_paymentCategory_createdAt pc) - (Just now) - Nothing -> - do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formattedNewName, categoryId, now) - paymentCategoryId <- SQLite.lastInsertRowId conn - return $ PaymentCategory - paymentCategoryId - formattedNewName - categoryId - now - Nothing - ) - where - formattedNewName = T.toLower newName - -deleteIfUnused :: Text -> Query () -deleteIfUnused name = - Query (\conn -> - SQLite.execute - conn - "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" - (name, name) - ) >> return () diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 4ec2dcf..3c3a2b1 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -3,7 +3,7 @@ module Persistence.User , get ) where -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -32,6 +32,6 @@ list = get :: Text -> Query (Maybe User) get userEmail = Query (\conn -> do - fmap (\(Row u) -> u) . listToMaybe <$> + fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/server/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -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) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 7e88d98..1f637bc 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,6 +9,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Common.Model (ExceedingPayer (..), Income (..), @@ -23,10 +24,11 @@ import Model.IncomeResource (IncomeResource (..)) import Model.Mail (Mail (Mail)) import qualified Model.Mail as M import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = +mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -35,24 +37,24 @@ mail conf users payments incomes start end = , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users payments incomes start end + , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end } -body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text -body conf users payments incomes start end = +body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text +body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) + [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where - paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text -exceedingPayers conf time users incomes payments = +exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text +exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = T.intercalate "\n" . map formatPayer $ payers where - payers = CM.getExceedingPayers time users incomes payments + payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users |