diff options
| -rw-r--r-- | client/src/Loadable.hs | 37 | ||||
| -rw-r--r-- | client/src/View/Income/Income.hs | 15 | ||||
| -rw-r--r-- | client/src/View/Income/Reducer.hs | 40 | ||||
| -rw-r--r-- | client/src/View/Payment/Form.hs | 1 | ||||
| -rw-r--r-- | client/src/View/Payment/Payment.hs | 18 | ||||
| -rw-r--r-- | client/src/View/Payment/Reducer.hs | 30 | ||||
| -rw-r--r-- | common/src/Common/Model/IncomePage.hs | 3 | ||||
| -rw-r--r-- | server/server.cabal | 1 | ||||
| -rw-r--r-- | server/src/Controller/Income.hs | 28 | ||||
| -rw-r--r-- | server/src/Controller/Payment.hs | 16 | ||||
| -rw-r--r-- | server/src/Design/Global.hs | 6 | ||||
| -rw-r--r-- | server/src/Design/Loadable.hs | 29 | ||||
| -rw-r--r-- | server/src/Design/View/Table.hs | 3 | ||||
| -rw-r--r-- | server/src/Design/Views.hs | 16 | ||||
| -rw-r--r-- | server/src/Job/WeeklyReport.hs | 17 | ||||
| -rw-r--r-- | server/src/Payer.hs | 135 | ||||
| -rw-r--r-- | server/src/Persistence/Income.hs | 58 | ||||
| -rw-r--r-- | server/src/Persistence/Payment.hs | 12 | ||||
| -rw-r--r-- | server/src/View/Mail/WeeklyReport.hs | 21 |
19 files changed, 262 insertions, 224 deletions
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 2b9008a..9a14b3f 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -1,9 +1,12 @@ module Loadable ( Loadable (..) + , Loadable2 (..) , fromEvent , view + , view2 ) where +import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -50,3 +53,37 @@ view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe 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 + +data Loadable2 t a = Loadable2 + { _loadable_isLoading :: Dynamic t Bool + , _loadable_value :: Dynamic t (Maybe a) + } + +view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b)) +view2 (Loadable2 isLoading value) f = + withLoader isLoading $ + R.dyn . R.ffor value . viewMaybe $ f + + where + viewMaybe _ Nothing = return Nothing + viewMaybe f (Just x) = Just <$> f x + +withLoader + :: forall t m a. MonadWidget t m + => Dynamic t Bool + -> m a + -> m a +withLoader isLoading block = + R.divClass "g-Loadable" $ do + R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ + R.divClass "spinner" R.blank + R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block + where + spinnerAttrs l = M.singleton "class" $ + "g-Loadable__Spinner" + <> (if l then " g-Loadable__Spinner--Loading" else "") + + blockAttrs l = M.singleton "class" $ + "g-Loadable__Content" + <> (if l then " g-Loadable__Content--Loading" else "") diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d82ab4d..fa2585d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -19,6 +19,7 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer @@ -33,9 +34,8 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do rec - incomes <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage + incomePage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] , Reducer._in_editIncome = editIncome , Reducer._in_deleteIncome = deleteIncome @@ -44,15 +44,14 @@ view input = do let eventFromResult :: forall a. ((Header.Out t, 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 + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(IncomePage header incomes count) -> do + result <- Loadable.view2 incomePage $ + \(IncomePage page header incomes count) -> do header <- Header.view $ Header.In { Header._in_users = _in_users input , Header._in_header = header @@ -69,7 +68,7 @@ view input = do 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 (header, table, pages) diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 092d9b3..391890f 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -11,53 +11,51 @@ import qualified Reflex.Dom as R import Common.Model (IncomePage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil 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_addIncome :: Event t a , _in_editIncome :: Event t b , _in_deleteIncome :: Event t c } -data Action - = LoadPage Int - | GetResult (Either Text IncomePage) - -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage) reducer input = do postBuild <- R.getPostBuild + currentPage <- R.holdDyn 1 (_in_page input) + let loadPage = R.leftmost [ 1 <$ postBuild - , _in_newPage input + , _in_page input , 1 <$ _in_addIncome input - , R.tag (R.current $ _in_currentPage input) (_in_editIncome input) - , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input) + , R.tag (R.current currentPage) (_in_editIncome input) + , R.tag (R.current currentPage) (_in_deleteIncome input) ] getResult <- AjaxUtil.get $ fmap pageUrl loadPage - R.foldDyn - (\action _ -> case action of - LoadPage _ -> Loading - GetResult (Left err) -> Error err - GetResult (Right incomes) -> Loaded incomes - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$> loadPage - , GetResult <$> getResult + [ True <$ loadPage + , False <$ getResult ]) + incomePage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading incomePage + where pageUrl p = "api/incomes?page=" diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99dce13..064b5b3 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -113,6 +113,7 @@ view input cancel = do setCategory <- R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index a34d2f4..a97c3df 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -41,7 +41,7 @@ view input = do R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec - payments <- Reducer.reducer $ Reducer.In + paymentPage <- Reducer.reducer $ Reducer.In { Reducer._in_page = page , Reducer._in_search = HeaderForm._out_search form , Reducer._in_frequency = HeaderForm._out_frequency form @@ -50,7 +50,7 @@ view input = do , Reducer._in_deletePayment = deletePayment } - let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + 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 let addPayment = @@ -59,18 +59,18 @@ view input = do , 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) + page <- eventFromResult $ Pages._out_newPage . snd + tableAddPayment <- eventFromResult $ Table._out_add . fst + editPayment <- eventFromResult $ Table._out_edit . fst + deletePayment <- eventFromResult $ Table._out_delete . fst form <- HeaderForm.view $ HeaderForm.In { HeaderForm._in_reset = () <$ addPayment , HeaderForm._in_categories = categories } - result <- R.dyn . R.ffor payments $ - Loadable.view $ \(PaymentPage page frequency header payments count) -> do + result <- Loadable.view2 paymentPage $ + \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input @@ -94,7 +94,7 @@ view input = do , Pages._in_page = page } - return ((), table, pages) + return (table, pages) return () diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0b6c041..d221ff0 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -13,9 +13,9 @@ import qualified Reflex.Dom as R import Common.Model (Frequency (..), PaymentPage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil perPage :: Int perPage = 7 @@ -29,10 +29,6 @@ data In t a b c = In , _in_deletePayment :: Event t c } -data Action - = LoadPage - | GetResult (Either Text PaymentPage) - data Params = Params { _params_page :: Int , _params_search :: Text @@ -48,7 +44,7 @@ data Msg | ResetSearch deriving Show -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage) reducer input = do postBuild <- R.getPostBuild @@ -94,19 +90,19 @@ reducer input = do getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) - - R.foldDyn - (\action _ -> case action of - LoadPage -> Loading - GetResult (Left err) -> Error err - GetResult (Right payments) -> Loaded payments - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$ paramsEvent - , GetResult <$> getResult + [ True <$ paramsEvent + , False <$ getResult ]) + paymentPage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading paymentPage + where pageUrl (Params page search frequency) = "api/payments?page=" diff --git a/common/src/Common/Model/IncomePage.hs b/common/src/Common/Model/IncomePage.hs index c3f478e..0572141 100644 --- a/common/src/Common/Model/IncomePage.hs +++ b/common/src/Common/Model/IncomePage.hs @@ -9,7 +9,8 @@ import Common.Model.Income (Income) import Common.Model.IncomeHeader (IncomeHeader) data IncomePage = IncomePage - { _incomePage_header :: IncomeHeader + { _incomePage_page :: Int + , _incomePage_header :: IncomeHeader , _incomePage_incomes :: [Income] , _incomePage_totalCount :: Int } deriving (Show, Generic) diff --git a/server/server.cabal b/server/server.cabal index 7056b3f..c9ab2c7 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -72,6 +72,7 @@ Executable server Design.Form Design.Global Design.Helper + Design.Loadable Design.Media Design.Modal Design.Tooltip diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 75d0133..784a2db 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), Income (..), + EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) @@ -21,7 +21,6 @@ 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 @@ -36,26 +35,19 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - paymentRange <- PaymentPersistence.getRange - allIncomes <- IncomePersistence.listAll -- TODO optimize - - let since = - Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) + let userIds = _user_id <$> users - let byUser = - case since of - Just s -> - M.fromList . flip map users $ \user -> - ( _user_id user - , Payer.cumulativeIncomesSince currentTime s $ - filter ((==) (_user_id user) . _income_userId) allIncomes - ) + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll - Nothing -> - M.empty + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty incomes <- IncomePersistence.list page perPage - return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c860810..42a4436 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -11,7 +11,6 @@ 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 @@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () list frequency page perPage search = - Secure.loggedAction (\_ -> do - currentTime <- liftIO Clock.getCurrentTime + Secure.loggedAction (\_ -> (liftIO . Query.run $ do count <- PaymentPersistence.count frequency search payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll -- TODO optimize paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty searchRepartition <- case paymentRange of @@ -57,7 +63,7 @@ list frequency page perPage search = (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index df41cfd..ebd7084 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -12,6 +12,7 @@ import qualified Design.Constants as Constants import qualified Design.Errors as Errors import qualified Design.Form as Form import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable import qualified Design.Media as Media import qualified Design.Modal as Modal import qualified Design.Tooltip as Tooltip @@ -28,6 +29,7 @@ global = do ".tooltip" ? Tooltip.design Views.design Form.design + Loadable.design spinKeyframes appearKeyframe @@ -92,14 +94,14 @@ global = do h1 ? do color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) + lineHeight (em 1.3) Media.desktop $ fontSize (px 24) Media.tablet $ fontSize (px 22) Media.mobile $ fontSize (px 20) ul ? do + "margin-top" -: "1vh" "margin-bottom" -: "3vh" "margin-left" -: "1vh" li <? do diff --git a/server/src/Design/Loadable.hs b/server/src/Design/Loadable.hs new file mode 100644 index 0000000..6b13f2d --- /dev/null +++ b/server/src/Design/Loadable.hs @@ -0,0 +1,29 @@ +module Design.Loadable + ( design + ) where + +import Clay + +design :: Css +design = do + ".g-Loadable" ? do + position relative + width (pct 100) + height (pct 100) + + ".g-Loadable__Spinner" ? do + position absolute + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + display none + + ".g-Loadable__Spinner--Loading" ? do + display block + + ".g-Loadable__Content" ? + transition "opacity" (sec 0.4) ease (sec 0) + + ".g-Loadable__Content--Loading" ? + opacity 0.5 diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index c77cb7c..56bd389 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -15,6 +15,9 @@ design = do margin (em 2) (em 2) (em 2) (em 2) textAlign (alignSide sideCenter) + ".table" ? do + minHeight (px 540) + ".lines" ? do Media.tabletDesktop $ display displayTable width (pct 100) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index d36a728..270bb8e 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -32,15 +32,19 @@ design = do "margin" -: "0 2vw" ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft + display flex + marginBottom (em 1) + + Media.tabletDesktop $ do + justifyContent spaceBetween + alignItems center + + Media.mobile $ do + flexDirection column + "h1" ? marginBottom (em 0.5) button ? do Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) Media.mobile $ do width (pct 100) marginBottom (px 20) diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 34bbd3a..16be396 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,8 +2,11 @@ module Job.WeeklyReport ( weeklyReport ) where +import qualified Data.Map as M import Data.Time.Clock (UTCTime, getCurrentTime) +import Common.Model (User (..)) + import Conf (Conf) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence @@ -21,19 +24,27 @@ weeklyReport conf mbLastExecution = do return () Just lastExecution -> do - (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do users <- UserPersistence.list paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty weekPayments <- PaymentPersistence.listModifiedSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) _ <- SendMail.sendMail conf - (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) return () diff --git a/server/src/Payer.hs b/server/src/Payer.hs index d913afe..ab8312e 100644 --- a/server/src/Payer.hs +++ b/server/src/Payer.hs @@ -1,25 +1,17 @@ module Payer ( getExceedingPayers - , useIncomesFrom - , cumulativeIncomesSince ) where -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 Data.Map (Map) +import qualified Data.Map as M -import Common.Model (ExceedingPayer (..), Income (..), - User (..), UserId) +import Common.Model (ExceedingPayer (..), User (..), UserId) data Payer = Payer { _payer_userId :: UserId , _payer_preIncomePayments :: Int , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] + , _payer_income :: Int } data PostPaymentPayer = PostPaymentPayer @@ -29,43 +21,29 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] -getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = let userIds = map _user_id users - payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - mbSince = useIncomesFrom userIds incomes firstPayment - in case mbSince of - Just since -> - let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day -useIncomesFrom userIds incomes firstPayment = - case (firstPayment, incomeDefinedForAll userIds incomes) of - (Just d1, Just d2) -> Just (max d1 d2) - _ -> Nothing - -dayUTCTime :: Day -> UTCTime -dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) - -getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] -getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome 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 + , _payer_income = M.findWithDefault 0 userId cumulativeIncome } ) @@ -85,15 +63,14 @@ exceedingPayersFromAmounts userAmounts = $ userAmounts where mbMinAmount = safeMinimum . map snd $ userAmounts -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = PostPaymentPayer { _postPaymentPayer_userId = _payer_userId payer , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) getFinalDiff :: Float -> PostPaymentPayer -> Int getFinalDiff maxRatio payer = @@ -101,66 +78,6 @@ getFinalDiff maxRatio payer = truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) in postIncomeDiff + _postPaymentPayer_preIncomePayments payer -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes - in if all Maybe.isJust firstIncomes - then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: Day -> [Income] -> [Income] -getOrderedIncomesSince since incomes = - let mbStarterIncome = getIncomeAt since incomes - orderedIncomesSince = filter (\income -> _income_date income >= since) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: Day -> [Income] -> Maybe Income -getIncomeAt day incomes = - case incomes of - [x] -> - if _income_date x < day - then Just $ x { _income_date = day } - else Nothing - x1 : x2 : xs -> - if _income_date x1 < day && _income_date x2 >= day - then Just $ x1 { _income_date = day } - else getIncomeAt day (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = dayUTCTime . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - safeMinimum :: (Ord a) => [a] -> Maybe a safeMinimum [] = Nothing safeMinimum xs = Just . minimum $ xs diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index ba7ad19..e689505 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,21 +1,24 @@ module Persistence.Income ( count , list - , listAll , listModifiedSince , create , edit , delete , definedForAll + , getCumulativeIncome ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M 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 Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), + Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -58,13 +61,6 @@ list page perPage = (perPage, (page - 1) * perPage) ) -listAll :: Query [Income] -listAll = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> @@ -79,7 +75,7 @@ listModifiedSince since = , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) create :: UserId -> Day -> Int -> Query Income @@ -156,6 +152,46 @@ definedForAll users = where fromRows rows = if L.sort users == L.sort (map fst rows) then - Maybe.listToMaybe . L.sort . map snd $ rows + Maybe.listToMaybe . reverse . L.sort . map snd $ rows else Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index f75925d..953f0ae 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -163,14 +163,14 @@ listModifiedSince since = SQLite.query conn (SQLite.Query . T.intercalate " " $ - [ "SELECT *" + [ "SELECT " <> fields , "FROM payment" , "WHERE" , "created_at >= ?" , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) @@ -300,7 +300,13 @@ searchCategory paymentName = fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE ?" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) (Only $ "%" <> paymentName <> "%") ) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 1f637bc..3fe224f 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,7 +9,6 @@ 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 (..), @@ -27,8 +26,8 @@ import Model.PaymentResource (PaymentResource (..)) import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -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 :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -37,24 +36,24 @@ mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPay , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition 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 = +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments - incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text -exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = T.intercalate "\n" . map formatPayer $ payers where - payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users |