Jatka lähettämistä yksittäisistä lähetysvirheistä huolimatta

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

@@ -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