From d8eedc3e2639f0f50f0554f89dc121da4941d4d1 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 4 Apr 2016 22:48:33 +0200
Subject: Rename birthday to event

---
 src/Main.hs                  | 16 ++++----
 src/Model/Birthdate.hs       | 43 ---------------------
 src/Model/BirthdateParser.hs | 84 ----------------------------------------
 src/Model/Conf.hs            | 25 ++++++++++++
 src/Model/Config.hs          | 32 ---------------
 src/Model/Event.hs           | 38 ++++++++++++++++++
 src/Model/EventParser.hs     | 92 ++++++++++++++++++++++++++++++++++++++++++++
 src/Model/Mail.hs            | 78 ++++++++++++++++++-------------------
 src/Model/Path.hs            | 12 +++---
 src/Notification.hs          | 24 ++++++------
 10 files changed, 220 insertions(+), 224 deletions(-)
 delete mode 100644 src/Model/Birthdate.hs
 delete mode 100644 src/Model/BirthdateParser.hs
 create mode 100644 src/Model/Conf.hs
 delete mode 100644 src/Model/Config.hs
 create mode 100644 src/Model/Event.hs
 create mode 100644 src/Model/EventParser.hs

(limited to 'src')

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"
-- 
cgit v1.2.3