diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,49 +0,0 @@ -This file lists the user-visible interesting changes between releases. For a -full list of changes to the source, see the ChangeLog. - - - -feed-collect 0.1.0.1 -- 2015-09-15 -================================== - -General, build and documentation changes: - -* (None) - -New APIs, features and enhancements: - -* (None) - -Bug fixes: - -* The feed XML file was being parsed in a byte-based manner, which works right - only for ASCII (or other single-byte encodings). Now the parsing involves - UTF-8 encoding. - -Dependency changes: - -* Add utf8-string (but it already was an indirect dependency before) -* Remove bytestring (but it's still an indirect dependency) - - - - - -feed-collect 0.1.0.0 -- 2015-09-11 -================================== - -General, build and documentation changes: - -* (This is the first release, so everything is new) - -New APIs, features and enhancements: - -* (This is the first release, so everything is a new feature) - -Bug fixes: - -* (This is just the first release) - -Dependency changes: - -* (This is the first release) diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,80 @@ +This file lists the user-visible interesting changes between releases. For a +full list of changes to the source, see the ChangeLog. + + + +feed-collect 0.2.0.0 -- 2015-12-16 +================================== + +General, build and documentation changes: + +* Tutorial and (hopefully) all other docs updated to reflect new API + +New APIs, features and enhancements: + +* Error logging callback now takes an additional parameter, the feed label +* Parameters for `run` are now passed through a `WatcherConfig` type +* Debug options have evolved from `Bool` into `DebugConfig` +* `feedActive` has become `setFeedActive` +* New commands for controlling debug mode while running +* Convenience functions for specifying the feed list + +Bug fixes: + +* When the 'feedActive' (now 'setFeedActive') was executed, the updated list of + feed records would contain only the updated feed, and all other feeds would + be discarded. As a result, from that point at most that one feed would be + visited. Thanks to wolftune for noticing and reporting a problem! + +Dependency changes: + +* Add data-default-class, time-interval + + + + + +feed-collect 0.1.0.1 -- 2015-09-15 +================================== + +General, build and documentation changes: + +* (None) + +New APIs, features and enhancements: + +* (None) + +Bug fixes: + +* The feed XML file was being parsed in a byte-based manner, which works right + only for ASCII (or other single-byte encodings). Now the parsing involves + UTF-8 encoding. + +Dependency changes: + +* Add utf8-string (but it already was an indirect dependency before) +* Remove bytestring (but it's still an indirect dependency) + + + + + +feed-collect 0.1.0.0 -- 2015-09-11 +================================== + +General, build and documentation changes: + +* (This is the first release, so everything is new) + +New APIs, features and enhancements: + +* (This is the first release, so everything is a new feature) + +Bug fixes: + +* (This is just the first release) + +Dependency changes: + +* (This is the first release) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,5 +10,5 @@ boring "legal" details see the file 'COPYING'. See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains -how to see the history log of the changes done in the code. 'NEWS' provides a -friendly overview of the changes for each release. +how to see the history log of the changes done in the code. 'NEWS.md' provides +a friendly overview of the changes for each release. diff --git a/feed-collect.cabal b/feed-collect.cabal --- a/feed-collect.cabal +++ b/feed-collect.cabal @@ -1,5 +1,5 @@ name: feed-collect -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Watch RSS/Atom feeds (and do with them whatever you like). description: RSS and Atom are common technologies for publishing news updates and watching @@ -26,7 +26,7 @@ copyright: ♡ Copying is an act of love. Please copy, reuse and share. category: Web build-type: Simple -extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README.md +extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS.md README.md cabal-version: >=1.10 source-repository head @@ -35,17 +35,19 @@ library exposed-modules: Web.Feed.Collect - other-modules: Control.Applicative.Util + -- other-modules: -- other-extensions: - build-depends: base >=4.7 && <5 - , feed >=0.3.9 - , http-client >=0.4.19 - , http-client-tls >=0.2.2 - , time >=1.5 - , timerep >=2 - , time-units >=1 + build-depends: base >=4.7 && <5 + , data-default-class + , feed >=0.3.9 + , http-client >=0.4.19 + , http-client-tls >=0.2.2 + , time >=1.5 + , time-interval + , timerep >=2 + , time-units >=1 , transformers - , utf8-string >=1 + , utf8-string >=1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Control/Applicative/Util.hs b/src/Control/Applicative/Util.hs deleted file mode 100644 --- a/src/Control/Applicative/Util.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- This file is part of feed-collect. - - - - Written in 2015 by fr33domlover . - - Date parser format strings written originally by koral - - for the imm package and were copied here (imm is released as WTFPL). - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -{-# Language CPP #-} - -module Control.Applicative.Util - ( applyIf - , applyIf' - ) -where - -#if MIN_VERSION_base(4,8,0) - -import Control.Applicative - --- | Conditionally apply an applicative action to a value. If the condition is --- 'False', return the value as-is (inside the applicative). -applyIf :: Applicative f => a -> Bool -> (a -> f a) -> f a -applyIf val apply action = if apply then action val else pure val - --- | Like 'applyIf', but takes a condition predicate to apply to the value. -applyIf' :: Applicative f => a -> (a -> Bool) -> (a -> f a) -> f a -applyIf' v p = applyIf v (p v) - -#else - --- | Conditionally apply an monadic action to a value. If the condition is --- 'False', return the value as-is (inside the monad). -applyIf :: Monad m => a -> Bool -> (a -> m a) -> m a -applyIf val apply action = if apply then action val else return val - --- | Like 'applyIf', but takes a condition predicate to apply to the value. -applyIf' :: Monad m => a -> (a -> Bool) -> (a -> m a) -> m a -applyIf' v p = applyIf v (p v) - -#endif diff --git a/src/Web/Feed/Collect.hs b/src/Web/Feed/Collect.hs --- a/src/Web/Feed/Collect.hs +++ b/src/Web/Feed/Collect.hs @@ -25,7 +25,7 @@ -- Both http and https URLs are supported. -- -- The original use case which motivated the creation of this library is --- . +-- . -- -- = Running -- @@ -34,6 +34,8 @@ -- -- Here is a simple usage example. -- +-- > import Data.Default.Class (def) +-- > import Data.Time.Interval -- > import Data.Time.Units -- > import Web.Feed.Collect -- > @@ -44,14 +46,20 @@ -- > putStrLn $ showFeed feed -- > putStrLn $ showItem item -- > --- > logError :: Error -> IO () --- > logError = print +-- > logError :: Label -> Error -> IO () +-- > logError l e = putStrLn $ l ++ " : " ++ show e -- > -- > feeds :: [(Label, Url)] -- > feeds = [("democ-now", "http://www.democracynow.org/democracynow.rss")] -- > -- > main :: IO () --- > main = run collect Nothing logError Nothing (1 :: Minute) 3 feeds +-- > main = run def +-- > { wcCollect = collect +-- > , wcLogError = logError +-- > , wcVisitInterval = time (1 :: Minute) +-- > , wcMaxItems = 3 +-- > , wcFeeds = fromPairs feeds +-- > } -- -- For quick testing, you can use one of the predefined collector functions. -- For example, there is 'collectorNull' which discards the feed items and does @@ -59,17 +67,17 @@ -- debugging the library itself), and 'collectorPretty' which writes a short -- nicely formatted entry to stdout for each new feed item. And there are more. -- --- If new items aren't being detected correctly, you can try using 'runDebug' --- in place of 'run'. It takes and same arguments and runs the same loop, but --- also writes a detailed log of the detection process into a file --- \"debug.log\". You can use @tail -f debug.log@ from your terminal to watch --- new log entries get appended to the file. +-- If new items aren't being detected correctly, you can enable debugging +-- through the 'wcDebug' field. You can get detailed logs of the detection +-- process. You can @tail -f@ a log file from your terminal to watch new log +-- entries get appended to it. -- -- = Using Control Commands -- --- Now let's see how to push control commands into the loop. The 4th parameter --- 'run' takes is an optional command queue. In the example above we just --- passed 'Nothing'. Now let's provide an actual queue and use it. +-- Now let's see how to push control commands into the loop. The +-- 'wcCommandQueue' field is an optional command queue for making changes +-- while the watcher runs. In the example above we didn't provide one. Now +-- let's provide a queue and use it. -- -- Suppose we are writing a program with a command-line interface. It watches -- news feeds in the background, and can take commands from the user at the @@ -83,6 +91,8 @@ -- @parseCommand@ we can write the program like this: -- -- > import Control.Concurrent (forkIO) +-- > import Data.Default.Class (def) +-- > import Data.Time.Interval -- > import Data.Time.Units -- > import System.IO -- > import Web.Feed.Collect @@ -90,11 +100,8 @@ -- > collect :: Label -> URL -> Feed -> Item -> IO () -- > collect = collectPretty -- > --- > logE :: Error -> IO () --- > logE = print --- > --- > feeds :: [(Label, Url)] --- > feeds = [("fsf-news", "https://www.fsf.org/static/fsforg/rss/news.xml")] +-- > feed :: FeedConfig +-- > feed = mkFeed "fsf-news" "https://www.fsf.org/static/fsforg/rss/news.xml" -- > -- > parseCommand :: String -> Maybe Command -- > parseCommand line = {- ... - } @@ -102,7 +109,11 @@ -- > main :: IO () -- > main = do -- > cqueue <- newCommandQueue --- > forkIO $ run collect Nothing logE (Just cqueue) (1 :: Minute) 3 feeds +-- > forkIO $ run def +-- > { wcCollect = collect +-- > , wcCommandQueue = Just cqueue +-- > , wcFeeds = [feed] +-- > } -- > let loop = do -- > line <- getLine -- > if line == "quit" @@ -114,12 +125,27 @@ -- > loop -- > loop module Web.Feed.Collect - ( -- * Types + ( -- * Misc Types Label , Url - , Command () - , CommandQueue () , Error (..) + -- * Specifying Feeds + , FeedConfig () + , fcLabel + , fcUrl + , fcActive + , fcDebug + , mkFeed + , fromPairs + -- * Watcher Configuration + , WatcherConfig () + , wcCollect + , wcCollectMany + , wcLogError + , wcCommandQueue + , wcVisitInterval + , wcMaxItems + , wcFeeds -- * Collectors , collectorNull , collectorPrint @@ -127,43 +153,51 @@ , collectorLog -- * Running , run - , runDebug - -- * Control commands + -- * Control Commands + , CommandQueue () , newCommandQueue , sendCommand , sendCommands + , Command () , addFeed , removeFeed - , feedActive + , setFeedActive , setInterval , setMaxPerVisit - -- * Utilities + -- * Utilities and Debugging , showFeed , showItem + , DebugConfig (..) + , setFeedDebug + , setGeneralDebug ) where -import Control.Applicative.Util (applyIf') -import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar -import Control.Exception (catch) -import Control.Monad (liftM, when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar +import Control.Exception (catch) +import Control.Monad (liftM, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Default.Class +import Data.List (partition) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Time.Clock (UTCTime) +import Data.Time.Format +import Data.Time.Interval +import Data.Time.LocalTime (getZonedTime, zonedTimeToUTC) +import Data.Time.RFC2822 (parseTimeRFC2822) +import Data.Time.RFC3339 (parseTimeRFC3339) +import Data.Time.RFC822 (parseTimeRFC822) +import Data.Time.Units (TimeUnit (..), Minute) +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import System.IO +import Text.Feed.Import (parseFeedString) +import Text.Feed.Query +import Text.Feed.Types (Item, Feed (..)) +import Text.Show.Functions () + import qualified Data.ByteString.Lazy.UTF8 as BU -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) -import Data.Time.Clock (UTCTime) -import Data.Time.Format -import Data.Time.LocalTime (getZonedTime, zonedTimeToUTC) -import Data.Time.RFC2822 (parseTimeRFC2822) -import Data.Time.RFC3339 (parseTimeRFC3339) -import Data.Time.RFC822 (parseTimeRFC822) -import Data.Time.Units (TimeUnit (..)) -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import System.IO -import Text.Feed.Import (parseFeedString) -import Text.Feed.Query -import Text.Feed.Types (Item, Feed (..)) -- | A short name tag for a feed, for quick reference and internal use. type Label = String @@ -175,16 +209,20 @@ -- behavior. data Command -- | Add a new feed to watch. - = AddFeed Label Url + = AddFeed FeedConfig -- | Remove a previously added feed. | RemoveFeed Label -- | Set whether a given feed should be watched (active) or not (inactive). - | FeedActive Label Bool + | SetFeedActive Label Bool -- | Set the interval, in microseconds, between feed scans. | SetInterval Int -- | Set the maximal number of feed items to be collected per feed per -- scan. If more new items are found, they wait for the next scan. | SetMaxPerVisit Int + -- | Enable or disable feed specific debug log. + | SetFeedDebug Label Bool + -- | Enable or disable general debug log. + | SetGeneralDebug Bool -- | A queue of control commands for the 'run' loop to execute while running. -- @@ -194,6 +232,112 @@ -- calls). newtype CommandQueue = CommandQueue { cqMVar :: MVar [Command] } +-- | Details of a news feed to be watched. Some of these are just initial +-- settings which you can change while the watcher runs, using the command +-- queue. +-- +-- You can use 'def' and override fields a needed. In that case you should +-- specify at least the label and URL! Alternatively, use 'mkFeed' or +-- 'fromPairs'. +data FeedConfig = FeedConfig + { -- | A short name tag by which you can refer to the feed. + fcLabel :: Label + -- | The HTTP or HTTPS URL of the feed. + , fcUrl :: Url + -- | Whether the feed should initially be active. Disabled feeds aren't + -- visited (except once to remember the old feed items). You can enable + -- and disable feeds later, while the watcher runs, using the command + -- queue. + , fcActive :: Bool + -- | Whether per-feed debug logs should be written for this feed. These + -- are detailed messages listing the results of each step of the new item + -- detection process. You can later toggle this setting per feed using + -- the command queue. + , fcDebug :: Bool + } + +instance Default FeedConfig where + def = FeedConfig + { fcLabel = "" + , fcUrl = "" + , fcActive = True + , fcDebug = False + } + +-- | Debugging options. Useful when new items aren't being detected as +-- expected. The 'Default' instance has all debugging off. These are just the +-- initial settings: you can change some of them while the feed watcher runs, +-- using the command queue. +-- +-- Since debugging is expected to be used only during development, changes to +-- the fields of this type will cause only a /micro/ version change in the +-- package version. If you think some options here are useful for more than +-- debugging, please contact the author. +data DebugConfig = DebugConfig + { -- | Whether to log a summary of the watcher cycle. The log lists for + -- each iteration which feeds are active and which aren't, whether items + -- were detected for the active feeds, and whether any command came + -- through the command queue. + dcDebugCycle :: Bool + -- | File into which to write debug messages which aren't specific to a + -- single feed. The cycle debug log (see 'dcDebugCycle') is written into + -- this file. + , dcGeneralLog :: FilePath + -- | A function used to determine the detection debug log file for a + -- given feed. + , dcFeedLog :: Label -> FilePath + } + deriving Show + +instance Default DebugConfig where + def = DebugConfig + { dcDebugCycle = False + , dcGeneralLog = "feed-debug.log" + , dcFeedLog = \ l -> "feed-debug-" ++ l ++ ".log" + } + +-- | Feed watcher behavior description. To create one, use 'def' and override +-- fields as needed. +data WatcherConfig m = WatcherConfig + { -- | Collector, i.e. action to perform when receiving a feed item. + wcCollect :: (Label -> Url -> Feed -> Item -> m ()) + -- | Action to perform when receiving feed items. This is just a chance + -- to provide an efficient shortcut instead of repeated use of + -- 'wcCollect'. If there is no such shortcut, simply pass 'Nothing'. + , wcCollectMany :: Maybe (Label -> Url -> Feed -> [Item] -> m ()) + -- | Error logging action. It will be called when an error occurs while + -- trying to download and parse a feed. Such an error doesn't cause + -- anything to stop. Execution simply goes on to read the next feed, and + -- will try the erronous feed again in the next round. + , wcLogError :: (Label -> Error -> m ()) + -- | A command queue you can use to change settings while the program + -- runs. For example, you can add a new feed or change the interval + -- between polls without relaunching 'run'. + , wcCommandQueue :: Maybe CommandQueue + -- | Time interval between visits of a watched feed. + , wcVisitInterval :: TimeInterval + -- | Maximal number of items to collect per visit (if more are available, + -- they will be collected in the next visit). + , wcMaxItems :: Int + -- | List of feeds and their configuration details. + , wcFeeds :: [FeedConfig] + -- | Debugging options. Useful when new items aren't being detected as + -- expected. + , wcDebug :: DebugConfig + } + +instance MonadIO m => Default (WatcherConfig m) where + def = WatcherConfig + { wcCollect = \ l u f i -> liftIO $ collectorPretty l u f i + , wcCollectMany = Nothing + , wcLogError = \ l e -> liftIO $ putStrLn $ l ++ " : " ++ show e + , wcCommandQueue = Nothing + , wcVisitInterval = time (1 :: Minute) + , wcMaxItems = 3 + , wcFeeds = [] + , wcDebug = def + } + -- Since no item field is guaranteed to be provided, we need some way to attach -- a practically-mostly-unique ID to each feed item, so that we can remember -- the items we already collected. Item fields we can expect to be mostly @@ -224,12 +368,15 @@ (BySummary i) == (BySummary j) = i == j _ == _ = False +-- | Information the feed watcher holds per feed while running. data FeedRecord = FeedRecord - { feedName :: String -- A short identifier for easy reference - , feedUrl :: String -- The feed's URL - , feedOn :: Bool -- Whether the feed is active - , feedPrevIDs :: [ItemID] -- Previously collected feed item IDs - , feedUpdated :: Maybe UTCTime -- Last time a feed item was published + { feedName :: String -- A short identifier for easy reference + , feedUrl :: String -- The feed's URL + , feedOn :: Bool -- Whether the feed is active + , feedPrevIDs :: [ItemID] -- Previously collected feed item IDs + , feedUpdated :: Maybe UTCTime -- Last time a feed item was published + , feedDebug :: Bool -- Whether to create detection debug logs + , feedDebugLog :: FilePath -- Debug log file name } deriving Show @@ -237,6 +384,7 @@ { usecInterval :: Int -- Microseconds between polls , maxItemsPerVisit :: Int -- Per-feed items to collect per poll , records :: [FeedRecord] -- Per-feed state + , stDebug :: Bool -- Whether to write general debug logs } deriving Show @@ -245,9 +393,17 @@ -- | Error while creating an HTTP request or receiving a response. = HttpError HttpException -- | Error while parsing the HTTP response body into feed content - | FeedParsingFailed Label Url + | FeedParsingFailed Url deriving Show +-- | Initialize feed details from a feed label and its URL. +mkFeed :: Label -> Url -> FeedConfig +mkFeed l u = def { fcLabel = l, fcUrl = u } + +-- | Create a list of feed configs from a list of label-url pairs. +fromPairs :: [(Label, Url)] -> [FeedConfig] +fromPairs = map $ uncurry mkFeed + showFeedKind :: Feed -> String showFeedKind (AtomFeed _) = "Atom" showFeedKind (RSSFeed _) = "RSS" @@ -351,6 +507,9 @@ (Just u) `newerThan` (Just v) = u > v _ `newerThan` _ = True +showTime :: FormatTime t => t -> String +showTime = formatTime defaultTimeLocale rfc822DateFormat + -- Find recent items we haven't collected yet detectNewItems :: Int -> FeedRecord -> Feed -> ([Item], FeedRecord, IO ()) detectNewItems maxItems rec feed = @@ -371,16 +530,14 @@ [] -> feedUpdated rec } report = do - let showTime :: FormatTime t => t -> String - showTime = formatTime defaultTimeLocale rfc822DateFormat - updated' = fmap showTime . feedUpdated + let updated' = fmap showTime . feedUpdated prevIDs = feedPrevIDs rec prevIDsS = take 5 prevIDs itemsS = take maxItems items iidsS = take maxItems iids prevIDsFinal = feedPrevIDs rec' prevIDsFinalS = take 5 prevIDsFinal - h <- openFile "debug.log" AppendMode + h <- openFile (feedDebugLog rec) AppendMode let line = hPutStrLn h nl = hPutChar h '\n' printIT (_, i, t) = line $ show t ++ " " ++ show i @@ -438,167 +595,194 @@ in action `catch` handler -- Try to download a feed from its URL -fetch :: Manager -> Label -> Url -> IO (Either Error Feed) -fetch manager label url = do +fetch :: Manager -> Url -> IO (Either Error Feed) +fetch manager url = do ebody <- fetchRaw manager url return $ case ebody of Left err -> Left $ HttpError err Right body -> case parseFeedString body of Just feed -> Right feed - Nothing -> Left $ FeedParsingFailed label url + Nothing -> Left $ FeedParsingFailed url -- Fill initial feed record initRec :: MonadIO m - => (Error -> m ()) + => (Label -> Error -> m ()) -> Manager - -> Label - -> Url + -> FilePath + -> FeedConfig -> m FeedRecord -initRec logError manager label url = do - efeed <- liftIO $ fetch manager label url +initRec logError manager logfile fc = do + efeed <- liftIO $ fetch manager (fcUrl fc) + let rec = FeedRecord + { feedName = fcLabel fc + , feedUrl = fcUrl fc + , feedOn = fcActive fc + , feedPrevIDs = [] + , feedUpdated = Nothing + , feedDebug = fcDebug fc + , feedDebugLog = logfile + } case efeed of Right feed -> let items = feedItems feed - in return $ FeedRecord - { feedName = label - , feedUrl = url - , feedOn = True - , feedPrevIDs = map itemID $ take maxNumIDs items - , feedUpdated = listToMaybe items >>= itemTime + in return rec + { feedPrevIDs = map itemID $ take maxNumIDs items + , feedUpdated = listToMaybe items >>= itemTime } - Left e -> do - logError e - return $ FeedRecord - { feedName = label - , feedUrl = url - , feedOn = True - , feedPrevIDs = [] - , feedUpdated = Nothing - } + Left e -> logError (fcLabel fc) e >> return rec -- Execute a control command -exec :: MonadIO m => (Error -> m ()) -> Manager -> Command -> State -> m State -exec logError manager command state@State { records = rs } = +exec :: MonadIO m + => (Label -> Error -> m ()) + -> Manager + -> (Label -> FilePath) + -> Command + -> State + -> m State +exec logError manager mklog command state@State { records = rs } = case command of - AddFeed label url -> do - rec <- initRec logError manager label url + AddFeed fc -> do + rec <- initRec logError manager (mklog $ fcLabel fc) fc return state { records = rs ++ [rec] } - RemoveFeed label -> + RemoveFeed label -> return state { records = filter ((== label) . feedName) rs } - FeedActive label active -> - let rs' = [r { feedOn = active } | r <- rs, feedName r == label] - in return state { records = rs' } - SetInterval usec -> return state { usecInterval = usec } - SetMaxPerVisit nitems -> return state { maxItemsPerVisit = nitems } + SetFeedActive label active -> + let update rec = + if feedName rec == label + then rec { feedOn = active } + else rec + in return state { records = map update rs } + SetInterval usec -> return state { usecInterval = usec } + SetMaxPerVisit nitems -> return state { maxItemsPerVisit = nitems } + SetFeedDebug label debug -> + let update rec = + if feedName rec == label + then rec { feedDebug = debug } + else rec + in return state { records = map update rs } + SetGeneralDebug debug -> return state { stDebug = debug } foldrM :: Monad m => (a -> b -> m b) -> b -> [a] -> m b foldrM _ v [] = return v foldrM f v (x:xs) = f x =<< foldrM f v xs +makeLine :: Command -> String +makeLine (AddFeed fc) = "Add feed " ++ fcLabel fc +makeLine (RemoveFeed l) = "Remove feed " ++ l +makeLine (SetFeedActive l True) = "Enable feed " ++ l +makeLine (SetFeedActive l False) = "Disable feed " ++ l +makeLine (SetInterval usec) = "Set interval to " ++ show usec ++ "usec" +makeLine (SetMaxPerVisit n) = "Set max items to " ++ show n +makeLine (SetFeedDebug l True) = "Enable debug for feed " ++ l +makeLine (SetFeedDebug l False) = "Disable debug for feed " ++ l +makeLine (SetGeneralDebug True) = "Enable general debug" +makeLine (SetGeneralDebug False) = "Disable general debug" + -- Execute all commands waiting in the queue execAll :: MonadIO m - => (Error -> m ()) + => (Label -> Error -> m ()) -> Manager + -> (Label -> FilePath) -> CommandQueue -> State - -> m State -execAll logError manager cq state = do + -> m (State, [String]) +execAll logError manager mklog cq state = do cmds <- liftIO $ modifyMVar (cqMVar cq) $ \ l -> return ([], l) - foldrM (exec logError manager) state cmds + state' <- foldrM (exec logError manager mklog) state cmds + return (state', map makeLine cmds) -run' :: (TimeUnit t, MonadIO m) - => Bool - -> (Label -> Url -> Feed -> Item -> m ()) - -> Maybe (Label -> Url -> Feed -> [Item] -> m ()) - -> (Error -> m ()) - -> Maybe CommandQueue - -> t - -> Int - -> [(Label, Url)] - -> m () -run' debug collect mCollectMany logError mq interval maxPerVisit sources = do - let collectMany - = fromMaybe (\ l u f -> mapM_ $ collect l u f) mCollectMany +-- | Visit a feed, collect new items and return an updated feed record and the +-- number of new collected items. Note that the feed's active setting is +-- ignored: It will be visited even if marked as disabled. Therefore, check the +-- setting before you call this function. +visitFeed + :: MonadIO m + => Manager + -- ^ HTTP connection manager. + -> (Label -> Url -> Feed -> [Item] -> m ()) + -- ^ Multi-item collector function. + -> (Label -> Error -> m ()) + -- ^ Error logging function. + -> Int + -- ^ Maximal number of new items to collect and remember for this visit. + -- Remaining new items will be detected in the next visit. + -> FeedRecord + -- ^ Details of the feed to visit. + -> m (FeedRecord, Int) +visitFeed manager collectMany logError maxitems rec = do + efeed <- liftIO $ fetch manager (feedUrl rec) + case efeed of + Right feed -> do + let (items, rec', report) = detectNewItems maxitems rec feed + ritems = reverse items + when (feedDebug rec) $ liftIO report + collectMany (feedName rec) (feedUrl rec) feed ritems + return (rec', length ritems) + Left e -> do + logError (feedName rec) e + return (rec, -1) + +-- | A single watcher loop iteration. +runIteration + :: MonadIO m + => (Int -> FeedRecord -> m (FeedRecord, Int)) + -> (State -> m (State, [String])) + -> FilePath + -> State + -> m State +runIteration visit execCmds logfile state = do + liftIO $ threadDelay $ usecInterval state + let (recsOn, recsOff) = partition feedOn $ records state + pairs <- mapM (visit $ maxItemsPerVisit state) recsOn + let recsOn' = map fst pairs + stateCollected = state { records = recsOn' ++ recsOff } + (stateExec, actions) <- execCmds stateCollected + liftIO $ when (stDebug state) $ withFile logfile AppendMode $ \ h -> do + let line = hPutStrLn h + fline label s = line $ label ++ ": " ++ s + nl = hPutChar h '\n' + t <- getZonedTime + line $ showTime t + line $ "Feeds: " ++ show (length $ records stateExec) + let info n + | n == 0 = "No new items" + | n == -1 = "Error" + | otherwise = show n ++ " new items" + mapM_ (\ (r, n) -> fline (feedName r) $ info n) pairs + mapM_ (\ r -> fline (feedName r) "Disabled") recsOff + line $ "Commands: " ++ show (length actions) + mapM_ line actions + nl + return stateExec + +-- | Watch feeds and perform the given action on received feed items. +run :: MonadIO m => WatcherConfig m -> m () +run wc = do + let mapCollect l u f = mapM_ $ (wcCollect wc) l u f + collectMany = fromMaybe mapCollect $ wcCollectMany wc + logError = wcLogError wc + dc = wcDebug wc + mklog = dcFeedLog dc manager <- liftIO $ newManager tlsManagerSettings - initialRecords <- - mapM (\ (label, url) -> initRec logError manager label url) sources + let mkRecord fc = initRec logError manager (mklog $ fcLabel fc) fc + initialRecords <- mapM mkRecord $ wcFeeds wc let initialState = State - { usecInterval = fromInteger $ toMicroseconds interval - , maxItemsPerVisit = maxPerVisit + { usecInterval = + fromInteger $ microseconds $ wcVisitInterval wc + , maxItemsPerVisit = wcMaxItems wc , records = initialRecords + , stDebug = dcDebugCycle dc } execCmds st = - case mq of - Just cq -> execAll logError manager cq st - Nothing -> return st - visit record = applyIf' record feedOn $ \ rec -> do - efeed <- liftIO $ fetch manager (feedName rec) (feedUrl rec) - case efeed of - Right feed -> do - let (items, rec', report) = - detectNewItems maxPerVisit rec feed - ritems = reverse items - when debug $ liftIO report - collectMany (feedName rec) (feedUrl rec) feed ritems - return rec' - Left e -> do - logError e - return rec - loop state = do - liftIO $ threadDelay $ usecInterval state - recs <- mapM visit $ records state - let stateCollected = state { records = recs } - stateExec <- execCmds stateCollected - loop stateExec + case wcCommandQueue wc of + Just cq -> execAll logError manager mklog cq st + Nothing -> return (st, []) + visit = visitFeed manager collectMany logError + iter = runIteration visit execCmds (dcGeneralLog dc) + loop state = iter state >>= loop loop initialState --- | Watch feeds and perform the given action on received feed items. -run :: (TimeUnit t, MonadIO m) - => (Label -> Url -> Feed -> Item -> m ()) - -- ^ Collector, i.e. action to perform when receiving a feed item. - -> Maybe (Label -> Url -> Feed -> [Item] -> m ()) - -- ^ Action to perform when receiving feed items. This is just a chance to - -- provide an efficient shortcut instead of repeated use of the previous - -- parameter. If there is no such shortcut, simply pass 'Nothing'. - -> (Error -> m ()) - -- ^ Error logging action. It will be called when an error occurs while - -- trying to download and parse a feed. Such an error doesn't cause - -- anything to stop. Execution simply goes on to read the next feed, and - -- will try the erronous feed again in the next round. - -> Maybe CommandQueue - -- ^ A command queue you can use to change settings while the program runs. - -- For example, you can add a new feed or change the interval between polls - -- without relaunching 'run'. - -> t - -- ^ Time interval between visits of a watched feed. - -> Int - -- ^ Maximal number of items to collect per visit (if more are available, - -- they will be collected in the next visit) - -> [(Label, Url)] - -- ^ List of short feed labels (for easy reference and logging), and their - -- URLs to watch. - -> m () -run = run' False - --- | Like 'run', but writes detailed reports into a file named \"debug.log\". --- This should help you understand which feeds items are being received and why --- new items aren't being detected in the way you expect. --- --- For some feeds, the new item detection method used by this library may fail. --- In that case, please report the issue, and then the method can be updated --- and extended to support more cases. -runDebug :: (TimeUnit t, MonadIO m) - => (Label -> Url -> Feed -> Item -> m ()) - -> Maybe (Label -> Url -> Feed -> [Item] -> m ()) - -> (Error -> m ()) - -> Maybe CommandQueue - -> t - -> Int - -> [(Label, Url)] - -> m () -runDebug = run' True - -- | Create a new empty command queue. newCommandQueue :: IO CommandQueue newCommandQueue = liftM CommandQueue $ newMVar [] @@ -613,7 +797,7 @@ modifyMVar_ (cqMVar cq) $ \ l -> return $ reverse cmds ++ l -- | Add a new feed to watch. -addFeed :: Label -> Url -> Command +addFeed :: FeedConfig -> Command addFeed = AddFeed -- | Remove a previously added feed. @@ -621,8 +805,8 @@ removeFeed = RemoveFeed -- | Set whether a given feed should be watched (active) or not (inactive). -feedActive :: Label -> Bool -> Command -feedActive = FeedActive +setFeedActive :: Label -> Bool -> Command +setFeedActive = SetFeedActive -- | Set the interval, in microseconds, between feed scans. setInterval :: TimeUnit t => t -> Command @@ -632,3 +816,11 @@ -- more new items are found, they wait for the next scan. setMaxPerVisit :: Int -> Command setMaxPerVisit = SetMaxPerVisit + +-- | Enable or disable debug logs for a given feed. +setFeedDebug :: Label -> Bool -> Command +setFeedDebug = SetFeedDebug + +-- | Enable or disable general (i.e. not feed-specific) debug logs. +setGeneralDebug :: Bool -> Command +setGeneralDebug = SetGeneralDebug