Get next week birthdays and send an empty mail for the moment

1 files changed, 74 insertions, 0 deletions

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)