aboutsummaryrefslogtreecommitdiff
path: root/src/Model
diff options
context:
space:
mode:
Diffstat (limited to 'src/Model')
-rw-r--r--src/Model/Birthdate.hs38
-rw-r--r--src/Model/BirthdateParser.hs57
-rw-r--r--src/Model/Config.hs32
-rw-r--r--src/Model/Date.hs74
-rw-r--r--src/Model/Mail.hs60
-rw-r--r--src/Model/Path.hs10
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"