Get next week birthdays and send an empty mail for the moment

14 files changed, 182 insertions, 109 deletions

diff --git a/.gitignore b/.gitignore
index 2a63a4c..22c0c69 100644
--- a/.gitignore
+++ b/.gitignore
@@ -4,3 +4,4 @@ cabal.sandbox.config
 dist
 config.txt
 deploy
+logs
diff --git a/README.md b/README.md
index 5fa517b..cd90214 100644
--- a/README.md
+++ b/README.md
@@ -1,8 +1,10 @@
 Birthday
 ========
 
-Notify by email if there is a birthday today. Birthdates are parsed from
-birthdates.csv:
+Notify by email if there is a birthday today. This program is intended to be
+launched everyday.
+
+Create birthdates.csv which stores birthdates:
 
 ```
 23 Oct 1982, Jean, Dupont
@@ -16,6 +18,7 @@ Create config.txt:
 ```
 mail-to = john.dupont@mail.com
 mail-from = no-reply@service.com
+day-for-next-week-notification = Friday
 ```
 
 The usage is as follow:
diff --git a/logs b/logs
deleted file mode 100644
index 3269e69..0000000
--- a/logs
+++ /dev/null
@@ -1,2 +0,0 @@
-[21/11/2015] - Sending mail to joris.guyonvarch@gmail.com with subject “Hey, there is 1 birthday today!” and body “Alain Noe is now 19 years old.”
-[21/11/2015, 18:55] - Sending mail to joris.guyonvarch@gmail.com with subject “Hey, there is 1 birthday today!” and body “Alain Noe is now 19 years old.”
diff --git a/src/Logger.hs b/src/Logger.hs
index 4be55be..6faa482 100644
--- a/src/Logger.hs
+++ b/src/Logger.hs
@@ -7,12 +7,12 @@ module Logger
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T (appendFile)
-import Data.Time.LocalTime (getZonedTime)
-import Data.Time.Format (formatTime, defaultTimeLocale)
+
+import Time (formatCurrentLocale)
 
 info :: Text -> IO ()
 info message = do
-  time <- T.pack <$> formatTime defaultTimeLocale "[%d/%m/%Y, %H:%M]" <$> getZonedTime
+  time <- formatCurrentLocale "[%d/%m/%Y, %H:%M]"
   T.appendFile "logs" $
     T.concat
       [ time
diff --git a/src/Main.hs b/src/Main.hs
index 0aa2910..e3bd0ce 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,67 +4,24 @@ module Main
   ( main
   ) where
 
-import System.IO (stderr)
-
-import Data.Text (Text)
-import qualified Data.Text as T
 import qualified Data.Text.IO as T
 
-import Date (getCurrentDate)
-import Birthdate (Birthdate, filterBirthdayAt)
-import BirthdateParser (parseBirthdates)
-import Mail (mailSubject, mailBody)
-import SendMail (sendMail)
-import Config
-
-birthdatePath :: FilePath
-birthdatePath = "birthdates.csv"
+import qualified RenderError
+import qualified Notification
 
-configPath :: FilePath
-configPath = "config.txt"
+import Model.Config
+import Model.BirthdateParser (parseBirthdates)
+import qualified Model.Path as Path
 
 main :: IO ()
 main = do
-  eitherBirthdates <- parseBirthdates <$> T.readFile birthdatePath
-  eitherConfig <- getConfig configPath
+  eitherBirthdates <- parseBirthdates <$> T.readFile Path.birthdate
+  eitherConfig <- getConfig Path.config
   case (eitherBirthdates, eitherConfig) of
     (Left err, _) ->
-      birthdateError err
+      RenderError.birthdate err
     (_, Left err) ->
-      configError err
-    (Right birthdates, Right config) ->
-      sendNotificationForBirthdayToday birthdates config
-
-birthdateError :: Text -> IO ()
-birthdateError err =
-  T.hPutStr stderr $
-    T.concat
-      [ "Error while parsing file "
-      , T.pack birthdatePath
-      , ":\n"
-      , err
-      ]
-
-configError :: Text -> IO ()
-configError err =
-  T.hPutStr stderr $
-    T.concat
-      [ "Error while parsing config file "
-      , T.pack configPath
-      , ":\n"
-      , err
-      ]
-
-sendNotificationForBirthdayToday :: [Birthdate] -> Config -> IO ()
-sendNotificationForBirthdayToday birthdates config = do
-  currentDate <- getCurrentDate
-  let birthdays = filterBirthdayAt currentDate birthdates
-  if not (null birthdays)
-    then
-      sendMail
-        (mailTo config)
-        (mailFrom config)
-        (mailSubject birthdays)
-        (mailBody currentDate birthdays)
-    else
-      return ()
+      RenderError.config err
+    (Right birthdates, Right config) -> do
+      Notification.today birthdates config
+      Notification.nextWeek birthdates config
diff --git a/src/Birthdate.hs b/src/Model/Birthdate.hs
index 48d3a4e..d135419 100644
--- a/src/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -1,16 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Birthdate
+module Model.Birthdate
   ( Birthdate(..)
   , fullname
   , age
   , filterBirthdayAt
+  , filterBirthdayBetween
   ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
 
-import Date
+import Model.Date
 
 data Birthdate = Birthdate
   { date :: Date
diff --git a/src/BirthdateParser.hs b/src/Model/BirthdateParser.hs
index 9fa7c50..c9ac3b9 100644
--- a/src/BirthdateParser.hs
+++ b/src/Model/BirthdateParser.hs
@@ -1,4 +1,4 @@
-module BirthdateParser
+module Model.BirthdateParser
   ( parseBirthdates
   ) where
 
@@ -9,8 +9,8 @@ import qualified Data.Text as T
 
 import Text.ParserCombinators.Parsec
 
-import Birthdate
-import Date
+import Model.Birthdate
+import Model.Date
 
 parseBirthdates :: Text -> Either Text [Birthdate]
 parseBirthdates input =
diff --git a/src/Config.hs b/src/Model/Config.hs
index c01bbe1..b583048 100644
--- a/src/Config.hs
+++ b/src/Model/Config.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module Config
+module Model.Config
   ( getConfig
   , Config(..)
   ) where
@@ -14,19 +14,19 @@ import Control.Monad.Trans.Error (runErrorT)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad (join)
 import Control.Arrow (left)
-import Control.Applicative (liftA2)
 
 data Config = Config
   { mailTo :: Text
   , mailFrom :: Text
+  , dayForNextWeekNotification :: Text
   } deriving (Read, Eq, Show)
 
 getConfig :: FilePath -> IO (Either Text Config)
 getConfig filePath =
   left (T.pack . show) <$> (runErrorT $ do
     cp <- join $ liftIO $ readfile emptyCP filePath
-    liftA2
-      Config
-      (T.pack <$> get cp "DEFAULT" "mail-to")
-      (T.pack <$> get cp "DEFAULT" "mail-from")
+    Config <$>
+      (T.pack <$> get cp "DEFAULT" "mail-to") <*>
+      (T.pack <$> get cp "DEFAULT" "mail-from") <*>
+      (T.pack <$> get cp "DEFAULT" "day-for-next-week-notification")
   )
diff --git a/src/Date.hs b/src/Model/Date.hs
index 63830d3..96c15e9 100644
--- a/src/Date.hs
+++ b/src/Model/Date.hs
@@ -1,6 +1,10 @@
-module Date
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Date
   ( Date(..)
   , getCurrentDate
+  , getNextWeek
+  , plusDays
   , sameDayAndMonth
   , isBeforeOrEqualDayAndMonth
   , isAfterOrEqualDayAndMonth
@@ -10,6 +14,9 @@ module Date
 import Data.Time.Clock
 import Data.Time.Calendar
 import Data.Time.LocalTime
+import qualified Data.Text as T
+
+import Time (formatCurrentLocale)
 
 data Date = Date
   { day :: Int
@@ -22,8 +29,24 @@ getCurrentDate = do
   now <- getCurrentTime
   timezone <- getCurrentTimeZone
   let zoneNow = utcToLocalTime timezone now
-  let (y, m, d) = toGregorian $ localDay zoneNow
-  return $ Date d m (fromIntegral y)
+  return . dateFromDay $ localDay zoneNow
+
+getNextWeek :: IO (Date, Date)
+getNextWeek = do
+  currentDate <- getCurrentDate
+  currentDayNumberOfWeek <- (read . T.unpack <$> formatCurrentLocale "%u") :: IO Int
+  let begin = currentDate `plusDays` (8 - currentDayNumberOfWeek)
+  let end = begin `plusDays` 6
+  return (begin, end)
+
+plusDays :: Date -> Int -> Date
+plusDays (Date d m y) n =
+  dateFromDay . addDays (toInteger n) $ fromGregorian (toInteger y) m d
+
+dateFromDay :: Day -> Date
+dateFromDay dayTime =
+  let (y, m, d) = toGregorian dayTime
+  in  Date d m (fromIntegral y)
 
 sameDayAndMonth :: Date -> Date -> Bool
 sameDayAndMonth d1 d2 =
diff --git a/src/Mail.hs b/src/Model/Mail.hs
index dc533ef..e730e32 100644
--- a/src/Mail.hs
+++ b/src/Model/Mail.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Mail
+module Model.Mail
   ( mailSubject
   , mailBody
   ) where
@@ -8,8 +8,8 @@ module Mail
 import Data.Text (Text)
 import qualified Data.Text as T
 
-import Date
-import Birthdate
+import Model.Date
+import Model.Birthdate
 
 mailSubject :: [Birthdate] -> Text
 mailSubject birthdates =
@@ -26,14 +26,15 @@ mailSubject birthdates =
 
 mailBody :: Date -> [Birthdate] -> Text
 mailBody currentDate birthdates =
+  T.concat $ map (mailLine currentDate) (attachLines birthdates)
+
+attachLines :: [Birthdate] -> [(Line, Birthdate)]
+attachLines birthdates =
   let count = length birthdates
-      birthdatesWithLines = map (mapFst lineKind) . zip [1..] $ birthdates
       lineKind 1 = if count == 1 then SingleLine else FirstLine
       lineKind line = if line == count then LastLine else MiddleLine
-  in  T.concat $ map (mailLine currentDate) birthdatesWithLines
-
-mapFst :: (a -> c) -> (a, b) -> (c, b)
-mapFst f (x, y) = (f x, y)
+      mapFst f (x, y) = (f x, y)
+  in  map (mapFst lineKind) . zip [1..] $ birthdates
 
 data Line =
   SingleLine
@@ -43,33 +44,17 @@ data Line =
   deriving (Eq, Show)
 
 mailLine :: Date -> (Line, Birthdate) -> Text
-mailLine currDate (SingleLine, birthdate) =
+mailLine currDate (line, birthdate) =
   T.concat
-    [ fullname birthdate
-    , " is now "
-    , T.pack . show $ age currDate birthdate
-    , " years old."
-    ]
-mailLine currDate (FirstLine, birthdate) =
-  T.concat
-    [ fullname birthdate
-    , " is now "
-    , T.pack . show $ age currDate birthdate
-    , " years old"
-    ]
-mailLine currDate (MiddleLine, birthdate) =
-  T.concat
-    [ ", "
+    [ case line of
+        MiddleLine -> ", "
+        LastLine -> " and "
+        _ -> ""
     , fullname birthdate
-    , " is "
+    , case line of
+        x | x `elem` [SingleLine, FirstLine] -> " is now "
+        _ -> " is "
     , T.pack . show $ age currDate birthdate
     , " years old"
-    ]
-mailLine currDate (LastLine, birthdate) =
-  T.concat
-    [ " and "
-    , fullname birthdate
-    , " is "
-    , T.pack . show $ age currDate birthdate
-    , " years old."
+    , if line == LastLine then "." else ""
     ]
diff --git a/src/Model/Path.hs b/src/Model/Path.hs
new file mode 100644
index 0000000..d34716c
--- /dev/null
+++ b/src/Model/Path.hs
@@ -0,0 +1,10 @@
+module Model.Path
+  ( birthdate
+  , config
+  ) where
+
+birthdate :: FilePath
+birthdate = "birthdates.csv"
+
+config :: FilePath
+config = "config.txt"
diff --git a/src/Notification.hs b/src/Notification.hs
new file mode 100644
index 0000000..de4a591
--- /dev/null
+++ b/src/Notification.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Notification
+  ( today
+  , nextWeek
+  ) where
+
+import qualified Data.Text as T
+
+import SendMail (sendMail)
+import Time (formatCurrentLocale)
+
+import Model.Date (getCurrentDate, getNextWeek)
+import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayBetween)
+import Model.Mail (mailSubject, mailBody)
+import Model.Config
+
+today :: [Birthdate] -> Config -> IO ()
+today birthdates config = do
+  currentDate <- getCurrentDate
+  let birthdays = filterBirthdayAt currentDate birthdates
+  if not (null birthdays)
+    then
+      sendMail
+        (mailTo config)
+        (mailFrom config)
+        (mailSubject birthdays)
+        (mailBody currentDate birthdays)
+    else
+      return ()
+
+nextWeek :: [Birthdate] -> Config -> IO ()
+nextWeek birthdates config = do
+  currentDayOfWeek <- formatCurrentLocale "%A"
+  if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config)
+    then do
+      (begin, end) <- getNextWeek
+      let birthdays = filterBirthdayBetween begin end birthdates
+      if not (null birthdays)
+        then
+          sendMail
+            (mailTo config)
+            (mailFrom config)
+            ""
+            ""
+        else
+          return ()
+    else
+      return ()
diff --git a/src/RenderError.hs b/src/RenderError.hs
new file mode 100644
index 0000000..9b9732f
--- /dev/null
+++ b/src/RenderError.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RenderError
+  ( birthdate
+  , config
+  ) where
+
+import System.IO (stderr)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+import qualified Model.Path as Path
+
+birthdate :: Text -> IO ()
+birthdate err =
+  T.hPutStr stderr $
+    T.concat
+      [ "Error while parsing file "
+      , T.pack Path.birthdate
+      , ":\n"
+      , err
+      ]
+
+config :: Text -> IO ()
+config err =
+  T.hPutStr stderr $
+    T.concat
+      [ "Error while parsing config file "
+      , T.pack Path.config
+      , ":\n"
+      , err
+      ]
diff --git a/src/Time.hs b/src/Time.hs
new file mode 100644
index 0000000..97a9317
--- /dev/null
+++ b/src/Time.hs
@@ -0,0 +1,12 @@
+module Time
+  ( formatCurrentLocale
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.LocalTime (getZonedTime)
+import Data.Time.Format (formatTime, defaultTimeLocale)
+
+formatCurrentLocale :: Text -> IO Text
+formatCurrentLocale format =
+  T.pack <$> formatTime defaultTimeLocale (T.unpack format) <$> getZonedTime