aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore6
-rw-r--r--README20
-rw-r--r--birthday.cabal17
-rw-r--r--src/Birthdate.hs76
-rw-r--r--src/Config.hs32
-rw-r--r--src/Date.hs30
-rw-r--r--src/Mail.hs75
-rw-r--r--src/Main.hs52
-rw-r--r--src/SendMail.hs21
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
diff --git a/README b/README
new file mode 100644
index 0000000..fd0d2d0
--- /dev/null
+++ b/README
@@ -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
+ }