Commit 4dc84dbd authored by Joris's avatar Joris

Show payment header infos

parent f4f24158
......@@ -61,7 +61,6 @@ Executable client
Util.Ajax
Util.Css
Util.Either
Util.List
Util.Reflex
Util.Router
Util.Validation
......@@ -76,8 +75,8 @@ Executable client
View.Income.Table
View.NotFound
View.Payment.Form
View.Payment.Header
View.Payment.Init
View.Payment.HeaderForm
View.Payment.HeaderInfos
View.Payment.Payment
View.Payment.Reducer
View.Payment.Table
......
module View.Payment.Header
( view
, In(..)
, Out(..)
) where
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import qualified Data.List as L hiding (groupBy)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import qualified Data.Time as Time
import qualified Data.Validation as V
import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Category, Currency,
ExceedingPayer (..), Frequency (..),
Income (..), Payment (..),
PaymentCategory, SavedPayment (..),
User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import qualified Component.Button as Button
import qualified Component.Input as Input
import qualified Component.Modal as Modal
import qualified Component.Select as Select
import qualified Util.List as L
import qualified View.Payment.Form as Form
import View.Payment.Init (Init (..))
data In t = In
{ _in_init :: Init
, _in_currency :: Currency
, _in_payments :: Dynamic t [Payment]
, _in_searchPayments :: Dynamic t [Payment]
, _in_paymentCategories :: Dynamic t [PaymentCategory]
}
data Out t = Out
{ _out_searchName :: Dynamic t Text
, _out_searchFrequency :: Dynamic t Frequency
, _out_addPayment :: Event t SavedPayment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input =
R.divClass "header" $ do
rec
addPayment <-
payerAndAdd
incomes
payments
users
categories
paymentCategories
currency
searchFrequency
let resetSearchName = fmap (const ()) $ addPayment
(searchName, searchFrequency) <- searchLine resetSearchName
infos (_in_searchPayments input) users currency
return $ Out
{ _out_searchName = searchName
, _out_searchFrequency = searchFrequency
, _out_addPayment = addPayment
}
where
init = _in_init input
incomes = _init_incomes init
initPayments = _init_payments init
payments = _in_payments input
users = _init_users init
categories = _init_categories init
currency = _in_currency input
paymentCategories = _in_paymentCategories input
payerAndAdd
:: forall t m. MonadWidget t m
=> [Income]
-> Dynamic t [Payment]
-> [User]
-> [Category]
-> Dynamic t [PaymentCategory]
-> Currency
-> Dynamic t Frequency
-> m (Event t SavedPayment)
payerAndAdd incomes payments users categories paymentCategories currency frequency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
let exceedingPayers =
R.ffor payments $ \ps ->
CM.getExceedingPayers time users incomes $
filter ((==) Punctual . _payment_frequency) ps
R.divClass "exceedingPayers" $
R.simpleList exceedingPayers $ \exceedingPayer ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
R.dynText . R.ffor exceedingPayer $ \ep ->
fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
R.elClass "span" "amount" $ do
R.text "+ "
R.dynText . R.ffor exceedingPayer $ \ep ->
Format.price currency $ _exceedingPayer_amount ep
addPayment <- Button._out_clic <$>
(Button.view $
(Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
{ Button._in_class = R.constDyn "addPayment"
})
Modal.view $ Modal.In
{ Modal._in_show = addPayment
, Modal._in_content = \_ -> return (R.never, R.never) -- TODO
}
searchLine
:: forall t m. MonadWidget t m
=> Event t ()
-> m (Dynamic t Text, Dynamic t Frequency)
searchLine reset = do
R.divClass "searchLine" $ do
searchName <- Input._out_raw <$> (Input.view
( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
("" <$ reset)
R.never)
let frequencies = M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
, (Monthly, Msg.get Msg.Payment_MonthlyMale)
]
searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
{ Select._in_label = ""
, Select._in_initialValue = Punctual
, Select._in_value = R.never
, Select._in_values = R.constDyn frequencies
, Select._in_reset = R.never
, Select._in_isValid = V.Success
, Select._in_validate = R.never
})
return (searchName, searchFrequency)
infos
:: forall t m. MonadWidget t m
=> Dynamic t [Payment]
-> [User]
-> Currency -> m ()
infos payments users currency =
R.divClass "infos" $ do
R.elClass "span" "total" $ do
R.dynText $ do
ps <- payments
let paymentCount = length ps
total = sum . map _payment_cost $ ps
pure . Msg.get $ Msg.Payment_Worth
(T.intercalate " "
[ (Format.number paymentCount)
, if paymentCount > 1
then Msg.get Msg.Payment_Many
else Msg.get Msg.Payment_One
])
(Format.price currency total)
R.elClass "span" "partition" . R.dynText $ do
ps <- payments
let totalByUser =
L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
. map (\(u, xs) -> (u, sum . map snd $ xs))
. L.groupBy fst
. map (\p -> (_payment_user p, _payment_cost p))
$ ps
pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
Msg.get $ Msg.Payment_By
(fromMaybe "" . fmap _user_name $ CM.findUser userId users)
(Format.price currency userTotal)
module View.Payment.HeaderForm
( view
) where
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Category, Currency, ExceedingPayer (..),
Frequency (..), Income (..), Payment (..),
PaymentCategory, SavedPayment (..),
User (..))
import qualified Common.Msg as Msg
import qualified Component.Button as Button
import qualified Component.Input as Input
import qualified Component.Modal as Modal
import qualified Component.Select as Select
import qualified View.Payment.Form as Form
data In t = In
{ _in_reset :: Event t ()
, _in_categories :: [Category]
, _in_paymentCategories :: [PaymentCategory]
}
data Out = Out
{ _out_name :: Event t Text
, _out_frequency :: Event t Frequency
, _out_addPayment :: Event t SavedPayment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input = do
R.divClass "g-HeaderForm" $ do
searchName <- Input._out_raw <$> (Input.view
( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
("" <$ _in_reset input)
R.never)
let frequencies = M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
, (Monthly, Msg.get Msg.Payment_MonthlyMale)
]
searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
{ Select._in_label = ""
, Select._in_initialValue = Punctual
, Select._in_value = R.never
, Select._in_values = R.constDyn frequencies
, Select._in_reset = R.never
, Select._in_isValid = V.Success
, Select._in_validate = R.never
})
addPaymentButton <- Button._out_clic <$>
(Button.view $
(Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
{ Button._in_class = R.constDyn "addPayment"
})
addPayment <- Modal.view $ Modal.In
{ Modal._in_show = addPaymentButton
, Modal._in_content =
Form.view $ Form.In
{ Form._in_categories = _in_categories input
, Form._in_paymentCategories = _in_paymentCategories input
, Form._in_operation = Form.New searchFrequency
}
}
return $ Out
{ _out_name = searchName
, _out_frequency = searchFrequency
, _out_addPayment = addPayment
}
module View.Payment.HeaderInfos
( view
, In(..)
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.List as L hiding (groupBy)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Time as Time
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Currency, ExceedingPayer (..),
Payment (..), PaymentHeader (..),
SavedPayment (..), User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import qualified Util.List as L
data In t = In
{ _in_users :: [User]
, _in_currency :: Currency
, _in_header :: PaymentHeader
, _in_paymentCount :: Int
}
view :: forall t m. MonadWidget t m => In t -> m ()
view input =
R.divClass "g-HeaderInfos" $ do
exceedingPayers
(_in_users input)
(_in_currency input)
(_paymentHeader_exceedingPayers header)
infos
(_in_users input)
(_in_currency input)
(_paymentHeader_repartition header)
(_in_paymentCount input)
where
header = _in_header input
exceedingPayers
:: forall t m. MonadWidget t m
=> [User]
-> Currency
-> [ExceedingPayer]
-> m ()
exceedingPayers users currency payers =
R.divClass "g-HeaderInfos__ExceedingPayers" $
flip mapM_ payers $ \payer ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
R.text $
fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users
R.elClass "span" "amount" $ do
R.text "+ "
R.text . Format.price currency $ _exceedingPayer_amount payer
infos
:: forall t m. MonadWidget t m
=> [User]
-> Currency
-> Map UserId Int
-> Int
-> m ()
infos users currency repartition paymentCount =
R.divClass "g-HeaderInfos__Repartition" $ do
R.elClass "span" "total" $ do
R.text $
Msg.get $ Msg.Payment_Worth
(T.intercalate " "
[ (Format.number paymentCount)
, if paymentCount > 1
then Msg.get Msg.Payment_Many
else Msg.get Msg.Payment_One
])
(Format.price currency (M.foldl (+) 0 repartition))
R.elClass "span" "partition" . R.text $
let totalByUser =
L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
. M.toList
$ repartition
in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
Msg.get $ Msg.Payment_By
(fromMaybe "" . fmap _user_name $ CM.findUser userId users)
(Format.price currency userTotal)
module View.Payment.Init
( Init(..)
) where
import Common.Model (Category, Income, Payment, PaymentCategory, User)
data Init = Init
{ _init_users :: [User]
, _init_payments :: [Payment]
, _init_incomes :: [Income]
, _init_categories :: [Category]
, _init_paymentCategories :: [PaymentCategory]
} deriving (Show)
......@@ -3,29 +3,29 @@ module View.Payment.Payment
, In(..)
) where
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (NominalDiffTime)
import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Currency, Frequency, Income (..),
Payment (..), PaymentCategory (..),
PaymentId, PaymentPage (..),
SavedPayment (..), User, UserId)
import qualified Common.Util.Text as T
import qualified Component.Pages as Pages
import Loadable (Loadable (..))
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (NominalDiffTime)
import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Currency, Frequency, Income (..),
Payment (..), PaymentCategory (..),
PaymentId, PaymentPage (..),
SavedPayment (..), User, UserId)
import qualified Common.Util.Text as T
import qualified Component.Pages as Pages
import Loadable (Loadable (..))
import qualified Loadable
import qualified Util.Ajax as AjaxUtil
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Header as Header
import View.Payment.Init (Init (..))
import qualified View.Payment.Reducer as Reducer
import qualified View.Payment.Table as Table
import qualified Util.Ajax as AjaxUtil
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.HeaderInfos as HeaderInfos
-- import qualified View.Payment.HeaderForm as HeaderForm
import qualified View.Payment.Reducer as Reducer
import qualified View.Payment.Table as Table
data In t = In
{ _in_currentUser :: UserId
......@@ -61,7 +61,14 @@ view input = do
deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
HeaderInfos.view $ HeaderInfos.In
{ HeaderInfos._in_users = _in_users input
, HeaderInfos._in_currency = _in_currency input
, HeaderInfos._in_header = header
, HeaderInfos._in_paymentCount = count
}
table <- Table.view $ Table.In
{ Table._in_users = _in_users input
, Table._in_currentUser = _in_currentUser input
......
......@@ -59,6 +59,7 @@ Library
Common.Model.EditIncome
Common.Model.EditIncomeForm
Common.Model.EditPaymentForm
Common.Model.ExceedingPayer
Common.Model.Frequency
Common.Model.Income
Common.Model.IncomeHeader
......@@ -67,4 +68,5 @@ Library
Common.Model.InitResult
Common.Model.Payer
Common.Model.PaymentCategory
Common.Model.PaymentHeader
Common.Model.PaymentPage
......@@ -10,6 +10,7 @@ import Common.Model.EditIncome as X
import Common.Model.EditIncomeForm as X
import Common.Model.EditPaymentForm as X
import Common.Model.Email as X
import Common.Model.ExceedingPayer as X
import Common.Model.Frequency as X
import Common.Model.Income as X
import Common.Model.IncomeHeader as X
......@@ -19,6 +20,7 @@ import Common.Model.InitResult as X
import Common.Model.Payer as X
import Common.Model.Payment as X
import Common.Model.PaymentCategory as X
import Common.Model.PaymentHeader as X
import Common.Model.PaymentPage as X
import Common.Model.SavedPayment as X
import Common.Model.SignInForm as X
......
module Common.Model.ExceedingPayer
( ExceedingPayer(..)
) where
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Common.Model.User (UserId)
data ExceedingPayer = ExceedingPayer
{ _exceedingPayer_userId :: UserId
, _exceedingPayer_amount :: Int
} deriving (Show, Generic)
instance FromJSON ExceedingPayer
instance ToJSON ExceedingPayer
module Common.Model.Payer
( ExceedingPayer(..)
, getExceedingPayers
( getExceedingPayers
, useIncomesFrom
, cumulativeIncomesSince
) where
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Data.Time (NominalDiffTime, UTCTime (..))
import qualified Data.Time as Time
import Data.Time.Calendar (Day)
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Data.Time (NominalDiffTime, UTCTime (..))
import qualified Data.Time as Time
import Data.Time.Calendar (Day)
import Common.Model.Income (Income (..))
import Common.Model.Payment (Payment (..))
import Common.Model.User (User (..), UserId)
import Common.Model.ExceedingPayer (ExceedingPayer (..))
import Common.Model.Income (Income (..))
import Common.Model.Payment (Payment (..))
import Common.Model.User (User (..), UserId)
data Payer = Payer
{ _payer_userId :: UserId
......@@ -29,11 +29,6 @@ data PostPaymentPayer = PostPaymentPayer
, _postPaymentPayer_ratio :: Float
}
data ExceedingPayer = ExceedingPayer
{ _exceedingPayer_userId :: UserId
, _exceedingPayer_amount :: Int
} deriving (Show)
getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer]
getExceedingPayers currentTime users incomes payments =
let userIds = map _user_id users
......
module Common.Model.PaymentHeader
( PaymentHeader(..)
) where
import Data.Aeson (FromJSON, ToJSON)
import Data.Map (Map)
import GHC.Generics (Generic)
import Common.Model.ExceedingPayer (ExceedingPayer)
import Common.Model.User (UserId)
data PaymentHeader = PaymentHeader
{ _paymentHeader_exceedingPayers :: [ExceedingPayer]
, _paymentHeader_repartition :: Map UserId Int
} deriving (Show, Generic)
instance FromJSON PaymentHeader
instance ToJSON PaymentHeader
......@@ -7,9 +7,11 @@ import GHC.Generics (Generic)
import Common.Model.Payment (Payment)
import Common.Model.PaymentCategory (PaymentCategory)
import Common.Model.PaymentHeader (PaymentHeader)
data PaymentPage = PaymentPage
{ _paymentPage_payments :: [Payment]
{ _paymentPage_header :: PaymentHeader
, _paymentPage_payments :: [Payment]
, _paymentPage_paymentCategories :: [PaymentCategory]
, _paymentPage_totalCount :: Int
} deriving (Show, Generic)
......
......@@ -80,12 +80,8 @@ Executable server
Design.View.NotFound
Design.View.Pages
Design.View.Payment
Design.View.Payment.Add
Design.View.Payment.Delete
Design.View.Payment.Form
Design.View.Payment.Header
Design.View.Payment.Pages
Design.View.Payment.Table
Design.View.SignIn
Design.View.Stat
Design.View.Table
......@@ -117,6 +113,7 @@ Executable server
Resource
Secure
SendMail
Util.List
Util.Time
Validation.Income
Validation.Payment
......
module Controller.Payment
( deprecatedList
, list
( list
, listPaymentCategories
, create
, edit
......@@ -8,48 +7,69 @@ module Controller.Payment
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import qualified Data.Time.Clock as Clock
import Data.Validation (Validation (Failure, Success))
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
import Common.Model (Category (..),
CreatePaymentForm (..),
EditPaymentForm (..),
Payment (..), PaymentId,
PaymentPage (..),
Frequency (Punctual),
Payment (..), PaymentHeader (..),
PaymentId, PaymentPage (..),
SavedPayment (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Controller.Helper as ControllerHelper
import Model.CreatePayment (CreatePayment (..))
import Model.EditPayment (EditPayment (..))
import qualified Model.Query as Query
import qualified Persistence.Category as CategoryPersistence
import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified Util.List as L
import qualified Validation.Payment as PaymentValidation
deprecatedList :: ActionM ()
deprecatedList =
Secure.loggedAction (\_ ->
(liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
list :: Int -> Int -> ActionM ()
list page perPage =
Secure.loggedAction (\_ ->
Secure.loggedAction (\_ -> do
currentTime <- liftIO Clock.getCurrentTime
(liftIO . Query.run $ do
count <- PaymentPersistence.count
payments <- PaymentPersistence.listActivePage page perPage
paymentCategories <- PaymentCategoryPersistence.list
return $ PaymentPage payments paymentCategories count
) >>= json
users <- UserPersistence.list
incomes <- IncomePersistence.listAll
allPayments <- PaymentPersistence.listActive Punctual
let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments
repartition =
M.fromList
. map (\(u, xs) -> (u, sum . map snd $ xs))
. L.groupBy fst
. map (\p -> (_payment_user p, _payment_cost p))
$ allPayments
header = PaymentHeader
{ _paymentHeader_exceedingPayers = exceedingPayers
, _paymentHeader_repartition = repartition
}
return $ PaymentPage header payments paymentCategories count) >>= S.json
)
listPaymentCategories :: ActionM ()
listPaymentCategories =
Secure.loggedAction (\_ ->
(liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json
(liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
......@@ -100,7 +120,7 @@ delete paymentId =
_ ->
return False
if deleted then
status Status.ok200
S.status Status.ok200
else
status Status.badRequest400
S.status Status.badRequest400