aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore4
-rw-r--r--README.md56
-rw-r--r--application.conf5
-rw-r--r--events.cabal (renamed from birthday.cabal)11
-rw-r--r--src/Main.hs16
-rw-r--r--src/Model/Birthdate.hs43
-rw-r--r--src/Model/BirthdateParser.hs84
-rw-r--r--src/Model/Conf.hs25
-rw-r--r--src/Model/Config.hs32
-rw-r--r--src/Model/Event.hs38
-rw-r--r--src/Model/EventParser.hs92
-rw-r--r--src/Model/Mail.hs78
-rw-r--r--src/Model/Path.hs12
-rw-r--r--src/Notification.hs24
14 files changed, 259 insertions, 261 deletions
diff --git a/.gitignore b/.gitignore
index 5ac0a89..9aae7be 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,5 @@
shell.nix
-birthdates.csv
+events
dist
-config.txt
+local.conf
logs
diff --git a/README.md b/README.md
index 41f4a36..e196120 100644
--- a/README.md
+++ b/README.md
@@ -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"