aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Model/Birthdate.hs18
-rw-r--r--src/Model/Date.hs15
-rw-r--r--src/Model/Mail.hs71
-rw-r--r--src/Notification.hs32
4 files changed, 62 insertions, 74 deletions
diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs
index f871860..96783a7 100644
--- a/src/Model/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -5,13 +5,13 @@ module Model.Birthdate
, renderBirthdate
, fullname
, age
- , ageNextWeek
, filterBirthdayAt
- , filterBirthdayBetween
+ , filterBirthdayInside
) where
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Maybe (isJust)
import Model.Date
@@ -36,18 +36,8 @@ 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)
-filterBirthdayBetween :: Date -> Date -> [Birthdate] -> [Birthdate]
-filterBirthdayBetween begin end =
- filter (\bd ->
- let d = date bd
- in ( begin `isBeforeOrEqualDayAndMonth` d
- && d `isBeforeOrEqualDayAndMonth` end
- )
- )
+filterBirthdayInside :: [Date] -> [Birthdate] -> [Birthdate]
+filterBirthdayInside dates = filter (isJust . dayAndMonthInRange dates . date)
diff --git a/src/Model/Date.hs b/src/Model/Date.hs
index 081dccc..dd8a09f 100644
--- a/src/Model/Date.hs
+++ b/src/Model/Date.hs
@@ -2,12 +2,14 @@
module Model.Date
( Date(..)
+ , SuccessiveDates
, renderDate
, getCurrentDate
, getNextWeek
, getWeekDay
, plusDays
, sameDayAndMonth
+ , dayAndMonthInRange
, isBeforeOrEqualDayAndMonth
, yearsGap
, daysGap
@@ -22,7 +24,7 @@ import Data.Time.LocalTime
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, listToMaybe)
import Time (formatCurrentLocale)
@@ -49,13 +51,13 @@ getCurrentDate = do
let zoneNow = utcToLocalTime timezone now
return . dateFromDay $ localDay zoneNow
-getNextWeek :: IO (Date, Date)
+type SuccessiveDates = [Date]
+
+getNextWeek :: IO SuccessiveDates
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)
+ return $ map (plusDays currentDate) $ take 7 [(8 - currentDayNumberOfWeek)..]
getWeekDay :: Date -> Text
getWeekDay = T.toLower . T.pack . formatTime defaultTimeLocale "%A" . dateToDay
@@ -93,3 +95,6 @@ daysGap d1 d2 = abs . fromIntegral $ (dateToDay d1) `diffDays` (dateToDay d2)
isValid :: Date -> Bool
isValid (Date d m y) = isJust $ fromGregorianValid (toInteger y) m d
+
+dayAndMonthInRange :: [Date] -> Date -> Maybe Date
+dayAndMonthInRange dates date = listToMaybe . filter (sameDayAndMonth date) $ dates
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
index deb720a..8cc8116 100644
--- a/src/Model/Mail.hs
+++ b/src/Model/Mail.hs
@@ -7,6 +7,7 @@ module Model.Mail
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Maybe (fromMaybe)
import Model.Date
import Model.Birthdate
@@ -49,24 +50,24 @@ mailSubjectSentence event birthdates =
, if event == Today then "today" else "next week"
]
-mailBody :: Date -> [Birthdate] -> [Birthdate] -> Text
-mailBody currentDate birthdaysToday birthdaysNextWeek =
+mailBody :: Date -> SuccessiveDates -> [Birthdate] -> [Birthdate] -> Text
+mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek =
T.concat
[ if not . null $ birthdaysToday
- then mailBodySentence Today currentDate birthdaysToday
+ then mailBodySentence Today currentDate nextWeek birthdaysToday
else ""
, if not . null $ birthdaysNextWeek
then
T.concat
[ if not . null $ birthdaysToday then " " else ""
- , mailBodySentence NextWeek currentDate birthdaysNextWeek
+ , mailBodySentence NextWeek currentDate nextWeek birthdaysNextWeek
]
else ""
]
-mailBodySentence :: Event -> Date -> [Birthdate] -> Text
-mailBodySentence event currentDate birthdates =
- T.concat $ map (mailBodyPart event currentDate) (attachLines birthdates)
+mailBodySentence :: Event -> Date -> SuccessiveDates -> [Birthdate] -> Text
+mailBodySentence event currentDate nextWeek birthdates =
+ T.concat $ map (mailBodyPart event currentDate nextWeek) (attachLines birthdates)
attachLines :: [Birthdate] -> [(Line, Birthdate)]
attachLines birthdates =
@@ -83,32 +84,30 @@ data Line =
| LastLine
deriving (Eq, Show)
-mailBodyPart :: Event -> Date -> (Line, Birthdate) -> Text
-mailBodyPart event currDate (line, birthdate) =
- T.concat
- [ case line of
- x | x `elem` [SingleLine, FirstLine] ->
- if event == Today then "Today, " else "Next week, "
- MiddleLine ->
- ", "
- LastLine ->
- " and "
- _ ->
- ""
- , fullname birthdate
- , if event == Today then " is " else " will be "
- , T.pack . show $
- if event == Today
- then age currDate birthdate
- else ageNextWeek currDate birthdate
- , " years old"
- , if event == NextWeek
- then
- T.concat
- [ " on "
- , getWeekDay $ (date birthdate) { year = year currDate }
- ]
- else
- ""
- , if line == SingleLine || line == LastLine then "." else ""
- ]
+mailBodyPart :: Event -> Date -> SuccessiveDates -> (Line, Birthdate) -> Text
+mailBodyPart event currDate nextWeek (line, birthdate) =
+ let nextWeekDay = dayAndMonthInRange nextWeek (date birthdate)
+ in T.concat
+ [ case line of
+ x | x `elem` [SingleLine, FirstLine] ->
+ if event == Today then "Today, " else "Next week, "
+ MiddleLine ->
+ ", "
+ LastLine ->
+ " and "
+ _ ->
+ ""
+ , fullname birthdate
+ , if event == Today then " is " else " will be "
+ , T.pack . show $
+ if event == Today
+ then age currDate birthdate
+ else fromMaybe 0 $ (\d -> year d - year (date birthdate)) <$> nextWeekDay
+ , " years old"
+ , if event == NextWeek
+ then
+ fromMaybe "" $ (\d -> T.concat [" on " , getWeekDay d]) <$> nextWeekDay
+ else
+ ""
+ , if line == SingleLine || line == LastLine then "." else ""
+ ]
diff --git a/src/Notification.hs b/src/Notification.hs
index 18cd260..6e6677e 100644
--- a/src/Notification.hs
+++ b/src/Notification.hs
@@ -9,37 +9,31 @@ 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.Date (getCurrentDate, getNextWeek, SuccessiveDates)
+import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayInside)
import Model.Mail (mailSubject, mailBody)
import Model.Config
notifyTodayAndNextWeek :: [Birthdate] -> Config -> IO ()
notifyTodayAndNextWeek birthdates config = do
currentDate <- getCurrentDate
- birthdaysToday <- filterBirthdaysToday birthdates
- birthdaysNextWeek <- filterBirthdaysNextWeek birthdates config
+ let birthdaysToday = filterBirthdayAt currentDate birthdates
+ nextWeek <- getNextWeek
+ birthdaysNextWeek <- filterBirthdaysNextWeek config nextWeek birthdates
if length birthdaysToday > 0 || length birthdaysNextWeek > 0
then
sendMail
(mailTo config)
(mailFrom config)
(mailSubject birthdaysToday birthdaysNextWeek)
- (mailBody currentDate birthdaysToday birthdaysNextWeek)
+ (mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek)
else
return ()
-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
- return (filterBirthdayBetween begin end birthdates)
- else
- return []
+filterBirthdaysNextWeek :: Config -> SuccessiveDates -> [Birthdate] -> IO [Birthdate]
+filterBirthdaysNextWeek config nextWeek birthdates =
+ (\currentDayOfWeek ->
+ if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config)
+ then filterBirthdayInside nextWeek birthdates
+ else []
+ ) <$> formatCurrentLocale "%A"