Send weekly activity at start of week about previous week

1 files changed, 30 insertions, 8 deletions

diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs
index 170ab36..4a247e9 100644
--- a/src/server/Utils/Time.hs
+++ b/src/server/Utils/Time.hs
@@ -1,22 +1,44 @@
 module Utils.Time
   ( belongToCurrentMonth
+  , belongToCurrentWeek
   , timeToDay
+  , monthToKey
   ) where
 
-import Data.Time.Clock
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.LocalTime
 import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate (toWeekDate)
+
+import Model.Message.Key (Key)
+import qualified Model.Message.Key as K
 
 belongToCurrentMonth :: UTCTime -> IO Bool
 belongToCurrentMonth time = do
-  timeMonth <- dayMonth <$> timeToDay time
-  actualMonth <- dayMonth <$> (getCurrentTime >>= timeToDay)
-  return (timeMonth == actualMonth)
+  (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time
+  (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay)
+  return (actualYear == timeYear && actualMonth == timeMonth)
+
+belongToCurrentWeek :: UTCTime -> IO Bool
+belongToCurrentWeek time = do
+  (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time
+  (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay)
+  return (actualYear == timeYear && actualWeek == timeWeek)
 
 timeToDay :: UTCTime -> IO Day
 timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time
 
-dayMonth :: Day -> Int
-dayMonth day =
-  let (_, month, _) = toGregorian day
-  in  month
+monthToKey :: Int -> Maybe Key
+monthToKey 1  = Just K.January
+monthToKey 2  = Just K.February
+monthToKey 3  = Just K.March
+monthToKey 4  = Just K.April
+monthToKey 5  = Just K.May
+monthToKey 6  = Just K.June
+monthToKey 7  = Just K.July
+monthToKey 8  = Just K.August
+monthToKey 9  = Just K.September
+monthToKey 10 = Just K.October
+monthToKey 11 = Just K.November
+monthToKey 12 = Just K.December
+monthToKey _ = Nothing