diff options
| -rw-r--r-- | .gitignore | 4 | ||||
| -rw-r--r-- | README.md | 56 | ||||
| -rw-r--r-- | application.conf | 5 | ||||
| -rw-r--r-- | events.cabal (renamed from birthday.cabal) | 11 | ||||
| -rw-r--r-- | src/Main.hs | 16 | ||||
| -rw-r--r-- | src/Model/Birthdate.hs | 43 | ||||
| -rw-r--r-- | src/Model/BirthdateParser.hs | 84 | ||||
| -rw-r--r-- | src/Model/Conf.hs | 25 | ||||
| -rw-r--r-- | src/Model/Config.hs | 32 | ||||
| -rw-r--r-- | src/Model/Event.hs | 38 | ||||
| -rw-r--r-- | src/Model/EventParser.hs | 92 | ||||
| -rw-r--r-- | src/Model/Mail.hs | 78 | ||||
| -rw-r--r-- | src/Model/Path.hs | 12 | ||||
| -rw-r--r-- | src/Notification.hs | 24 |
14 files changed, 259 insertions, 261 deletions
@@ -1,5 +1,5 @@ shell.nix -birthdates.csv +events dist -config.txt +local.conf logs @@ -1,10 +1,11 @@ -Birthday -======== +Event +===== -Notify by email if there are any birthday today or next week. This program is -intended to be launched everyday. +Notify by email if there are any event today or next week. This program has to +be launched everyday, with cron for example. -## Required dependencies +Required dependencies +--------------------- - `cabal2nix` - `nix-shell` @@ -13,26 +14,26 @@ intended to be launched everyday. Usage ----- -Create birthdates.csv which stores birthdates: +Create the events file: ``` -# Family -30 Jan 1955, Henry, Brown -08 May 1980, Alexander, Khan - -# Friends -02 Aug 1976, Violet, Koval -02 Aug 1976, Jude, Martinez -23 Oct 1982, Katie, Clarke -… -``` +[January] -Create config.txt: +30, 1955: Henry Brown -``` -mail-to = john.dupont@mail.com -mail-from = no-reply@service.com -day-for-next-week-notification = Friday +[May] + +08, 1980: Alexander Khan +16, 2003: Wedding + +[August] + +02, 1976: Violet Koval +02, 1976: Jude Martinez + +[October] + +23, 1982: Katie Clarke ``` Launch the following commands: @@ -43,17 +44,14 @@ nix-shell -I ~ --command 'cabal configure' cabal run ``` -Notification ------------- - -Notification are in plan english so that it is more friendly to read them. Here -is an example notification with 3 birthdays today and 2 birthdays next week: +Mail Notification example +------------------------- -### Mail subject +### Subject -“Hey, there are 3 birthdays today and there will be 2 birthdays next week!” +“Hey, there are 3 events today and there will be 2 events next week!” -### Mail body +### Body “Today, Katie Clarke is 19 years old, Henry Brown is 34 years old and Alexander Khan is 22 years old. Next week, Violet Koval will be 65 years old on thirsday diff --git a/application.conf b/application.conf new file mode 100644 index 0000000..04d308e --- /dev/null +++ b/application.conf @@ -0,0 +1,5 @@ +mailTo = "mail-to@mail.com" +mailFrom = "mail-from@mail.com" +dayForNextWeekNotification = "Friday" + +import "local.conf" diff --git a/birthday.cabal b/events.cabal index a79f2b3..1bbf8a3 100644 --- a/birthday.cabal +++ b/events.cabal @@ -1,19 +1,18 @@ -name: birthday +name: event version: 1.0.0 license: GPL-3 -homepage: https://github.com/guyonvarch/birthday +homepage: https://gitlab.com/guyonvarch/event author: Joris Guyonvarch build-type: Simple cabal-version: >= 1.8 -executable birthday +executable event main-is: Main.hs hs-source-dirs: src - ghc-options: -Wall -fwarn-incomplete-uni-patterns + ghc-options: -Wall -Werror build-depends: base , text , mime-mail , time - , ConfigFile - , transformers + , config-manager , parsec diff --git a/src/Main.hs b/src/Main.hs index 3a34269..bc9b112 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,15 +9,15 @@ import qualified Data.Text.IO as T import Exit (exitWithParsingError) import Notification (notifyTodayAndNextWeek) -import Model.Config -import Model.BirthdateParser (parseBirthdates) +import Model.Conf +import Model.EventParser (parseEvents) import qualified Model.Path as Path main :: IO () main = do - eitherBirthdates <- parseBirthdates <$> T.readFile Path.birthdate - eitherConfig <- getConfig Path.config - case (eitherBirthdates, eitherConfig) of - (Left err, _) -> exitWithParsingError Path.birthdate err - (_, Left err) -> exitWithParsingError Path.config err - (Right birthdates, Right config) -> notifyTodayAndNextWeek birthdates config + eitherEvents <- parseEvents <$> T.readFile Path.event + eitherConf <- getConf Path.conf + case (eitherEvents, eitherConf) of + (Left err, _) -> exitWithParsingError Path.event err + (_, Left err) -> exitWithParsingError Path.conf err + (Right events, Right conf) -> notifyTodayAndNextWeek events conf diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs deleted file mode 100644 index 96783a7..0000000 --- a/src/Model/Birthdate.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Birthdate - ( Birthdate(..) - , renderBirthdate - , fullname - , age - , filterBirthdayAt - , filterBirthdayInside - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Maybe (isJust) - -import Model.Date - -data Birthdate = Birthdate - { date :: Date - , firstname :: Text - , lastname :: Text - } deriving (Eq, Show) - -renderBirthdate :: Birthdate -> Text -renderBirthdate birthdate = - T.concat - [ fullname birthdate - , " (" - , renderDate (date birthdate) - , ")" - ] - -fullname :: Birthdate -> Text -fullname d = T.concat [firstname d, " ", lastname d] - -age :: Date -> Birthdate -> Int -age currentDate birthdate = yearsGap currentDate (date birthdate) - -filterBirthdayAt :: Date -> [Birthdate] -> [Birthdate] -filterBirthdayAt d = filter (sameDayAndMonth d . date) - -filterBirthdayInside :: [Date] -> [Birthdate] -> [Birthdate] -filterBirthdayInside dates = filter (isJust . dayAndMonthInRange dates . date) diff --git a/src/Model/BirthdateParser.hs b/src/Model/BirthdateParser.hs deleted file mode 100644 index 9bed07a..0000000 --- a/src/Model/BirthdateParser.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.BirthdateParser - ( parseBirthdates - ) where - -import Control.Arrow (left) - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Maybe (catMaybes) - -import Text.ParserCombinators.Parsec -import Text.Parsec.Char (endOfLine) - -import Model.Birthdate -import Model.Date - -parseBirthdates :: Text -> Either Text [Birthdate] -parseBirthdates input = - left (T.pack . show) (parse birthdatesParser "" (T.unpack input)) >>= validateBirthdates - -validateBirthdates :: [Birthdate] -> Either Text [Birthdate] -validateBirthdates birthdates = - let invalid = filter (not . isValid . date) birthdates - in if null invalid - then - Right birthdates - else - Left $ - T.concat - [ "Invalid birthdates: " - , T.intercalate ", " (map renderBirthdate invalid) - ] - -birthdatesParser :: Parser [Birthdate] -birthdatesParser = catMaybes <$> many lineParser - -lineParser :: Parser (Maybe Birthdate) -lineParser = - (Just <$> birthdateParser <* endOfLine) - <|> (emptyLine >> return Nothing) - <|> (commentLine >> return Nothing) - -emptyLine :: Parser () -emptyLine = skipMany (char ' ') >> endOfLine >> return () - -commentLine :: Parser Text -commentLine = T.strip . T.pack <$> (spaces *> char '#' *> many (noneOf "\n") <* endOfLine) - -birthdateParser :: Parser Birthdate -birthdateParser = - Birthdate <$> - dateParser <* spaces <* char ',' <*> - valueParser <* char ',' <*> - valueParser - -valueParser :: Parser Text -valueParser = T.strip . T.pack <$> many (noneOf ",\n") - -dateParser :: Parser Date -dateParser = - Date <$> - integerParser <* spaces <*> - monthParser <* spaces <*> - integerParser - -integerParser :: Parser Int -integerParser = (read :: String -> Int) <$> many1 digit - -monthParser :: Parser Int -monthParser = - (try $ string "Jan" >> return 1) - <|> (try $ string "Feb" >> return 2) - <|> (try $ string "Mar" >> return 3) - <|> (try $ string "Apr" >> return 4) - <|> (try $ string "May" >> return 5) - <|> (try $ string "Jun" >> return 6) - <|> (try $ string "Jul" >> return 7) - <|> (try $ string "Aug" >> return 8) - <|> (try $ string "Sep" >> return 9) - <|> (try $ string "Oct" >> return 10) - <|> (try $ string "Nov" >> return 11) - <|> (try $ string "Dec" >> return 12) diff --git a/src/Model/Conf.hs b/src/Model/Conf.hs new file mode 100644 index 0000000..0763cd8 --- /dev/null +++ b/src/Model/Conf.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.Conf + ( getConf + , Conf(..) + ) where + +import Data.Text (Text) +import qualified Data.ConfigManager as Conf + +data Conf = Conf + { mailTo :: Text + , mailFrom :: Text + , dayForNextWeekNotification :: Text + } deriving (Read, Eq, Show) + +getConf :: FilePath -> IO (Either Text Conf) +getConf path = + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "mailTo" conf <*> + Conf.lookup "mailFrom" conf <*> + Conf.lookup "dayForNextWeekNotification" conf + ) diff --git a/src/Model/Config.hs b/src/Model/Config.hs deleted file mode 100644 index b583048..0000000 --- a/src/Model/Config.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} - -module Model.Config - ( getConfig - , Config(..) - ) where - -import Data.ConfigFile -import Data.Text (Text) -import qualified Data.Text as T - -import Control.Monad.Trans.Error (runErrorT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad (join) -import Control.Arrow (left) - -data Config = Config - { mailTo :: Text - , mailFrom :: Text - , dayForNextWeekNotification :: Text - } deriving (Read, Eq, Show) - -getConfig :: FilePath -> IO (Either Text Config) -getConfig filePath = - left (T.pack . show) <$> (runErrorT $ do - cp <- join $ liftIO $ readfile emptyCP filePath - Config <$> - (T.pack <$> get cp "DEFAULT" "mail-to") <*> - (T.pack <$> get cp "DEFAULT" "mail-from") <*> - (T.pack <$> get cp "DEFAULT" "day-for-next-week-notification") - ) diff --git a/src/Model/Event.hs b/src/Model/Event.hs new file mode 100644 index 0000000..e0d536d --- /dev/null +++ b/src/Model/Event.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.Event + ( Event(..) + , renderEvent + , age + , filterBirthdayAt + , filterBirthdayInside + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Maybe (isJust) + +import Model.Date + +data Event = Event + { date :: Date + , name :: Text + } deriving (Eq, Show) + +renderEvent :: Event -> Text +renderEvent event = + T.concat + [ name event + , " (" + , renderDate (date event) + , ")" + ] + +age :: Date -> Event -> Int +age currentDate event = yearsGap currentDate (date event) + +filterBirthdayAt :: Date -> [Event] -> [Event] +filterBirthdayAt d = filter (sameDayAndMonth d . date) + +filterBirthdayInside :: [Date] -> [Event] -> [Event] +filterBirthdayInside dates = filter (isJust . dayAndMonthInRange dates . date) diff --git a/src/Model/EventParser.hs b/src/Model/EventParser.hs new file mode 100644 index 0000000..7a9955f --- /dev/null +++ b/src/Model/EventParser.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.EventParser + ( parseEvents + ) where + +import Control.Arrow (left) + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Maybe (catMaybes) + +import Text.ParserCombinators.Parsec +import Text.Parsec.Char (endOfLine) + +import Model.Event (Event, Event(Event)) +import qualified Model.Event as Event +import Model.Date (Date(Date)) +import qualified Model.Date as Date + +parseEvents :: Text -> Either Text [Event] +parseEvents input = + left (T.pack . show) (parse eventsParser "" (T.unpack input)) >>= validateEvents + +validateEvents :: [Event] -> Either Text [Event] +validateEvents events = + let invalid = filter (not . Date.isValid . Event.date) events + in if null invalid + then + Right events + else + Left $ + T.concat + [ "Invalid events: " + , T.intercalate ", " (map Event.renderEvent invalid) + ] + +eventsParser :: Parser [Event] +eventsParser = concat <$> many monthSection + +monthSection :: Parser [Event] +monthSection = do + month <- monthSectionTitle + spaces + events <- catMaybes <$> many lineParser + return $ + map (\(day, year, name) -> + Event (Date day month year) name + ) events + +lineParser :: Parser (Maybe (Int, Int, Text)) +lineParser = + (Just <$> eventParser <* endOfLine) + <|> (comment >> return Nothing) + <|> (emptyLine >> return Nothing) + +monthSectionTitle :: Parser Int +monthSectionTitle = char '[' *> monthParser <* char ']' + +monthParser :: Parser Int +monthParser = + (try $ string "January" >> return 1) + <|> (try $ string "February" >> return 2) + <|> (try $ string "March" >> return 3) + <|> (try $ string "April" >> return 4) + <|> (try $ string "May" >> return 5) + <|> (try $ string "June" >> return 6) + <|> (try $ string "July" >> return 7) + <|> (try $ string "August" >> return 8) + <|> (try $ string "September" >> return 9) + <|> (try $ string "October" >> return 10) + <|> (try $ string "November" >> return 11) + <|> (try $ string "December" >> return 12) + +eventParser :: Parser (Int, Int, Text) +eventParser = + (,,) <$> + integerParser <* separator ',' <*> + integerParser <* separator ':' <*> + (T.strip . T.pack <$> many (noneOf "\n")) + +separator :: Char -> Parser () +separator c = many (char ' ') >> char c >> many (char ' ') >> return () + +integerParser :: Parser Int +integerParser = (read :: String -> Int) <$> many1 digit + +emptyLine :: Parser () +emptyLine = skipMany (char ' ') >> endOfLine >> return () + +comment :: Parser () +comment = char '#' >> many (noneOf "\n") >> endOfLine >> return () diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs index 8cc8116..dd166ab 100644 --- a/src/Model/Mail.hs +++ b/src/Model/Mail.hs @@ -10,72 +10,72 @@ import qualified Data.Text as T import Data.Maybe (fromMaybe) import Model.Date -import Model.Birthdate +import Model.Event -data Event = +data Time = Today | NextWeek deriving (Eq, Show) -mailSubject :: [Birthdate] -> [Birthdate] -> Text -mailSubject birthdaysToday birthdaysNextWeek = +mailSubject :: [Event] -> [Event] -> Text +mailSubject eventsToday eventsNextWeek = T.concat [ "Hey, " - , if not . null $ birthdaysToday - then mailSubjectSentence Today birthdaysToday + , if not . null $ eventsToday + then mailSubjectSentence Today eventsToday else "" - , if not . null $ birthdaysNextWeek + , if not . null $ eventsNextWeek then T.concat - [ if not . null $ birthdaysToday then " and " else "" - , mailSubjectSentence NextWeek birthdaysNextWeek + [ if not . null $ eventsToday then " and " else "" + , mailSubjectSentence NextWeek eventsNextWeek ] else "" , "!" ] -mailSubjectSentence :: Event -> [Birthdate] -> Text -mailSubjectSentence event birthdates = - let count = length birthdates +mailSubjectSentence :: Time -> [Event] -> Text +mailSubjectSentence time events = + let count = length events in T.concat - [ case event of + [ case time of Today -> if count > 1 then "there are" else "there is" NextWeek -> "there will be" , " " , T.pack . show $ count - , " birthday" + , " event" , if count > 1 then "s" else "" , " " - , if event == Today then "today" else "next week" + , if time == Today then "today" else "next week" ] -mailBody :: Date -> SuccessiveDates -> [Birthdate] -> [Birthdate] -> Text -mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek = +mailBody :: Date -> SuccessiveDates -> [Event] -> [Event] -> Text +mailBody currentDate nextWeek eventsToday eventsNextWeek = T.concat - [ if not . null $ birthdaysToday - then mailBodySentence Today currentDate nextWeek birthdaysToday + [ if not . null $ eventsToday + then mailBodySentence Today currentDate nextWeek eventsToday else "" - , if not . null $ birthdaysNextWeek + , if not . null $ eventsNextWeek then T.concat - [ if not . null $ birthdaysToday then " " else "" - , mailBodySentence NextWeek currentDate nextWeek birthdaysNextWeek + [ if not . null $ eventsToday then " " else "" + , mailBodySentence NextWeek currentDate nextWeek eventsNextWeek ] else "" ] -mailBodySentence :: Event -> Date -> SuccessiveDates -> [Birthdate] -> Text -mailBodySentence event currentDate nextWeek birthdates = - T.concat $ map (mailBodyPart event currentDate nextWeek) (attachLines birthdates) +mailBodySentence :: Time -> Date -> SuccessiveDates -> [Event] -> Text +mailBodySentence time currentDate nextWeek events = + T.concat $ map (mailBodyPart time currentDate nextWeek) (attachLines events) -attachLines :: [Birthdate] -> [(Line, Birthdate)] -attachLines birthdates = - let count = length birthdates +attachLines :: [Event] -> [(Line, Event)] +attachLines events = + let count = length events lineKind 1 = if count == 1 then SingleLine else FirstLine lineKind line = if line == count then LastLine else MiddleLine mapFst f (x, y) = (f x, y) - in map (mapFst lineKind) . zip [1..] $ birthdates + in map (mapFst lineKind) . zip [1..] $ events data Line = SingleLine @@ -84,27 +84,27 @@ data Line = | LastLine deriving (Eq, Show) -mailBodyPart :: Event -> Date -> SuccessiveDates -> (Line, Birthdate) -> Text -mailBodyPart event currDate nextWeek (line, birthdate) = - let nextWeekDay = dayAndMonthInRange nextWeek (date birthdate) +mailBodyPart :: Time -> Date -> SuccessiveDates -> (Line, Event) -> Text +mailBodyPart time currDate nextWeek (line, event) = + let nextWeekDay = dayAndMonthInRange nextWeek (date event) in T.concat [ case line of x | x `elem` [SingleLine, FirstLine] -> - if event == Today then "Today, " else "Next week, " + if time == Today then "Today, " else "Next week, " MiddleLine -> ", " LastLine -> " and " _ -> "" - , fullname birthdate - , if event == Today then " is " else " will be " + , name event + , if time == 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 + if time == Today + then age currDate event + else fromMaybe 0 $ (\d -> year d - year (date event)) <$> nextWeekDay , " years old" - , if event == NextWeek + , if time == NextWeek then fromMaybe "" $ (\d -> T.concat [" on " , getWeekDay d]) <$> nextWeekDay else diff --git a/src/Model/Path.hs b/src/Model/Path.hs index d34716c..3256638 100644 --- a/src/Model/Path.hs +++ b/src/Model/Path.hs @@ -1,10 +1,10 @@ module Model.Path - ( birthdate - , config + ( event + , conf ) where -birthdate :: FilePath -birthdate = "birthdates.csv" +event :: FilePath +event = "events" -config :: FilePath -config = "config.txt" +conf :: FilePath +conf = "application.conf" diff --git a/src/Notification.hs b/src/Notification.hs index 6e6677e..60062cc 100644 --- a/src/Notification.hs +++ b/src/Notification.hs @@ -10,30 +10,30 @@ import SendMail (sendMail) import Time (formatCurrentLocale) import Model.Date (getCurrentDate, getNextWeek, SuccessiveDates) -import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayInside) +import Model.Event (Event, filterBirthdayAt, filterBirthdayInside) import Model.Mail (mailSubject, mailBody) -import Model.Config +import Model.Conf -notifyTodayAndNextWeek :: [Birthdate] -> Config -> IO () -notifyTodayAndNextWeek birthdates config = do +notifyTodayAndNextWeek :: [Event] -> Conf -> IO () +notifyTodayAndNextWeek events conf = do currentDate <- getCurrentDate - let birthdaysToday = filterBirthdayAt currentDate birthdates + let birthdaysToday = filterBirthdayAt currentDate events nextWeek <- getNextWeek - birthdaysNextWeek <- filterBirthdaysNextWeek config nextWeek birthdates + birthdaysNextWeek <- filterBirthdaysNextWeek conf nextWeek events if length birthdaysToday > 0 || length birthdaysNextWeek > 0 then sendMail - (mailTo config) - (mailFrom config) + (mailTo conf) + (mailFrom conf) (mailSubject birthdaysToday birthdaysNextWeek) (mailBody currentDate nextWeek birthdaysToday birthdaysNextWeek) else return () -filterBirthdaysNextWeek :: Config -> SuccessiveDates -> [Birthdate] -> IO [Birthdate] -filterBirthdaysNextWeek config nextWeek birthdates = +filterBirthdaysNextWeek :: Conf -> SuccessiveDates -> [Event] -> IO [Event] +filterBirthdaysNextWeek conf nextWeek events = (\currentDayOfWeek -> - if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config) - then filterBirthdayInside nextWeek birthdates + if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification conf) + then filterBirthdayInside nextWeek events else [] ) <$> formatCurrentLocale "%A" |