Send weekly activity at start of week about previous week

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
+    ]