Get next week birthdays and send an empty mail for the moment

6 files changed, 271 insertions, 0 deletions

diff --git a/src/Model/Birthdate.hs b/src/Model/Birthdate.hs
new file mode 100644
index 0000000..d135419
--- /dev/null
+++ b/src/Model/Birthdate.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Birthdate
+  ( Birthdate(..)
+  , fullname
+  , age
+  , filterBirthdayAt
+  , filterBirthdayBetween
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Model.Date
+
+data Birthdate = Birthdate
+  { date :: Date
+  , firstname :: Text
+  , lastname :: Text
+  } deriving (Eq, Show)
+
+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)
+
+filterBirthdayBetween :: Date -> Date -> [Birthdate] -> [Birthdate]
+filterBirthdayBetween begin end =
+  filter (\bd ->
+    let d = date bd
+    in  (  d `isAfterOrEqualDayAndMonth` begin
+        && d `isBeforeOrEqualDayAndMonth` end
+        )
+  )
diff --git a/src/Model/BirthdateParser.hs b/src/Model/BirthdateParser.hs
new file mode 100644
index 0000000..c9ac3b9
--- /dev/null
+++ b/src/Model/BirthdateParser.hs
@@ -0,0 +1,57 @@
+module Model.BirthdateParser
+  ( parseBirthdates
+  ) where
+
+import Control.Arrow (left)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.ParserCombinators.Parsec
+
+import Model.Birthdate
+import Model.Date
+
+parseBirthdates :: Text -> Either Text [Birthdate]
+parseBirthdates input =
+  left
+    (T.pack . show)
+    (parse birthdatesParser "" (T.unpack input))
+
+birthdatesParser :: Parser [Birthdate]
+birthdatesParser = many (many newline >> birthdateParser <* many newline)
+
+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/Config.hs b/src/Model/Config.hs
new file mode 100644
index 0000000..b583048
--- /dev/null
+++ b/src/Model/Config.hs
@@ -0,0 +1,32 @@
+{-# 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/Date.hs b/src/Model/Date.hs
new file mode 100644
index 0000000..96c15e9
--- /dev/null
+++ b/src/Model/Date.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Date
+  ( Date(..)
+  , getCurrentDate
+  , getNextWeek
+  , plusDays
+  , sameDayAndMonth
+  , isBeforeOrEqualDayAndMonth
+  , isAfterOrEqualDayAndMonth
+  , yearsGap
+  ) where
+
+import Data.Time.Clock
+import Data.Time.Calendar
+import Data.Time.LocalTime
+import qualified Data.Text as T
+
+import Time (formatCurrentLocale)
+
+data Date = Date
+  { day :: Int
+  , month :: Int
+  , year :: Int
+  } deriving (Eq, Show)
+
+getCurrentDate :: IO Date
+getCurrentDate = do
+  now <- getCurrentTime
+  timezone <- getCurrentTimeZone
+  let zoneNow = utcToLocalTime timezone now
+  return . dateFromDay $ localDay zoneNow
+
+getNextWeek :: IO (Date, Date)
+getNextWeek = do
+  currentDate <- getCurrentDate
+  currentDayNumberOfWeek <- (read . T.unpack <$> formatCurrentLocale "%u") :: IO Int
+  let begin = currentDate `plusDays` (8 - currentDayNumberOfWeek)
+  let end = begin `plusDays` 6
+  return (begin, end)
+
+plusDays :: Date -> Int -> Date
+plusDays (Date d m y) n =
+  dateFromDay . addDays (toInteger n) $ fromGregorian (toInteger y) m d
+
+dateFromDay :: Day -> Date
+dateFromDay dayTime =
+  let (y, m, d) = toGregorian dayTime
+  in  Date d m (fromIntegral y)
+
+sameDayAndMonth :: Date -> Date -> Bool
+sameDayAndMonth d1 d2 =
+  (  day d1 == day d2
+  && month d1 == month d2
+  )
+
+isBeforeOrEqualDayAndMonth :: Date -> Date -> Bool
+isBeforeOrEqualDayAndMonth d1 d2 =
+  (  month d1 < month d2
+  || (  month d1 == month d2
+     && day d1 <= day 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)
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
new file mode 100644
index 0000000..e730e32
--- /dev/null
+++ b/src/Model/Mail.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Mail
+  ( mailSubject
+  , mailBody
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Model.Date
+import Model.Birthdate
+
+mailSubject :: [Birthdate] -> Text
+mailSubject birthdates =
+  let count = length birthdates
+  in  T.concat
+        [ "Hey, "
+        , if count > 1 then "there are" else "there is"
+        , " "
+        , T.pack . show $ count
+        , " birthday"
+        , if count > 1 then "s" else ""
+        , " today!"
+        ]
+
+mailBody :: Date -> [Birthdate] -> Text
+mailBody currentDate birthdates =
+  T.concat $ map (mailLine currentDate) (attachLines birthdates)
+
+attachLines :: [Birthdate] -> [(Line, Birthdate)]
+attachLines birthdates =
+  let count = length birthdates
+      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
+
+data Line =
+  SingleLine
+  | FirstLine
+  | MiddleLine
+  | LastLine
+  deriving (Eq, Show)
+
+mailLine :: Date -> (Line, Birthdate) -> Text
+mailLine currDate (line, birthdate) =
+  T.concat
+    [ case line of
+        MiddleLine -> ", "
+        LastLine -> " and "
+        _ -> ""
+    , fullname birthdate
+    , case line of
+        x | x `elem` [SingleLine, FirstLine] -> " is now "
+        _ -> " is "
+    , T.pack . show $ age currDate birthdate
+    , " years old"
+    , if line == LastLine then "." else ""
+    ]
diff --git a/src/Model/Path.hs b/src/Model/Path.hs
new file mode 100644
index 0000000..d34716c
--- /dev/null
+++ b/src/Model/Path.hs
@@ -0,0 +1,10 @@
+module Model.Path
+  ( birthdate
+  , config
+  ) where
+
+birthdate :: FilePath
+birthdate = "birthdates.csv"
+
+config :: FilePath
+config = "config.txt"