From b9941268b7e35c20100dbefba65bf887a40aa11c Mon Sep 17 00:00:00 2001
From: Saku Laesvuori <saku@laesvuori.fi>
Date: Wed, 14 May 2025 15:45:19 +0300
Subject: [PATCH] =?UTF-8?q?Jatka=20l=C3=A4hett=C3=A4mist=C3=A4=20yksitt?=
 =?UTF-8?q?=C3=A4isist=C3=A4=20l=C3=A4hetysvirheist=C3=A4=20huolimatta?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Yksi ainoa lähetysvirhe riitti aiemmin kaatamaan tiedotejärjestelmän
postitussilmukan. Tällä muutoksella lähetysvirheet tulostetaan
virhelokiin ja ne aiheuttaneet viestit unohdetaan.
---
 src/TiedoteMD/Send.hs | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

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