From 86a96decdb8892b10c5314eb916ef15a64204450 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Nov 2016 00:49:32 +0100
Subject: Send weekly activity at start of week about previous week

---
 .tmuxinator.yml                          |   2 +-
 README.md                                |   9 +-
 src/server/Conf.hs                       |  31 ++++---
 src/server/Controller/SignIn.hs          |   2 +-
 src/server/Job.hs                        |  25 ------
 src/server/Job/Daemon.hs                 |  40 +++++++++
 src/server/Job/Frequency.hs              |  13 +++
 src/server/Job/Kind.hs                   |  14 +++
 src/server/Job/Model.hs                  |  33 +++++++
 src/server/Job/MonthlyPayment.hs         |  24 +++++
 src/server/Job/WeeklyReport.hs           |  31 +++++++
 src/server/Main.hs                       |  71 +++++++--------
 src/server/Model/Database.hs             |  17 +++-
 src/server/Model/Income.hs               |  12 ++-
 src/server/Model/Job.hs                  |  33 -------
 src/server/Model/JobKind.hs              |  13 ---
 src/server/Model/Mail.hs                 |   3 +-
 src/server/Model/Message.hs              |   5 ++
 src/server/Model/Message/Key.hs          |  22 ++++-
 src/server/Model/Message/Translations.hs | 147 +++++++++++++++++++++++--------
 src/server/Model/Payment.hs              |  11 +++
 src/server/Model/User.hs                 |   5 ++
 src/server/MonthlyPaymentJob.hs          |  33 -------
 src/server/Resource.hs                   |  50 +++++++++++
 src/server/SendMail.hs                   |   7 +-
 src/server/Utils/Time.hs                 |  38 ++++++--
 src/server/View/Format.hs                |  33 +++++++
 src/server/View/Mail/SignIn.hs           |  16 +---
 src/server/View/Mail/WeeklyReport.hs     | 124 ++++++++++++++++++++++++++
 29 files changed, 639 insertions(+), 225 deletions(-)
 delete mode 100644 src/server/Job.hs
 create mode 100644 src/server/Job/Daemon.hs
 create mode 100644 src/server/Job/Frequency.hs
 create mode 100644 src/server/Job/Kind.hs
 create mode 100644 src/server/Job/Model.hs
 create mode 100644 src/server/Job/MonthlyPayment.hs
 create mode 100644 src/server/Job/WeeklyReport.hs
 delete mode 100644 src/server/Model/Job.hs
 delete mode 100644 src/server/Model/JobKind.hs
 delete mode 100644 src/server/MonthlyPaymentJob.hs
 create mode 100644 src/server/Resource.hs
 create mode 100644 src/server/View/Format.hs
 create mode 100644 src/server/View/Mail/WeeklyReport.hs

diff --git a/.tmuxinator.yml b/.tmuxinator.yml
index 2be1fda..e714e72 100644
--- a/.tmuxinator.yml
+++ b/.tmuxinator.yml
@@ -5,4 +5,4 @@ windows:
       layout: fff4,119x58,0,0{94x58,0,0,0,24x58,95,0,1}
       panes:
         - # Empty
-        - make install && make && make watch
+        - make install build watch
diff --git a/README.md b/README.md
index dbe30b7..b880ee8 100644
--- a/README.md
+++ b/README.md
@@ -1,7 +1,12 @@
 Shared Cost
 ===========
 
-Share costs with a group of people.
+Share costs with a group of people:
+
+- Share according to people income,
+- Monthly payments available,
+- Statistics by month,
+- Weekly activity sent by email.
 
 Getting started
 ---------------
@@ -42,4 +47,4 @@ TODO
 ----
 
 - CRUD animations (loading, created-updated-deleted element)
-- Weekly notifications about added, modified, deleted payments and incomes
+- Payment categories ?
diff --git a/src/server/Conf.hs b/src/server/Conf.hs
index 13d5981..a05349d 100644
--- a/src/server/Conf.hs
+++ b/src/server/Conf.hs
@@ -1,11 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Conf
-  ( getConf
+  ( get
   , Conf(..)
   ) where
 
 import Data.Text (Text)
+import qualified Data.Text as T
 import qualified Data.ConfigManager as Conf
 import Data.Time.Clock (NominalDiffTime)
 
@@ -18,15 +19,19 @@ data Conf = Conf
   , https :: Bool
   } deriving Show
 
-getConf :: FilePath -> IO (Either Text Conf)
-getConf path =
-  (flip fmap) (Conf.readConfig path) (\configOrError -> do
-    conf <- configOrError
-    Conf <$>
-      Conf.lookup "hostname" conf <*>
-      Conf.lookup "port" conf <*>
-      Conf.lookup "signInExpiration" conf <*>
-      Conf.lookup "currency" conf <*>
-      Conf.lookup "noReplyMail" conf <*>
-      Conf.lookup "https" conf
-  )
+get :: FilePath -> IO Conf
+get path = do
+  conf <-
+    (flip fmap) (Conf.readConfig path) (\configOrError -> do
+      conf <- configOrError
+      Conf <$>
+        Conf.lookup "hostname" conf <*>
+        Conf.lookup "port" conf <*>
+        Conf.lookup "signInExpiration" conf <*>
+        Conf.lookup "currency" conf <*>
+        Conf.lookup "noReplyMail" conf <*>
+        Conf.lookup "https" conf
+    )
+  case conf of
+    Left msg -> error (T.unpack msg)
+    Right c -> return c
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 0fbe7c5..1b8121d 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -45,7 +45,7 @@ signIn conf login =
                       "?signInToken=",
                       token
                     ]
-          maybeSentMail <- liftIO . sendMail $ SignIn.getMail conf (entityVal user) url [login]
+          maybeSentMail <- liftIO . sendMail $ SignIn.mail conf (entityVal user) url [login]
           case maybeSentMail of
             Right _ ->
               status ok200
diff --git a/src/server/Job.hs b/src/server/Job.hs
deleted file mode 100644
index bf8f15b..0000000
--- a/src/server/Job.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Job
-  ( jobListener
-  ) where
-
-import Data.Time.Clock
-
-import Control.Concurrent (threadDelay)
-
-import Model.Database
-import Model.JobKind
-import Model.Job
-
-jobListener :: JobKind -> (UTCTime -> IO Bool) -> (() -> Persist ()) -> Int -> IO ()
-jobListener kind lastExecutionTooOld runJob msDelay = do
-  mbLastExecution <- runDb $ do
-    actualizeLastCheck kind
-    getLastExecution kind
-  hasToRun <- case mbLastExecution of
-    Just lastExecution -> lastExecutionTooOld lastExecution
-    Nothing -> return True
-  if hasToRun
-    then runDb (runJob () >> actualizeLastExecution kind)
-    else return ()
-  threadDelay msDelay
-  jobListener kind lastExecutionTooOld runJob msDelay
diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs
new file mode 100644
index 0000000..8259b18
--- /dev/null
+++ b/src/server/Job/Daemon.hs
@@ -0,0 +1,40 @@
+module Job.Daemon
+  ( runDaemons
+  ) where
+
+import Data.Time.Clock (UTCTime)
+
+import Control.Concurrent (threadDelay, forkIO, ThreadId)
+import Control.Monad (forever)
+
+import Model.Database
+
+import Job.Kind (Kind(..))
+import Job.Frequency (Frequency(..), microSeconds)
+import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution)
+import Job.MonthlyPayment (monthlyPayment)
+import Job.WeeklyReport (weeklyReport)
+
+import Conf (Conf)
+
+import Utils.Time (belongToCurrentMonth, belongToCurrentWeek)
+
+runDaemons :: Conf -> IO ()
+runDaemons conf = do
+  _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment
+  _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf)
+  return ()
+
+runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId
+runDaemon kind frequency isLastExecutionTooOld runJob =
+  forkIO . forever $ do
+    mbLastExecution <- runDb $ do
+      actualizeLastCheck kind
+      getLastExecution kind
+    hasToRun <- case mbLastExecution of
+      Just lastExecution -> isLastExecutionTooOld lastExecution
+      Nothing -> return True
+    if hasToRun
+      then runJob mbLastExecution >>= (runDb . actualizeLastExecution kind)
+      else return ()
+    threadDelay . microSeconds $ frequency
diff --git a/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs
new file mode 100644
index 0000000..263f6e6
--- /dev/null
+++ b/src/server/Job/Frequency.hs
@@ -0,0 +1,13 @@
+module Job.Frequency
+  ( Frequency(..)
+  , microSeconds
+  ) where
+
+data Frequency =
+  EveryHour
+  | EveryDay
+  deriving (Eq, Read, Show)
+
+microSeconds :: Frequency -> Int
+microSeconds EveryHour = 1000000 * 60 * 60
+microSeconds EveryDay = (microSeconds EveryHour) * 24
diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs
new file mode 100644
index 0000000..473b7c4
--- /dev/null
+++ b/src/server/Job/Kind.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Job.Kind
+  ( Kind(..)
+  ) where
+
+import Database.Persist.TH
+
+data Kind =
+  MonthlyPayment
+  | WeeklyReport
+  deriving (Eq, Show, Read)
+
+derivePersistField "Kind"
diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs
new file mode 100644
index 0000000..cd7297a
--- /dev/null
+++ b/src/server/Job/Model.hs
@@ -0,0 +1,33 @@
+module Job.Model
+  ( getLastExecution
+  , actualizeLastExecution
+  , actualizeLastCheck
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Maybe (isJust)
+
+import Database.Persist
+
+import Model.Database
+
+import Job.Kind
+
+getLastExecution :: Kind -> Persist (Maybe UTCTime)
+getLastExecution kind = do
+  mbJob <- fmap entityVal <$> selectFirst [JobKind ==. kind] []
+  return (mbJob >>= jobLastExecution)
+
+actualizeLastExecution :: Kind -> UTCTime -> Persist ()
+actualizeLastExecution kind time = do
+  jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] []
+  if jobKindDefined
+    then updateWhere [JobKind ==. kind] [JobLastExecution =. Just time]
+    else insert (Job kind (Just time) (Just time)) >> return ()
+
+actualizeLastCheck :: Kind -> Persist ()
+actualizeLastCheck kind = do
+  now <- liftIO getCurrentTime
+  updateWhere [JobKind ==. kind] [JobLastCheck =. Just now]
diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs
new file mode 100644
index 0000000..bac7062
--- /dev/null
+++ b/src/server/Job/MonthlyPayment.hs
@@ -0,0 +1,24 @@
+module Job.MonthlyPayment
+  ( monthlyPayment
+  ) where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Database.Persist (entityVal, insert)
+
+import Model.Database
+import qualified Model.Payment as Payment
+import Model.Frequency
+
+import Utils.Time (timeToDay)
+
+monthlyPayment :: Maybe UTCTime -> IO UTCTime
+monthlyPayment _ = runDb $ do
+  monthlyPayments <- map entityVal <$> Payment.listMonthly
+  now <- liftIO $ getCurrentTime
+  actualDay <- liftIO $ timeToDay now
+  let punctualPayments = map (\p -> p { paymentFrequency = Punctual, paymentDate = actualDay, paymentCreatedAt = now }) monthlyPayments
+  _ <- sequence $ map insert punctualPayments
+  return now
diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs
new file mode 100644
index 0000000..0d1eb35
--- /dev/null
+++ b/src/server/Job/WeeklyReport.hs
@@ -0,0 +1,31 @@
+module Job.WeeklyReport
+  ( weeklyReport
+  ) where
+
+import Data.Time.Clock (UTCTime, getCurrentTime)
+
+import Model.Database (runDb)
+import qualified Model.Payment as Payment
+import qualified Model.Income as Income
+import Model.User (getUsers)
+
+import SendMail
+
+import Conf (Conf)
+
+import View.Mail.WeeklyReport (mail)
+
+weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime
+weeklyReport conf mbLastExecution = do
+  now <- getCurrentTime
+  case mbLastExecution of
+    Nothing -> return ()
+    Just lastExecution -> do
+      (payments, incomes, users) <- runDb $
+        (,,) <$>
+          Payment.modifiedDuring lastExecution now <*>
+          Income.modifiedDuring lastExecution now <*>
+          getUsers
+      _ <- sendMail (mail conf users payments incomes lastExecution now)
+      return ()
+  return now
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 4636674..2ce8115 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -3,14 +3,10 @@
 import Web.Scotty
 
 import Network.Wai.Middleware.Static
-import Network.HTTP.Types.Status (ok200)
 
-import Control.Concurrent (forkIO)
+import Job.Daemon (runDaemons)
 
-import MonthlyPaymentJob (monthlyPaymentJobListener)
-
-import Data.Text (Text)
-import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as LT
 
 import Controller.Index
 import Controller.SignIn
@@ -24,48 +20,41 @@ import qualified Conf
 main :: IO ()
 main = do
   runMigrations
-  _ <- forkIO monthlyPaymentJobListener
-  confOrError <- Conf.getConf "application.conf"
-  case confOrError of
-    Left errorMessage ->
-      T.putStrLn errorMessage
-    Right conf -> do
-      scotty (Conf.port conf) $ do
-        middleware $
-          staticPolicy (noDots >-> addBase "public")
-
-        get "/" $
-          ( do
-              signInToken <- param "signInToken" :: ActionM Text
-              status ok200
-              getIndex conf (Just signInToken)
-          ) `rescue` (\_ -> do
-            status ok200
-            getIndex conf Nothing
-          )
+  conf <- Conf.get "application.conf"
+  _ <- runDaemons conf
+  scotty (Conf.port conf) $ do
+    middleware . staticPolicy $ noDots >-> addBase "public"
 
-        post "/signIn" $ do
-          email <- param "email" :: ActionM Text
-          signIn conf email
+    get "/" $ do
+      signInToken <- mbParam "signInToken"
+      getIndex conf signInToken
 
-        post "/signOut" (signOut conf)
+    post "/signIn" $ do
+      email <- param "email"
+      signIn conf email
 
-        -- Payments
+    post "/signOut" $
+      signOut conf
 
-        post "/payment" $ jsonData >>= Payment.create
+    post "/payment" $
+      jsonData >>= Payment.create
 
-        put "/payment" $ jsonData >>= Payment.editOwn
+    put "/payment" $
+      jsonData >>= Payment.editOwn
 
-        delete "/payment" $ do
-          paymentId <- param "id" :: ActionM Text
-          Payment.deleteOwn paymentId
+    delete "/payment" $ do
+      paymentId <- param "id"
+      Payment.deleteOwn paymentId
 
-        -- Incomes
+    post "/income" $
+      jsonData >>= Income.create
 
-        post "/income" $ jsonData >>= Income.create
+    put "/income" $
+      jsonData >>= Income.editOwn
 
-        put "/income" $ jsonData >>= Income.editOwn
+    delete "/income" $ do
+      incomeId <- param "id"
+      Income.deleteOwn incomeId
 
-        delete "/income" $ do
-          incomeId <- param "id" :: ActionM Text
-          Income.deleteOwn incomeId
+mbParam :: Parsable a => LT.Text -> ActionM (Maybe a)
+mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing)
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 6a2fefe..7f8326e 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -22,8 +22,11 @@ import Data.Int (Int64)
 import Database.Persist.Sqlite
 import Database.Persist.TH
 
+import Resource (Resource, createdAt, editedAt, deletedAt)
+
 import Model.Frequency
-import Model.JobKind
+
+import Job.Kind
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 User
@@ -51,7 +54,7 @@ SignIn
   UniqSignInToken token
   deriving Show
 Job
-  kind JobKind
+  kind Kind
   lastExecution UTCTime Maybe
   lastCheck UTCTime Maybe
   UniqJobName kind
@@ -66,6 +69,16 @@ Income
   deriving Show
 |]
 
+instance Resource Payment where
+  createdAt = paymentCreatedAt
+  editedAt = paymentEditedAt
+  deletedAt = paymentDeletedAt
+
+instance Resource Income where
+  createdAt = incomeCreatedAt
+  editedAt = incomeEditedAt
+  deletedAt = incomeDeletedAt
+
 type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
 
 runDb :: Persist a -> IO a
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index f389661..b7dd11c 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -4,9 +4,10 @@ module Model.Income
   , create
   , editOwn
   , deleteOwn
+  , modifiedDuring
   ) where
 
-import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Calendar (Day)
 
 import Control.Monad.IO.Class (liftIO)
@@ -62,3 +63,12 @@ deleteOwn user incomeId = do
           return False
     Nothing ->
       return False
+
+modifiedDuring :: UTCTime -> UTCTime -> Persist [Income]
+modifiedDuring start end =
+  map entityVal <$> selectList
+    (   [IncomeCreatedAt >=. start, IncomeCreatedAt <. end]
+    ||. [IncomeEditedAt >=. Just start, IncomeEditedAt <. Just end]
+    ||. [IncomeDeletedAt >=. Just start, IncomeDeletedAt <. Just end]
+    )
+    []
diff --git a/src/server/Model/Job.hs b/src/server/Model/Job.hs
deleted file mode 100644
index 5b0d89d..0000000
--- a/src/server/Model/Job.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Model.Job
-  ( getLastExecution
-  , actualizeLastExecution
-  , actualizeLastCheck
-  ) where
-
-import Control.Monad.IO.Class (liftIO)
-
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import Data.Maybe (isJust)
-
-import Database.Persist
-
-import Model.Database
-import Model.JobKind
-
-getLastExecution :: JobKind -> Persist (Maybe UTCTime)
-getLastExecution kind = do
-  mbJob <- fmap entityVal <$> selectFirst [JobKind ==. kind] []
-  return (mbJob >>= jobLastExecution)
-
-actualizeLastExecution :: JobKind -> Persist ()
-actualizeLastExecution kind = do
-  now <- liftIO getCurrentTime
-  jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] []
-  if jobKindDefined
-    then updateWhere [JobKind ==. kind] [JobLastExecution =. Just now]
-    else insert (Job kind (Just now) (Just now)) >> return ()
-
-actualizeLastCheck :: JobKind -> Persist ()
-actualizeLastCheck kind = do
-  now <- liftIO getCurrentTime
-  updateWhere [JobKind ==. kind] [JobLastCheck =. Just now]
diff --git a/src/server/Model/JobKind.hs b/src/server/Model/JobKind.hs
deleted file mode 100644
index bbe1d45..0000000
--- a/src/server/Model/JobKind.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Model.JobKind
-  ( JobKind(..)
-  ) where
-
-import Database.Persist.TH
-
-data JobKind =
-  MonthlyPaymentJob
-  deriving (Eq, Show, Read)
-
-derivePersistField "JobKind"
diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs
index 7c1a6ed..9a4db73 100644
--- a/src/server/Model/Mail.hs
+++ b/src/server/Model/Mail.hs
@@ -3,11 +3,10 @@ module Model.Mail
   ) where
 
 import Data.Text (Text)
-import qualified Data.Text.Lazy as LT
 
 data Mail = Mail
   { from :: Text
   , to :: [Text]
   , subject :: Text
-  , plainBody :: LT.Text
+  , plainBody :: Text
   } deriving (Eq, Show)
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index 0e83e5b..026967f 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -2,6 +2,7 @@ module Model.Message
   ( getMessage
   , getParamMessage
   , getTranslations
+  , plural
   ) where
 
 import Data.Text (Text)
@@ -28,3 +29,7 @@ getTranslation translationKey =
   Translation
     (T.pack . show $ translationKey)
     (getParts $ getNonFormattedMessage lang translationKey)
+
+plural :: Int -> Key -> Key -> Text
+plural count singularKey pluralKey =
+  getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 8deca69..e64cfb5 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -77,7 +77,6 @@ data Key =
 
   | PaymentName
   | PaymentCost
-  | PaymentDate
   | PaymentPunctual
   | PaymentMonthly
 
@@ -101,7 +100,6 @@ data Key =
   | CloneIncome
   | EditIncome
   | IncomeNotDeleted
-  | IncomeDate
   | IncomeAmount
   | ConfirmIncomeDelete
   | Add
@@ -130,6 +128,26 @@ data Key =
   | Confirm
   | Undo
 
+  -- Weekly report
+
+  | WeeklyReport
+  | PaymentCreated
+  | PaymentsCreated
+  | PaymentEdited
+  | PaymentsEdited
+  | PaymentDeleted
+  | PaymentsDeleted
+  | IncomeCreated
+  | IncomesCreated
+  | IncomeEdited
+  | IncomesEdited
+  | IncomeDeleted
+  | IncomesDeleted
+  | PayedFor
+  | DidNotPayFor
+  | IsPayedFrom
+  | IsNotPayedFrom
+
   -- Http error
 
   | Timeout
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index 994a56c..cf11a5e 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -118,63 +118,63 @@ m l SignInEmailSent =
 
 m l January =
   case l of
-    English -> "January"
-    French  -> "Janvier"
+    English -> "january"
+    French  -> "janvier"
 
 m l February =
   case l of
-    English -> "February"
-    French  -> "Février"
+    English -> "february"
+    French  -> "février"
 
 m l March =
   case l of
-    English -> "March"
-    French  -> "Mars"
+    English -> "march"
+    French  -> "mars"
 
 m l April =
   case l of
-    English -> "April"
-    French  -> "Avril"
+    English -> "april"
+    French  -> "avril"
 
 m l May =
   case l of
-    English -> "May"
-    French  -> "Mai"
+    English -> "may"
+    French  -> "mai"
 
 m l June =
   case l of
-    English -> "June"
-    French  -> "Juin"
+    English -> "june"
+    French  -> "juin"
 
 m l July =
   case l of
-    English -> "July"
-    French  -> "Juillet"
+    English -> "july"
+    French  -> "juillet"
 
 m l August =
   case l of
-    English -> "August"
-    French  -> "Août"
+    English -> "august"
+    French  -> "août"
 
 m l September =
   case l of
-    English -> "September"
-    French  -> "Septembre"
+    English -> "september"
+    French  -> "septembre"
 
 m l October =
   case l of
-    English -> "October"
-    French  -> "Octobre"
+    English -> "october"
+    French  -> "octobre"
 
 m l November =
   case l of
-    English -> "November"
-    French  -> "Novembre"
+    English -> "november"
+    French  -> "novembre"
 
 m l December =
   case l of
-    English -> "December"
-    French  -> "Décembre"
+    English -> "december"
+    French  -> "décembre"
 
 m l ShortDate =
   case l of
@@ -322,11 +322,6 @@ m l PaymentCost =
     English -> "Cost"
     French  -> "Coût"
 
-m l PaymentDate =
-  case l of
-    English -> "Date"
-    French  -> "Date"
-
 m l PaymentPunctual =
   case l of
     English -> "Punctual"
@@ -371,7 +366,7 @@ m l Income =
 
 m l MonthlyNetIncomes =
   case l of
-    English -> "Monthly incomes"
+    English -> "Net monthly incomes"
     French  -> "Revenus mensuels nets"
 
 m l AddIncome =
@@ -394,11 +389,6 @@ m l IncomeNotDeleted =
     English -> "The income could not have been deleted."
     French  -> "Le revenu n'a pas pu être supprimé."
 
-m l IncomeDate =
-  case l of
-    English -> "Date"
-    French  -> "Date"
-
 m l IncomeAmount =
   case l of
     English -> "Amount"
@@ -495,6 +485,93 @@ m l Undo =
     English -> "Undo"
     French  -> "Annuler"
 
+-- Weekly report
+
+m l WeeklyReport =
+  case l of
+    English -> "Weekly report"
+    French  -> "Rapport hebdomadaire"
+
+m l PaymentCreated =
+  case l of
+    English -> "{1} payment created:"
+    French  -> "{1} paiement créé :"
+
+m l PaymentsCreated =
+  case l of
+    English -> "{1} payments created:"
+    French  -> "{1} paiements créés :"
+
+m l PaymentEdited =
+  case l of
+    English -> "{1} payment edited:"
+    French  -> "{1} paiement modifié :"
+
+m l PaymentsEdited =
+  case l of
+    English -> "{1} payments edited:"
+    French  -> "{1} paiements modifiés :"
+
+m l PaymentDeleted =
+  case l of
+    English -> "{1} payment deleted:"
+    French  -> "{1} paiement supprimé :"
+
+m l PaymentsDeleted =
+  case l of
+    English -> "{1} payments deleted:"
+    French  -> "{1} paiements supprimés :"
+
+m l IncomeCreated =
+  case l of
+    English -> "{1} income created:"
+    French  -> "{1} revenu créé :"
+
+m l IncomesCreated =
+  case l of
+    English -> "{1} incomes created:"
+    French  -> "{1} revenus créés :"
+
+m l IncomeEdited =
+  case l of
+    English -> "{1} income edited:"
+    French  -> "{1} revenu modifié :"
+
+m l IncomesEdited =
+  case l of
+    English -> "{1} incomes edited:"
+    French  -> "{1} revenus modifiés :"
+
+m l IncomeDeleted =
+  case l of
+    English -> "{1} income deleted:"
+    French  -> "{1} revenu supprimé :"
+
+m l IncomesDeleted =
+  case l of
+    English -> "{1} incomes deleted:"
+    French  -> "{1} revenus supprimés :"
+
+m l PayedFor =
+  case l of
+    English -> "{1} payed {2} for “{3}” at {4}"
+    French  -> "{1} a payé {2} concernant « {3} » le {4}"
+
+m l DidNotPayFor =
+  case l of
+    English -> "{1} didn't pay {2} for “{3}” at {4}"
+    French  -> "{1} n'a pas payé {2} concernant « {3} » le {4}"
+
+m l IsPayedFrom =
+  case l of
+    English -> "{1} is payed {2} of net monthly income from {3}"
+    French  -> "{1} est payé {2} net par mois à partir du {3}"
+
+m l IsNotPayedFrom =
+  case l of
+    English -> "{1} isn't payed {2} of net monthly income from {3}"
+    French  -> "{1} n'est pas payé {2} net par mois à partir du {3}"
+
 -- Http error
 
 m l Timeout =
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 0d5e188..ac6cf0a 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -6,9 +6,11 @@ module Model.Payment
   , create
   , editOwn
   , deleteOwn
+  , modifiedDuring
   ) where
 
 import Data.Text (Text)
+import Data.Time (UTCTime)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Calendar (Day)
 
@@ -86,3 +88,12 @@ deleteOwn userId paymentId = do
           return False
     Nothing ->
       return False
+
+modifiedDuring :: UTCTime -> UTCTime -> Persist [Payment]
+modifiedDuring start end =
+  map entityVal <$> selectList
+    (   [PaymentFrequency ==. Punctual, PaymentCreatedAt >=. start, PaymentCreatedAt <. end]
+    ||. [PaymentFrequency ==. Punctual, PaymentEditedAt >=. Just start, PaymentEditedAt <. Just end]
+    ||. [PaymentFrequency ==. Punctual, PaymentDeletedAt >=. Just start, PaymentDeletedAt <. Just end]
+    )
+    []
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
index 2b52d03..696ef4f 100644
--- a/src/server/Model/User.hs
+++ b/src/server/Model/User.hs
@@ -1,6 +1,7 @@
 module Model.User
   ( getUsers
   , getUser
+  , findUser
   , getJsonUser
   , createUser
   , deleteUser
@@ -8,6 +9,7 @@ module Model.User
 
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
+import Data.List (find)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -22,6 +24,9 @@ getUsers = selectList [] [Desc UserCreation]
 getUser :: Text -> Persist (Maybe (Entity User))
 getUser email = selectFirst [UserEmail ==. email] []
 
+findUser :: UserId -> [Entity User] -> Maybe User
+findUser i = fmap entityVal . find ((==) i . entityKey)
+
 getJsonUser :: Entity User -> Json.User
 getJsonUser userEntity =
   let user = entityVal userEntity
diff --git a/src/server/MonthlyPaymentJob.hs b/src/server/MonthlyPaymentJob.hs
deleted file mode 100644
index c4022c9..0000000
--- a/src/server/MonthlyPaymentJob.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module MonthlyPaymentJob
-  ( monthlyPaymentJobListener
-  ) where
-
-import Control.Monad.IO.Class (liftIO)
-
-import Data.Time.Clock
-
-import Database.Persist (entityVal, insert)
-
-import Job (jobListener)
-
-import Model.Database
-import qualified Model.Payment as Payment
-import Model.JobKind
-import Model.Frequency
-
-import Utils.Time (belongToCurrentMonth, timeToDay)
-
-monthlyPaymentJobListener :: IO ()
-monthlyPaymentJobListener =
-  let lastExecutionTooOld = fmap not . belongToCurrentMonth
-      runJob () = monthlyPaymentJob
-      msDelay = 1000000 * 60 * 60
-  in  jobListener MonthlyPaymentJob lastExecutionTooOld runJob msDelay
-
-monthlyPaymentJob :: Persist ()
-monthlyPaymentJob = do
-  monthlyPayments <- map entityVal <$> Payment.listMonthly
-  now <- liftIO $ getCurrentTime
-  actualDay <- liftIO $ timeToDay now
-  let punctualPayments = map (\p -> p { paymentFrequency = Punctual, paymentDate = actualDay, paymentCreatedAt = now }) monthlyPayments
-  sequence_ $ map insert punctualPayments
diff --git a/src/server/Resource.hs b/src/server/Resource.hs
new file mode 100644
index 0000000..4dd8615
--- /dev/null
+++ b/src/server/Resource.hs
@@ -0,0 +1,50 @@
+module Resource
+  ( Resource
+  , createdAt
+  , editedAt
+  , deletedAt
+  , Status(..)
+  , groupByStatus
+  , statusDuring
+  ) where
+
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Time.Clock (UTCTime)
+
+class Resource a where
+  createdAt :: a -> UTCTime
+  editedAt :: a -> Maybe UTCTime
+  deletedAt :: a -> Maybe UTCTime
+
+data Status =
+  Created
+  | Edited
+  | Deleted
+  deriving (Eq, Show, Read, Ord)
+
+groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a]
+groupByStatus start end resources =
+  foldl
+    (\m resource ->
+      case statusDuring start end resource of
+        Just status -> M.insertWith (++) status [resource] m
+        Nothing -> m
+    )
+    M.empty
+    resources
+
+statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status
+statusDuring start end resource
+  | created && not deleted = Just Created
+  | not created && edited && not deleted = Just Edited
+  | not created && deleted = Just Deleted
+  | otherwise = Nothing
+  where
+    created = belongs (createdAt resource) start end
+    edited = fromMaybe False (fmap (\t -> belongs t start end) $ editedAt resource)
+    deleted = fromMaybe False (fmap (\t -> belongs t start end) $ deletedAt resource)
+
+belongs :: UTCTime -> UTCTime -> UTCTime -> Bool
+belongs time start end = time >= start && time < end
diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs
index 7d537fc..e434b38 100644
--- a/src/server/SendMail.hs
+++ b/src/server/SendMail.hs
@@ -7,6 +7,8 @@ module SendMail
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Either (isLeft)
+import qualified Data.Text.Lazy as LT
+import Data.Text.Lazy.Builder (toLazyText, fromText)
 
 import Control.Exception (SomeException, try)
 import Control.Arrow (left)
@@ -28,7 +30,7 @@ getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) =
   let fromMail = M.emptyMail (address mailFrom)
   in  fromMail
         { M.mailTo = map address mailTo
-        , M.mailParts = [ [ M.plainPart mailPlainBody ] ]
+        , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ]
         , M.mailHeaders = [("Subject", mailSubject)]
         }
 
@@ -38,3 +40,6 @@ address addressEmail =
     { M.addressName = Nothing
     , M.addressEmail = addressEmail
     }
+
+strictToLazy :: Text -> LT.Text
+strictToLazy = toLazyText . fromText
diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs
index 170ab36..4a247e9 100644
--- a/src/server/Utils/Time.hs
+++ b/src/server/Utils/Time.hs
@@ -1,22 +1,44 @@
 module Utils.Time
   ( belongToCurrentMonth
+  , belongToCurrentWeek
   , timeToDay
+  , monthToKey
   ) where
 
-import Data.Time.Clock
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.LocalTime
 import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate (toWeekDate)
+
+import Model.Message.Key (Key)
+import qualified Model.Message.Key as K
 
 belongToCurrentMonth :: UTCTime -> IO Bool
 belongToCurrentMonth time = do
-  timeMonth <- dayMonth <$> timeToDay time
-  actualMonth <- dayMonth <$> (getCurrentTime >>= timeToDay)
-  return (timeMonth == actualMonth)
+  (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time
+  (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay)
+  return (actualYear == timeYear && actualMonth == timeMonth)
+
+belongToCurrentWeek :: UTCTime -> IO Bool
+belongToCurrentWeek time = do
+  (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time
+  (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay)
+  return (actualYear == timeYear && actualWeek == timeWeek)
 
 timeToDay :: UTCTime -> IO Day
 timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time
 
-dayMonth :: Day -> Int
-dayMonth day =
-  let (_, month, _) = toGregorian day
-  in  month
+monthToKey :: Int -> Maybe Key
+monthToKey 1  = Just K.January
+monthToKey 2  = Just K.February
+monthToKey 3  = Just K.March
+monthToKey 4  = Just K.April
+monthToKey 5  = Just K.May
+monthToKey 6  = Just K.June
+monthToKey 7  = Just K.July
+monthToKey 8  = Just K.August
+monthToKey 9  = Just K.September
+monthToKey 10 = Just K.October
+monthToKey 11 = Just K.November
+monthToKey 12 = Just K.December
+monthToKey _ = Nothing
diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs
new file mode 100644
index 0000000..354d46a
--- /dev/null
+++ b/src/server/View/Format.hs
@@ -0,0 +1,33 @@
+{-# 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 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
+    ]
-- 
cgit v1.2.3