lucienne-0.0.1: Lucienne/Fetch.hs

module Lucienne.Fetch
  (fetchFeedByUrl,fetchFeed)
where

import           Data.Maybe (fromMaybe)
import           Data.List (find)
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Network.HTTP as HTTP
import           Network.URI (URI)
import qualified Network.URI as URI
import qualified Text.Feed.Import as TFI
import qualified Text.Feed.Types as TFT
import qualified Text.Atom.Feed as TFAtom
import qualified Text.RSS.Syntax as TFRss
import           Lucienne.Model.FeedItem (FeedItem)
import qualified Lucienne.Model.FeedItem as FI
import           Lucienne.Model.Feed (Feed)
import qualified Lucienne.Model.Feed as F

fetchFeedByUrl :: String -> IO (Either String (Feed,[FeedItem]))
fetchFeedByUrl url = 
  case URI.parseURI url of
    Nothing  -> return $ Left $ concat ["'",url,"' is no valid URL"]
    Just uri -> fetchAndProcessFeed uri $ parseFeed uri

fetchFeed :: Feed -> IO (Either String (Feed,[FeedItem]))
fetchFeed = fetchFeedByUrl . F.url

parseFeed :: URI -> String -> Either String (Feed,[FeedItem])
parseFeed feedUri content =
  let textFeed = TFI.parseFeedString content
  in
    case textFeed of
      Nothing               -> Left "Can not parse feed items"
      Just (TFT.AtomFeed f) -> Right $ parseAtomFeed feedUri f
      Just (TFT.RSSFeed f)  -> Right $ parseRssFeed feedUri f
      Just _                -> Left "Unsupported feed format"

parseAtomFeed :: URI -> TFAtom.Feed -> (Feed,[FeedItem])
parseAtomFeed feedUri feed =
  let parseFeedItems entry = 
        let title   = TFAtom.txtToString $ TFAtom.entryTitle entry
            url     = chooseAtomLink $ TFAtom.entryLinks entry
            content = maybe "" TFAtom.txtToString $ TFAtom.entrySummary entry
        in
          FI.newItem title url content
      feedTitle = TFAtom.txtToString $ TFAtom.feedTitle feed
  in
    ( F.newFeed feedTitle $ show feedUri
    , map parseFeedItems $ TFAtom.feedEntries feed
    )

chooseAtomLink :: [TFAtom.Link] -> String
chooseAtomLink links = 
  let selfLink = find (\l -> case TFAtom.linkRel l of 
                              Just (Right "self") -> True
                              Just (Left "self")  -> True
                              _                   -> False)
  in
    TFAtom.linkHref $ fromMaybe (head links) $ selfLink links

parseRssFeed :: URI -> TFRss.RSS -> (Feed,[FeedItem])
parseRssFeed feedUri feed = 
  let parseFeedItems item =
        let title   = fromMaybe "" $ TFRss.rssItemTitle item
            url     = fromMaybe "" $ TFRss.rssItemLink item
            content = fromMaybe "" $ TFRss.rssItemDescription item
        in
          FI.newItem title url content
      feedTitle = TFRss.rssTitle $ TFRss.rssChannel feed
  in
    ( F.newFeed feedTitle $ show feedUri
    , map parseFeedItems $ TFRss.rssItems $ TFRss.rssChannel feed
    )

fetchAndProcessFeed :: URI -> (String -> Either String a) -> IO (Either String a)
fetchAndProcessFeed uri f = do
  result <- HTTP.simpleHTTP request
  return $ case result of
             Left connectionError -> Left $ show connectionError
             Right response       -> f $ T.unpack . E.decodeUtf8 $ HTTP.rspBody response
  where
    request = HTTP.Request uri HTTP.GET [] BS.empty