diff options
| -rw-r--r-- | leboncoin-listener.cabal | 2 | ||||
| -rw-r--r-- | src/AdListener.hs | 10 | ||||
| -rw-r--r-- | src/Mail.hs | 20 | ||||
| -rw-r--r-- | src/View/Html/Ad.hs | 77 | ||||
| -rw-r--r-- | src/View/Plain/Ad.hs (renamed from src/View/Ad.hs) | 10 |
5 files changed, 102 insertions, 17 deletions
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/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/Ad.hs b/src/View/Plain/Ad.hs index ec5da2d..9dc5289 100644 --- a/src/View/Ad.hs +++ b/src/View/Plain/Ad.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module View.Ad +module View.Plain.Ad ( renderConsoleAds , renderAds ) where @@ -79,14 +79,10 @@ renderDetail :: Detail -> Text renderDetail detail = T.concat [ fromMaybe "−" (Detail.description detail) - , renderURLs "\n\nImages" (Detail.images 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 - ] + T.intercalate "\n" (title:urls) |