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
|
{-# LANGUAGE OverloadedStrings #-}
module View.Mail.WeeklyReport
( mail
) where
import Data.Monoid ((<>))
import Data.Maybe (catMaybes, fromMaybe)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.Calendar (Day, toGregorian)
import Data.List (sortOn)
import Resource (Status(..), groupByStatus, statuses)
import Database.Persist (Entity, entityVal)
import Model.Database (Payment, Income, User, UserId)
import qualified Model.Database as D
import Model.Mail (Mail(Mail))
import qualified Model.Mail as M
import Model.Message (getMessage, getParamMessage, plural)
import qualified Model.Message.Key as K
import Model.User (findUser)
import Conf (Conf)
import qualified Conf as Conf
import qualified View.Format as Format
import Utils.Time (monthToKey)
mail :: Conf -> [Entity User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
mail conf users payments incomes start end =
Mail
{ M.from = Conf.noReplyMail conf
, M.to = map (D.userEmail . entityVal) 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 -> [Entity 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\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 -> [Entity User] -> [Payment] -> Text
paymentSection status conf users payments =
section
(plural (length payments) singleKey pluralKey)
(map (payedFor status conf users) . sortOn D.paymentDate $ 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 -> [Entity User] -> Payment -> Text
payedFor status conf users payment =
getParamMessage
[ formatUserName (D.paymentUserId payment) users
, Format.price conf . D.paymentCost $ payment
, D.paymentName payment
, formatDay $ D.paymentDate payment
]
( case status of
Created -> K.PayedFor
Edited -> K.PayedFor
Deleted -> K.DidNotPayFor
)
incomeSection :: Status -> Conf -> [Entity User] -> [Income] -> Text
incomeSection status conf users incomes =
section
(plural (length incomes) singleKey pluralKey)
(map (isPayedFrom status conf users) . sortOn D.incomeDate $ 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 -> [Entity User] -> Income -> Text
isPayedFrom status conf users income =
getParamMessage
[ formatUserName (D.incomeUserId income) users
, Format.price conf . D.incomeAmount $ income
, formatDay $ D.incomeDate income
]
( case status of
Created -> K.IsPayedFrom
Edited -> K.IsPayedFrom
Deleted -> K.IsNotPayedFrom
)
formatUserName :: UserId -> [Entity User] -> Text
formatUserName userId = fromMaybe "−" . fmap D.userName . 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"
, T.unlines . map (" - " <>) $ items
]
|
