Reworked network stuff to use libcurl - it supports https and has easier error handling. Added error handling! Transform functions now return maybe articles.

Author: bcorrigan

PipeFeed.cabal

@@ -11,14 +11,14 @@ executable PipeFeed
                    base >= 4,
                    configurator >=0.2 && <0.3,
                    text >=0.11.3 && <0.12,
-                   network >=2.4.1 && <2.5,
-                   HTTP >=4000.2.8 && <4000.3,
                    regex-tdfa >=1.1.8 && <1.2,
                    feed >=0.3.9 && <0.4,
                    hashable >=1.2.0 && <1.3,
                    directory >=1.2.0 && <1.3,
                    strict >=0.3.2 && <0.4,
-                   xml >=1.3.13 && <1.4
+                   xml >=1.3.13 && <1.4,
+                   download-curl >=0.1.4 && <0.2,
+                   network >=2.4.1 && <2.5
   ghc-options:     -fglasgow-exts
   extensions:      
                    NoMonomorphismRestriction, 

src/PipeFeed.hs

@@ -2,6 +2,7 @@ module Main where
 
 import Config as Conf
 import Types as T
+import Util
 import Transforms
 
 import Text.Feed.Import 
@@ -13,9 +14,7 @@ import Text.Feed.Types as FT
 import Text.Feed.Export(xmlFeed)
 import Text.XML.Light.Output(showTopElement)
 
-import Network.URI
-import Network.HTTP(simpleHTTP,getRequest,getResponseBody)
-import Data.Maybe(fromMaybe,maybe)
+import Data.Maybe(fromMaybe,maybe,catMaybes)
 import Data.Hashable(hash) 
 import System.Directory
 import System.Environment
@@ -35,7 +34,7 @@ main = do
         print $ "Using " ++ cfgLoc ++ " as config file." 
         config <- Conf.configure cfgLoc
         feeds <- mapM fetchFeed (feeds config)
-        feeds <- mapM (loadCache config . hashFeed) feeds
+        feeds <- mapM (loadCache config . hashFeed) (catMaybes feeds)
         feeds <- mapM transform feeds
         mapM_ (writeCache config) feeds
         mapM_ (deleteCache config) feeds
@@ -45,22 +44,24 @@ main = do
 
         return ()
 
-fetchFeed::T.Feed -> IO T.Feed 
+fetchFeed::T.Feed -> IO (Maybe T.Feed) 
 fetchFeed feedcfg = do
-                        let url = feedurl feedcfg
-                        rsp <- simpleHTTP (getRequest url) -- >>= fmap (take 100) . getResponseBody
-                        feedText <- getResponseBody rsp
-                        --print feedText
-                        let feed = fromMaybe (error "Can't get feed") (parseFeedString feedText) 
+                        rsp <-  grabUrl $ feedurl feedcfg
+                        case rsp of
+                            Nothing -> do
+                                print $ "Error fetching " ++ feedurl feedcfg
+                                return Nothing
+                            Just feedText -> do
+                                let feed = fromMaybe (error "Can't get feed") (parseFeedString feedText) 
 
-                        let items = Query.feedItems feed
-                        let title = getFeedTitle feed
+                                let items = Query.feedItems feed
+                                let title = getFeedTitle feed
 
-                        let author = fromMaybe "unknown" (getFeedAuthor feed)
+                                let author = fromMaybe "unknown" (getFeedAuthor feed)
 
-                        print $ "Fetched " ++ show (length items) ++ " items from " ++ name feedcfg
+                                print $ "Fetched " ++ show (length items) ++ " items from " ++ name feedcfg
 
-                        let articles = map (\item ->
+                                let articles = map (\item ->
                                       Article{title=fromMaybe "Unknown title" (getItemTitle item)
                                         , body=maybe "nowt" fst3 (getItemEnclosure item)
                                         , itemurl=fromMaybe "Unknown url" (getItemLink item)
@@ -69,11 +70,7 @@ fetchFeed feedcfg = do
                                         , itemRec=item 
                                         , bodyhash=Nothing} ) items
 
-                        return ( feedcfg{ items=articles, feedRec=feed } ) 
-
---haskell doesn't have basic triple-or-above manip funcs, wtf?
-fst3::(a,b,c)->a
-fst3 (a,b,c) = a
+                                return ( Just $ feedcfg{ items=articles, feedRec=feed } ) 
 
 --any on disk should be loaded
 --this loads body into matching article, and marks that article as transformed
@@ -134,19 +131,22 @@ hashFeed feed = feed{items=map (\(a,h) -> a{bodyhash=Just h})
 
 --apply the transforms in order
 --also marks transformed
+--todo one day implement some sort of "error article" in case of error, so that feed consumer can see issue in feed
 transform :: T.Feed -> IO T.Feed
 transform feed = do
                     articles<-mapM (\article -> 
                         if transformed article 
-                        then return article{transformed=True}
+                        then return $ Just $ article{transformed=True}
                         else applyTransforms article
                       ) (items feed) 
 
-                    return $ updateFeedItems feed articles
+                    return $ updateFeedItems feed (catMaybes articles)
 
-                    where applyTransforms :: Article -> IO Article
-                          applyTransforms article = foldM (\acc f -> (f acc)) article
-                                                             (transforms feed)
+                    where applyTransforms :: Article -> IO (Maybe Article)
+                          applyTransforms article = foldM (\acc f -> case acc of
+                                                                        Nothing -> return Nothing
+                                                                        Just art -> f art) (Just article)
+                                                                                                (transforms feed)
 --write the resulting feed
 serialiseFeed:: T.Config -> T.Feed -> IO()
 serialiseFeed cfg feed = do

src/Transforms.hs

@@ -1,25 +1,25 @@
 module Transforms where
 
 import Text.Regex.TDFA ((=~))
---import Network.URI
---import Network.HTTP(simpleHTTP,getRequest,getResponseBody)
 import Util
 import Types
 import Control.Concurrent
 
 --fetches full length version of article and packs into body
-fetchfull::Article -> IO Article
+fetchfull::Article -> IO (Maybe Article)
 fetchfull article = do 
                         print $ "Fetching full article from " ++ itemurl article
-                        newbody <- grabUrl $ itemurl article
+                        rsp <- grabUrl $ itemurl article
                         threadDelay $ 10*1000*1000
-                        return $ updateArticle article newbody
+                        return $ case rsp of
+                            Nothing -> Nothing
+                            Just newbody -> Just $ updateArticle article newbody
 
 --new body only has content between start_re and end_re                        
-regexsnip::String -> String -> Article -> IO Article
+regexsnip::String -> String -> Article -> IO (Maybe Article)
 regexsnip start_re end_re article = do
                         let (_,_,post) = body article =~ start_re :: (String, String, String)
                         let (newbody,_,_) = post =~ end_re :: (String,String,String)
-                        return $ updateArticle article newbody
+                        return $ Just $ updateArticle article newbody
 
 

src/Types.hs

@@ -1,6 +1,5 @@
 module Types where
 
-import Network.URI
 import Data.List(intercalate)
 import Text.Feed.Types as F
 import Text.RSS.Syntax as RSS2
@@ -22,7 +21,7 @@ data Feed = Feed { name :: String
                  , items :: [Article]
                  , feedurl :: String
                  , feedRec :: F.Feed
-                 , transforms :: [Article -> IO Article]
+                 , transforms :: [Article -> IO (Maybe Article)]
                  } 
 
 data Config = Config { feeds :: [Types.Feed]

src/Util.hs

@@ -1,16 +1,22 @@
 module Util where
 
-import Network.Browser
-import Network.HTTP.Base (rspBody)
-import Network.HTTP (getRequest)
+import Network.Curl.Download
+import Data.Either
 
-grabUrl :: String -> IO String
-grabUrl url = fmap (rspBody . snd) . browse $ do
-    -- Disable logging output
-    setErrHandler $ const (return ())
-    setOutHandler $ const (return ())
-
-    setAllowRedirects True
-    request $ getRequest url
+grabUrl :: String -> IO (Maybe String)
+grabUrl url = do
+                result <- openURIString url
+                case result of
+                    Left error -> do 
+                        print $ "Error fetching " ++ url ++ " Error: " ++ error
+                        return Nothing
+                    Right body ->
+                        return $ Just body
 
-    
+--for error handling Eithers - crap haskell stdlib again?
+isLeft (Left _) = True
+isLeft _        = False
+
+--haskell doesn't have basic triple-or-above manip funcs, wtf?
+fst3::(a,b,c)->a
+fst3 (a,b,c) = a