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/Service/AdListener.hs  | 64 ++++++++++++++-------------
 src/executable/haskell/Service/MailService.hs | 29 ++++++++----
 2 files changed, 54 insertions(+), 39 deletions(-)

(limited to 'src/executable/haskell/Service')

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