diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | README.md | 7 | ||||
| -rw-r--r-- | logs | 2 | ||||
| -rw-r--r-- | src/Logger.hs | 6 | ||||
| -rw-r--r-- | src/Main.hs | 67 | ||||
| -rw-r--r-- | src/Model/Birthdate.hs (renamed from src/Birthdate.hs) | 5 | ||||
| -rw-r--r-- | src/Model/BirthdateParser.hs (renamed from src/BirthdateParser.hs) | 6 | ||||
| -rw-r--r-- | src/Model/Config.hs (renamed from src/Config.hs) | 12 | ||||
| -rw-r--r-- | src/Model/Date.hs (renamed from src/Date.hs) | 29 | ||||
| -rw-r--r-- | src/Model/Mail.hs (renamed from src/Mail.hs) | 51 | ||||
| -rw-r--r-- | src/Model/Path.hs | 10 | ||||
| -rw-r--r-- | src/Notification.hs | 49 | ||||
| -rw-r--r-- | src/RenderError.hs | 34 | ||||
| -rw-r--r-- | src/Time.hs | 12 |
14 files changed, 182 insertions, 109 deletions
@@ -4,3 +4,4 @@ cabal.sandbox.config dist config.txt deploy +logs @@ -1,8 +1,10 @@ Birthday ======== -Notify by email if there is a birthday today. Birthdates are parsed from -birthdates.csv: +Notify by email if there is a birthday today. This program is intended to be +launched everyday. + +Create birthdates.csv which stores birthdates: ``` 23 Oct 1982, Jean, Dupont @@ -16,6 +18,7 @@ Create config.txt: ``` mail-to = john.dupont@mail.com mail-from = no-reply@service.com +day-for-next-week-notification = Friday ``` The usage is as follow: @@ -1,2 +0,0 @@ -[21/11/2015] - Sending mail to joris.guyonvarch@gmail.com with subject “Hey, there is 1 birthday today!” and body “Alain Noe is now 19 years old.” -[21/11/2015, 18:55] - Sending mail to joris.guyonvarch@gmail.com with subject “Hey, there is 1 birthday today!” and body “Alain Noe is now 19 years old.” diff --git a/src/Logger.hs b/src/Logger.hs index 4be55be..6faa482 100644 --- a/src/Logger.hs +++ b/src/Logger.hs @@ -7,12 +7,12 @@ module Logger import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T (appendFile) -import Data.Time.LocalTime (getZonedTime) -import Data.Time.Format (formatTime, defaultTimeLocale) + +import Time (formatCurrentLocale) info :: Text -> IO () info message = do - time <- T.pack <$> formatTime defaultTimeLocale "[%d/%m/%Y, %H:%M]" <$> getZonedTime + time <- formatCurrentLocale "[%d/%m/%Y, %H:%M]" T.appendFile "logs" $ T.concat [ time diff --git a/src/Main.hs b/src/Main.hs index 0aa2910..e3bd0ce 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,67 +4,24 @@ module Main ( main ) where -import System.IO (stderr) - -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.IO as T -import Date (getCurrentDate) -import Birthdate (Birthdate, filterBirthdayAt) -import BirthdateParser (parseBirthdates) -import Mail (mailSubject, mailBody) -import SendMail (sendMail) -import Config - -birthdatePath :: FilePath -birthdatePath = "birthdates.csv" +import qualified RenderError +import qualified Notification -configPath :: FilePath -configPath = "config.txt" +import Model.Config +import Model.BirthdateParser (parseBirthdates) +import qualified Model.Path as Path main :: IO () main = do - eitherBirthdates <- parseBirthdates <$> T.readFile birthdatePath - eitherConfig <- getConfig configPath + eitherBirthdates <- parseBirthdates <$> T.readFile Path.birthdate + eitherConfig <- getConfig Path.config case (eitherBirthdates, eitherConfig) of (Left err, _) -> - birthdateError err + RenderError.birthdate err (_, Left err) -> - configError err - (Right birthdates, Right config) -> - sendNotificationForBirthdayToday birthdates config - -birthdateError :: Text -> IO () -birthdateError err = - T.hPutStr stderr $ - T.concat - [ "Error while parsing file " - , T.pack birthdatePath - , ":\n" - , err - ] - -configError :: Text -> IO () -configError err = - T.hPutStr stderr $ - T.concat - [ "Error while parsing config file " - , T.pack configPath - , ":\n" - , err - ] - -sendNotificationForBirthdayToday :: [Birthdate] -> Config -> IO () -sendNotificationForBirthdayToday birthdates config = do - currentDate <- getCurrentDate - let birthdays = filterBirthdayAt currentDate birthdates - if not (null birthdays) - then - sendMail - (mailTo config) - (mailFrom config) - (mailSubject birthdays) - (mailBody currentDate birthdays) - else - return () + RenderError.config err + (Right birthdates, Right config) -> do + Notification.today birthdates config + Notification.nextWeek birthdates config diff --git a/src/Birthdate.hs b/src/Model/Birthdate.hs index 48d3a4e..d135419 100644 --- a/src/Birthdate.hs +++ b/src/Model/Birthdate.hs @@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module Birthdate +module Model.Birthdate ( Birthdate(..) , fullname , age , filterBirthdayAt + , filterBirthdayBetween ) where import Data.Text (Text) import qualified Data.Text as T -import Date +import Model.Date data Birthdate = Birthdate { date :: Date diff --git a/src/BirthdateParser.hs b/src/Model/BirthdateParser.hs index 9fa7c50..c9ac3b9 100644 --- a/src/BirthdateParser.hs +++ b/src/Model/BirthdateParser.hs @@ -1,4 +1,4 @@ -module BirthdateParser +module Model.BirthdateParser ( parseBirthdates ) where @@ -9,8 +9,8 @@ import qualified Data.Text as T import Text.ParserCombinators.Parsec -import Birthdate -import Date +import Model.Birthdate +import Model.Date parseBirthdates :: Text -> Either Text [Birthdate] parseBirthdates input = diff --git a/src/Config.hs b/src/Model/Config.hs index c01bbe1..b583048 100644 --- a/src/Config.hs +++ b/src/Model/Config.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -module Config +module Model.Config ( getConfig , Config(..) ) where @@ -14,19 +14,19 @@ import Control.Monad.Trans.Error (runErrorT) import Control.Monad.IO.Class (liftIO) import Control.Monad (join) import Control.Arrow (left) -import Control.Applicative (liftA2) 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 - liftA2 - Config - (T.pack <$> get cp "DEFAULT" "mail-to") - (T.pack <$> get cp "DEFAULT" "mail-from") + 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/Date.hs b/src/Model/Date.hs index 63830d3..96c15e9 100644 --- a/src/Date.hs +++ b/src/Model/Date.hs @@ -1,6 +1,10 @@ -module Date +{-# LANGUAGE OverloadedStrings #-} + +module Model.Date ( Date(..) , getCurrentDate + , getNextWeek + , plusDays , sameDayAndMonth , isBeforeOrEqualDayAndMonth , isAfterOrEqualDayAndMonth @@ -10,6 +14,9 @@ module Date 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 @@ -22,8 +29,24 @@ getCurrentDate = do now <- getCurrentTime timezone <- getCurrentTimeZone let zoneNow = utcToLocalTime timezone now - let (y, m, d) = toGregorian $ localDay zoneNow - return $ Date d m (fromIntegral y) + 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 = diff --git a/src/Mail.hs b/src/Model/Mail.hs index dc533ef..e730e32 100644 --- a/src/Mail.hs +++ b/src/Model/Mail.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Mail +module Model.Mail ( mailSubject , mailBody ) where @@ -8,8 +8,8 @@ module Mail import Data.Text (Text) import qualified Data.Text as T -import Date -import Birthdate +import Model.Date +import Model.Birthdate mailSubject :: [Birthdate] -> Text mailSubject birthdates = @@ -26,14 +26,15 @@ mailSubject birthdates = mailBody :: Date -> [Birthdate] -> Text mailBody currentDate birthdates = + T.concat $ map (mailLine currentDate) (attachLines birthdates) + +attachLines :: [Birthdate] -> [(Line, Birthdate)] +attachLines birthdates = let count = length birthdates - birthdatesWithLines = map (mapFst lineKind) . zip [1..] $ birthdates lineKind 1 = if count == 1 then SingleLine else FirstLine lineKind line = if line == count then LastLine else MiddleLine - in T.concat $ map (mailLine currentDate) birthdatesWithLines - -mapFst :: (a -> c) -> (a, b) -> (c, b) -mapFst f (x, y) = (f x, y) + mapFst f (x, y) = (f x, y) + in map (mapFst lineKind) . zip [1..] $ birthdates data Line = SingleLine @@ -43,33 +44,17 @@ data Line = deriving (Eq, Show) mailLine :: Date -> (Line, Birthdate) -> Text -mailLine currDate (SingleLine, birthdate) = +mailLine currDate (line, birthdate) = T.concat - [ fullname birthdate - , " is now " - , T.pack . show $ age currDate birthdate - , " years old." - ] -mailLine currDate (FirstLine, birthdate) = - T.concat - [ fullname birthdate - , " is now " - , T.pack . show $ age currDate birthdate - , " years old" - ] -mailLine currDate (MiddleLine, birthdate) = - T.concat - [ ", " + [ case line of + MiddleLine -> ", " + LastLine -> " and " + _ -> "" , fullname birthdate - , " is " + , case line of + x | x `elem` [SingleLine, FirstLine] -> " is now " + _ -> " is " , T.pack . show $ age currDate birthdate , " years old" - ] -mailLine currDate (LastLine, birthdate) = - T.concat - [ " and " - , fullname birthdate - , " 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" diff --git a/src/Notification.hs b/src/Notification.hs new file mode 100644 index 0000000..de4a591 --- /dev/null +++ b/src/Notification.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Notification + ( today + , nextWeek + ) where + +import qualified Data.Text as T + +import SendMail (sendMail) +import Time (formatCurrentLocale) + +import Model.Date (getCurrentDate, getNextWeek) +import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayBetween) +import Model.Mail (mailSubject, mailBody) +import Model.Config + +today :: [Birthdate] -> Config -> IO () +today birthdates config = do + currentDate <- getCurrentDate + let birthdays = filterBirthdayAt currentDate birthdates + if not (null birthdays) + then + sendMail + (mailTo config) + (mailFrom config) + (mailSubject birthdays) + (mailBody currentDate birthdays) + else + return () + +nextWeek :: [Birthdate] -> Config -> IO () +nextWeek birthdates config = do + currentDayOfWeek <- formatCurrentLocale "%A" + if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config) + then do + (begin, end) <- getNextWeek + let birthdays = filterBirthdayBetween begin end birthdates + if not (null birthdays) + then + sendMail + (mailTo config) + (mailFrom config) + "" + "" + else + return () + else + return () diff --git a/src/RenderError.hs b/src/RenderError.hs new file mode 100644 index 0000000..9b9732f --- /dev/null +++ b/src/RenderError.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module RenderError + ( birthdate + , config + ) where + +import System.IO (stderr) + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import qualified Model.Path as Path + +birthdate :: Text -> IO () +birthdate err = + T.hPutStr stderr $ + T.concat + [ "Error while parsing file " + , T.pack Path.birthdate + , ":\n" + , err + ] + +config :: Text -> IO () +config err = + T.hPutStr stderr $ + T.concat + [ "Error while parsing config file " + , T.pack Path.config + , ":\n" + , err + ] diff --git a/src/Time.hs b/src/Time.hs new file mode 100644 index 0000000..97a9317 --- /dev/null +++ b/src/Time.hs @@ -0,0 +1,12 @@ +module Time + ( formatCurrentLocale + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.LocalTime (getZonedTime) +import Data.Time.Format (formatTime, defaultTimeLocale) + +formatCurrentLocale :: Text -> IO Text +formatCurrentLocale format = + T.pack <$> formatTime defaultTimeLocale (T.unpack format) <$> getZonedTime |