aboutsummaryrefslogtreecommitdiff
path: root/src/executable/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/executable/haskell')
-rw-r--r--src/executable/haskell/Conf.hs6
-rw-r--r--src/executable/haskell/Main.hs7
-rw-r--r--src/executable/haskell/Service/AdListener.hs64
-rw-r--r--src/executable/haskell/Service/MailService.hs29
4 files changed, 62 insertions, 44 deletions
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 =
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 03:16:30 +0000