aboutsummaryrefslogtreecommitdiff
path: root/server/src/View
diff options
context:
space:
mode:
authorJoris2020-01-30 11:35:31 +0000
committerJoris2020-01-30 11:35:31 +0000
commit960fa7cb7ae4c57d01306f78cd349f3a8337d0ab (patch)
tree5077cc720525fb025e4dba65a9a8b631862cbcc8 /server/src/View
parent14bdbc8c937f5d0b35c61350dba28cb41c3737cd (diff)
parent6a04e640955051616c3ad0874605830c448f2d75 (diff)
Merge branch 'with-ghcjs' into 'master'
Use Haskell on the frontend See merge request guyonvarch/shared-cost!2
Diffstat (limited to 'server/src/View')
-rw-r--r--server/src/View/Mail/WeeklyReport.hs124
-rw-r--r--server/src/View/Page.hs43
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