aboutsummaryrefslogtreecommitdiff
path: root/server/src/View
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/View')
-rw-r--r--server/src/View/Mail/SignIn.hs24
-rw-r--r--server/src/View/Mail/WeeklyReport.hs102
-rw-r--r--server/src/View/Page.hs43
3 files changed, 169 insertions, 0 deletions
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
new file mode 100644
index 0000000..1daca1e
--- /dev/null
+++ b/server/src/View/Mail/SignIn.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module View.Mail.SignIn
+ ( mail
+ ) where
+
+import Data.Text (Text)
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (User(..))
+
+import Conf (Conf)
+import qualified Conf as Conf
+import qualified Model.Mail as M
+
+mail :: Conf -> User -> Text -> [Text] -> M.Mail
+mail conf user url to =
+ M.Mail
+ { M.from = Conf.noReplyMail conf
+ , M.to = to
+ , M.subject = Message.get Key.SignIn_MailTitle
+ , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url)
+ }
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
new file mode 100644
index 0000000..b5f2b67
--- /dev/null
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -0,0 +1,102 @@
+{-# 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.Clock (UTCTime)
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (Payment(..), User(..), UserId, Income(..))
+import qualified Common.Model as CM
+import qualified Common.View.Format as Format
+
+import Model.Mail (Mail(Mail))
+import Model.Payment ()
+import qualified Model.Income ()
+import qualified Model.Mail as M
+import Resource (Status(..), groupByStatus, statuses)
+import Conf (Conf)
+import qualified Conf as Conf
+
+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
+ [ Message.get Key.App_Title
+ , " − "
+ , Message.get Key.WeeklyReport_Title
+ ]
+ , 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
+ Message.get Key.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] -> [Payment] -> Text
+paymentSection status conf users payments =
+ section sectionTitle sectionItems
+ where count = length payments
+ sectionTitle = Message.get $ case status of
+ Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count
+ Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count
+ Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count
+ sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments
+
+payedFor :: Status -> Conf -> [User] -> Payment -> Text
+payedFor status conf users payment =
+ case status of
+ Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at)
+ _ -> Message.get (Key.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] -> [Income] -> Text
+incomeSection status conf users incomes =
+ section sectionTitle sectionItems
+ where count = length incomes
+ sectionTitle = Message.get $ case status of
+ Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count
+ Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count
+ Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count
+ sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes
+
+isPayedFrom :: Status -> Conf -> [User] -> Income -> Text
+isPayedFrom status conf users income =
+ case status of
+ Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for)
+ _ -> Message.get (Key.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..6bf9527
--- /dev/null
+++ b/server/src/View/Page.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module View.Page
+ ( page
+ ) where
+
+import Data.Text.Internal.Lazy (Text)
+import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.Aeson (encode)
+import qualified Data.Aeson.Types as Json
+
+import Text.Blaze.Html
+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 Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult)
+
+import Design.Global (globalDesign)
+
+page :: InitResult -> Text
+page initResult =
+ 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 $ Message.get Key.App_Title)
+ script ! src "javascript/main.js" $ ""
+ jsonScript "init" initResult
+ link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
+ link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
+ H.style $ toHtml globalDesign
+
+jsonScript :: Json.ToJSON a => Text -> a -> Html
+jsonScript scriptId json =
+ script
+ ! A.id (toValue scriptId)
+ ! type_ "application/json"
+ $ toHtml . decodeUtf8 . encode $ json