some error handling and cleanup that comes with it

app/Config.hs

@@ -4,6 +4,7 @@ module Config where
 import qualified Toml
 import Toml(TomlCodec, (.=))
 import qualified Data.Text as T
+import Monad
 
 data Config = Config {
   mailDomain :: String
@@ -11,6 +12,7 @@ data Config = Config {
   ,mailPassword :: String
   ,mailTo       :: T.Text
   ,mailFrom     :: T.Text
+  ,mailErrorTo  :: T.Text
   } deriving Show
 
 configCodec :: TomlCodec Config
@@ -20,10 +22,11 @@ configCodec = Config
   <*> Toml.string "mailPassword" .= mailPassword
   <*> Toml.text   "mailTo"       .= mailTo
   <*> Toml.text   "mailFrom"     .= mailFrom
+  <*> Toml.text   "mailErrorTo"  .= mailErrorTo
 
-parseFile :: String -> IO (Either String Config)
+parseConfigFile :: (MonadIO m, MonadFail m) => String -> m Config
-parseFile path = do
+parseConfigFile path = do
-  config <- Toml.decodeFileEither configCodec path
+  config <- liftIO $ Toml.decodeFileEither configCodec path
   case config of
-    Left errors -> return $ Left $ unwords $ fmap show errors
+    Left errors -> fail $ unwords $ fmap show errors
-    Right x -> return $ Right $ x
+    Right x -> return x

app/Main.hs

@@ -16,6 +16,7 @@ import System.Environment
 import System.Exit
 import Data.Time.Format.ISO8601
 import Sender
+import Monad
 
 isChoirThisWeek :: Day -> Day -> Bool
 isChoirThisWeek today day = today <= day && diffDays day today <= 6
@@ -23,30 +24,46 @@ isChoirThisWeek today day = today <= day && diffDays day today <= 6
 getToday :: IO Day
 getToday = utctDay <$> getCurrentTime
 
-reportError :: String -> IO ()
+reportErrorLocal :: MonadIO m => String -> m ()
-reportError err = hPutStr stderr err
+reportErrorLocal err = liftIO $ hPutStr stderr err
+
+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')
+
+findChoirDay :: Day -> [MailRecord] -> Either String MailRecord
+findChoirDay today table = maybe
+  (Left "Keine Probe :(")
+  (Right)
+  (L.find ((isChoirThisWeek today) .date) table)
+
+
+main' :: App ()
+main' = do
+  args <- liftIO getArgs
+  if length args /= 1
+  then
+    fail "We need exactly one config path as option"
+  else do
+    config <- parseConfigFile (head args)
+    -- we want to handle these while we have the config in scope
+    result <- liftIO $ runApp $ do
+      bs <- request
+      table <- except $ parseBString bs
+      today <- liftIO getToday
+      record <- except $ findChoirDay today table
+      send (mailDomain config) (mailUsername config) (mailPassword config) (mailTo config) (mailFrom config) (mailSubject record) (mailText record)
+    case result of
+      Right x -> return x
+      Left error' -> reportErrorMail config error'
+
+
 
 main :: IO ()
 main = do
-  args <- getArgs
+  result <- runApp main'
-  if length args /= 1
+  case result of
-  then
+    Right x -> return x
-    die "We need exactly one argument"
+    Left error' -> reportErrorLocal error'
-  else do
-    configE <- parseFile (head args)
-    case configE of
-      Left text -> reportError text
-      Right config -> do
-        bs <- request
-        let eitherTable = parseBString bs
-        case eitherTable of
-          Left x -> reportError x
-          Right table -> do
-            today <- getToday
-            maybe 
-              (T.putStr "Keine Probe :(")
-              (\record -> send (mailDomain config) (mailUsername config) (mailPassword config) (mailTo config) (mailFrom config) (mailSubject record) (mailText record))
-              (L.find ((isChoirThisWeek today) . date) table)
 
 mailText :: MailRecord -> LT.Text
 mailText record = LT.fromStrict $T.concat ["Guten Morgen,\n\n"

app/Monad.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+module Monad(
+    App
+  ,module Control.Monad.Fail
+  ,module Control.Monad.IO.Class
+  ,throwE
+  ,except
+  ,runApp
+  ) where
+  
+import qualified Control.Monad.Trans.Except as T
+import Control.Monad.Fail
+import Control.Monad.IO.Class
+
+
+-- We need this type isomorphism, because we want a different
+-- MonadFail implementation, if someone knows how to do this
+-- without writing the isomorphism out explicitly for all
+-- the other instances, (or without scary GeneralisedNewtypeDeriving)
+--  I would be happy
+newtype App a = App { runApp' :: T.ExceptT String IO a}
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadFail App where
+  fail = throwE
+
+-- reimplementing ExceptT interface
+-- I would love not to have to do this but I don't know how
+throwE :: String -> App a
+throwE = App . T.throwE
+
+except :: Either String a -> App a
+except = App . T.except
+
+runApp :: App a -> IO (Either String a)
+runApp = T.runExceptT . runApp'

app/Sender.hs

@@ -5,14 +5,15 @@ import Network.Mail.Mime
 import Network.Mail.SMTP
 import qualified Data.Text as ST
 import qualified Data.Text.Lazy as LT
+import Monad
 
 
 generateMail :: ST.Text -> ST.Text -> ST.Text -> LT.Text -> Mail
 generateMail to from subj = simpleMail' (Address Nothing to) (Address Nothing from) subj
 
 --     domain -> Username -> password -> To  -> From   -> Subject -> Body
-send :: String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> IO ()
+send :: (MonadIO m) => String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> m ()
-send domain user pass to from subj body = sendMailWithLoginTLS domain user pass mail
+send domain user pass to from subj body = liftIO $ sendMailWithLoginTLS domain user pass mail
   where
     mail = generateMail to from subj body
 

choirMail.cabal

@@ -69,6 +69,7 @@ executable choirMail
                       , TableParser
                       , Requester
                       , Sender
+                      , Monad
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -76,6 +77,7 @@ executable choirMail
     -- Other library packages from which modules are imported.
     -- ^>=4.15.1.0
     build-depends:    base ^>=4.15.1.0
+                      ,transformers
                       ,tomland >= 1.3.3.0
                       ,smtp-mail
                       ,optparse-applicative

choirMail.nix

@@ -1,5 +1,6 @@
 { mkDerivation, base, bytestring, lib, mime-mail, modern-uri
 , optparse-applicative, parsec, req, smtp-mail, text, time, tomland
+, transformers
 }:
 mkDerivation {
   pname = "choirMail";
@@ -9,7 +10,7 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [
     base bytestring mime-mail modern-uri optparse-applicative parsec
-    req smtp-mail text time tomland
+    req smtp-mail text time tomland transformers
   ];
   homepage = ""https://git.nerfingen.de/nerf/choirMail"";
   license = lib.licenses.gpl3Plus;

flake.nix

@@ -49,8 +49,8 @@
                        colorscheme solarized-dark
                        set global tabstop 2
                        set global indentwidth 2
-                       # eval %sh{kak-lsp  --kakoune --session $kak_session -c ${kak-lsp-config}}
+                       eval %sh{kak-lsp  --kakoune --session $kak_session -c ${kak-lsp-config}}
-                       eval %sh{kak-lsp --kakoune --session $kak_session -c ${kak-lsp-config} --log /tmp/kak-lpsLog -vvvv}
+                       # eval %sh{kak-lsp --kakoune --session $kak_session -c ${kak-lsp-config} --log /tmp/kak-lpsLog -vvvv}
                        hook global WinSetOption filetype=(haskell|nix) %{
                          lsp-auto-hover-enable
                          lsp-enable-window