From 78048fcbc81521d145b79b4b47761a8b698d7ff7 Mon Sep 17 00:00:00 2001 From: Joris Guyonvarch Date: Sun, 19 Apr 2015 12:14:50 +0200 Subject: Adding a design to the HTML mail + Adding waitInMinutes in the configuration --- README.md | 5 ++++- leboncoin-listener.cabal | 1 + src/Config.hs | 10 ++++++++++ src/Main.hs | 12 ------------ src/Model/Config.hs | 1 + src/View/Html/Ad.hs | 39 +++++++++++++++++++++++---------------- src/View/Html/Design.hs | 35 +++++++++++++++++++++++++++++++++++ 7 files changed, 74 insertions(+), 29 deletions(-) create mode 100644 src/View/Html/Design.hs diff --git a/README.md b/README.md index c8794df..5be7473 100644 --- a/README.md +++ b/README.md @@ -30,9 +30,12 @@ url = http://www.leboncoin.fr/locations/offres/ile_de_france/?f=a&th=1 # The properties field is an optional list # properties = cp, city, surface, ges + +# The waitInMinutes field is an optional integer, default to 1 +# waitInMinutes = 60 ``` Email ----- -leboncoin-listener uses the sendmail command under the hood. +leboncoin-listener uses the sendmail command for notifications. diff --git a/leboncoin-listener.cabal b/leboncoin-listener.cabal index dc7fe0a..643ee6d 100644 --- a/leboncoin-listener.cabal +++ b/leboncoin-listener.cabal @@ -16,3 +16,4 @@ executable leboncoin-listener , mime-mail == 0.4.8.2 , blaze-html == 0.8.0.2 , blaze-markup == 0.7.0.2 + , clay == 0.10.1 diff --git a/src/Config.hs b/src/Config.hs index 0a421fa..98e2c9a 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Text.Read (decimal) import Control.Monad (guard) @@ -35,6 +36,7 @@ configUsage = , " - url (required)" , " - mailTo (optional)" , " - properties (optional)" + , " - waitInMinutes (optional, default to 1)" , "" , " Example:" , "" @@ -46,6 +48,9 @@ configUsage = , "" , " # The properties field is an optional list" , " # properties = cp, city, surface, ges" + , "" + , " # The waitInMinutes field is an optional integer, default to 1" + , " # waitInMinutes = 60" ] configPath :: FilePath @@ -79,9 +84,14 @@ configFromMap map = do { url = url , mailTo = fieldValues "mailTo" map , properties = fieldValues "properties" map + , waitInMinutes = fromMaybe 1 $ M.lookup "waitInMinutes" map >>= fmap fst . eitherToMaybe . decimal } return config +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right x) = Just x +eitherToMaybe _ = Nothing + fieldValues :: Text -> Map Text Text -> [Text] fieldValues field map = fromMaybe [] $ fmap T.strip . T.splitOn "," <$> M.lookup field map diff --git a/src/Main.hs b/src/Main.hs index 82135a2..f38646b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,15 +19,3 @@ main = do listenToNewAds config Nothing -> T.putStrLn C.configUsage - --- import Page --- import Parser.Detail - --- main :: IO () --- main = do --- eitherPage <- getPage "http://www.leboncoin.fr/locations/794858813.htm?ca=18_s" --- case eitherPage of --- Right page -> --- putStrLn (show $ parseDetail page) --- Left error -> --- T.putStrLn error diff --git a/src/Model/Config.hs b/src/Model/Config.hs index 42b390e..8fb05b9 100644 --- a/src/Model/Config.hs +++ b/src/Model/Config.hs @@ -10,4 +10,5 @@ data Config = Config { url :: URL , mailTo :: [Text] , properties :: [Text] + , waitInMinutes :: Int } deriving (Eq, Read, Show) diff --git a/src/View/Html/Ad.hs b/src/View/Html/Ad.hs index f3d9ece..2d6bdb5 100644 --- a/src/View/Html/Ad.hs +++ b/src/View/Html/Ad.hs @@ -32,11 +32,13 @@ import qualified Model.Detail as D import Model.URL import Model.Config +import View.Html.Design + renderAds :: Config -> [Ad] -> Text renderAds config = toStrict . renderHtml . (adsHtml config) adsHtml :: Config -> [Ad] -> Html -adsHtml config ads = H.div (mapM_ (adHtml config) ads) +adsHtml config ads = do mapM_ (adHtml config) ads adHtml :: Config -> Ad -> Html adHtml config ad = @@ -47,16 +49,18 @@ adHtml config ad = detailHtml config 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 +resumeHtml resume = do + H.h1 $ do + (toHtml . R.name $ resume) + case R.price resume of + Just price -> + H.span + ! A.class_ "price" + ! A.style (textValue . toStrict $ priceDesign) + $ toHtml price + Nothing -> + H.span "" + linkHtml (R.url resume) detailHtml :: Config -> Detail -> Html detailHtml config detail = do @@ -70,15 +74,16 @@ detailHtml config detail = do propertiesHtml :: [Text] -> Map Text Text -> Html propertiesHtml keys properties = - H.dl $ - sequence_ $ catMaybes $ map (propertyHtml properties) keys + H.dl + ! A.style (textValue . toStrict $ dlDesign) + $ sequence_ (catMaybes $ map (propertyHtml properties) keys) propertyHtml :: Map Text Text -> Text -> Maybe Html propertyHtml properties key = fmap (\value -> do - H.dt (toHtml key) - H.dd (toHtml value) + H.dt $ (toHtml key) + H.dd ! A.style (textValue . toStrict $ ddDesign) $ (toHtml value) ) (M.lookup key properties) @@ -92,4 +97,6 @@ linkHtml url = imageLinkHtml :: URL -> Html imageLinkHtml url = H.a ! A.href (textValue url) $ - H.img ! A.src (textValue url) + H.img + ! A.src (textValue url) + ! A.alt (textValue url) diff --git a/src/View/Html/Design.hs b/src/View/Html/Design.hs new file mode 100644 index 0000000..c33d991 --- /dev/null +++ b/src/View/Html/Design.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Html.Design + ( dlDesign + , ddDesign + , priceDesign + ) where + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Monoid ((<>)) + +import Clay + +dlDesign :: Text +dlDesign = inlineRender $ do + fontWeight bold + fontSize (px 16) + +ddDesign :: Text +ddDesign = inlineRender $ do + marginLeft (px 0) + marginBottom (px 10) + color orangered + +priceDesign :: Text +priceDesign = inlineRender $ do + marginLeft (px 10) + color orangered + +inlineRender :: Css -> Text +inlineRender = + T.dropEnd 1 + . T.drop 1 + . renderWith compact [] -- cgit v1.2.3