aboutsummaryrefslogtreecommitdiff
path: root/src/executable
diff options
context:
space:
mode:
Diffstat (limited to 'src/executable')
-rw-r--r--src/executable/haskell/Conf.hs39
-rw-r--r--src/executable/haskell/Main.hs13
-rw-r--r--src/executable/haskell/Model/Mail.hs12
-rw-r--r--src/executable/haskell/Service/AdListener.hs67
-rw-r--r--src/executable/haskell/Service/MailService.hs46
-rw-r--r--src/executable/haskell/Utils/Either.hs7
-rw-r--r--src/executable/haskell/Utils/HTTP.hs20
-rw-r--r--src/executable/haskell/Utils/Text.hs13
-rw-r--r--src/executable/haskell/Utils/Time.hs14
-rw-r--r--src/executable/haskell/View/Ad.hs58
10 files changed, 289 insertions, 0 deletions
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]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 10:16:02 +0000