From 69e69017b75d1cdaa1fd2aef2818de5111b29735 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 14 Jul 2016 11:57:12 +0000
Subject: Update code and fix parsers
---
src/AdListener.hs | 105 +++++++++++++++++++++--------------------------
src/Conf.hs | 32 +++++++++++++++
src/Config.hs | 106 ------------------------------------------------
src/Fetch.hs | 21 ++++------
src/Mail.hs | 51 ++++++++++++-----------
src/Main.hs | 17 ++++----
src/Model/Config.hs | 13 ------
src/Model/Mail.hs | 14 +++++++
src/Model/Resume.hs | 3 +-
src/Page.hs | 13 +++---
src/Parser/Detail.hs | 12 +++---
src/Parser/Resume.hs | 20 ++++-----
src/Parser/Utils.hs | 14 ++++++-
src/View/Html/Ad.hs | 48 +++++++++++-----------
src/View/Html/Design.hs | 1 -
src/View/Plain/Ad.hs | 38 ++++++++---------
16 files changed, 216 insertions(+), 292 deletions(-)
create mode 100644 src/Conf.hs
delete mode 100644 src/Config.hs
delete mode 100644 src/Model/Config.hs
create mode 100644 src/Model/Mail.hs
(limited to 'src')
diff --git a/src/AdListener.hs b/src/AdListener.hs
index a52e188..9946d9e 100644
--- a/src/AdListener.hs
+++ b/src/AdListener.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module AdListener
- ( listenToNewAds
+ ( start
) where
-import Data.List (intersperse)
+import Prelude hiding (error)
+
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime)
+import qualified Data.Text.Lazy as LT
+import Data.Text.Lazy.Builder (toLazyText, fromText)
import Control.Concurrent (threadDelay)
@@ -21,84 +22,72 @@ import Model.Resume
import qualified View.Plain.Ad as P
import qualified View.Html.Ad as H
-import Page
-import Parser.Detail
-
-import Mail (sendMail)
+import Mail
+import Model.Mail (Mail(Mail))
-import Config (Config)
-import qualified Config as C
+import Conf (Conf)
+import qualified Conf
import Time (getCurrentFormattedTime)
-listenToNewAds :: Config -> IO ()
-listenToNewAds config = do
- eitherResumes <- fetchResumes (C.url config)
+start :: Conf -> IO ()
+start conf = do
+ eitherResumes <- fetchResumes (Conf.url conf)
case eitherResumes of
Left error ->
- showErrorAndListenBack config [] error
- Right resumes ->
+ showErrorAndListenBack conf [] error
+ Right resumes -> do
let newURLs = map url resumes
- in do
- putStrLn "Listening for new ads…"
- waitOneMinute
- listenToNewAdsWithViewedURLs config newURLs
-
-listenToNewAdsWithViewedURLs :: Config -> [URL] -> IO ()
-listenToNewAdsWithViewedURLs config viewedURLs = do
- eitherResumes <- fetchResumes (C.url config)
+ putStrLn "Listening to new ads…"
+ waitListenInterval conf
+ listenToNewAdsWithViewedURLs conf newURLs
+
+listenToNewAdsWithViewedURLs :: Conf -> [URL] -> IO ()
+listenToNewAdsWithViewedURLs conf viewedURLs = do
+ eitherResumes <- fetchResumes (Conf.url conf)
case eitherResumes of
Left error ->
- showErrorAndListenBack config viewedURLs error
+ showErrorAndListenBack conf viewedURLs error
Right resumes ->
- listenToNewAdsWithResumes config viewedURLs resumes
+ listenToNewAdsWithResumes conf viewedURLs resumes
-listenToNewAdsWithResumes :: Config -> [URL] -> [Resume] -> IO ()
-listenToNewAdsWithResumes config viewedURLs resumes =
+listenToNewAdsWithResumes :: Conf -> [URL] -> [Resume] -> IO ()
+listenToNewAdsWithResumes conf viewedURLs resumes =
let (newURLs, newResumes) = getNewResumes viewedURLs resumes
in do
eitherNewAds <- fetchAds newResumes
case eitherNewAds of
Left error ->
- showErrorAndListenBack config viewedURLs error
+ showErrorAndListenBack conf viewedURLs error
Right newAds ->
do
time <- getCurrentFormattedTime
if not (null newAds)
then
- let message = P.renderConsoleAds config time newAds
+ let message = P.renderConsoleAds conf time newAds
in do
T.putStrLn message
- trySendMail config newAds
+ trySendMail conf newAds
else
return ()
- waitOneMinute
- listenToNewAdsWithViewedURLs config (viewedURLs ++ newURLs)
-
-trySendMail :: Config -> [Ad] -> IO ()
-trySendMail config ads =
- case C.mailTo config of
- [] ->
- return ()
- mailTo ->
- let (title, plainBody) = P.renderAds config ads
- htmlBody = H.renderAds config ads
- in do
- eitherMailSuccess <- sendMail mailTo title plainBody htmlBody
- case eitherMailSuccess of
- Right () ->
- putStrLn "\nMail sent."
- Left error ->
- T.putStrLn . T.concat $
- [ "\nError sending mail: "
- , error
- ]
-
-showErrorAndListenBack :: Config -> [URL] -> Text -> IO ()
-showErrorAndListenBack config viewedURLs error = do
+ waitListenInterval conf
+ listenToNewAdsWithViewedURLs conf (viewedURLs ++ newURLs)
+
+trySendMail :: Conf -> [Ad] -> IO ()
+trySendMail conf ads =
+ let (title, plainBody) = P.renderAds conf ads
+ htmlBody = H.renderAds conf ads
+ mail = Mail (Conf.mailFrom conf) (Conf.mailTo conf) title (strictToLazy plainBody) (strictToLazy htmlBody)
+ in Mail.send mail >> return ()
+
+strictToLazy :: Text -> LT.Text
+strictToLazy = toLazyText . fromText
+
+showErrorAndListenBack :: Conf -> [URL] -> Text -> IO ()
+showErrorAndListenBack conf viewedURLs error = do
T.putStrLn error
- waitOneMinute
- listenToNewAdsWithViewedURLs config viewedURLs
+ waitListenInterval conf
+ listenToNewAdsWithViewedURLs conf viewedURLs
-waitOneMinute :: IO ()
-waitOneMinute = threadDelay (1000 * 1000 * 60)
+waitListenInterval :: Conf -> IO ()
+waitListenInterval = threadDelay . (*) 1000000 . round . Conf.listenInterval
diff --git a/src/Conf.hs b/src/Conf.hs
new file mode 100644
index 0000000..fccf2a5
--- /dev/null
+++ b/src/Conf.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conf
+ ( parse
+ , Conf(..)
+ ) where
+
+import Data.Text (Text)
+import qualified Data.ConfigManager as Conf
+import Data.Time.Clock (NominalDiffTime)
+
+import Model.URL
+
+data Conf = Conf
+ { url :: URL
+ , mailFrom :: Text
+ , mailTo :: [Text]
+ , properties :: [Text]
+ , listenInterval :: NominalDiffTime
+ } deriving Show
+
+parse :: FilePath -> IO (Either Text Conf)
+parse path =
+ (flip fmap) (Conf.readConfig path) (\configOrError -> do
+ conf <- configOrError
+ Conf <$>
+ Conf.lookup "url" conf <*>
+ Conf.lookup "mailFrom" conf <*>
+ Conf.lookup "mailTo" conf <*>
+ Conf.lookup "properties" conf <*>
+ Conf.lookup "listenInterval" conf
+ )
diff --git a/src/Config.hs b/src/Config.hs
deleted file mode 100644
index 0a80183..0000000
--- a/src/Config.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Config
- ( configUsage
- , Config(..)
- , getConfig
- ) where
-
-import Data.Maybe (catMaybes, isJust, fromMaybe)
-import Data.Map (Map)
-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)
-
-import System.Directory (doesFileExist)
-
-import Model.URL
-import Model.Config
-
-import Utils.Text
-
-configUsage :: Text
-configUsage =
- T.intercalate "\n"
- [ ""
- , T.concat
- [ " Some information is required in the file `"
- , T.pack configPath
- , "`:"
- ]
- , ""
- , " - url (required)"
- , " - mailTo (optional)"
- , " - properties (optional)"
- , ""
- , " Example:"
- , ""
- , " # Lines beginning with '#' are ignored"
- , ""
- , " # The url field is required"
- , " url = http://www.leboncoin.fr/locations/offres/ile_de_france/?f=a&th=1"
- , ""
- , " # The mailTo field is an optional list"
- , " # mailTo = jean.dupont@mail.fr, john.smith@mail.com"
- , ""
- , " # The properties field is an optional list"
- , " # properties = cp, city, surface, ges"
- ]
-
-configPath :: FilePath
-configPath = "conf"
-
-getConfig :: IO (Maybe Config)
-getConfig = do
- exists <- doesFileExist configPath
- if exists
- then
- configFromFile <$> T.readFile configPath
- else
- return Nothing
-
-configFromFile :: Text -> Maybe Config
-configFromFile =
- configFromMap
- . M.fromList
- . catMaybes
- . map lineConfig
- . filter (not . T.null)
- . filter (not . startsWith "#")
- . map T.strip
- . T.lines
-
-configFromMap :: Map Text Text -> Maybe Config
-configFromMap map = do
- url <- M.lookup "url" map
- let config =
- Config
- { url = url
- , mailTo = fieldValues "mailTo" map
- , properties = fieldValues "properties" map
- }
- return config
-
-fieldValues :: Text -> Map Text Text -> [Text]
-fieldValues field map = fromMaybe [] $ fmap T.strip . T.splitOn "," <$> M.lookup field map
-
-lineConfig :: Text -> Maybe (Text, Text)
-lineConfig line = do
- (key, value) <- keyValue line
- guard (T.length key > 0)
- return (key, value)
-
-keyValue :: Text -> Maybe (Text, Text)
-keyValue line =
- let sep = '='
- in if isJust (T.find (== sep) line)
- then
- let key = T.takeWhile (/= sep) line
- value = T.drop 1 . T.dropWhile (/= sep) $ line
- in Just (T.strip key, T.strip value)
- else
- Nothing
diff --git a/src/Fetch.hs b/src/Fetch.hs
index a4e8c94..c80a980 100644
--- a/src/Fetch.hs
+++ b/src/Fetch.hs
@@ -4,20 +4,19 @@ module Fetch
) where
import Data.Text (Text)
-import qualified Data.Text as T
-import Page (getPage)
+import Page
-import Model.Ad
-import Model.Resume
-import Model.Detail
-import Model.URL
+import Model.Ad (Ad(Ad))
+import Model.Resume (Resume)
+import qualified Model.Resume as Resume
+import Model.URL (URL)
-import Parser.Resume
-import Parser.Detail
+import qualified Parser.Resume as Resume
+import qualified Parser.Detail as Detail
fetchResumes :: URL -> IO (Either Text [Resume])
-fetchResumes url = fmap parseResumes <$> getPage url
+fetchResumes url = fmap Resume.parse <$> Page.get url
fetchAds :: [Resume] -> IO (Either Text [Ad])
fetchAds resumes = do
@@ -25,6 +24,4 @@ fetchAds resumes = do
return $ sequence xs
fetchAd :: Resume -> IO (Either Text Ad)
-fetchAd resume = do
- page <- getPage (url resume)
- fmap (\page -> Ad { resume = resume, detail = parseDetail page}) <$> getPage (url resume)
+fetchAd resume = fmap (\ad -> Ad resume (Detail.parse ad)) <$> Page.get (Resume.url resume)
diff --git a/src/Mail.hs b/src/Mail.hs
index 83a2bbd..bf1516e 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -1,42 +1,45 @@
{-# LANGUAGE OverloadedStrings #-}
module Mail
- ( sendMail
+ ( send
) where
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Text.Lazy.Builder (toLazyText, fromText)
+import Data.Either (isLeft)
import Control.Exception (SomeException, try)
+import Control.Arrow (left)
-import Network.Mail.Mime
+import qualified Network.Mail.Mime as Mime
-import Utils.Either (mapLeft)
+import Model.Mail (Mail)
+import qualified Model.Mail as Mail
-sendMail :: [Text] -> Text -> Text -> Text -> IO (Either Text ())
-sendMail mailTo subject plainBody htmlBody = safeSendMail (mail mailTo subject plainBody htmlBody)
+send :: Mail -> IO (Either Text ())
+send mail = do
+ result <- left (T.pack . show) <$> (try (Mime.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ()))
+ if isLeft result
+ then putStrLn ("Error sending the following email:" ++ (show mail))
+ else return ()
+ return result
-safeSendMail :: Mail -> IO (Either Text ())
-safeSendMail mail =
- mapLeft (T.pack . show) <$> (try (renderSendMail mail) :: IO (Either SomeException ()))
-
-mail :: [Text] -> Text -> Text -> Text -> Mail
-mail mailTo subject plainBody htmlBody =
- let fromMail = emptyMail (address "no-reply@leboncoin-listener.com")
+getMimeMail :: Mail -> Mime.Mail
+getMimeMail mail =
+ let fromMail = Mime.emptyMail . address . Mail.from $ mail
in fromMail
- { mailTo = map address mailTo
- , mailParts =
- [ [ plainPart . strictToLazy $ plainBody
- , htmlPart . strictToLazy $ htmlBody
+ { Mime.mailTo = map address . Mail.to $ mail
+ , Mime.mailParts =
+ [ [ Mime.plainPart . Mail.plainBody $ mail
+ , Mime.htmlPart . Mail.htmlBody $ mail
]
]
- , mailHeaders = [("Subject", subject)]
+ , Mime.mailHeaders = [("Subject", Mail.subject mail)]
}
-strictToLazy :: Text -> LT.Text
-strictToLazy = toLazyText . fromText
-
-address :: Text -> Address
-address mail = Address { addressName = Nothing, addressEmail = mail }
+address :: Text -> Mime.Address
+address addressEmail =
+ Mime.Address
+ { Mime.addressName = Nothing
+ , Mime.addressEmail = addressEmail
+ }
diff --git a/src/Main.hs b/src/Main.hs
index f38646b..27dcfa5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,16 +6,15 @@ module Main
import qualified Data.Text.IO as T
-import AdListener (listenToNewAds)
+import qualified AdListener
-import Config (Config)
-import qualified Config as C
+import qualified Conf
main :: IO ()
main = do
- maybeConfig <- C.getConfig
- case maybeConfig of
- Just config ->
- listenToNewAds config
- Nothing ->
- T.putStrLn C.configUsage
+ eitherConfig <- Conf.parse "application.conf"
+ case eitherConfig of
+ Right config ->
+ AdListener.start config
+ Left message ->
+ T.putStrLn message
diff --git a/src/Model/Config.hs b/src/Model/Config.hs
deleted file mode 100644
index 42b390e..0000000
--- a/src/Model/Config.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Model.Config
- ( Config(..)
- ) where
-
-import Data.Text
-
-import Model.URL
-
-data Config = Config
- { url :: URL
- , mailTo :: [Text]
- , properties :: [Text]
- } deriving (Eq, Read, Show)
diff --git a/src/Model/Mail.hs b/src/Model/Mail.hs
new file mode 100644
index 0000000..20addee
--- /dev/null
+++ b/src/Model/Mail.hs
@@ -0,0 +1,14 @@
+module Model.Mail
+ ( Mail(..)
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text.Lazy as LT
+
+data Mail = Mail
+ { from :: Text
+ , to :: [Text]
+ , subject :: Text
+ , plainBody :: LT.Text
+ , htmlBody :: LT.Text
+ } deriving (Eq, Show)
diff --git a/src/Model/Resume.hs b/src/Model/Resume.hs
index 46d07a1..3e3cd82 100644
--- a/src/Model/Resume.hs
+++ b/src/Model/Resume.hs
@@ -6,9 +6,8 @@ module Model.Resume
import Data.List ((\\))
import Data.Text (Text)
-import qualified Data.Text as T
-import Model.URL
+import Model.URL (URL)
data Resume = Resume
{ name :: Text
diff --git a/src/Page.hs b/src/Page.hs
index 443f768..8a8ebea 100644
--- a/src/Page.hs
+++ b/src/Page.hs
@@ -1,21 +1,22 @@
module Page
- ( getPage
+ ( get
) where
import Control.Exception (SomeException, try)
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Text.Encoding as T
+import Data.ByteString.Lazy as BS
-import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
+import Network.HTTP.Conduit
import Model.URL
import Utils.Either (mapLeft)
-getPage :: URL -> IO (Either Text Text)
-getPage url =
- mapLeft (T.pack . show) <$> (try (unsafeGetPage url) :: IO (Either SomeException Text))
+get :: URL -> IO (Either Text Text)
+get url = mapLeft (T.pack . show) <$> (try (unsafeGetPage url) :: IO (Either SomeException Text))
unsafeGetPage :: URL -> IO Text
-unsafeGetPage url = simpleHTTP (getRequest (T.unpack url)) >>= (\x -> T.pack <$> getResponseBody x)
+unsafeGetPage url = (T.decodeLatin1 . BS.toStrict) <$> simpleHttp (T.unpack url)
diff --git a/src/Parser/Detail.hs b/src/Parser/Detail.hs
index 3f424e9..2418d07 100644
--- a/src/Parser/Detail.hs
+++ b/src/Parser/Detail.hs
@@ -1,5 +1,5 @@
module Parser.Detail
- ( parseDetail
+ ( parse
) where
import Data.Text (Text)
@@ -16,18 +16,18 @@ import Model.Detail
import Parser.Utils
-parseDetail :: Text -> Detail
-parseDetail page =
+parse :: Text -> Detail
+parse page =
let tags = parseTags page
in Detail
{ description = parseDescription tags
- , images = getTagAttributes "" (T.pack "content") tags
+ , images = map (\url -> T.concat [T.pack "https:", url]) $ getTagAttributes "" (T.pack "content") tags
, properties = parseProperties tags
}
parseDescription :: [Tag Text] -> Maybe Text
parseDescription tags =
- let descriptionTags = getTagsBetween "" "
" tags
+ let descriptionTags = getTagsBetween "" "
" tags
in if null descriptionTags
then
Nothing
@@ -37,7 +37,7 @@ parseDescription tags =
parseProperties :: [Tag Text] -> Map Text Text
parseProperties tags =
- let mbUtagData = getTagTextAfter "" . getTagsAfter "" $ tags
in fromMaybe M.empty (fmap parseUtagData mbUtagData)
parseUtagData :: Text -> Map Text Text
diff --git a/src/Parser/Resume.hs b/src/Parser/Resume.hs
index 76faca4..f300ec3 100644
--- a/src/Parser/Resume.hs
+++ b/src/Parser/Resume.hs
@@ -1,5 +1,5 @@
module Parser.Resume
- ( parseResumes
+ ( parse
) where
import Data.Maybe (catMaybes)
@@ -8,22 +8,22 @@ import qualified Data.Text as T
import Text.HTML.TagSoup
-import Model.Resume
+import Model.Resume (Resume(Resume))
import Parser.Utils
-parseResumes :: Text -> [Resume]
-parseResumes page =
- case sections (~== "