diff --git a/src/TiedoteMD/Send.hs b/src/TiedoteMD/Send.hs index 0b9963d..33809af 100644 --- a/src/TiedoteMD/Send.hs +++ b/src/TiedoteMD/Send.hs @@ -4,7 +4,6 @@ module TiedoteMD.Send where import Control.Concurrent (threadDelay) -import Control.Exception (throwIO) import Control.Lens (set, _Just) import Control.Monad (forever, unless) import Data.Acid (AcidState, query, update) @@ -15,8 +14,7 @@ import Data.MIME.Charset (defaultCharsets) import Data.Set (Set) import Data.Time (getCurrentTime) import System.Exit (ExitCode(..)) -import System.Exit.Codes (codeTempFail) -import System.IO (hClose, stdout) +import System.IO (hClose, stdout, stderr) import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc) import System.Random (getStdRandom, uniform) @@ -25,18 +23,25 @@ import qualified Data.IMF as IMF import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.IO as T import TiedoteMD.State import TiedoteMD.Types sendmail :: FilePath -> LBS.ByteString -> IO () sendmail path bs = do - (Just stdin, _, _, processHandle) <- createProcess (proc path ["-t"]) {std_in = CreatePipe} + (Just stdin, _, Just stderr, processHandle) <- createProcess + (proc path ["-t"]) {std_in = CreatePipe, std_err = CreatePipe} LBS.hPut stdin bs hClose stdin + errors <- T.hGetContents stderr exitCode <- waitForProcess processHandle - unless (exitCode `elem` [ExitSuccess, codeTempFail]) $ - throwIO $ ProcessError (T.pack path) exitCode + -- TODO: handle System.Exit.Codes.codeTempFail differently from other failures + unless (exitCode == ExitSuccess) $ do + T.hPutStr System.IO.stderr $ + "Sending mail with " <> (T.pack path) <> " failed with " <> (T.pack $ show exitCode) + unless (T.null errors) $ T.hPutStrLn System.IO.stderr $ ":\n" <> errors + T.hPutStrLn System.IO.stderr "" manageQueue :: AcidState State -> Mailbox -> FilePath -> IO () manageQueue acid sender sendmailPath = forever $ do