diff options
| -rw-r--r-- | src/Model/Birthdate.hs | 18 | ||||
| -rw-r--r-- | src/Model/Date.hs | 15 | ||||
| -rw-r--r-- | src/Model/Mail.hs | 71 | ||||
| -rw-r--r-- | src/Notification.hs | 32 |
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" |