aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Logger.hs6
-rw-r--r--src/Main.hs67
-rw-r--r--src/Model/Birthdate.hs (renamed from src/Birthdate.hs)5
-rw-r--r--src/Model/BirthdateParser.hs (renamed from src/BirthdateParser.hs)6
-rw-r--r--src/Model/Config.hs (renamed from src/Config.hs)12
-rw-r--r--src/Model/Date.hs (renamed from src/Date.hs)29
-rw-r--r--src/Model/Mail.hs (renamed from src/Mail.hs)51
-rw-r--r--src/Model/Path.hs10
-rw-r--r--src/Notification.hs49
-rw-r--r--src/RenderError.hs34
-rw-r--r--src/Time.hs12
11 files changed, 176 insertions, 105 deletions
diff --git a/src/Logger.hs b/src/Logger.hs
index 4be55be..6faa482 100644
--- a/src/Logger.hs
+++ b/src/Logger.hs
@@ -7,12 +7,12 @@ module Logger
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T (appendFile)
-import Data.Time.LocalTime (getZonedTime)
-import Data.Time.Format (formatTime, defaultTimeLocale)
+
+import Time (formatCurrentLocale)
info :: Text -> IO ()
info message = do
- time <- T.pack <$> formatTime defaultTimeLocale "[%d/%m/%Y, %H:%M]" <$> getZonedTime
+ time <- formatCurrentLocale "[%d/%m/%Y, %H:%M]"
T.appendFile "logs" $
T.concat
[ time
diff --git a/src/Main.hs b/src/Main.hs
index 0aa2910..e3bd0ce 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,67 +4,24 @@ module Main
( main
) where
-import System.IO (stderr)
-
-import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Date (getCurrentDate)
-import Birthdate (Birthdate, filterBirthdayAt)
-import BirthdateParser (parseBirthdates)
-import Mail (mailSubject, mailBody)
-import SendMail (sendMail)
-import Config
-
-birthdatePath :: FilePath
-birthdatePath = "birthdates.csv"
+import qualified RenderError
+import qualified Notification
-configPath :: FilePath
-configPath = "config.txt"
+import Model.Config
+import Model.BirthdateParser (parseBirthdates)
+import qualified Model.Path as Path
main :: IO ()
main = do
- eitherBirthdates <- parseBirthdates <$> T.readFile birthdatePath
- eitherConfig <- getConfig configPath
+ eitherBirthdates <- parseBirthdates <$> T.readFile Path.birthdate
+ eitherConfig <- getConfig Path.config
case (eitherBirthdates, eitherConfig) of
(Left err, _) ->
- birthdateError err
+ RenderError.birthdate err
(_, Left err) ->
- configError err
- (Right birthdates, Right config) ->
- sendNotificationForBirthdayToday birthdates config
-
-birthdateError :: Text -> IO ()
-birthdateError err =
- T.hPutStr stderr $
- T.concat
- [ "Error while parsing file "
- , T.pack birthdatePath
- , ":\n"
- , err
- ]
-
-configError :: Text -> IO ()
-configError err =
- T.hPutStr stderr $
- T.concat
- [ "Error while parsing config file "
- , T.pack configPath
- , ":\n"
- , err
- ]
-
-sendNotificationForBirthdayToday :: [Birthdate] -> Config -> IO ()
-sendNotificationForBirthdayToday birthdates config = do
- currentDate <- getCurrentDate
- let birthdays = filterBirthdayAt currentDate birthdates
- if not (null birthdays)
- then
- sendMail
- (mailTo config)
- (mailFrom config)
- (mailSubject birthdays)
- (mailBody currentDate birthdays)
- else
- return ()
+ RenderError.config err
+ (Right birthdates, Right config) -> do
+ Notification.today birthdates config
+ Notification.nextWeek birthdates config
diff --git a/src/Birthdate.hs b/src/Model/Birthdate.hs
index 48d3a4e..d135419 100644
--- a/src/Birthdate.hs
+++ b/src/Model/Birthdate.hs
@@ -1,16 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
-module Birthdate
+module Model.Birthdate
( Birthdate(..)
, fullname
, age
, filterBirthdayAt
+ , filterBirthdayBetween
) where
import Data.Text (Text)
import qualified Data.Text as T
-import Date
+import Model.Date
data Birthdate = Birthdate
{ date :: Date
diff --git a/src/BirthdateParser.hs b/src/Model/BirthdateParser.hs
index 9fa7c50..c9ac3b9 100644
--- a/src/BirthdateParser.hs
+++ b/src/Model/BirthdateParser.hs
@@ -1,4 +1,4 @@
-module BirthdateParser
+module Model.BirthdateParser
( parseBirthdates
) where
@@ -9,8 +9,8 @@ import qualified Data.Text as T
import Text.ParserCombinators.Parsec
-import Birthdate
-import Date
+import Model.Birthdate
+import Model.Date
parseBirthdates :: Text -> Either Text [Birthdate]
parseBirthdates input =
diff --git a/src/Config.hs b/src/Model/Config.hs
index c01bbe1..b583048 100644
--- a/src/Config.hs
+++ b/src/Model/Config.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
-module Config
+module Model.Config
( getConfig
, Config(..)
) where
@@ -14,19 +14,19 @@ 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
+ , dayForNextWeekNotification :: 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")
+ Config <$>
+ (T.pack <$> get cp "DEFAULT" "mail-to") <*>
+ (T.pack <$> get cp "DEFAULT" "mail-from") <*>
+ (T.pack <$> get cp "DEFAULT" "day-for-next-week-notification")
)
diff --git a/src/Date.hs b/src/Model/Date.hs
index 63830d3..96c15e9 100644
--- a/src/Date.hs
+++ b/src/Model/Date.hs
@@ -1,6 +1,10 @@
-module Date
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Date
( Date(..)
, getCurrentDate
+ , getNextWeek
+ , plusDays
, sameDayAndMonth
, isBeforeOrEqualDayAndMonth
, isAfterOrEqualDayAndMonth
@@ -10,6 +14,9 @@ module Date
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
@@ -22,8 +29,24 @@ getCurrentDate = do
now <- getCurrentTime
timezone <- getCurrentTimeZone
let zoneNow = utcToLocalTime timezone now
- let (y, m, d) = toGregorian $ localDay zoneNow
- return $ Date d m (fromIntegral y)
+ 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 =
diff --git a/src/Mail.hs b/src/Model/Mail.hs
index dc533ef..e730e32 100644
--- a/src/Mail.hs
+++ b/src/Model/Mail.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-module Mail
+module Model.Mail
( mailSubject
, mailBody
) where
@@ -8,8 +8,8 @@ module Mail
import Data.Text (Text)
import qualified Data.Text as T
-import Date
-import Birthdate
+import Model.Date
+import Model.Birthdate
mailSubject :: [Birthdate] -> Text
mailSubject birthdates =
@@ -26,14 +26,15 @@ mailSubject birthdates =
mailBody :: Date -> [Birthdate] -> Text
mailBody currentDate birthdates =
+ T.concat $ map (mailLine currentDate) (attachLines birthdates)
+
+attachLines :: [Birthdate] -> [(Line, Birthdate)]
+attachLines birthdates =
let count = length birthdates
- birthdatesWithLines = map (mapFst lineKind) . zip [1..] $ birthdates
lineKind 1 = if count == 1 then SingleLine else FirstLine
lineKind 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)
+ mapFst f (x, y) = (f x, y)
+ in map (mapFst lineKind) . zip [1..] $ birthdates
data Line =
SingleLine
@@ -43,33 +44,17 @@ data Line =
deriving (Eq, Show)
mailLine :: Date -> (Line, Birthdate) -> Text
-mailLine currDate (SingleLine, birthdate) =
+mailLine currDate (line, birthdate) =
T.concat
- [ fullname birthdate
- , " is now "
- , T.pack . show $ age currDate birthdate
- , " years old."
- ]
-mailLine currDate (FirstLine, birthdate) =
- T.concat
- [ fullname birthdate
- , " is now "
- , T.pack . show $ age currDate birthdate
- , " years old"
- ]
-mailLine currDate (MiddleLine, birthdate) =
- T.concat
- [ ", "
+ [ case line of
+ MiddleLine -> ", "
+ LastLine -> " and "
+ _ -> ""
, fullname birthdate
- , " is "
+ , case line of
+ x | x `elem` [SingleLine, FirstLine] -> " is now "
+ _ -> " is "
, T.pack . show $ age currDate birthdate
, " years old"
- ]
-mailLine currDate (LastLine, birthdate) =
- T.concat
- [ " and "
- , fullname birthdate
- , " is "
- , T.pack . show $ age currDate birthdate
- , " years old."
+ , if line == LastLine then "." else ""
]
diff --git a/src/Model/Path.hs b/src/Model/Path.hs
new file mode 100644
index 0000000..d34716c
--- /dev/null
+++ b/src/Model/Path.hs
@@ -0,0 +1,10 @@
+module Model.Path
+ ( birthdate
+ , config
+ ) where
+
+birthdate :: FilePath
+birthdate = "birthdates.csv"
+
+config :: FilePath
+config = "config.txt"
diff --git a/src/Notification.hs b/src/Notification.hs
new file mode 100644
index 0000000..de4a591
--- /dev/null
+++ b/src/Notification.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Notification
+ ( today
+ , nextWeek
+ ) where
+
+import qualified Data.Text as T
+
+import SendMail (sendMail)
+import Time (formatCurrentLocale)
+
+import Model.Date (getCurrentDate, getNextWeek)
+import Model.Birthdate (Birthdate, filterBirthdayAt, filterBirthdayBetween)
+import Model.Mail (mailSubject, mailBody)
+import Model.Config
+
+today :: [Birthdate] -> Config -> IO ()
+today birthdates config = do
+ currentDate <- getCurrentDate
+ let birthdays = filterBirthdayAt currentDate birthdates
+ if not (null birthdays)
+ then
+ sendMail
+ (mailTo config)
+ (mailFrom config)
+ (mailSubject birthdays)
+ (mailBody currentDate birthdays)
+ else
+ return ()
+
+nextWeek :: [Birthdate] -> Config -> IO ()
+nextWeek birthdates config = do
+ currentDayOfWeek <- formatCurrentLocale "%A"
+ if T.toLower currentDayOfWeek == T.toLower (dayForNextWeekNotification config)
+ then do
+ (begin, end) <- getNextWeek
+ let birthdays = filterBirthdayBetween begin end birthdates
+ if not (null birthdays)
+ then
+ sendMail
+ (mailTo config)
+ (mailFrom config)
+ ""
+ ""
+ else
+ return ()
+ else
+ return ()
diff --git a/src/RenderError.hs b/src/RenderError.hs
new file mode 100644
index 0000000..9b9732f
--- /dev/null
+++ b/src/RenderError.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RenderError
+ ( birthdate
+ , config
+ ) where
+
+import System.IO (stderr)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+import qualified Model.Path as Path
+
+birthdate :: Text -> IO ()
+birthdate err =
+ T.hPutStr stderr $
+ T.concat
+ [ "Error while parsing file "
+ , T.pack Path.birthdate
+ , ":\n"
+ , err
+ ]
+
+config :: Text -> IO ()
+config err =
+ T.hPutStr stderr $
+ T.concat
+ [ "Error while parsing config file "
+ , T.pack Path.config
+ , ":\n"
+ , err
+ ]
diff --git a/src/Time.hs b/src/Time.hs
new file mode 100644
index 0000000..97a9317
--- /dev/null
+++ b/src/Time.hs
@@ -0,0 +1,12 @@
+module Time
+ ( formatCurrentLocale
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.LocalTime (getZonedTime)
+import Data.Time.Format (formatTime, defaultTimeLocale)
+
+formatCurrentLocale :: Text -> IO Text
+formatCurrentLocale format =
+ T.pack <$> formatTime defaultTimeLocale (T.unpack format) <$> getZonedTime
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 02:01:34 +0000