aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--leboncoin-listener.cabal2
-rw-r--r--src/AdListener.hs10
-rw-r--r--src/Mail.hs20
-rw-r--r--src/View/Html/Ad.hs77
-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)