FeedParser.hs

{- hpodder component
Copyright (C) 2006 John Goerzen <jgoerzen@complete.org>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module     : FeedParser
   Copyright  : Copyright (C) 2006 John Goerzen
   License    : GNU GPL, version 2 or above

   Maintainer : John Goerzen <jgoerzen@complete.org>
   Stability  : provisional
   Portability: portable

Written by John Goerzen, jgoerzen\@complete.org

-}
module FeedParser where

import Types
import Text.XML.HaXml
import Text.XML.HaXml.Parse
import Text.XML.HaXml.Posn
import Utils
import Data.Maybe.Utils
import Data.Char
import Data.Either.Utils
import Data.List
import System.IO

data Item = Item {itemtitle :: String,
                  itemguid :: Maybe String,
                  enclosureurl :: String,
                  enclosuretype :: String,
                  enclosurelength :: String
                  }
          deriving (Eq, Show, Read)

data Feed = Feed {channeltitle :: String,
                  items :: [Item]}
            deriving (Eq, Show, Read)

item2ep pc item =
    Episode {podcast = pc, epid = 0,
             eptitle = sanitize_basic (itemtitle item), 
             epurl = sanitize_basic (enclosureurl item),
             epguid = fmap sanitize_basic (itemguid item),
             eptype = sanitize_basic (enclosuretype item), epstatus = Pending,
             eplength = case reads . sanitize_basic . enclosurelength $ item of
                          [] -> 0
                          [(x, [])] -> x
                          _ -> 0,
             epfirstattempt = Nothing,
             eplastattempt = Nothing,
             epfailedattempts = 0}

parse :: FilePath -> String -> IO (Either String Feed)
parse fp name = 
    do h <- openBinaryFile fp ReadMode
       c <- hGetContents h
       case xmlParse' name (unifrob c) of
         Left x -> return (Left x)
         Right y ->
             do let doc = getContent y
                let title = getTitle doc
                let feeditems = getEnclosures doc
                return $ Right $
                           (Feed {channeltitle = title, items = feeditems})
       where getContent (Document _ _ e _) = CElem e noPos

unifrob ('\xfeff':x) = x -- Strip off unicode BOM
unifrob x = x

unesc = xmlUnEscape stdXmlEscaper

getTitle doc = forceEither $ strofm "title" (channel doc)

getEnclosures doc =
    concat . map procitem $ item doc
    where procitem i = map (procenclosure title guid) enclosure
              where title = case strofm "title" [i] of
                              Left x -> "Untitled"
                              Right x -> x
                    guid = case strofm "guid" [i] of
                              Left _ -> Nothing
                              Right x -> Just x
                    enclosure = tag "enclosure" `o` children $ i
          procenclosure title guid e =
              Item {itemtitle = title,
                    itemguid = guid,
                    enclosureurl = head0 $ forceMaybe $ stratt "url" e,
                    enclosuretype = head0 $ case stratt "type" e of
                                              Nothing -> ["application/octet-stream"]
                                              Just x -> x,
                    enclosurelength = head $ case stratt "length" e of
                                                Nothing -> ["0"]
                                                Just [] -> ["0"]
                                                Just x -> x
                                                }
          head0 [] = ""
          head0 (x:xs) = x
              

item = tag "item" `o` children `o` channel

channel =
    tag "channel" `o` children `o` tag "rss"


--------------------------------------------------
-- Utilities
--------------------------------------------------

attrofelem :: String -> Content Posn -> Maybe AttValue
attrofelem attrname (CElem inelem _) =
    case unesc inelem of
      Elem name al _ -> lookup attrname al
attrofelem _ _ =
    error "attrofelem: called on something other than a CElem"
stratt :: String -> Content Posn -> Maybe [String]
stratt attrname content =
    case attrofelem attrname content of
      Just (AttValue x) -> Just (concat . map mapfunc $ x)
      Nothing -> Nothing
    where mapfunc (Left x) = [x]
          mapfunc (Right _) = []

-- Finds the literal children of the named tag, and returns it/them
tagof :: String -> CFilter Posn
tagof x = keep /> tag x -- /> txt

-- Retruns the literal string that tagof would find
strof :: String -> Content Posn -> String
strof x y = forceEither $ strof_either x y

strof_either :: String -> Content Posn -> Either String String
strof_either x y =
    case tagof x $ y of
      [CElem elem pos] -> Right $ verbatim $ tag x /> txt
           $ CElem (unesc elem) pos
      z -> Left $ "strof: expecting CElem in " ++ x ++ ", got "
           ++ verbatim z ++ " at " ++ verbatim y

strofm x y = 
    if length errors /= 0
       then Left errors
       else Right (concat plainlist)
    where mapped = map (strof_either x) $ y
          (errors, plainlist) = conveithers mapped
          isright (Left _) = False
          isright (Right _) = True

conveithers :: [Either a b] -> ([a], [b])
conveithers inp =  worker inp ([], [])
    where worker [] y = y
          worker (Left x:xs) (lefts, rights) =
              worker xs (x:lefts, rights)
          worker (Right x:xs) (lefts, rights) =
              worker xs (lefts, x:rights)