From 6cfff0cc8dea84e2a304d350118112ff5113adec Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 9 Oct 2015 23:09:28 +0200
Subject: Initial commit

---
 .gitignore       |  6 +++++
 README           | 20 +++++++++++++++
 birthday.cabal   | 17 +++++++++++++
 src/Birthdate.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/Config.hs    | 32 ++++++++++++++++++++++++
 src/Date.hs      | 30 ++++++++++++++++++++++
 src/Mail.hs      | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/Main.hs      | 52 ++++++++++++++++++++++++++++++++++++++
 src/SendMail.hs  | 21 ++++++++++++++++
 9 files changed, 329 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 README
 create mode 100644 birthday.cabal
 create mode 100644 src/Birthdate.hs
 create mode 100644 src/Config.hs
 create mode 100644 src/Date.hs
 create mode 100644 src/Mail.hs
 create mode 100644 src/Main.hs
 create mode 100644 src/SendMail.hs

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
+    }
-- 
cgit v1.2.3