aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-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
10 files changed, 220 insertions, 224 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 22:48:32 +0000