From 0a4d3c8f12dc5797a919a00b6bcaf759947687cc Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Jun 2018 23:24:47 +0200 Subject: Add ouest france parser --- src/executable/haskell/Conf.hs | 39 ++++++++++++++++ src/executable/haskell/Main.hs | 13 ++++++ src/executable/haskell/Model/Mail.hs | 12 +++++ src/executable/haskell/Service/AdListener.hs | 67 +++++++++++++++++++++++++++ src/executable/haskell/Service/MailService.hs | 46 ++++++++++++++++++ src/executable/haskell/Utils/Either.hs | 7 +++ src/executable/haskell/Utils/HTTP.hs | 20 ++++++++ src/executable/haskell/Utils/Text.hs | 13 ++++++ src/executable/haskell/Utils/Time.hs | 14 ++++++ src/executable/haskell/View/Ad.hs | 58 +++++++++++++++++++++++ 10 files changed, 289 insertions(+) create mode 100644 src/executable/haskell/Conf.hs create mode 100644 src/executable/haskell/Main.hs create mode 100644 src/executable/haskell/Model/Mail.hs create mode 100644 src/executable/haskell/Service/AdListener.hs create mode 100644 src/executable/haskell/Service/MailService.hs create mode 100644 src/executable/haskell/Utils/Either.hs create mode 100644 src/executable/haskell/Utils/HTTP.hs create mode 100644 src/executable/haskell/Utils/Text.hs create mode 100644 src/executable/haskell/Utils/Time.hs create mode 100644 src/executable/haskell/View/Ad.hs (limited to 'src/executable/haskell') diff --git a/src/executable/haskell/Conf.hs b/src/executable/haskell/Conf.hs new file mode 100644 index 0000000..e59f2a7 --- /dev/null +++ b/src/executable/haskell/Conf.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Conf + ( parse + , Conf(..) + ) where + +import qualified Data.ConfigManager as Conf +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) + +import Model.URL + +data Conf = Conf + { leboncoinUrls :: [URL] + , ouestFranceUrls :: [URL] + , mailFrom :: Text + , mailTo :: [Text] + , listenInterval :: NominalDiffTime + , devMode :: Bool + } deriving Show + +parse :: FilePath -> IO Conf +parse path = do + conf <- + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "leboncoinUrls" conf <*> + Conf.lookup "ouestFranceUrls" conf <*> + Conf.lookup "mailFrom" conf <*> + Conf.lookup "mailTo" conf <*> + Conf.lookup "listenInterval" conf <*> + Conf.lookup "devMode" conf + ) + case conf of + Left msg -> error (T.unpack msg) + Right c -> return c diff --git a/src/executable/haskell/Main.hs b/src/executable/haskell/Main.hs new file mode 100644 index 0000000..b6705f9 --- /dev/null +++ b/src/executable/haskell/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import qualified Conf +import qualified Service.AdListener as AdListener + +main :: IO () +main = do + conf <- Conf.parse "application.conf" + AdListener.start conf diff --git a/src/executable/haskell/Model/Mail.hs b/src/executable/haskell/Model/Mail.hs new file mode 100644 index 0000000..a19f9ae --- /dev/null +++ b/src/executable/haskell/Model/Mail.hs @@ -0,0 +1,12 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) + +data Mail = Mail + { from :: Text + , to :: [Text] + , subject :: Text + , plainBody :: Text + } deriving (Eq, Show) diff --git a/src/executable/haskell/Service/AdListener.hs b/src/executable/haskell/Service/AdListener.hs new file mode 100644 index 0000000..f903f94 --- /dev/null +++ b/src/executable/haskell/Service/AdListener.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Service.AdListener + ( start + ) where + +import Control.Concurrent (threadDelay) +import Data.Either (rights) +import qualified Data.Text.IO as T +import Prelude hiding (error) + +import Conf (Conf) +import qualified Conf +import Model.Ad (Ad) +import qualified Model.Ad as Ad +import Model.Mail (Mail (Mail)) +import Model.URL (URL) +import qualified Parser.LeboncoinParser as LeboncoinParser +import qualified Parser.OuestFranceParser as OuestFranceParser +import qualified Service.MailService as MailService +import qualified Utils.HTTP as HTTP +import qualified Utils.Time as TimeUtils +import qualified View.Ad as Ad + +start :: Conf -> IO () +start conf = do + ads <- fetchAds conf + let newURLs = map Ad.url ads + T.putStrLn "Listening to new ads…" + waitListenInterval conf + listenToNewAdsWithViewedURLs conf newURLs + +listenToNewAdsWithViewedURLs :: Conf -> [URL] -> IO () +listenToNewAdsWithViewedURLs conf viewedURLs = do + ads <- fetchAds conf + let (newURLs, newAds) = Ad.getNewAds viewedURLs ads + time <- TimeUtils.getCurrentFormattedTime + if not (null newAds) + then + do + _ <- T.putStrLn (Ad.renderConsoleAds time newAds) + if Conf.devMode conf + then return () + else sendMail conf newAds + else + return () + waitListenInterval conf + listenToNewAdsWithViewedURLs conf (viewedURLs ++ newURLs) + +fetchAds :: Conf -> IO [Ad] +fetchAds conf = do + leboncoinAds <- fmap (concat . map LeboncoinParser.parse . rights) . sequence . map HTTP.get . Conf.leboncoinUrls $ conf + ouestFranceAds <- fmap (concat . map OuestFranceParser.parse . rights) . sequence . map HTTP.get . Conf.ouestFranceUrls $ conf + let results = leboncoinAds ++ ouestFranceAds + if null results + then T.putStrLn "Parsed 0 results!" + else return () + return results + +sendMail :: Conf -> [Ad] -> IO () +sendMail conf ads = + let (title, plainBody) = Ad.renderAds ads + mail = Mail (Conf.mailFrom conf) (Conf.mailTo conf) title plainBody + in MailService.send mail >> return () + +waitListenInterval :: Conf -> IO () +waitListenInterval = threadDelay . (*) 1000000 . round . Conf.listenInterval diff --git a/src/executable/haskell/Service/MailService.hs b/src/executable/haskell/Service/MailService.hs new file mode 100644 index 0000000..f6d9542 --- /dev/null +++ b/src/executable/haskell/Service/MailService.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Service.MailService + ( send + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified Network.Mail.Mime as Mime + +import Model.Mail (Mail) +import qualified Model.Mail as Mail + +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 + +getMimeMail :: Mail -> Mime.Mail +getMimeMail mail = + let fromMail = Mime.emptyMail . address . Mail.from $ mail + in fromMail + { Mime.mailTo = map address . Mail.to $ mail + , Mime.mailParts = + [ [ Mime.plainPart . strictToLazy . Mail.plainBody $ mail ] + ] + , Mime.mailHeaders = [("Subject", Mail.subject mail)] + } + +address :: Text -> Mime.Address +address addressEmail = + Mime.Address + { Mime.addressName = Nothing + , Mime.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/src/executable/haskell/Utils/Either.hs b/src/executable/haskell/Utils/Either.hs new file mode 100644 index 0000000..5d62dcc --- /dev/null +++ b/src/executable/haskell/Utils/Either.hs @@ -0,0 +1,7 @@ +module Utils.Either + ( mapLeft + ) where + +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left l) = Left (f l) +mapLeft _ (Right r) = (Right r) diff --git a/src/executable/haskell/Utils/HTTP.hs b/src/executable/haskell/Utils/HTTP.hs new file mode 100644 index 0000000..c901500 --- /dev/null +++ b/src/executable/haskell/Utils/HTTP.hs @@ -0,0 +1,20 @@ +module Utils.HTTP + ( get + ) where + +import Control.Exception (SomeException, try) + +import Data.ByteString.Lazy as BS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding as T +import Network.HTTP.Conduit + +import Model.URL +import Utils.Either (mapLeft) + +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 = (T.decodeLatin1 . BS.toStrict) <$> simpleHttp (T.unpack url) diff --git a/src/executable/haskell/Utils/Text.hs b/src/executable/haskell/Utils/Text.hs new file mode 100644 index 0000000..1297bbd --- /dev/null +++ b/src/executable/haskell/Utils/Text.hs @@ -0,0 +1,13 @@ +module Utils.Text + ( startsWith + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +startsWith :: Text -> Text -> Bool +startsWith mbStart text = + case (T.uncons mbStart, T.uncons text) of + (Just (x, xs), Just (y, ys)) -> x == y && startsWith xs ys + (Nothing, _) -> True + _ -> False diff --git a/src/executable/haskell/Utils/Time.hs b/src/executable/haskell/Utils/Time.hs new file mode 100644 index 0000000..b6045a7 --- /dev/null +++ b/src/executable/haskell/Utils/Time.hs @@ -0,0 +1,14 @@ +module Utils.Time + ( getCurrentFormattedTime + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (getZonedTime) + +getCurrentFormattedTime :: IO Text +getCurrentFormattedTime = do + zonedTime <- getZonedTime + return (T.pack $ formatTime defaultTimeLocale "%Hh%M" zonedTime) diff --git a/src/executable/haskell/View/Ad.hs b/src/executable/haskell/View/Ad.hs new file mode 100644 index 0000000..ba0c550 --- /dev/null +++ b/src/executable/haskell/View/Ad.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Ad + ( renderConsoleAds + , renderAds + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T + +import Model.Ad (Ad) +import qualified Model.Ad as Ad + +renderConsoleAds :: Text -> [Ad] -> Text +renderConsoleAds time ads = + let (title, message) = renderAds ads + titleWithTime = + T.concat + [ "\n[" + , time + , "] " + , title + ] + line = T.map (\_ -> '-') titleWithTime + in T.intercalate + "\n" + [ titleWithTime + , line + , "" + , message + ] + +renderAds :: [Ad] -> (Text, Text) +renderAds ads = + let titleMessage = renderTitle $ length ads + adsMessage = T.intercalate "\n\n" . map renderAd $ ads + in (titleMessage, adsMessage) + +renderTitle :: Int -> Text +renderTitle count = + T.concat + [ T.pack . show $ count + , agreement " nouvelle" + , agreement " annonce" + ] + where agreement word = + T.concat + [ word + , if count > 1 then "s" else "" + ] + +renderAd :: Ad -> Text +renderAd ad = + let formatPrice price = T.concat [" - ", price] + getPrice = Maybe.fromMaybe "" . fmap formatPrice . Ad.price $ ad + titleLine = T.concat [Ad.name ad, Ad.location ad, getPrice] + in T.intercalate "\n" [titleLine, Ad.url ad] -- cgit v1.2.3