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
119
120
121
122
123
124
125
126
|
{-# LANGUAGE OverloadedStrings #-}
module View.Mail.WeeklyReport
( mail
) where
import Data.List (sortOn)
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Calendar (Day, toGregorian)
import Data.Time.Clock (UTCTime)
import qualified Data.Map as M
import qualified Data.Text as T
import Resource (Status(..), groupByStatus, statuses)
import Model.Income (Income)
import Model.Mail (Mail(Mail))
import Model.Message (getMessage, getParamMessage, plural)
import Model.Payment (Payment)
import Model.User (findUser)
import Model.User (User, UserId)
import qualified Model.Income as Income
import qualified Model.Mail as M
import qualified Model.Message.Key as K
import qualified Model.Payment as Payment
import qualified Model.User as User
import Conf (Conf)
import qualified Conf as Conf
import qualified View.Format as Format
import Utils.Time (monthToKey)
mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
mail conf users payments incomes start end =
Mail
{ M.from = Conf.noReplyMail conf
, M.to = map User.email users
, M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport]
, M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes)
}
body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
body conf users paymentsByStatus incomesByStatus =
if M.null paymentsByStatus && M.null incomesByStatus
then
getMessage K.WeeklyReportEmpty
else
T.intercalate "\n" . catMaybes . concat $
[ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses
, map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses
]
paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text
paymentSection status conf users payments =
section
(plural (length payments) singleKey pluralKey)
(map (payedFor status conf users) . sortOn Payment.date $ payments)
where (singleKey, pluralKey) =
case status of
Created -> (K.PaymentCreated, K.PaymentsCreated)
Edited -> (K.PaymentEdited, K.PaymentsEdited)
Deleted -> (K.PaymentDeleted, K.PaymentsDeleted)
payedFor :: Status -> Conf -> [User] -> Payment -> Text
payedFor status conf users payment =
getParamMessage
[ formatUserName (Payment.userId payment) users
, Format.price conf . Payment.cost $ payment
, Payment.name payment
, formatDay $ Payment.date payment
]
( case status of
Created -> K.PayedFor
Edited -> K.PayedFor
Deleted -> K.DidNotPayFor
)
incomeSection :: Status -> Conf -> [User] -> [Income] -> Text
incomeSection status conf users incomes =
section
(plural (length incomes) singleKey pluralKey)
(map (isPayedFrom status conf users) . sortOn Income.date $ incomes)
where (singleKey, pluralKey) =
case status of
Created -> (K.IncomeCreated, K.IncomesCreated)
Edited -> (K.IncomeEdited, K.IncomesEdited)
Deleted -> (K.IncomeDeleted, K.IncomesDeleted)
isPayedFrom :: Status -> Conf -> [User] -> Income -> Text
isPayedFrom status conf users income =
getParamMessage
[ formatUserName (Income.userId income) users
, Format.price conf . Income.amount $ income
, formatDay $ Income.date income
]
( case status of
Created -> K.IsPayedFrom
Edited -> K.IsPayedFrom
Deleted -> K.IsNotPayedFrom
)
formatUserName :: UserId -> [User] -> Text
formatUserName userId = fromMaybe "−" . fmap User.name . findUser userId
formatDay :: Day -> Text
formatDay d =
let (year, month, day) = toGregorian d
in getParamMessage
[ T.pack . show $ day
, fromMaybe "−" . fmap getMessage . monthToKey $ month
, T.pack . show $ year
]
K.LongDate
section :: Text -> [Text] -> Text
section title items =
T.concat
[ title
, "\n\n"
, T.unlines . map (" - " <>) $ items
]
|
