Adding a design to the HTML mail + Adding waitInMinutes in the

configuration

5 files changed, 69 insertions, 28 deletions

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 []