aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs3
-rw-r--r--src/Model/Birthdate.hs6
-rw-r--r--src/Model/Date.hs19
-rw-r--r--src/Model/Mail.hs77
-rw-r--r--src/Notification.hs38
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 []