From 5cedcecd6ae31e2485dcab2ddd74c74a4779545d Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 3 Sep 2019 21:01:53 +0200 Subject: Make LBC to work Use request headers to simulate a normal browser --- src/executable/haskell/Conf.hs | 6 +-- src/executable/haskell/Main.hs | 7 ++- src/executable/haskell/Service/AdListener.hs | 64 ++++++++++++++------------- src/executable/haskell/Service/MailService.hs | 29 ++++++++---- 4 files changed, 62 insertions(+), 44 deletions(-) (limited to 'src/executable') diff --git a/src/executable/haskell/Conf.hs b/src/executable/haskell/Conf.hs index e6bd4ca..df26ea0 100644 --- a/src/executable/haskell/Conf.hs +++ b/src/executable/haskell/Conf.hs @@ -16,8 +16,8 @@ data Conf = Conf , seLogerUrls :: [URL] , mailFrom :: Text , mailTo :: [Text] + , mailMock :: Bool , listenInterval :: NominalDiffTime - , devMode :: Bool } deriving Show parse :: FilePath -> IO Conf @@ -31,8 +31,8 @@ parse path = do Conf.lookup "seLogerUrls" conf <*> Conf.lookup "mailFrom" conf <*> Conf.lookup "mailTo" conf <*> - Conf.lookup "listenInterval" conf <*> - Conf.lookup "devMode" conf + Conf.lookup "mailMock" conf <*> + Conf.lookup "listenInterval" conf ) case conf of Left msg -> error (T.unpack msg) diff --git a/src/executable/haskell/Main.hs b/src/executable/haskell/Main.hs index fa1388c..d082b94 100644 --- a/src/executable/haskell/Main.hs +++ b/src/executable/haskell/Main.hs @@ -2,10 +2,13 @@ module Main ( main ) where +import qualified Network.HTTP.Conduit as H + import qualified Conf -import qualified Service.AdListener as AdListener +import qualified Service.AdListener as AdListener main :: IO () main = do conf <- Conf.parse "application.conf" - AdListener.start conf + manager <- H.newManager H.tlsManagerSettings + AdListener.start conf manager diff --git a/src/executable/haskell/Service/AdListener.hs b/src/executable/haskell/Service/AdListener.hs index bbd06d9..5cf26d1 100644 --- a/src/executable/haskell/Service/AdListener.hs +++ b/src/executable/haskell/Service/AdListener.hs @@ -2,62 +2,64 @@ module Service.AdListener ( start ) where -import Control.Concurrent (threadDelay) -import qualified Data.Text.IO as T -import Prelude hiding (error) +import Control.Concurrent (threadDelay) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Network.HTTP.Conduit (Manager) +import Prelude hiding (error) -import Conf (Conf) +import Conf (Conf) import qualified Conf import qualified FetchAd -import Model.Ad (Ad) -import qualified Model.Ad as Ad -import Model.Mail (Mail (Mail)) -import Model.URL (URL) -import qualified Service.MailService as MailService -import qualified Utils.Time as TimeUtils -import qualified View.Ad as Ad +import Model.Ad (Ad) +import qualified Model.Ad as Ad +import Model.Mail (Mail (Mail)) +import Model.URL (URL) +import qualified Service.MailService as MailService +import qualified Utils.Time as TimeUtils +import qualified View.Ad as Ad -start :: Conf -> IO () -start conf = do - ads <- fetchAds conf +start :: Conf -> Manager -> IO () +start conf manager = do + ads <- fetchAds conf manager let newURLs = map Ad.url ads T.putStrLn "Listening to new ads…" waitListenInterval conf - listenToNewAdsWithViewedURLs conf newURLs + listenToNewAdsWithViewedURLs conf manager newURLs -listenToNewAdsWithViewedURLs :: Conf -> [URL] -> IO () -listenToNewAdsWithViewedURLs conf viewedURLs = do - ads <- fetchAds conf +listenToNewAdsWithViewedURLs :: Conf -> Manager -> [URL] -> IO () +listenToNewAdsWithViewedURLs conf manager viewedURLs = do + ads <- fetchAds conf manager 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 + sendMail conf newAds else return () waitListenInterval conf - listenToNewAdsWithViewedURLs conf (viewedURLs ++ newURLs) + listenToNewAdsWithViewedURLs conf manager (viewedURLs ++ newURLs) -fetchAds :: Conf -> IO [Ad] -fetchAds conf = do - leboncoinAds <- FetchAd.leboncoin (Conf.leboncoinUrls conf) - ouestFranceAds <- FetchAd.ouestFrance (Conf.ouestFranceUrls conf) - seLogerAds <- FetchAd.seLoger (Conf.seLogerUrls conf) +fetchAds :: Conf -> Manager -> IO [Ad] +fetchAds conf manager = do + leboncoinAds <- FetchAd.leboncoin manager (Conf.leboncoinUrls conf) + ouestFranceAds <- FetchAd.ouestFrance manager (Conf.ouestFranceUrls conf) + seLogerAds <- FetchAd.seLoger manager (Conf.seLogerUrls conf) let results = leboncoinAds ++ ouestFranceAds ++ seLogerAds - if null results - then T.putStrLn "Parsed 0 results!" - else return () + T.putStrLn . T.concat $ + [ "Parsed " + , T.pack . show $ length results + , " results" + ] 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 () + in MailService.send (Conf.mailMock conf) 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 index 955dea1..cb61c47 100644 --- a/src/executable/haskell/Service/MailService.hs +++ b/src/executable/haskell/Service/MailService.hs @@ -4,9 +4,9 @@ module Service.MailService 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.IO as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (fromText, toLazyText) import qualified Network.Mail.Mime as Mime @@ -14,13 +14,26 @@ 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 +send :: Bool -> Mail -> IO (Either Text ()) +send isMock mail = + if isMock then do + putStrLn $ "MOCK sending mail " ++ (show mail) + return . Right $ () + else do + result <- + left (T.pack . show) <$> + (try (Mime.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + case result of + Left err -> + T.putStrLn . T.concat $ + [ "Error sending the following email (" + , T.pack . show $ mail + , ":\n" + , err + ] + Right _ -> + return () + return result getMimeMail :: Mail -> Mime.Mail getMimeMail mail = -- cgit v1.2.3