diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 3 | ||||
| -rw-r--r-- | src/Model/Birthdate.hs | 6 | ||||
| -rw-r--r-- | src/Model/Date.hs | 19 | ||||
| -rw-r--r-- | src/Model/Mail.hs | 77 | ||||
| -rw-r--r-- | src/Notification.hs | 38 |
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 [] |