From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 24 Sep 2017 22:14:48 +0200
Subject: Bootstrap with GHCJS and reflex:

- setup login and logout,
- first draft of payment view.
---
 src/server/View/Format.hs            |  33 -----------
 src/server/View/Mail/SignIn.hs       |  11 ++--
 src/server/View/Mail/WeeklyReport.hs | 110 ++++++++++++++---------------------
 src/server/View/Page.hs              |  23 +++-----
 4 files changed, 58 insertions(+), 119 deletions(-)
 delete mode 100644 src/server/View/Format.hs

(limited to 'src/server/View')

diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs
deleted file mode 100644
index 354d46a..0000000
--- a/src/server/View/Format.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module View.Format
-  ( price
-  ) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.List (intersperse)
-
-import Conf (Conf)
-import qualified Conf
-
-price :: Conf -> Int -> Text
-price conf amount = T.concat [number amount, " ", Conf.currency conf]
-
-number :: Int -> Text
-number n =
-  T.pack
-  . (++) (if n < 0 then "-" else "")
-  . reverse
-  . concat
-  . intersperse " "
-  . group 3
-  . reverse
-  . show
-  . abs $ n
-
-group :: Int -> [a] -> [[a]]
-group n xs =
-  if length xs <= n
-    then [xs]
-    else (take n xs) : (group n (drop n xs))
diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs
index c7d40d8..12c4f34 100644
--- a/src/server/View/Mail/SignIn.hs
+++ b/src/server/View/Mail/SignIn.hs
@@ -6,10 +6,11 @@ module View.Mail.SignIn
 
 import Data.Text (Text)
 
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model.User (User(..))
+
 import Conf (Conf)
-import Model.Message
-import Model.Message.Key
-import Model.User (User(..))
 import qualified Conf as Conf
 import qualified Model.Mail as M
 
@@ -18,6 +19,6 @@ mail conf user url to =
   M.Mail
     { M.from = Conf.noReplyMail conf
     , M.to = to
-    , M.subject = (getMessage SignInMailTitle)
-    , M.plainBody = getParamMessage [name user, url] SignInMail
+    , M.subject = Message.get Key.SignIn_MailTitle
+    , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url)
     }
diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs
index 1a80b95..0bafb70 100644
--- a/src/server/View/Mail/WeeklyReport.hs
+++ b/src/server/View/Mail/WeeklyReport.hs
@@ -9,38 +9,34 @@ import Data.Map (Map)
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Monoid ((<>))
 import Data.Text (Text)
-import Data.Time.Calendar (Day, toGregorian)
 import Data.Time.Clock (UTCTime)
 import qualified Data.Map as M
 import qualified Data.Text as T
 
-import Resource (Status(..), groupByStatus, statuses)
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (Payment(..), User(..), UserId, Income(..))
+import qualified Common.Model.User as User
+import qualified Common.View.Format as Format
 
-import Model.Income (Income)
 import Model.Mail (Mail(Mail))
-import Model.Message (getMessage, getParamMessage, plural)
-import Model.Payment (Payment)
-import Model.User (findUser)
-import Model.User (User, UserId)
-import qualified Model.Income as Income
+import Model.Payment ()
+import qualified Model.Income ()
 import qualified Model.Mail as M
-import qualified Model.Message.Key as K
-import qualified Model.Payment as Payment
-import qualified Model.User as User
-
+import Resource (Status(..), groupByStatus, statuses)
 import Conf (Conf)
 import qualified Conf as Conf
 
-import qualified View.Format as Format
-
-import Utils.Time (monthToKey)
-
 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 [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport]
+    , 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)
     }
 
@@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
 body conf users paymentsByStatus incomesByStatus =
   if M.null paymentsByStatus && M.null incomesByStatus
     then
-      getMessage K.WeeklyReportEmpty
+      Message.get Key.WeeklyReport_Empty
     else
       T.intercalate "\n" . catMaybes . concat $
         [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses
@@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus =
 
 paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text
 paymentSection status conf users payments =
-  section
-    (plural (length payments) singleKey pluralKey)
-    (map (payedFor status conf users) . sortOn Payment.date $ payments)
-  where (singleKey, pluralKey) =
-          case status of
-            Created -> (K.PaymentCreated, K.PaymentsCreated)
-            Edited -> (K.PaymentEdited, K.PaymentsEdited)
-            Deleted -> (K.PaymentDeleted, K.PaymentsDeleted)
+  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 =
-  getParamMessage
-    [ formatUserName (Payment.userId payment) users
-    , Format.price conf . Payment.cost $ payment
-    , Payment.name payment
-    , formatDay $ Payment.date payment
-    ]
-    ( case status of
-        Created -> K.PayedFor
-        Edited -> K.PayedFor
-        Deleted -> K.DidNotPayFor
-    )
+  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
-    (plural (length incomes) singleKey pluralKey)
-    (map (isPayedFrom status conf users) . sortOn Income.date $ incomes)
-  where (singleKey, pluralKey) =
-          case status of
-            Created -> (K.IncomeCreated, K.IncomesCreated)
-            Edited -> (K.IncomeEdited, K.IncomesEdited)
-            Deleted -> (K.IncomeDeleted, K.IncomesDeleted)
+  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 =
-  getParamMessage
-    [ formatUserName (Income.userId income) users
-    , Format.price conf . Income.amount $ income
-    , formatDay $ Income.date income
-    ]
-    ( case status of
-        Created -> K.IsPayedFrom
-        Edited -> K.IsPayedFrom
-        Deleted -> K.IsNotPayedFrom
-    )
+  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 . 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
+formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId
 
 section :: Text -> [Text] -> Text
 section title items =
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 5a2e4f8..1c072a4 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes
 import qualified Text.Blaze.Html5.Attributes as A
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
-import Design.Global (globalDesign)
+import qualified Common.Message as Message
+import Common.Model.InitResult (InitResult)
+import qualified Common.Message.Key as Key
 
-import Model.Message
-import Model.Json.Conf
-import Model.Json.Init (InitResult)
-import Model.Message.Key (Key(SharedCost))
+import Design.Global (globalDesign)
 
-page :: Conf -> InitResult -> Text
-page conf initResult =
+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 $ getMessage SharedCost)
-      script ! src "javascripts/client.js" $ ""
-      jsonScript "translations" getTranslations
-      jsonScript "conf" conf
-      jsonScript "result" initResult
+      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
-    body $ do
-      script ! src "javascripts/main.js" $ ""
 
 jsonScript :: Json.ToJSON a => Text -> a -> Html
 jsonScript scriptId json =
-- 
cgit v1.2.3


From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 8 Nov 2017 23:47:26 +0100
Subject: Use a better project structure

---
 src/server/View/Mail/SignIn.hs       |  24 ---------
 src/server/View/Mail/WeeklyReport.hs | 102 -----------------------------------
 src/server/View/Page.hs              |  43 ---------------
 3 files changed, 169 deletions(-)
 delete mode 100644 src/server/View/Mail/SignIn.hs
 delete mode 100644 src/server/View/Mail/WeeklyReport.hs
 delete mode 100644 src/server/View/Page.hs

(limited to 'src/server/View')

diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs
deleted file mode 100644
index 12c4f34..0000000
--- a/src/server/View/Mail/SignIn.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# 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 (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/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs
deleted file mode 100644
index 0bafb70..0000000
--- a/src/server/View/Mail/WeeklyReport.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-{-# 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.User as User
-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 . User.find userId
-
-section :: Text -> [Text] -> Text
-section title items =
-  T.concat
-    [ title
-    , "\n\n"
-    , T.unlines . map ("  - " <>) $ items
-    ]
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
deleted file mode 100644
index 1c072a4..0000000
--- a/src/server/View/Page.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# 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 Common.Model.InitResult (InitResult)
-import qualified Common.Message.Key as Key
-
-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
-- 
cgit v1.2.3