From 616fc489900434fda2a813fdc64749a6e278778e Mon Sep 17 00:00:00 2001 From: nerf van nerfingen Date: Sat, 12 Nov 2022 16:18:11 +0100 Subject: [PATCH] some error handling and cleanup that comes with it --- app/Config.hs | 13 ++++++----- app/Main.hs | 59 +++++++++++++++++++++++++++++++------------------ app/Monad.hs | 36 ++++++++++++++++++++++++++++++ app/Sender.hs | 5 +++-- choirMail.cabal | 2 ++ choirMail.nix | 3 ++- flake.nix | 4 ++-- 7 files changed, 91 insertions(+), 31 deletions(-) create mode 100644 app/Monad.hs diff --git a/app/Config.hs b/app/Config.hs index 9e60a41..6d87a35 100644 --- a/app/Config.hs +++ b/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) -parseFile path = do - config <- Toml.decodeFileEither configCodec path +parseConfigFile :: (MonadIO m, MonadFail m) => String -> m Config +parseConfigFile path = do + config <- liftIO $ Toml.decodeFileEither configCodec path case config of - Left errors -> return $ Left $ unwords $ fmap show errors - Right x -> return $ Right $ x + Left errors -> fail $ unwords $ fmap show errors + Right x -> return x diff --git a/app/Main.hs b/app/Main.hs index 2af03b4..61278d1 100644 --- a/app/Main.hs +++ b/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 () -reportError err = hPutStr stderr err +reportErrorLocal :: MonadIO m => String -> m () +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 - if length args /= 1 - then - die "We need exactly one argument" - 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) + result <- runApp main' + case result of + Right x -> return x + Left error' -> reportErrorLocal error' mailText :: MailRecord -> LT.Text mailText record = LT.fromStrict $T.concat ["Guten Morgen,\n\n" diff --git a/app/Monad.hs b/app/Monad.hs new file mode 100644 index 0000000..42b4593 --- /dev/null +++ b/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' diff --git a/app/Sender.hs b/app/Sender.hs index db83590..efbe8d2 100644 --- a/app/Sender.hs +++ b/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 domain user pass to from subj body = sendMailWithLoginTLS domain user pass mail +send :: (MonadIO m) => String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> m () +send domain user pass to from subj body = liftIO $ sendMailWithLoginTLS domain user pass mail where mail = generateMail to from subj body diff --git a/choirMail.cabal b/choirMail.cabal index 8f84479..a2b5e09 100644 --- a/choirMail.cabal +++ b/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 diff --git a/choirMail.nix b/choirMail.nix index 450fd5e..7763d97 100644 --- a/choirMail.nix +++ b/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; diff --git a/flake.nix b/flake.nix index 9b482f6..3c351e7 100644 --- a/flake.nix +++ b/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} --log /tmp/kak-lpsLog -vvvv} + 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} hook global WinSetOption filetype=(haskell|nix) %{ lsp-auto-hover-enable lsp-enable-window