Generate a mail that contains both birthdays today and birthdays next week

5 files changed, 91 insertions, 52 deletions

diff --git a/src/Main.hs b/src/Main.hs
index e3bd0ce..b2b0408 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -23,5 +23,4 @@ main = do
     (_, Left err) ->
       RenderError.config err
     (Right birthdates, Right config) -> do
-      Notification.today birthdates config
-      Notification.nextWeek birthdates config
+      Notification.todayAndNextWeek birthdates config
diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs
index d135419..32bd6a4 100644
--- a/src/Model/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -25,6 +25,10 @@ fullname d = T.concat [firstname d, " ", lastname d]
 age :: Date -> Birthdate -> Int
 age currentDate birthdate = yearsGap currentDate (date birthdate)
 
+ageNextWeek :: Date -> Birthdate -> Int
+ageNextWeek currentDate birthdate =
+  (+1) $ (daysGap currentDate (date birthdate)) `div` 365
+
 filterBirthdayAt :: Date -> [Birthdate] -> [Birthdate]
 filterBirthdayAt d = filter (sameDayAndMonth d . date)
 
@@ -32,7 +36,7 @@ filterBirthdayBetween :: Date -> Date -> [Birthdate] -> [Birthdate]
 filterBirthdayBetween begin end =
   filter (\bd ->
     let d = date bd
-    in  (  d `isAfterOrEqualDayAndMonth` begin
+    in  (  begin `isBeforeOrEqualDayAndMonth` d
         && d `isBeforeOrEqualDayAndMonth` end
         )
   )
diff --git a/src/Model/Date.hs b/src/Model/Date.hs
index 96c15e9..e095cc6 100644
--- a/src/Model/Date.hs
+++ b/src/Model/Date.hs
@@ -7,8 +7,8 @@ module Model.Date
   , plusDays
   , sameDayAndMonth
   , isBeforeOrEqualDayAndMonth
-  , isAfterOrEqualDayAndMonth
   , yearsGap
+  , daysGap
   ) where
 
 import Data.Time.Clock
@@ -40,8 +40,10 @@ getNextWeek = do
   return (begin, end)
 
 plusDays :: Date -> Int -> Date
-plusDays (Date d m y) n =
-  dateFromDay . addDays (toInteger n) $ fromGregorian (toInteger y) m d
+plusDays date n = dateFromDay . addDays (toInteger n) . dateToDay $ date
+
+dateToDay :: Date -> Day
+dateToDay (Date d m y) = fromGregorian (toInteger y) m d
 
 dateFromDay :: Day -> Date
 dateFromDay dayTime =
@@ -62,13 +64,8 @@ isBeforeOrEqualDayAndMonth d1 d2 =
      )
   )
 
-isAfterOrEqualDayAndMonth :: Date -> Date -> Bool
-isAfterOrEqualDayAndMonth d1 d2 =
-  (  month d1 > month d2
-  || (  month d1 == month d2
-     && day d1 >= day d2
-     )
-  )
-
 yearsGap :: Date -> Date -> Int
 yearsGap d1 d2 = abs (year d2 - year d1)
+
+daysGap :: Date -> Date -> Int
+daysGap d1 d2 = abs . fromIntegral $ (dateToDay d1) `diffDays` (dateToDay d2)
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
index e730e32..19ebaeb 100644
--- a/src/Model/Mail.hs
+++ b/src/Model/Mail.hs
@@ -11,22 +11,62 @@ import qualified Data.Text as T
 import Model.Date
 import Model.Birthdate
 
-mailSubject :: [Birthdate] -> Text
-mailSubject birthdates =
+data Event =
+  Today
+  | NextWeek
+  deriving (Eq, Show)
+
+mailSubject :: [Birthdate] -> [Birthdate] -> Text
+mailSubject birthdaysToday birthdaysNextWeek =
+  T.concat
+    [ "Hey, "
+    , if length birthdaysToday > 0
+        then mailSubjectSentence Today birthdaysToday
+        else ""
+    , if length birthdaysNextWeek > 0
+        then
+          T.concat
+            [ if length birthdaysToday > 0 then " and " else ""
+            , mailSubjectSentence NextWeek birthdaysNextWeek
+            ]
+        else
+          ""
+    , "!"
+    ]
+
+mailSubjectSentence :: Event -> [Birthdate] -> Text
+mailSubjectSentence event birthdates =
   let count = length birthdates
   in  T.concat
-        [ "Hey, "
-        , if count > 1 then "there are" else "there is"
+        [ case event of
+            Today -> if count > 1 then "there are" else "there is"
+            NextWeek -> "there will be"
         , " "
         , T.pack . show $ count
         , " birthday"
         , if count > 1 then "s" else ""
-        , " today!"
+        , " "
+        , if event == Today then "today" else "next week"
         ]
 
-mailBody :: Date -> [Birthdate] -> Text
-mailBody currentDate birthdates =
-  T.concat $ map (mailLine currentDate) (attachLines birthdates)
+mailBody :: Date -> [Birthdate] -> [Birthdate] -> Text
+mailBody currentDate birthdaysToday birthdaysNextWeek =
+  T.concat
+    [ if length birthdaysToday > 0
+        then mailBodySentence Today currentDate birthdaysToday
+        else ""
+    , if length birthdaysNextWeek > 0
+        then
+          T.concat
+            [ if length birthdaysToday > 0 then " " else ""
+            , mailBodySentence NextWeek currentDate birthdaysNextWeek
+            ]
+        else ""
+    ]
+
+mailBodySentence :: Event -> Date -> [Birthdate] -> Text
+mailBodySentence event currentDate birthdates =
+  T.concat $ map (mailBodyPart event currentDate) (attachLines birthdates)
 
 attachLines :: [Birthdate] -> [(Line, Birthdate)]
 attachLines birthdates =
@@ -43,18 +83,21 @@ data Line =
   | LastLine
   deriving (Eq, Show)
 
-mailLine :: Date -> (Line, Birthdate) -> Text
-mailLine currDate (line, birthdate) =
+mailBodyPart :: Event -> Date -> (Line, Birthdate) -> Text
+mailBodyPart event currDate (line, birthdate) =
   T.concat
     [ case line of
-        MiddleLine -> ", "
-        LastLine -> " and "
-        _ -> ""
+        x | x `elem` [SingleLine, FirstLine] ->
+          if event == Today then "Today, " else "Next week, "
+        MiddleLine ->
+          ", "
+        LastLine ->
+          " and "
+        _ ->
+          ""
     , fullname birthdate
-    , case line of
-        x | x `elem` [SingleLine, FirstLine] -> " is now "
-        _ -> " is "
+    , if event == Today then " is " else " will be "
     , T.pack . show $ age currDate birthdate
     , " years old"
-    , if line == LastLine then "." else ""
+    , if line == SingleLine || line == LastLine then "." else ""
     ]
diff --git a/src/Notification.hs b/src/Notification.hs
index de4a591..e5abe45 100644
--- a/src/Notification.hs
+++ b/src/Notification.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Notification
-  ( today
-  , nextWeek
+  ( todayAndNextWeek
   ) where
 
 import qualified Data.Text as T
@@ -15,35 +14,32 @@ import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayBetween)
 import Model.Mail (mailSubject, mailBody)
 import Model.Config
 
-today :: [Birthdate] -> Config -> IO ()
-today birthdates config = do
+todayAndNextWeek :: [Birthdate] -> Config -> IO ()
+todayAndNextWeek birthdates config = do
   currentDate <- getCurrentDate
-  let birthdays = filterBirthdayAt currentDate birthdates
-  if not (null birthdays)
+  birthdaysToday <- filterBirthdaysToday birthdates
+  birthdaysNextWeek <- filterBirthdaysNextWeek birthdates config
+  if length birthdaysToday > 0 || length birthdaysNextWeek > 0
     then
       sendMail
         (mailTo config)
         (mailFrom config)
-        (mailSubject birthdays)
-        (mailBody currentDate birthdays)
+        (mailSubject birthdaysToday birthdaysNextWeek)
+        (mailBody currentDate birthdaysToday birthdaysNextWeek)
     else
       return ()
 
-nextWeek :: [Birthdate] -> Config -> IO ()
-nextWeek birthdates config = do
+filterBirthdaysToday :: [Birthdate] -> IO [Birthdate]
+filterBirthdaysToday birthdates = do
+  currentDate <- getCurrentDate
+  return (filterBirthdayAt currentDate birthdates)
+
+filterBirthdaysNextWeek :: [Birthdate] -> Config -> IO [Birthdate]
+filterBirthdaysNextWeek 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 ()
+      return (filterBirthdayBetween begin end birthdates)
     else
-      return ()
+      return []