aboutsummaryrefslogtreecommitdiff
path: root/src/server/View/Mail
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/View/Mail')
-rw-r--r--src/server/View/Mail/SignIn.hs16
-rw-r--r--src/server/View/Mail/WeeklyReport.hs124
2 files changed, 128 insertions, 12 deletions
diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs
index f776ddd..8eaa077 100644
--- a/src/server/View/Mail/SignIn.hs
+++ b/src/server/View/Mail/SignIn.hs
@@ -1,12 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module View.Mail.SignIn
- ( getMail
+ ( mail
) where
import Data.Text (Text)
-import qualified Data.Text.Lazy as LT
-import Data.Text.Lazy.Builder (toLazyText, fromText)
import Model.Database (User(..))
import qualified Model.Mail as M
@@ -16,17 +14,11 @@ import Model.Message
import Conf (Conf)
import qualified Conf as Conf
-getMail :: Conf -> User -> Text -> [Text] -> M.Mail
-getMail conf user url to =
+mail :: Conf -> User -> Text -> [Text] -> M.Mail
+mail conf user url to =
M.Mail
{ M.from = Conf.noReplyMail conf
, M.to = to
, M.subject = (getMessage SignInMailTitle)
- , M.plainBody = plainBody user url
+ , M.plainBody = getParamMessage [userName user, url] SignInMail
}
-
-plainBody :: User -> Text -> LT.Text
-plainBody user url = strictToLazy (getParamMessage [userName user, url] SignInMail)
-
-strictToLazy :: Text -> LT.Text
-strictToLazy = toLazyText . fromText
diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs
new file mode 100644
index 0000000..b333891
--- /dev/null
+++ b/src/server/View/Mail/WeeklyReport.hs
@@ -0,0 +1,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)
+
+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 =
+ T.intercalate "\n\n" . catMaybes $
+ [ paymentSection Created conf users <$> M.lookup Created paymentsByStatus
+ , paymentSection Edited conf users <$> M.lookup Edited paymentsByStatus
+ , paymentSection Deleted conf users <$> M.lookup Deleted paymentsByStatus
+ , incomeSection Created conf users <$> M.lookup Created incomesByStatus
+ , incomeSection Edited conf users <$> M.lookup Edited incomesByStatus
+ , incomeSection Deleted conf users <$> M.lookup Deleted incomesByStatus
+ ]
+
+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
+ ]