diff options
Diffstat (limited to 'server/src/View')
| -rw-r--r-- | server/src/View/Mail/WeeklyReport.hs | 124 | ||||
| -rw-r--r-- | server/src/View/Page.hs | 43 |
2 files changed, 167 insertions, 0 deletions
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..3fe224f --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,124 @@ +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) + +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import Conf (Conf) +import qualified Conf as Conf +import Model.IncomeResource (IncomeResource (..)) +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer +import Resource (Status (..), groupByStatus, statuses) + +mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Msg.get Msg.App_Title + , " − " + , Msg.get Msg.WeeklyReport_Title + ] + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end + } + +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = + T.intercalate "\n" $ + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition + , operations conf users paymentsGroupedByStatus incomesGroupedByStatus + ] + where + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes + +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = + T.intercalate "\n" . map formatPayer $ payers + where + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition + formatPayer p = T.concat + [ " * " + , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users + , " + " + , Format.price (Conf.currency conf) $ _exceedingPayer_amount p + , "\n" + ] + +operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text +operations conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Msg.get Msg.WeeklyReport_Empty + 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] -> [PaymentResource] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" * " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..ae7a266 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +module View.Page + ( page + ) where + +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) + +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A + +import Common.Model (Init) +import qualified Common.Msg as Msg + +page :: Maybe Init -> Text +page init = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Msg.get Msg.App_Title) + script ! src "/javascript/main.js" $ "" + script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ "" + jsonScript "init" init + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" + link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" + H.body $ do + H.div ! A.class_ "spinner" $ "" + + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json |