OMS/tiedote.md
3
0
Fork 0
Code Issues 14 Pull Requests Projects Releases Wiki Activity

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

Browse Source 
Yksi ainoa lähetysvirhe riitti aiemmin kaatamaan tiedotejärjestelmän
postitussilmukan. Tällä muutoksella lähetysvirheet tulostetaan
virhelokiin ja ne aiheuttaneet viestit unohdetaan.
This commit is contained in:
Saku Laesvuori 2025-05-14 15:45:19 +03:00
parent 7a7022eba4
commit b9941268b7
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
1 changed files with 11 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/TiedoteMD/Send.hs
View File

@ -4,7 +4,6 @@
module TiedoteMD.Send where module TiedoteMD.Send where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Exception (throwIO)
import Control.Lens (set, _Just) import Control.Lens (set, _Just)
import Control.Monad (forever, unless) import Control.Monad (forever, unless)
import Data.Acid (AcidState, query, update) import Data.Acid (AcidState, query, update)
@ -15,8 +14,7 @@ import Data.MIME.Charset (defaultCharsets)
import Data.Set (Set) import Data.Set (Set)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.Exit.Codes (codeTempFail) import System.IO (hClose, stdout, stderr)
import System.IO (hClose, stdout)
import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc) import System.Process (CreateProcess(..), StdStream(..), waitForProcess, createProcess, proc)
import System.Random (getStdRandom, uniform) 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.List.NonEmpty as NE
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import TiedoteMD.State import TiedoteMD.State
import TiedoteMD.Types import TiedoteMD.Types
sendmail :: FilePath -> LBS.ByteString -> IO () sendmail :: FilePath -> LBS.ByteString -> IO ()
sendmail path bs = do 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 LBS.hPut stdin bs
hClose stdin hClose stdin
errors <- T.hGetContents stderr
exitCode <- waitForProcess processHandle exitCode <- waitForProcess processHandle
unless (exitCode `elem` [ExitSuccess, codeTempFail]) $ -- TODO: handle System.Exit.Codes.codeTempFail differently from other failures
throwIO $ ProcessError (T.pack path) exitCode 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 :: AcidState State -> Mailbox -> FilePath -> IO ()
manageQueue acid sender sendmailPath = forever $ do manageQueue acid sender sendmailPath = forever $ do