Add ouest france parser

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]