From 86f9991deeb44a6cc81044e61a9ad3ee001c5ced Mon Sep 17 00:00:00 2001 From: Joris Guyonvarch Date: Sat, 18 Apr 2015 15:46:44 +0200 Subject: Send both plain text and html in mail notifications --- leboncoin-listener.cabal | 2 ++ src/AdListener.hs | 10 +++--- src/Mail.hs | 20 +++++++---- src/View/Ad.hs | 92 ------------------------------------------------ src/View/Html/Ad.hs | 77 ++++++++++++++++++++++++++++++++++++++++ src/View/Plain/Ad.hs | 88 +++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 187 insertions(+), 102 deletions(-) delete mode 100644 src/View/Ad.hs create mode 100644 src/View/Html/Ad.hs create mode 100644 src/View/Plain/Ad.hs diff --git a/leboncoin-listener.cabal b/leboncoin-listener.cabal index e48cdb3..dc7fe0a 100644 --- a/leboncoin-listener.cabal +++ b/leboncoin-listener.cabal @@ -14,3 +14,5 @@ executable leboncoin-listener , HTTP == 4000.2.19 , tagsoup == 0.13.3 , mime-mail == 0.4.8.2 + , blaze-html == 0.8.0.2 + , blaze-markup == 0.7.0.2 diff --git a/src/AdListener.hs b/src/AdListener.hs index c08efc5..4fc9b20 100644 --- a/src/AdListener.hs +++ b/src/AdListener.hs @@ -17,7 +17,8 @@ import Model.Ad import Model.URL import Model.Resume -import View.Ad +import qualified View.Plain.Ad as P +import qualified View.Html.Ad as H import Page import Parser.Detail @@ -64,7 +65,7 @@ listenToNewAdsWithResumes config viewedURLs resumes = time <- getCurrentFormattedTime if not (null newAds) then - let message = renderConsoleAds time newAds + let message = P.renderConsoleAds time newAds in do T.putStrLn message trySendMail config newAds @@ -79,9 +80,10 @@ trySendMail config ads = Nothing -> return () Just mailTo -> - let (title, message) = renderAds ads + let (title, plainBody) = P.renderAds ads + htmlBody = H.renderAds ads in do - eitherMailSuccess <- sendMail mailTo title message + eitherMailSuccess <- sendMail mailTo title plainBody htmlBody case eitherMailSuccess of Right () -> putStrLn "\nMail sent." diff --git a/src/Mail.hs b/src/Mail.hs index 45962a5..83a2bbd 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -5,8 +5,9 @@ module Mail ) where import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (toLazyText, fromText) import Control.Exception (SomeException, try) @@ -14,21 +15,28 @@ import Network.Mail.Mime import Utils.Either (mapLeft) -sendMail :: [Text] -> Text -> Text -> IO (Either Text ()) -sendMail mailTo subject body = safeSendMail (mail mailTo subject body) +sendMail :: [Text] -> Text -> Text -> Text -> IO (Either Text ()) +sendMail mailTo subject plainBody htmlBody = safeSendMail (mail mailTo subject plainBody htmlBody) safeSendMail :: Mail -> IO (Either Text ()) safeSendMail mail = mapLeft (T.pack . show) <$> (try (renderSendMail mail) :: IO (Either SomeException ())) -mail :: [Text] -> Text -> Text -> Mail -mail mailTo subject body = +mail :: [Text] -> Text -> Text -> Text -> Mail +mail mailTo subject plainBody htmlBody = let fromMail = emptyMail (address "no-reply@leboncoin-listener.com") in fromMail { mailTo = map address mailTo - , mailParts = [[plainPart (toLazyText . fromText $ body)]] + , mailParts = + [ [ plainPart . strictToLazy $ plainBody + , htmlPart . strictToLazy $ htmlBody + ] + ] , mailHeaders = [("Subject", subject)] } +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText + address :: Text -> Address address mail = Address { addressName = Nothing, addressEmail = mail } diff --git a/src/View/Ad.hs b/src/View/Ad.hs deleted file mode 100644 index ec5da2d..0000000 --- a/src/View/Ad.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Ad - ( renderConsoleAds - , renderAds - ) where - -import Data.List (intersperse) -import Data.Maybe (fromMaybe) - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Ad (Ad(..)) -import qualified Model.Ad as Ad - -import Model.Resume (Resume(..)) -import qualified Model.Resume as Resume - -import Model.Detail (Detail(..)) -import qualified Model.Detail as Detail - -import Model.URL - -renderConsoleAds :: Text -> [Ad] -> Text -renderConsoleAds time ads = - let (title, message) = renderAds ads - titleWithTime = - T.concat - [ "\n[" - , time - , "] " - , title - ] - line = T.map (\_ -> '-') titleWithTime - in T.intercalate - "\n" - [ titleWithTime - , line - , "" - , message - ] - -renderAds :: [Ad] -> (Text, Text) -renderAds ads = - let titleMessage = renderTitle $ length ads - adsMessage = T.intercalate "\n\n" . map renderAd $ ads - in (titleMessage, adsMessage) - -renderTitle :: Int -> Text -renderTitle count = - T.concat - [ T.pack . show $ count - , agreement " nouvelle" - , agreement " annonce" - ] - where agreement word = - T.concat - [ word - , if count > 1 then "s" else "" - ] - -renderAd :: Ad -> Text -renderAd ad = - T.concat - [ renderResume (Ad.resume ad) - , "\n\n" - , renderDetail (Ad.detail ad) - ] - -renderResume :: Resume -> Text -renderResume resume = - let formatPrice price = T.concat [" - ", price] - price = fromMaybe "" . fmap formatPrice . Resume.price $ resume - titleLine = T.concat [Resume.name resume, price] - in T.intercalate "\n" [titleLine, Resume.url resume] - -renderDetail :: Detail -> Text -renderDetail detail = - T.concat - [ fromMaybe "−" (Detail.description detail) - , renderURLs "\n\nImages" (Detail.images detail) - ] - -renderURLs :: Text -> [URL] -> Text -renderURLs title [] = "" -renderURLs title urls = - T.concat - [ title - , "\n\n" - , T.intercalate "\n" urls - ] diff --git a/src/View/Html/Ad.hs b/src/View/Html/Ad.hs new file mode 100644 index 0000000..fce164e --- /dev/null +++ b/src/View/Html/Ad.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Html.Ad + ( renderAds + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.List (intersperse) + +import Text.Blaze.Html +import Text.Blaze.Html5 (Html) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Internal (textValue) + +import Model.Ad +import qualified Model.Ad as A + +import Model.Resume (Resume) +import qualified Model.Resume as R + +import Model.Detail (Detail) +import qualified Model.Detail as D + +import Model.URL + +renderAds :: [Ad] -> Text +renderAds = toStrict . renderHtml . adsHtml + +adsHtml :: [Ad] -> Html +adsHtml ads = H.div (mapM_ adHtml ads) + +adHtml :: Ad -> Html +adHtml ad = + let resume = A.resume ad + detail = A.detail ad + in do + resumeHtml resume + detailHtml detail + +resumeHtml :: Resume -> Html +resumeHtml resume = + let title = + T.concat + [ R.name resume + , fromMaybe "" . fmap (\p -> T.concat [" - ", p]) $ R.price resume + ] + url = R.url resume + in do + H.h1 (toHtml title) + linkHtml url + +detailHtml :: Detail -> Html +detailHtml detail = do + case D.description detail of + Just description -> + descriptionHtml description + Nothing -> + H.div "" + mapM_ imageLinkHtml (D.images detail) + +descriptionHtml :: Text -> Html +descriptionHtml = H.p . sequence_ . intersperse H.br . fmap toHtml . T.lines + +linkHtml :: URL -> Html +linkHtml url = + H.a ! A.href (textValue url) $ (toHtml url) + +imageLinkHtml :: URL -> Html +imageLinkHtml url = + H.a ! A.href (textValue url) $ + H.img ! A.src (textValue url) diff --git a/src/View/Plain/Ad.hs b/src/View/Plain/Ad.hs new file mode 100644 index 0000000..9dc5289 --- /dev/null +++ b/src/View/Plain/Ad.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Plain.Ad + ( renderConsoleAds + , renderAds + ) where + +import Data.List (intersperse) +import Data.Maybe (fromMaybe) + +import Data.Text (Text) +import qualified Data.Text as T + +import Model.Ad (Ad(..)) +import qualified Model.Ad as Ad + +import Model.Resume (Resume(..)) +import qualified Model.Resume as Resume + +import Model.Detail (Detail(..)) +import qualified Model.Detail as Detail + +import Model.URL + +renderConsoleAds :: Text -> [Ad] -> Text +renderConsoleAds time ads = + let (title, message) = renderAds ads + titleWithTime = + T.concat + [ "\n[" + , time + , "] " + , title + ] + line = T.map (\_ -> '-') titleWithTime + in T.intercalate + "\n" + [ titleWithTime + , line + , "" + , message + ] + +renderAds :: [Ad] -> (Text, Text) +renderAds ads = + let titleMessage = renderTitle $ length ads + adsMessage = T.intercalate "\n\n" . map renderAd $ ads + in (titleMessage, adsMessage) + +renderTitle :: Int -> Text +renderTitle count = + T.concat + [ T.pack . show $ count + , agreement " nouvelle" + , agreement " annonce" + ] + where agreement word = + T.concat + [ word + , if count > 1 then "s" else "" + ] + +renderAd :: Ad -> Text +renderAd ad = + T.concat + [ renderResume (Ad.resume ad) + , "\n\n" + , renderDetail (Ad.detail ad) + ] + +renderResume :: Resume -> Text +renderResume resume = + let formatPrice price = T.concat [" - ", price] + price = fromMaybe "" . fmap formatPrice . Resume.price $ resume + titleLine = T.concat [Resume.name resume, price] + in T.intercalate "\n" [titleLine, Resume.url resume] + +renderDetail :: Detail -> Text +renderDetail detail = + T.concat + [ fromMaybe "−" (Detail.description detail) + , renderURLs "\n\nImages:" (Detail.images detail) + ] + +renderURLs :: Text -> [URL] -> Text +renderURLs title [] = "" +renderURLs title urls = + T.intercalate "\n" (title:urls) -- cgit v1.2.3