Main.hs

import           Prelude hiding (log)
import           Control.Monad (forM_)
import           Control.Monad.Trans (liftIO)
import           Data.Time.LocalTime (getZonedTime)
import           Data.Bson (ObjectId)
import           Database.MongoDB (runIOE,readHostPort,connect,close)
import qualified Lucienne.Database as DB
import           Lucienne.ConnectionReader (ConnectionReader,runConnectionReader)
import           Lucienne.Fetch (fetchFeed)
import           Lucienne.Fetch.Util (partitionM)
import           Lucienne.Model.User (User)
import qualified Lucienne.Model.User as User
import           Lucienne.Model.Feed (Feed)
import qualified Lucienne.Model.Feed as F
import           Lucienne.Model.FeedItem (FeedItem)
import qualified Lucienne.Model.FeedItem as FI
import           Lucienne.Args (getArgs,dbConnectionString)

main :: IO ()
main = do
  args <- getArgs
  putStrLn $ "Connecting to database " ++ (dbConnectionString args) ++ " ..."
  connection <- runIOE $ connect $ readHostPort $ dbConnectionString args
  runConnectionReader connection fetch
  close connection
  
fetch :: ConnectionReader ()  
fetch = do 
  users <- DB.users
  forM_ users fetchFeedsAndUpdate
  
fetchFeedsAndUpdate :: User -> ConnectionReader ()
fetchFeedsAndUpdate user = do
  feeds <- DB.feedsByUser user
  forM_ feeds $ \f -> do
    log $ concat ["Fetching feed '",F.title f, "' for user '",User.name user,"'"]
    fetchFeedItemsAndUpdate user f
  
fetchFeedItemsAndUpdate :: User -> Feed -> ConnectionReader ()
fetchFeedItemsAndUpdate user feed = 
  let fId  = F.id  feed
      fUrl = F.url feed
  in do
   result <- liftIO $ fetchFeed feed
   case result of
     Left message      -> log $ "Could not fetch feed '" ++ fUrl ++ "' because of: " ++ message
     Right (_,items')  -> 
       let items = map (FI.setOwner user . FI.setFeedId fId) items'
       in do
         (rest,toAdd) <- partitionExistentFeedItems fId items
         log $ concat ["Fetched ", show $ length items," items (",show $ length toAdd," new)"]
                                
         forM_ toAdd DB.upsertFeedItem 
         deleteFeedItems fId rest

partitionExistentFeedItems :: ObjectId -> [FeedItem] -> ConnectionReader ([FeedItem],[FeedItem])
partitionExistentFeedItems feedId =
  partitionM $ \i -> DB.feedItemExists feedId (FI.title i) (FI.url i)

deleteFeedItems :: ObjectId -> [FeedItem] -> ConnectionReader ()
deleteFeedItems feedId feedItems =
  let titlesToRemain = map FI.title feedItems
      urlsToRemain   = map FI.url   feedItems
  in
   DB.deleteMarkedFeedItems feedId titlesToRemain urlsToRemain
   
log :: String -> ConnectionReader ()
log s = do
  time <- liftIO $ getZonedTime
  liftIO $ putStrLn $ concat ["[",show time,"]\t",s]