From 6f50add62a82c2765c71dd30fa73adabf073b403 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Fri, 6 Jun 2025 20:39:28 +0200 Subject: [PATCH 1/3] Added mandatory `Date:` header to E-Mail (why doesn't the library do that?) --- app/Sender.hs | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/app/Sender.hs b/app/Sender.hs index efbe8d2..1ac086a 100644 --- a/app/Sender.hs +++ b/app/Sender.hs @@ -1,19 +1,31 @@ {-# LANGUAGE OverloadedStrings #-} -module Sender where +module Sender + (generateMail + ,send + ) where import Network.Mail.Mime import Network.Mail.SMTP import qualified Data.Text as ST import qualified Data.Text.Lazy as LT import Monad +import Data.Time.LocalTime (getZonedTime) +import Data.Time.Format (formatTime, defaultTimeLocale) +rfc5322Format :: String +rfc5322Format = "%a, %d %b %0Y %T %z" -generateMail :: ST.Text -> ST.Text -> ST.Text -> LT.Text -> Mail -generateMail to from subj = simpleMail' (Address Nothing to) (Address Nothing from) subj +generateMail :: (MonadIO m) => ST.Text -> ST.Text -> ST.Text -> LT.Text -> m Mail +generateMail to from subj body = do + time <- liftIO getZonedTime + let timeString = ST.pack $ formatTime defaultTimeLocale rfc5322Format time + mailWithoutDate = simpleMail' (Address Nothing to) (Address Nothing from) subj body + mailWithDate = mailWithoutDate {mailHeaders = ("Date",timeString) : mailHeaders mailWithoutDate} + return mailWithDate -- domain -> Username -> password -> To -> From -> Subject -> Body send :: (MonadIO m) => String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> m () -send domain user pass to from subj body = liftIO $ sendMailWithLoginTLS domain user pass mail - where - mail = generateMail to from subj body +send domain user pass to from subj body = do + mail <- liftIO $ generateMail to from subj body + liftIO $ sendMailWithLoginTLS domain user pass mail From a460fd561f9b97aaaea5fba9e2f0483745eec8b9 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sat, 7 Jun 2025 03:33:27 +0200 Subject: [PATCH 2/3] added error handling to the web request (and changed from req to wreq) --- README.md | 19 +++++++++++-------- app/Requester.hs | 31 +++++++++++++++++++------------ app/TableParser.hs | 13 ++++++------- choirMail.cabal | 5 +++-- choirMail.nix | 10 +++++----- 5 files changed, 44 insertions(+), 34 deletions(-) diff --git a/README.md b/README.md index 93a4f5b..038d91f 100644 --- a/README.md +++ b/README.md @@ -12,14 +12,14 @@ Just run the binary to send a mail, it requires exactly one parameter that points to a config file. ### Configuration -The config file is a toml file, even though it as of now makes not really use +The config file is a toml file, even though as of now it makes not really use of any toml features. ```toml [mail] domain = "the domain of the smtp server to send messages with" user = "the username on the smtp server" -password = "the passwond on the smtp server" +password = "the password on the smtp server" to = "the mail to send to" from = "the sender of the mail" errorTo = "the address to send a mail to in case of error" @@ -30,10 +30,13 @@ If you run `nix develop` you get a set up kakoune with an lsp. Be aware this depends on your local cabal cache. # TODO -- [] Better E-Mail generation -- [] Add the nix modules to the flake -- [] Better Error handling - - [] Find out which exceptions the SMTP module throws -- [] Split config into secrets and non secret config - - [] make the pad url configurable +- [ ] Better E-Mail generation +- [ ] Add the nix modules to the flake +- [ ] Better Error handling + - [x] Find out which exceptions the SMTP module throws + - [ ] also log to stderr if we send an error E-Mail + - [ ] move from MonadFail to MonadError from Control.Monad.Except +- [ ] Split config into secrets and non secret config + - [ ] make the pad url configurable - [x] Clean up Strict vs Lazy Text +- [ ] decide finally if we want to use wreq or req and don't flip flop between both libs diff --git a/app/Requester.hs b/app/Requester.hs index 2890757..bb88f5e 100644 --- a/app/Requester.hs +++ b/app/Requester.hs @@ -1,18 +1,25 @@ {-# LANGUAGE OverloadedStrings, DataKinds#-} module Requester(request) where -import Network.HTTP.Req --- import qualified Data.Text as T -import Control.Monad.IO.Class(MonadIO) -import qualified Data.ByteString as B +import qualified Network.Wreq as N +import Network.HTTP.Client (HttpException) +import qualified Control.Exception as E +import Control.Lens.Getter ((^.)) +import qualified Data.ByteString.Lazy as LBS +import Monad -url :: Url 'Https -url = https "md.darmstadt.ccc.de" /: "mathechor-probenplanung" /: "download" +url :: String +url = "https://md.darmstadt.ccc.de/mathechor-probenplanung/download" +eitherToFail :: (Show a, MonadFail m) => Either a b -> m b +eitherToFail (Right a) = return a +eitherToFail (Left b) = fail $ show b - -requestRunner :: (MonadIO m)=> m BsResponse -requestRunner = runReq defaultHttpConfig $ req GET url NoReqBody bsResponse mempty - -request :: (MonadIO m) => m B.ByteString -request = fmap responseBody requestRunner +request :: (MonadIO m, MonadFail m) => m LBS.ByteString +request = do + -- catch might seem to be more convenient instead of catch. But the handler in catch forces + -- IO and not MonadIO, so we can't call fail. We use try to escape so we can escape IO first + -- and then handle the error (with fail in scope) + responseWithError <- liftIO (E.try (N.get url) :: IO (Either HttpException (N.Response LBS.ByteString))) + response <- eitherToFail responseWithError + return $ response ^. N.responseBody diff --git a/app/TableParser.hs b/app/TableParser.hs index 0bbd2cc..66a6491 100644 --- a/app/TableParser.hs +++ b/app/TableParser.hs @@ -3,12 +3,11 @@ module TableParser(MailRecord(..), parseBString, parseTable) where import qualified Text.Parsec as P -- import qualified Text.Parsec.Char as P -import qualified Text.Parsec.Text as P +import qualified Text.Parsec.Text.Lazy as P import qualified Data.Text.Lazy as LT -import qualified Data.Text as ST -import qualified Data.Text.Encoding as ST +import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Time.Calendar as D -import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as B import Control.Monad(void) @@ -70,7 +69,7 @@ parseTable = do P.eof return x -textToMailRecord :: ST.Text -> Either String [MailRecord] +textToMailRecord :: LT.Text -> Either String [MailRecord] textToMailRecord t = case P.parse parseTable "" t of Left x -> Left $ show x Right x -> Right x @@ -81,7 +80,7 @@ parseBString t = do text <- toText t textToMailRecord text -toText :: B.ByteString -> Either String ST.Text -toText t = case ST.decodeUtf8' t of +toText :: B.ByteString -> Either String LT.Text +toText t = case LT.decodeUtf8' t of Left x -> Left $ show x Right x -> Right x diff --git a/choirMail.cabal b/choirMail.cabal index 168d001..516436d 100644 --- a/choirMail.cabal +++ b/choirMail.cabal @@ -81,13 +81,14 @@ executable choirMail ,tomland >= 1.3.3.0 ,smtp-mail ,optparse-applicative - ,req + ,wreq ,parsec ,text ,time ,bytestring ,mime-mail - ,modern-uri + ,http-client + ,lens -- Directories containing source files. diff --git a/choirMail.nix b/choirMail.nix index 7763d97..6e2d449 100644 --- a/choirMail.nix +++ b/choirMail.nix @@ -1,6 +1,6 @@ -{ mkDerivation, base, bytestring, lib, mime-mail, modern-uri -, optparse-applicative, parsec, req, smtp-mail, text, time, tomland -, transformers +{ mkDerivation, base, bytestring, http-client, lens, lib, mime-mail +, optparse-applicative, parsec, smtp-mail, text, time, tomland +, transformers, wreq }: mkDerivation { pname = "choirMail"; @@ -9,8 +9,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base bytestring mime-mail modern-uri optparse-applicative parsec - req smtp-mail text time tomland transformers + base bytestring http-client lens mime-mail optparse-applicative + parsec smtp-mail text time tomland transformers wreq ]; homepage = ""https://git.nerfingen.de/nerf/choirMail""; license = lib.licenses.gpl3Plus; From ab7c39b7077eb37f1486bfa849d51def361928bf Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sat, 7 Jun 2025 03:36:39 +0200 Subject: [PATCH 3/3] if we send an error mail, we also print the error to stderr --- README.md | 2 +- app/Main.hs | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 038d91f..944513c 100644 --- a/README.md +++ b/README.md @@ -34,7 +34,7 @@ this depends on your local cabal cache. - [ ] Add the nix modules to the flake - [ ] Better Error handling - [x] Find out which exceptions the SMTP module throws - - [ ] also log to stderr if we send an error E-Mail + - [x] also log to stderr if we send an error E-Mail - [ ] move from MonadFail to MonadError from Control.Monad.Except - [ ] Split config into secrets and non secret config - [ ] make the pad url configurable diff --git a/app/Main.hs b/app/Main.hs index cc6c243..65ef276 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -25,7 +25,9 @@ reportErrorLocal :: MonadIO m => String -> m () reportErrorLocal = liftIO . hPutStr stderr reportErrorMail :: MonadIO m => Config -> String -> m () -reportErrorMail config error' = send (mailDomain config) (mailUsername config) (mailPassword config) (mailErrorTo config) (mailFrom config) "choirMail Error" (LT.pack error') +reportErrorMail config error' = do + reportErrorLocal error' + send (mailDomain config) (mailUsername config) (mailPassword config) (mailErrorTo config) (mailFrom config) "choirMail Error" (LT.pack error') findChoirDay :: Day -> [MailRecord] -> Either String MailRecord findChoirDay today table = maybe