Merge remote-tracking branch 'origin/development'

app/Main.hs

@@ -20,7 +20,7 @@ import Interest
 import Mail
 import News
 import Location
--- import Weather
+import Weather
 import Html
 import Database as DB
 import Error as E
@@ -62,7 +62,9 @@ sendWelcomeMailToUser user = do
   let userEmailAddress = User.getEmail user
   conn <- Mail.connect
   Mail.auth conn
+  putStrLn "Sending welcome email to user..."
   Mail.send conn userEmailAddress "Welcome to dailyHASK" "plain text body" (Html.renderWelcomeMailTemplate user)
+  putStrLn "Welcome email sent"
   Mail.closeConnection conn
   return ()
 
@@ -76,20 +78,41 @@ doWork :: IO ()
 doWork = let
   workActions :: SMTPConnection -> Bson.Document -> IO ()
   workActions conn user = do
-    let email = Bson.typed $ Bson.valueAt "email" user :: Text
+    let _id = M.fromJust $ Bson.lookup "_id" user :: User.ID
+
+    let name = M.fromJust $ Bson.lookup "name" user :: Bson.Document
+    let firstName = M.fromJust $ Bson.lookup "first" name :: Text
+    let lastName = M.fromJust $ Bson.lookup "last" name :: Text
+    let name' = Name firstName lastName :: User.Name
+
+    let email = M.fromJust $ Bson.lookup "email" user :: Text
+
+    let location = M.fromJust $ Bson.lookup "location" user :: Bson.Document
+    let address = M.fromJust $ Bson.lookup "address" location :: Text
+    let lat = M.fromJust $ Bson.lookup "lat" location :: Double
+    let long = M.fromJust $ Bson.lookup "long" location :: Double
+    let location' = GeoLoc address lat long :: GeoLoc
+
     let interests = Bson.typed $ Bson.valueAt "interests" user :: [Interest]
+
+    let userRecord = User _id name' email location' interests :: User
+
     news <- News.getNews interests
-    if M.isNothing news
-      then E.callError "Error. Main: couldn't retrive news articles. Aborting..."
+    currentWeather <- Weather.getCurrentWeatherFromGeoLoc $ User.getLocation userRecord
+    if M.isNothing news || M.isNothing currentWeather
+      then E.callError "Error. Main: couldn't retrive news articles or weather information. Aborting..."
       else let
         news' = M.fromJust news
-        in Mail.send conn email "Your dailyHASK" "plain text body" (Html.renderDailyMailTemplate news')
+        currentWeather' = M.fromJust currentWeather
+        in do
+          Mail.send conn email "Your dailyHASK" "" (Html.renderDailyMailTemplate userRecord news' currentWeather')
+          putStrLn "Daily mail sent to user..."
 
   work :: [Bson.Document] -> SMTPConnection -> IO ()
   work users conn = do
     mapM_ (workActions conn) users
   in do
-    putStrLn "doWork started..."
+    putStrLn "Processing database..."
     collection <- collection
     pipe <- DB.open
     users <- DB.findAll pipe [] collection
@@ -98,13 +121,13 @@ doWork = let
     Mail.auth conn
     work users conn
     Mail.closeConnection conn
-    putStrLn "doWork finished."
+    putStrLn "Process finished."
 
 main :: IO ()
 main = do
-  putStrLn ">> Select hour parameter to construct a cronjob"
+  putStrLn ">> Select hour parameter to construct cronjob"
   h <- getLine
-  putStrLn ">> Select minute parameter to construct a cronjob"
+  putStrLn ">> Select minute parameter to construct cronjob"
   m <- getLine
   main' h m
 
@@ -119,12 +142,7 @@ main' h m = do
     else forever $ do
       now <- Date.getCurrentTimeFromServer
       when (scheduleMatches schedule now) doWork
-      threadDelay 60000000 -- delay 1 minute to skip schedule
-      -- doWork
+      threadDelay 60000000 -- delay 1 minute to skip schedule. TODO: find a much simpler way to delay, i.e: using criterion package
     where
       cronSpec = Text.pack (m ++ " " ++ h ++ " * * *")
       schedule = either (E.callError "Error at configuring cron schedule (it should not happen). Aborting...") id (parseCronSchedule cronSpec)
-
-test = do
-  now <- Date.getCurrentTimeFromServer
-  return $ show $ now

dailyHASK.cabal

@@ -57,7 +57,7 @@ library
       Url
       Mail
       Html
-      Json
+      Http
       News
       Weather
       Utils
@@ -77,6 +77,7 @@ executable dailyHASK-exe
     , bson
     , cron
     , HaskellNet-SSL
+    , criterion
   other-modules:
       Paths_dailyHASK
   default-language: Haskell2010

src/Config.hs

@@ -1,3 +1,9 @@
+{-|
+Module      : Config
+
+Definition of functions to get values of certain keys form a configuration file named app.cfg placed in root folder
+-}
+
 module Config
     (
     getValue
@@ -12,6 +18,7 @@ import qualified Error as E
 appConfigFile :: String
 appConfigFile = "/app.cfg"
 
+-- |The 'getValue' function gets a value from a given key stored in /app.cfg
 getValue :: String -> IO (Maybe String)
 getValue key = do
   currDir <- Dir.getCurrentDirectory

src/Database.hs

@@ -1,3 +1,9 @@
+{-|
+Module      : Database
+
+Asbtraction of the Haskell MongoDB driver
+-}
+
 {-# LANGUAGE OverloadedStrings #-}
 
 module Database
@@ -42,12 +48,16 @@ db = do
     then E.callError "Error: database.db config file value not found"
     else return $ M.fromJust value
 
+-- |The 'open' function returns a TCP connection to a database defined in the
+-- /app.cfg file, a 'MongoDB.Pipe'
 open :: IO MongoDB.Pipe
 open = do
   server <- server
   pipe <- MongoDB.connect $ MongoDB.host server
   return $ pipe
 
+-- |The 'close' function closes the TCP connection the database setted in the
+-- config file /app.cfg
 close :: MongoDB.Pipe -> IO ()
 close pipe = MongoDB.close pipe
 
@@ -58,36 +68,43 @@ run pipe act = do
   exec <- MongoDB.access pipe MongoDB.master db' act
   return $ exec
 
+-- |The 'insert' function inserts a document into a given collection
 insert :: MongoDB.Pipe -> MongoDB.Collection -> Bson.Document -> IO Bson.Value
 insert pipe collection document = do
   exec <- run pipe $ MongoDB.insert collection document
   return $ exec
 
+-- |The 'insertMany' function inserts a set of documents into a given collection
 insertMany :: MongoDB.Pipe -> MongoDB.Collection -> [Bson.Document] -> IO [Bson.Value]
 insertMany pipe collection documents = do
   exec <- run pipe $ MongoDB.insertMany collection documents
   return $ exec
 
+-- |The 'count' function counts documents, from a collection, that preserve some property
 count :: MongoDB.Pipe -> MongoDB.Selector -> MongoDB.Collection -> IO Int
 count pipe fields collection = do
   exec <- run pipe $ MongoDB.count $ MongoDB.select fields collection
   return $ exec
 
+-- |The 'save' function updates documents, from a collection, that preserve some property
 save :: MongoDB.Pipe -> MongoDB.Collection -> MongoDB.Selector -> IO ()
 save pipe collection fields = do
   exec <- run pipe $ MongoDB.save collection fields
   return $ exec
 
+-- |The 'delete' function drops documents, from a collection, that preserve some property
 delete :: MongoDB.Pipe -> MongoDB.Selector -> MongoDB.Collection -> IO ()
 delete pipe fields collection = do
   exec <- run pipe $ MongoDB.delete $ MongoDB.select fields collection
   return $ exec
 
+-- |The 'findOne' function fetches just one document, the first one from a collection, that preserve some property
 findOne :: MongoDB.Pipe -> MongoDB.Selector -> MongoDB.Collection -> IO (Maybe Bson.Document)
 findOne pipe fields collection = do
   exec <- run pipe $ MongoDB.findOne $ MongoDB.select fields collection
   return $ exec
 
+-- |The 'findAll' function fetches all documents from a given collection.
 findAll :: MongoDB.Pipe -> MongoDB.Selector -> MongoDB.Collection -> IO [Bson.Document]
 findAll pipe fields collection = do
   exec <- run pipe $ MongoDB.find (MongoDB.select fields collection) >>= MongoDB.rest

src/Date.hs

@@ -1,3 +1,9 @@
+{-|
+Module      : Date
+
+Abstraction of 'Date.Time' library: definition of certain functions concerning actual project
+-}
+
 module Date
     (
     today
@@ -8,13 +14,15 @@ import Data.Time.Clock
 import Data.Time.Calendar
 import Data.Time.LocalTime
 
+-- |The 'getCurrentTimeFromServer' returns current time of server using actual time zone, and convert it to 'UTCTime' format
 getCurrentTimeFromServer :: IO UTCTime
 getCurrentTimeFromServer = do
   tz <- getCurrentTimeZone
   now @ (UTCTime day _) <- getCurrentTime
   let localDiffTime = timeOfDayToTime $ localTimeOfDay $ utcToLocalTime tz now :: DiffTime
   return $ UTCTime day localDiffTime
 
+-- |The 'today' function returns current y-m-d format
 today :: IO String
 today = do
   UTCTime day _ <- getCurrentTime

src/Error.hs

@@ -1,6 +1,12 @@
+{-|
+Module      : Error
+Description : Definition of error functions
+-}
+
 module Error
     (
     callError
     ) where
 
+-- |The 'callError' function just calls 'Prelude' 'error' function
 callError = error

src/Html.hs

@@ -1,4 +1,10 @@
-{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-}
+{-|
+Module      : Html
+
+Definition of functions to render HTML output code
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
 
 module Html
     (
@@ -15,12 +21,13 @@ import Text.Blaze.Html.Renderer.String
 
 import Control.Monad (forM_)
 import Data.Text as Text hiding (unwords)
+import Data.String
 
 import User
 import Location
 import Interest
 import News
--- import Weather
+import Weather
 import Utils
 
 userInfoToHtml :: User -> Html
@@ -53,26 +60,23 @@ articleToHtml article = let
   author = handleNull article News.getArticleAuthor
   title = handleNull article News.getArticleTitle
   description = handleNull article News.getArticleDescripton
-  url = News.getArticleUrl article
+  url = fromString $ Text.unpack $ News.getArticleUrl article :: AttributeValue
   urlToImage = handleNull article News.getArticleUrlToImage
   publishedAt = handleNull article News.getArticlePublishedAt
   in H.div $ do
     H.article $ do
-      h2 $ toHtml $ title
-      h3 $ toHtml $ description
-      p $ toHtml $ url
-
--- currentWeatherToHtml :: Weather -> Html
--- currentWeatherToHtml weather = let
---   temp = show $ Weather.getTemp weather
---   pressure = show $ Weather.getPressure weather
---   humidity = show $ Weather.getHumidity weather
---   in H.div $ do
---     h4 "The current weather: "
---     ul $ do
---       li $ toHtml $ "Temperature: " ++ temp
---       li $ toHtml $ "Pressure: " ++ pressure
---       li $ toHtml $ "Humidity: " ++ humidity
+      h3 $ a ! href url $ toHtml title
+      h5 $ toHtml $ sourceName
+      h4 $ toHtml $ description
+
+currentWeatherToHtml :: Weather -> Html
+currentWeatherToHtml weather = let
+  (temp, pressure, humidity) = (show $ round $ Weather.kelvinToCelsius $ Weather.getTemp weather
+                                , show $ Weather.getPressure weather
+                                , show $ Weather.getHumidity weather)
+  in H.div $ do
+    h2 "The current weather: "
+    h3 $ toHtml $ "Temperature: " ++ temp ++ " °C; " ++ "pressure: " ++ pressure ++ " hPa; " ++ "humidity: " ++ humidity ++ " %"
 
 welcomeMailTemplate :: User -> Html
 welcomeMailTemplate user = docTypeHtml $ do
@@ -81,25 +85,29 @@ welcomeMailTemplate user = docTypeHtml $ do
   body $ do
     userInfoToHtml user
 
+-- |The 'renderWelcomeMailTemplate' returns a string containing HTML code corresponding to a welcome-mail template
 renderWelcomeMailTemplate :: User -> String
 renderWelcomeMailTemplate user = renderHtml $ welcomeMailTemplate user
 
-dailyMailTemplate :: News -> Html
-dailyMailTemplate news = let
+dailyMailTemplate :: User -> News -> Weather -> Html
+dailyMailTemplate user news weather = let
   total = News.getNewsTotal news
   totalStr = show total :: String
-  totalHeader = "Total articles: " ++ totalStr
+  totalHeader = "total articles: " ++ totalStr
   articles = News.getNewsArticles news
+
+  userFirstName = Text.unpack $ User.getFirstName $ User.getName user
   in if total == 0
     then H.div $ do
       h3 "Application couldn't retrieve news articles matching your interests today."
     else docTypeHtml $ do
       H.head $ do
         H.title "dailyHASK"
       body $ do
-        h2 "The following news articles match your interests and were published today"
-        h3 $ toHtml $ totalHeader
+        currentWeatherToHtml weather
+        h2 $ toHtml $ userFirstName ++ ", the following news articles match your interests and were published today (" ++ totalHeader ++ ")"
         ul $ forM_ articles (li . articleToHtml)
 
-renderDailyMailTemplate :: News -> String
-renderDailyMailTemplate news = renderHtml $ dailyMailTemplate news
+-- |The 'renderDailyMailTemplate' returns a string containing HTML code corresponding to the daily-mail template
+renderDailyMailTemplate :: User -> News -> Weather -> String
+renderDailyMailTemplate user news weather = renderHtml $ dailyMailTemplate user news weather

src/Http.hs

@@ -0,0 +1,15 @@
+{-|
+Module      : Http
+
+Definition of functions to handle HTTP requests
+-}
+
+module Http
+    (
+    isGETRequestOk
+    ) where
+
+-- |The 'isGETRequestOk' returns whether a GET request got a 200 status code
+isGETRequestOk :: Int -> Bool
+isGETRequestOk 200 = True
+isGETRequestOk _ = False

src/Interest.hs

@@ -1,3 +1,9 @@
+{-|
+Module      : Interest
+
+Definition of 'Interest' type along multiple functions concerning 'Interest' values
+-}
+
 module Interest
     (
     Interest
@@ -9,8 +15,10 @@ import Data.Text as Text hiding (map)
 
 type Interest = Text
 
+-- |The 'toDataType' maps a list of strings to a list of 'Interest' values
 toDataType :: [String] -> [Interest]
 toDataType list = map pack list
 
+-- |The 'fromDataType' maps a list of 'Interest' values to a list of strings
 fromDataType :: [Interest] -> [String]
 fromDataType list = map unpack list