1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
module Controller.Payment
( list
, create
, edit
, delete
, searchCategory
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Time.Clock as Clock
import qualified Data.Time.Calendar as Calendar
import Data.Validation (Validation (Failure, Success))
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
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 Validation.Payment as PaymentValidation
list :: Frequency -> Int -> Int -> Text -> ActionM ()
list frequency page perPage search =
Secure.loggedAction (\_ -> do
currentUtctDay <- liftIO $ Clock.utctDay <$> Clock.getCurrentTime
(liftIO . Query.run $ do
count <- PaymentPersistence.count frequency search
payments <- PaymentPersistence.listActivePage frequency page perPage search
users <- UserPersistence.list
paymentRange <- PaymentPersistence.getRange
incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
cumulativeIncome <-
case (incomeDefinedForAll, paymentRange) of
(Just incomeStart, Just (paymentStart, _)) ->
IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) currentUtctDay
_ ->
return M.empty
searchRepartition <-
case paymentRange of
Just (from, to) ->
PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to)
Nothing ->
return M.empty
(preIncomeRepartition, postIncomeRepartition) <-
PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition
header = PaymentHeader
{ _paymentHeader_exceedingPayers = exceedingPayers
, _paymentHeader_repartition = searchRepartition
}
return $ PaymentPage page frequency header payments count) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
cs <- map _category_id <$> CategoryPersistence.listAll
case PaymentValidation.createPayment cs form of
Success (CreatePayment name cost date category frequency) ->
Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.okOrBadRequest
)
edit :: EditPaymentForm -> ActionM ()
edit form =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
cs <- map _category_id <$> CategoryPersistence.listAll
case PaymentValidation.editPayment cs form of
Success (EditPayment paymentId name cost date category frequency) -> do
isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
return $ if isSuccess then
Right ()
else
Left $ Msg.get Msg.Error_PaymentEdit
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.okOrBadRequest
)
delete :: PaymentId -> ActionM ()
delete paymentId =
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
)
|
