Add ouest france parser

2 files changed, 113 insertions, 0 deletions

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