diff options
| -rw-r--r-- | .gitignore | 6 | ||||
| -rw-r--r-- | README | 20 | ||||
| -rw-r--r-- | birthday.cabal | 17 | ||||
| -rw-r--r-- | src/Birthdate.hs | 76 | ||||
| -rw-r--r-- | src/Config.hs | 32 | ||||
| -rw-r--r-- | src/Date.hs | 30 | ||||
| -rw-r--r-- | src/Mail.hs | 75 | ||||
| -rw-r--r-- | src/Main.hs | 52 | ||||
| -rw-r--r-- | src/SendMail.hs | 21 |
9 files changed, 329 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2a63a4c --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +birthdates.csv +.cabal-sandbox +cabal.sandbox.config +dist +config.txt +deploy @@ -0,0 +1,20 @@ +Birthday +======== + +Send an email to notify if there is a birthday today. Birthdates are parsed +from a csv file: + +``` +23/10/1982 , Dupont Jean +30/01/1955 , Doe Anne +… +``` + +The usage is as follow: + +``` +cabal sandbox init +cabal instal --only-dependencies +cabal build +./dist/build/birthday/birthday +``` diff --git a/birthday.cabal b/birthday.cabal new file mode 100644 index 0000000..29bafad --- /dev/null +++ b/birthday.cabal @@ -0,0 +1,17 @@ +name: Birthday +version: 1.0.0 +homepage: https://github.com/guyonvarch/birthday +author: Joris Guyonvarch +build-type: Simple +cabal-version: >= 1.8 + +executable birthday + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall -fwarn-incomplete-uni-patterns + build-depends: base + , text == 1.2.1.3 + , mime-mail == 0.4.11 + , time == 1.5.0.1 + , ConfigFile == 1.1.4 + , transformers == 0.4.3.0 diff --git a/src/Birthdate.hs b/src/Birthdate.hs new file mode 100644 index 0000000..2ef1bcb --- /dev/null +++ b/src/Birthdate.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Birthdate + ( Birthdate(..) + , fullname + , age + , readBirthdates + , filterBirthday + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Read as T +import Data.Either (partitionEithers) + +import Date (Date(Date), sameDayAndMonth, yearsGap) + +data Birthdate = Birthdate + { date :: Date + , lastname :: Text + , firstname :: 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) + +readBirthdates :: FilePath -> IO (Either Text [Birthdate]) +readBirthdates path = do + eitherBirthdates <- map parseBirthdate . zip [1..] . T.lines <$> T.readFile path + return $ + case partitionEithers eitherBirthdates of + ([], birthdates) -> + Right birthdates + (errors, _) -> + Left $ T.intercalate "\n" errors + +parseBirthdate :: (Int, Text) -> Either Text Birthdate +parseBirthdate (line, text) = + case map T.strip $ T.splitOn "," text of + [date, lastname, firstname] -> + case map T.decimal $ T.splitOn "/" date of + [Right (day, ""), Right (month, ""), Right (year, "")] -> + Right Birthdate + { date = Date year month day + , lastname = lastname + , firstname = firstname + } + _ -> + Left $ T.concat + [ lineOutput line + , " birthdate: " + , date + , ". (Required: year/month/day)" + ] + _ -> + Left $ T.concat + [ lineOutput line + , " line: " + , text + , ". (Required: date, lastname, firstname)" + ] + +lineOutput :: Int -> Text +lineOutput line = + T.concat + [ "[L" + , T.pack . show $ line + , "]" + ] + +filterBirthday :: Date -> [Birthdate] -> [Birthdate] +filterBirthday d = filter (sameDayAndMonth d . date) diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..c01bbe1 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module 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) +import Control.Applicative (liftA2) + +data Config = Config + { mailTo :: Text + , mailFrom :: 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") + ) diff --git a/src/Date.hs b/src/Date.hs new file mode 100644 index 0000000..efbef8c --- /dev/null +++ b/src/Date.hs @@ -0,0 +1,30 @@ +module Date + ( Date(..) + , getCurrentDate + , sameDayAndMonth + , yearsGap + ) where + +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.LocalTime + +data Date = Date + { year :: Int + , month :: Int + , day :: Int + } deriving (Eq, Show) + +getCurrentDate :: IO Date +getCurrentDate = do + now <- getCurrentTime + timezone <- getCurrentTimeZone + let zoneNow = utcToLocalTime timezone now + let (year, month, day) = toGregorian $ localDay zoneNow + return $ Date (fromIntegral year) month day + +sameDayAndMonth :: Date -> Date -> Bool +sameDayAndMonth (Date _ m1 d1) (Date _ m2 d2) = m1 == m2 && d1 == d2 + +yearsGap :: Date -> Date -> Int +yearsGap (Date y1 _ _) (Date y2 _ _) = abs (y2 - y1) diff --git a/src/Mail.hs b/src/Mail.hs new file mode 100644 index 0000000..7bb6814 --- /dev/null +++ b/src/Mail.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Mail + ( mailSubject + , mailBody + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Date +import 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 = + let count = length birthdates + birthdatesWithLines = map (mapFst getLine) . zip [1..] $ birthdates + getLine 1 = if count == 1 then SingleLine else FirstLine + getLine 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) + +data Line = + SingleLine + | FirstLine + | MiddleLine + | LastLine + deriving (Eq, Show) + +mailLine :: Date -> (Line, Birthdate) -> Text +mailLine date (SingleLine, birthdate) = + T.concat + [ fullname birthdate + , " is now " + , T.pack . show $ age date birthdate + , " years old." + ] +mailLine date (FirstLine, birthdate) = + T.concat + [ fullname birthdate + , " is now " + , T.pack . show $ age date birthdate + , " years old" + ] +mailLine date (MiddleLine, birthdate) = + T.concat + [ ", " + , fullname birthdate + , " is " + , T.pack . show $ age date birthdate + , " years old" + ] +mailLine date (LastLine, birthdate) = + T.concat + [ " and " + , fullname birthdate + , " is " + , T.pack . show $ age date birthdate + , " years old." + ] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..9debfe1 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import System.IO (stderr) + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Date (getCurrentDate) +import Birthdate (readBirthdates, filterBirthday) +import Mail (mailSubject, mailBody) +import SendMail (sendMail) +import Config + +birthdatePath :: FilePath +birthdatePath = "birthdates.csv" + +configPath :: FilePath +configPath = "config.txt" + +main :: IO () +main = do + eitherBirthdates <- readBirthdates birthdatePath + eitherConfig <- getConfig configPath + case (eitherBirthdates, eitherConfig) of + (Left error, _) -> + T.hPutStr stderr $ + T.concat + [ "Error while parsing file " + , T.pack birthdatePath + , ":\n" + , error + ] + (_, Left error) -> + T.hPutStr stderr $ + T.concat + [ "Error while parsing config file " + , T.pack birthdatePath + , ":\n" + , error + ] + (Right birthdates, Right config) -> do + currentDate <- getCurrentDate + let birthdays = filterBirthday currentDate birthdates + sendMail + (mailTo config) + (mailFrom config) + (mailSubject birthdays) + (mailBody currentDate birthdays) diff --git a/src/SendMail.hs b/src/SendMail.hs new file mode 100644 index 0000000..23b1b80 --- /dev/null +++ b/src/SendMail.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendMail + ( sendMail + ) where + +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) + +import Network.Mail.Mime + +sendMail :: Text -> Text -> Text -> Text -> IO () +sendMail to from subject body = do + renderSendMail (simpleMail' (address to) (address from) subject (fromStrict body)) + +address :: Text -> Address +address email = + Address + { addressName = Nothing + , addressEmail = email + } |