aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--leboncoin-listener.cabal2
-rw-r--r--src/Ad.hs10
-rw-r--r--src/AdListener.hs79
-rw-r--r--src/Config.hs72
-rw-r--r--src/Main.hs80
-rw-r--r--src/Model/Detail.hs4
-rw-r--r--src/Model/Resume.hs5
-rw-r--r--src/Model/URL.hs4
-rw-r--r--src/Page.hs9
-rw-r--r--src/Parser/Detail.hs3
-rw-r--r--src/Parser/Resume.hs7
-rw-r--r--src/Parser/Utils.hs9
-rw-r--r--src/View/Ad.hs11
14 files changed, 200 insertions, 96 deletions
diff --git a/.gitignore b/.gitignore
index cef4194..83a814e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
.cabal-sandbox
cabal.sandbox.config
dist
+conf
diff --git a/leboncoin-listener.cabal b/leboncoin-listener.cabal
index 224690f..e1ae0af 100644
--- a/leboncoin-listener.cabal
+++ b/leboncoin-listener.cabal
@@ -8,5 +8,7 @@ executable leboncoin-listener
hs-source-dirs: src
build-depends: base
, text == 1.2.0.4
+ , containers == 0.5.6.3
+ , directory == 1.2.2.1
, HTTP == 4000.2.19
, tagsoup == 0.13.3
diff --git a/src/Ad.hs b/src/Ad.hs
index 5f3a9f1..7bc66fc 100644
--- a/src/Ad.hs
+++ b/src/Ad.hs
@@ -3,9 +3,11 @@ module Ad
, getAds
) where
-import Page (getPage)
+import Data.Text (Text)
import qualified Data.Text as T
+import Page (getPage)
+
import Model.Ad
import Model.Resume
import Model.Detail
@@ -14,15 +16,15 @@ import Model.URL
import Parser.Resume
import Parser.Detail
-getResumes :: URL -> IO (Either T.Text [Resume])
+getResumes :: URL -> IO (Either Text [Resume])
getResumes url = fmap parseResumes <$> getPage url
-getAds :: [Resume] -> IO (Either T.Text [Ad])
+getAds :: [Resume] -> IO (Either Text [Ad])
getAds resumes = do
xs <- sequence $ map getAd resumes
return $ sequence xs
-getAd :: Resume -> IO (Either T.Text Ad)
+getAd :: Resume -> IO (Either Text Ad)
getAd resume = do
page <- getPage (url resume)
fmap (\page -> Ad { resume = resume, detail = parseDetail page}) <$> getPage (url resume)
diff --git a/src/AdListener.hs b/src/AdListener.hs
new file mode 100644
index 0000000..1f97e30
--- /dev/null
+++ b/src/AdListener.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module AdListener
+ ( listenToNewAds
+ ) where
+
+import Data.List (intersperse)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+import Control.Concurrent (threadDelay)
+
+import Ad (getResumes, getAds)
+
+import Model.Ad
+import Model.URL
+import Model.Resume
+
+import View.Ad (renderAds)
+
+import Page
+import Parser.Detail
+
+import Config (Config)
+import qualified Config as C
+
+listenToNewAds :: Config -> [Ad] -> IO ()
+listenToNewAds config viewedAds = do
+ eitherResumes <- getResumes (C.url config)
+ case eitherResumes of
+ Left error ->
+ listenError config viewedAds error
+ Right resumes ->
+ listenToNewAdsWithResumes config viewedAds resumes
+
+listenToNewAdsWithResumes :: Config -> [Ad] -> [Resume] -> IO ()
+listenToNewAdsWithResumes config viewedAds resumes =
+ let viewedURLs = getURLs $ map resume viewedAds
+ newResumes = getNewResumes viewedURLs resumes
+ in do
+ eitherNewAds <- getAds newResumes
+ case eitherNewAds of
+ Left error ->
+ listenError config viewedAds error
+ Right newAds ->
+ do
+ if not (null newAds)
+ then
+ T.putStrLn (newAdsMessage newAds)
+ else
+ return ()
+ waitOneMinute
+ listenToNewAds config (viewedAds ++ newAds)
+
+newAdsMessage :: [Ad] -> Text
+newAdsMessage newAds =
+ let newAdsMessage =
+ T.concat
+ [ "Got "
+ , T.pack . show . length $ newAds
+ , " new ads."
+ ]
+ line = T.map (\_ -> '-') newAdsMessage
+ in T.intercalate
+ "\n"
+ [ newAdsMessage
+ , T.concat [line, "\n"]
+ , renderAds newAds
+ ]
+
+listenError :: Config -> [Ad] -> Text -> IO ()
+listenError config viewedAds error = do
+ T.putStrLn error
+ waitOneMinute
+ listenToNewAds config viewedAds
+
+waitOneMinute :: IO ()
+waitOneMinute = threadDelay (1000 * 1000 * 60)
diff --git a/src/Config.hs b/src/Config.hs
new file mode 100644
index 0000000..c09f69e
--- /dev/null
+++ b/src/Config.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Config
+ ( configUsage
+ , Config(..)
+ , getConfig
+ ) where
+
+import Data.Maybe (catMaybes)
+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 Control.Monad (guard)
+
+import System.Directory (doesFileExist)
+
+import Model.URL
+
+configUsage :: Text
+configUsage =
+ T.intercalate
+ "\n"
+ [ T.concat
+ [ "Please provide an url for leboncoin in the file named: "
+ , T.pack configPath
+ ]
+ , "url = http://…"
+ ]
+
+configPath :: FilePath
+configPath = "conf"
+
+data Config = Config
+ { url :: URL
+ } deriving (Eq, Read, Show)
+
+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)
+ . map T.strip
+ . T.lines
+
+configFromMap :: Map Text Text -> Maybe Config
+configFromMap map = do
+ url <- M.lookup "url" map
+ return $ Config { url = url }
+
+lineConfig :: Text -> Maybe (Text, Text)
+lineConfig line = do
+ (key, value) <- twoElementsList (map T.strip . T.splitOn "=" $ line)
+ guard (T.length key > 0)
+ return (key, value)
+
+twoElementsList :: [a] -> Maybe (a, a)
+twoElementsList [x, y] = Just (x, y)
+twoElementsLisst _ = Nothing
diff --git a/src/Main.hs b/src/Main.hs
index 6208953..ad70402 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,78 +4,18 @@ module Main
( main
) where
-import Data.List (intersperse)
-import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Control.Concurrent (threadDelay)
+import AdListener (listenToNewAds)
-import Ad (getResumes, getAds)
-
-import Model.Ad
-import Model.URL
-import Model.Resume
-
-import View.Ad (renderAds)
-
-import Page
-import Parser.Detail
-
-listenURL :: URL
-listenURL = "http://www.leboncoin.fr/annonces/offres/corse/"
+import Config (Config)
+import qualified Config as C
main :: IO ()
-main = listenToNewAds []
-
-listenToNewAds :: [Ad] -> IO ()
-listenToNewAds viewedAds = do
- eitherResumes <- getResumes listenURL
- case eitherResumes of
- Left error ->
- listenError viewedAds error
- Right resumes ->
- listenToNewAdsWithResumes viewedAds resumes
-
-listenToNewAdsWithResumes :: [Ad] -> [Resume] -> IO ()
-listenToNewAdsWithResumes viewedAds resumes =
- let viewedURLs = getURLs $ map resume viewedAds
- newResumes = getNewResumes viewedURLs resumes
- in do
- eitherNewAds <- getAds newResumes
- case eitherNewAds of
- Left error ->
- listenError viewedAds error
- Right newAds ->
- do
- if not (null newAds)
- then
- T.putStrLn (newAdsMessage newAds)
- else
- return ()
- waitOneMinute
- listenToNewAds (viewedAds ++ newAds)
-
-newAdsMessage :: [Ad] -> T.Text
-newAdsMessage newAds =
- let newAdsMessage =
- T.concat
- [ "Got "
- , T.pack . show . length $ newAds
- , " new ads."
- ]
- line = T.map (\_ -> '-') newAdsMessage
- in T.intercalate
- "\n"
- [ newAdsMessage
- , T.concat [line, "\n"]
- , renderAds newAds
- ]
-
-listenError :: [Ad] -> T.Text -> IO ()
-listenError viewedAds error = do
- T.putStrLn error
- waitOneMinute
- listenToNewAds viewedAds
-
-waitOneMinute :: IO ()
-waitOneMinute = threadDelay (1000 * 1000 * 60)
+main = do
+ maybeConfig <- C.getConfig
+ case maybeConfig of
+ Just config ->
+ listenToNewAds config []
+ Nothing ->
+ T.putStrLn C.configUsage
diff --git a/src/Model/Detail.hs b/src/Model/Detail.hs
index 684a718..952cb7a 100644
--- a/src/Model/Detail.hs
+++ b/src/Model/Detail.hs
@@ -2,8 +2,8 @@ module Model.Detail
( Detail(..)
) where
-import qualified Data.Text as T
+import Data.Text
data Detail = Detail
- { description :: Maybe T.Text
+ { description :: Maybe Text
} deriving (Eq, Read, Show)
diff --git a/src/Model/Resume.hs b/src/Model/Resume.hs
index 9d966df..3d307f2 100644
--- a/src/Model/Resume.hs
+++ b/src/Model/Resume.hs
@@ -5,13 +5,14 @@ module Model.Resume
) where
import Data.List ((\\))
+import Data.Text (Text)
import qualified Data.Text as T
import Model.URL
data Resume = Resume
- { name :: T.Text
- , price :: Maybe T.Text
+ { name :: Text
+ , price :: Maybe Text
, url :: URL
} deriving (Eq, Read, Show)
diff --git a/src/Model/URL.hs b/src/Model/URL.hs
index 91cf22a..2114113 100644
--- a/src/Model/URL.hs
+++ b/src/Model/URL.hs
@@ -2,4 +2,6 @@ module Model.URL
( URL
) where
-type URL = String
+import Data.Text
+
+type URL = Text
diff --git a/src/Page.hs b/src/Page.hs
index b048410..da15ce4 100644
--- a/src/Page.hs
+++ b/src/Page.hs
@@ -4,18 +4,19 @@ module Page
import Control.Exception (SomeException, try)
+import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
import Model.URL
-getPage :: URL -> IO (Either T.Text T.Text)
+getPage :: URL -> IO (Either Text Text)
getPage url =
- mapLeft (T.pack . show) <$> (try (unsafeGetPage url) :: IO (Either SomeException T.Text))
+ mapLeft (T.pack . show) <$> (try (unsafeGetPage url) :: IO (Either SomeException Text))
-unsafeGetPage :: URL -> IO T.Text
-unsafeGetPage url = simpleHTTP (getRequest url) >>= (\x -> T.pack <$> getResponseBody x)
+unsafeGetPage :: URL -> IO Text
+unsafeGetPage url = simpleHTTP (getRequest (T.unpack url)) >>= (\x -> T.pack <$> getResponseBody x)
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft f (Left l) = Left (f l)
diff --git a/src/Parser/Detail.hs b/src/Parser/Detail.hs
index b787772..4144964 100644
--- a/src/Parser/Detail.hs
+++ b/src/Parser/Detail.hs
@@ -2,6 +2,7 @@ module Parser.Detail
( parseDetail
) where
+import Data.Text (Text)
import qualified Data.Text as T
import Text.HTML.TagSoup
@@ -10,7 +11,7 @@ import Model.Detail
import Parser.Utils
-parseDetail :: T.Text -> Detail
+parseDetail :: Text -> Detail
parseDetail page =
let tags = parseTags page
descriptionTags = getTagsBetween "<div itemprop=description>" "</div>" tags
diff --git a/src/Parser/Resume.hs b/src/Parser/Resume.hs
index 6cd4415..76faca4 100644
--- a/src/Parser/Resume.hs
+++ b/src/Parser/Resume.hs
@@ -3,6 +3,7 @@ module Parser.Resume
) where
import Data.Maybe (catMaybes)
+import Data.Text (Text)
import qualified Data.Text as T
import Text.HTML.TagSoup
@@ -11,7 +12,7 @@ import Model.Resume
import Parser.Utils
-parseResumes :: T.Text -> [Resume]
+parseResumes :: Text -> [Resume]
parseResumes page =
case sections (~== "<div class=list-lbc>") (parseTags page) of
[] ->
@@ -20,9 +21,9 @@ parseResumes page =
let lbcTags = takeWhile (~/= "<div id=alertesCartouche>") sectionTags
in catMaybes . fmap parseResume $ partitions (~== "<a>") lbcTags
-parseResume :: [Tag T.Text] -> Maybe Resume
+parseResume :: [Tag Text] -> Maybe Resume
parseResume item = do
name <- getTagTextAfter "<h2 class=title>" item
let price = getTagTextAfter "<div class=price>" item
url <- getTagAttribute "<a>" (T.pack "href") item
- return Resume { name = name, price = price, url = T.unpack url }
+ return Resume { name = name, price = price, url = url }
diff --git a/src/Parser/Utils.hs b/src/Parser/Utils.hs
index 8527777..16fe3d2 100644
--- a/src/Parser/Utils.hs
+++ b/src/Parser/Utils.hs
@@ -6,27 +6,28 @@ module Parser.Utils
import Data.List (find, findIndex)
import Data.Maybe (listToMaybe)
+import Data.Text (Text)
import qualified Data.Text as T
import Text.HTML.TagSoup
-getTagsBetween :: String -> String -> [Tag T.Text] -> [Tag T.Text]
+getTagsBetween :: String -> String -> [Tag Text] -> [Tag Text]
getTagsBetween beginSelector endSelector =
takeWhile (~/= endSelector)
. drop 1
. dropWhile (~/= beginSelector)
-getTagAttribute :: String -> T.Text -> [Tag T.Text] -> Maybe T.Text
+getTagAttribute :: String -> Text -> [Tag Text] -> Maybe Text
getTagAttribute selector attribute tags =
find (~== selector) tags >>= maybeTagAttribute attribute
-getTagTextAfter :: String -> [Tag T.Text] -> Maybe T.Text
+getTagTextAfter :: String -> [Tag Text] -> Maybe Text
getTagTextAfter selector tags =
case findIndex (~== selector) tags of
Just index -> fmap T.strip $ safeGetAt (index + 1) tags >>= maybeTagText
Nothing -> Nothing
-maybeTagAttribute :: T.Text -> Tag T.Text -> Maybe T.Text
+maybeTagAttribute :: Text -> Tag Text -> Maybe Text
maybeTagAttribute name (TagOpen _ xs) =
fmap snd . find (\(x, _) -> x == name) $ xs
maybeTagAttribute attribute _ = Nothing
diff --git a/src/View/Ad.hs b/src/View/Ad.hs
index 5e408f3..6f094ee 100644
--- a/src/View/Ad.hs
+++ b/src/View/Ad.hs
@@ -6,6 +6,7 @@ module View.Ad
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
+import Data.Text (Text)
import qualified Data.Text as T
import Model.Ad (Ad(..))
@@ -15,10 +16,10 @@ import qualified Model.Resume as Resume
import Model.Detail (Detail(..))
import qualified Model.Detail as Detail
-renderAds :: [Ad] -> T.Text
+renderAds :: [Ad] -> Text
renderAds = T.intercalate "\n\n" . map renderAd
-renderAd :: Ad -> T.Text
+renderAd :: Ad -> Text
renderAd ad =
T.concat
[ renderResume (Ad.resume ad)
@@ -26,13 +27,13 @@ renderAd ad =
, renderDetail (Ad.detail ad)
]
-renderResume :: Resume -> T.Text
+renderResume :: Resume -> Text
renderResume resume =
let formatPrice price = T.concat [" - ", price]
price = fromMaybe "" . fmap formatPrice . Resume.price $ resume
titleLine = T.concat [Resume.name resume, price]
- in T.intercalate "\n" [titleLine, T.pack . Resume.url $ resume]
+ in T.intercalate "\n" [titleLine, Resume.url resume]
-renderDetail :: Detail -> T.Text
+renderDetail :: Detail -> Text
renderDetail detail =
fromMaybe "−" (Detail.description detail)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 07:16:14 +0000