diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +fr33domlover diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,17 @@ +The changes are recorded by the version control system, Darcs. To see a log +quickly from the terminal, run: + + $ darcs changes --repo http://dev.rel4tion.org/fr33domlover/feed-collect + +There is also a web interface at which, among other +things, can display the history log. + +To see the log in a local clone, first get a copy of the repository if you +haven't yet: + + $ darcs get http://dev.rel4tion.org/fr33domlover/feed-collect + +Then move into the newly created directory and run darcs: + + $ cd feed-collect + $ darcs changes diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,13 @@ +Install from Hackage: + + $ cabal install feed-collect + +Install from unpacked release tarball or source repo: + + $ cd feed-collect + $ cabal install + +Just play with it without installing: + + $ cabal build + $ cabal repl diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,23 @@ +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.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 new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +See the .cabal file for more info and link to project website the version +control. + +The official download location is Hackage: + + + +This library is free software, and is committed to software freedom. It is +released to the public domain using the CC0 Public Domain Dedication. For the +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/feed-collect.cabal b/feed-collect.cabal new file mode 100644 --- /dev/null +++ b/feed-collect.cabal @@ -0,0 +1,52 @@ +name: feed-collect +version: 0.1.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 + then on the client side. Client programs do a variety of things with them: + Display feed items for a human user to read, send them into IRC, convert them + to e-mail messages, aggregate them into larger feeds ("planet"s) and so on. + . + This package tries to provide a generic API for handling a stream of news + items, not tied to any specific use case. + . + Using the library you can launch a thread which collects news items, and + handles them using a custom action you provide. Expected usage in many cases + is to push items (or specific parts of them) into a 'Chan', and have your + application's event loop thread do the actual logic. + . + Some related packages which make specific uses of feeds are @imm@ and + @rss2irc@. These 2 packages have inspired some ideas here. +homepage: http://rel4tion.org/projects/feed-collect/ +bug-reports: http://rel4tion.org/projects/feed-collect/tickets/ +license: PublicDomain +license-file: COPYING +author: fr33domlover +maintainer: fr33domlover@riseup.net +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 +cabal-version: >=1.10 + +source-repository head + type: darcs + location: http://dev.rel4tion.org/fr33domlover/feed-collect + +library + exposed-modules: Web.Feed.Collect + other-modules: Control.Applicative.Util + -- other-extensions: + build-depends: base >=4.7 && <5 + , bytestring +-- , exceptions + , feed >=0.3.9 + , http-client >=0.4.19 + , http-client-tls >=0.2.2 + , time >=1.5 + , timerep >=2 + , time-units >=1 + , transformers + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Control/Applicative/Util.hs b/src/Control/Applicative/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Util.hs @@ -0,0 +1,50 @@ +{- 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 new file mode 100644 --- /dev/null +++ b/src/Web/Feed/Collect.hs @@ -0,0 +1,634 @@ +{- 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 + - . + -} + +-- | = Intro +-- +-- This module allows you to run a loop which visits web feeds (RSS, Atom, +-- etc.) periodically and reports new items using a function you provide. You +-- can also insert control commands into the loop, such as adding and removing +-- a feed, so that stopping and restarting it isn't required. +-- +-- Both http and https URLs are supported. +-- +-- The original use case which motivated the creation of this library is +-- . +-- +-- = Running +-- +-- The 'run' function runs the loop, and it takes a collector callback function +-- (as one of its parameters) to be called when new feed items are found. +-- +-- Here is a simple usage example. +-- +-- > import Data.Time.Units +-- > import Web.Feed.Collect +-- > +-- > collect :: Label -> URL -> Feed -> Item -> IO () +-- > collect label url feed item = do +-- > putStrLn $ label ++ " : " ++ url +-- > putStrLn "Got a new feed item!" +-- > putStrLn $ showFeed feed +-- > putStrLn $ showItem item +-- > +-- > logError :: Error -> IO () +-- > logError = print +-- > +-- > feeds :: [(Label, Url)] +-- > feeds = [("democ-now", "http://www.democracynow.org/democracynow.rss")] +-- > +-- > main :: IO () +-- > main = run collect Nothing logError Nothing (1 :: Minute) 3 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 +-- nothing (you can use it e.g. when testing success of HTTP requests or +-- 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. +-- +-- = 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. +-- +-- 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 +-- same time on the command-line. Feeds can be added, removed, etc. without +-- restarting the program. +-- +-- Assume we've written a function named @parseCommand@, which takes a line of +-- user input and returns a command ready to push into the queue. The parsed +-- commands are of type 'Command' and are created using functions like +-- 'addFeed', 'removeFeed' and so on, which this module provides. Using our +-- @parseCommand@ we can write the program like this: +-- +-- > import Control.Concurrent (forkIO) +-- > import Data.Time.Units +-- > import System.IO +-- > import Web.Feed.Collect +-- > +-- > 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")] +-- > +-- > parseCommand :: String -> Maybe Command +-- > parseCommand line = {- ... - } +-- > +-- > main :: IO () +-- > main = do +-- > cqueue <- newCommandQueue +-- > forkIO $ run collect Nothing logE (Just cqueue) (1 :: Minute) 3 feeds +-- > let loop = do +-- > line <- getLine +-- > if line == "quit" +-- > then putStrLn "Bye!" +-- > else do +-- > case parseCommand line of +-- > Just cmd -> sendCommand cqueue cmd +-- > Nothing -> putStrLn "Invalid input" +-- > loop +-- > loop +module Web.Feed.Collect + ( -- * Types + Label + , Url + , Command () + , CommandQueue () + , Error (..) + -- * Collectors + , collectorNull + , collectorPrint + , collectorPretty + , collectorLog + -- * Running + , run + , runDebug + -- * Control commands + , newCommandQueue + , sendCommand + , sendCommands + , addFeed + , removeFeed + , feedActive + , setInterval + , setMaxPerVisit + -- * Utilities + , showFeed + , showItem + ) +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 qualified Data.ByteString.Lazy.Char8 as BC +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 + +-- | An HTTP or HTTPS URL of a feed or a feed item. +type Url = String + +-- | A control command sent to the feed watching loop, and affecting its +-- behavior. +data Command + -- | Add a new feed to watch. + = AddFeed Label Url + -- | Remove a previously added feed. + | RemoveFeed Label + -- | Set whether a given feed should be watched (active) or not (inactive). + | FeedActive 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 + +-- | A queue of control commands for the 'run' loop to execute while running. +-- +-- Commands can be pushed concurrently from different threads, but there should +-- be only one 'run' invocation reading from the queue (i.e. although this is +-- unlikely anyway, don't pass the same queue to multiple concurrent 'run' +-- calls). +newtype CommandQueue = CommandQueue { cqMVar :: MVar [Command] } + +-- 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 +-- unique are: +-- +-- * ID (this is meant to serve as a unique identifier) +-- * Title (usually an item doesn't repeat a past item's title), +-- * Date (usually you don't publish 2 items in the very same microsecond) +-- * Summary (same idea as the title) +-- +-- The other fields are based on these, or are likely to be, or aren't expected +-- to be unique. +-- +-- In the (hopefully very rare) case none of these is available, just assume we +-- never saw this ID before. +-- +-- We won't be checking for cases the available fields change over time, e.g. +-- suddenly feed items get their IDs published in the XML. If the need ever +-- arises, code to handle this can be added. +data ItemID + = ByID String | ByTitle String | ByTime String | BySummary String | Unique + deriving Show + +instance Eq ItemID where + (ByID i) == (ByID j) = i == j + (ByTitle i) == (ByTitle j) = i == j + (ByTime i) == (ByTime j) = i == j + (BySummary i) == (BySummary j) = i == j + _ == _ = False + +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 + } + deriving Show + +data State = State + { usecInterval :: Int -- Microseconds between polls + , maxItemsPerVisit :: Int -- Per-feed items to collect per poll + , records :: [FeedRecord] -- Per-feed state + } + deriving Show + +-- | An error occuring while reading from a news feed. +data Error + -- | 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 + deriving Show + +showFeedKind :: Feed -> String +showFeedKind (AtomFeed _) = "Atom" +showFeedKind (RSSFeed _) = "RSS" +showFeedKind (RSS1Feed _) = "RSS1" +showFeedKind (XMLFeed _) = "XML" + +-- | A short one-line description of a feed. +showFeed :: Feed -> String +showFeed feed = unwords [kind, title, "by", author, "at", home] + where + kind = '(' : showFeedKind feed ++ ")" + title = getFeedTitle feed + author = fromMaybe none $ getFeedAuthor feed + home = fromMaybe none $ getFeedHome feed + none = "[?]" + +-- | A short one-line description of a feed item. +showItem :: Item -> String +showItem item = unwords [title, "by", author, "at", date] + where + title = fromMaybe none $ getItemTitle item + author = fromMaybe none $ getItemAuthor item + date = fromMaybe none $ getItemDate item + none = "[?]" + +-- | An item collector which discards the item, i.e. does nothing. +collectorNull :: Label -> Url -> Feed -> Item -> IO () +collectorNull _ _ _ _ = return () + +-- | An item collector which prints feed and item fields to @stdout@. +collectorPrint :: Label -> Url -> Feed -> Item -> IO () +collectorPrint _label _url feed item = print feed >> print item + +-- | An item collector which prints short friendly feed and item descriptions +-- to @stdout@. +collectorPretty :: Label -> Url -> Feed -> Item -> IO () +collectorPretty _label _url feed item = do + putStrLn $ showFeed feed + putStrLn $ showItem item + +-- | An item collector which writes friendly descriptions into a log file, +-- determining the log file's name using the function given as the first +-- argument (the feed label, i.e. second argument, is also used as the argument +-- for that function). +collectorLog :: (Label -> FilePath) -> Label -> Url -> Feed -> Item -> IO () +collectorLog getPath label url feed item = + withFile (getPath $ getFeedTitle feed) AppendMode $ \ h -> do + hPutStrLn h $ label ++ " : " ++ url + hPutStrLn h $ showFeed feed + hPutStrLn h $ showItem item + hPutChar h '\n' + +-- Maximal number of item IDs to remember +maxNumIDs :: Int +maxNumIDs = 200 + +-- Find the value in the first 'Just' available in a list of 'Maybe's +findJust :: [Maybe a] -> Maybe a +findJust = listToMaybe . catMaybes + +-- Using the available item fields, get the best hopefully-unique ID we can. +itemID :: Item -> ItemID +itemID i = fromMaybe Unique $ findJust + [ fmap (ByID . snd) $ getItemId i + , fmap ByTitle $ getItemTitle i + , fmap ByTime $ getItemDate i + , fmap BySummary $ getItemSummary i + ] + +-- Parse and get an item's date. If not available, return 'Nothing'. +-- The format examples may be partial, i.e. not demonstrate the formats fully. +-- +-- Since the availability of item date isn't guaranteed, use 2 possible +-- representations. One, use the date if available. Two, otherwise, assume a +-- timeless value which always compares in a way causing us to find new items +-- to collect. +itemTime :: Item -> Maybe UTCTime +itemTime item = + let mdate = getItemDate item + dateParsers = + -- Sun, 15 Nov 2015 02:45:26 -0200 + fmap zonedTimeToUTC . parseTimeRFC2822 : + -- 2015-11-15T02:45:26-02:00 + fmap zonedTimeToUTC . parseTimeRFC3339 : + -- 15 Nov 2015 02:45 -0200 + fmap zonedTimeToUTC . parseTimeRFC822 : + map + (parseTimeM True defaultTimeLocale) + [ "%a, %d %b %G %T" -- Sun, 15 Nov 2015 02:45:26 + , "%Y-%m-%d" -- 2015-11-15 + , "%e %b %Y" -- 15 Nov 2015 + , "%a, %e %b %Y %k:%M:%S %z" -- Sun, 15 Nov 2015 2:45:26 -0200 + , "%a, %e %b %Y %T %Z" -- Sun, 15 Nov 2015 02:45:26 -0200 + ] + results = maybe [] (\ date -> map ($ date) dateParsers) mdate + in findJust results + +-- Check whether one 'ItemTime' is more recent than another, for the purpose of +-- identifying new feed items. +newerThan :: Maybe UTCTime -> Maybe UTCTime -> Bool +(Just u) `newerThan` (Just v) = u > v +_ `newerThan` _ = True + +-- Find recent items we haven't collected yet +detectNewItems :: Int -> FeedRecord -> Feed -> ([Item], FeedRecord, IO ()) +detectNewItems maxItems rec feed = + let items = feedItems feed + ids = map itemID items + times = map itemTime items + iids = zip3 items ids times + new (_i, iid, t) = + iid `notElem` feedPrevIDs rec && t `newerThan` feedUpdated rec + iidsAllNew = filter new iids + iids' = drop (length iidsAllNew - maxItems) iidsAllNew + (items', ids', _times') = unzip3 iids' + rec' = rec + { feedPrevIDs = take maxNumIDs $ ids' ++ feedPrevIDs rec + , feedUpdated = + case iids' of + (_i, _iid, t) : _ -> t + [] -> feedUpdated rec + } + report = do + let showTime :: FormatTime t => t -> String + showTime = formatTime defaultTimeLocale rfc822DateFormat + 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 + let line = hPutStrLn h + nl = hPutChar h '\n' + printIT (_, i, t) = line $ show t ++ " " ++ show i + t <- getZonedTime + line $ replicate 79 '-' + line $ showTime t + line $ replicate 79 '-' + line $ "Label " ++ feedName rec + line $ "URL " ++ feedUrl rec + line "----------- (1) Before changes ------------" + line $ "Active " ++ show (feedOn rec) ++ " (should be True!)" + line $ "Updated " ++ fromMaybe "[?]" (updated' rec) + line $ "At most " ++ show maxItems ++ " are reported per visit" + line $ showFeed feed + line $ show (length prevIDs) ++ " previous item IDs logged" + nl + line $ "Most recent " ++ show (length prevIDsS) ++ " are:" + mapM_ (hPrint h) prevIDsS + nl + line "------------ (2) While running ------------" + line $ "Feed has " ++ show (length items) ++ " items" + nl + line $ "First " ++ show maxItems ++ " from the top are:" + mapM_ (line . showItem) itemsS + nl + line "Their computed times and IDs are:" + mapM_ printIT iidsS + nl + line "Out of all feed items, the following have newly seen IDs:" + mapM_ printIT $ filter (\ (_, i, _) -> i `notElem` prevIDs) iids + nl + line "Out of them, the following are also newer than last update:" + mapM_ printIT iidsAllNew + nl + line "--------------- (3) Result ----------------" + line "Out of them, the following have been collected:" + mapM_ printIT iids' + nl + line $ "Updated " ++ fromMaybe "[?]" (updated' rec') + line $ show (length prevIDsFinal) ++ " previous item IDs logged" + nl + line $ "Most recent " ++ show (length prevIDsFinalS) ++ " are:" + mapM_ (hPrint h) prevIDsFinalS + nl + hClose h + in (items', rec', report) + +fetchRaw :: Manager -> String -> IO (Either HttpException String) +fetchRaw manager url = + let action = do + request <- parseUrl url + response <- httpLbs request manager + return $ Right $ BC.unpack $ responseBody response + handler e = return $ Left (e :: HttpException) + 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 + 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 + +-- Fill initial feed record +initRec :: MonadIO m + => (Error -> m ()) + -> Manager + -> Label + -> Url + -> m FeedRecord +initRec logError manager label url = do + efeed <- liftIO $ fetch manager label url + 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 + } + Left e -> do + logError e + return $ FeedRecord + { feedName = label + , feedUrl = url + , feedOn = True + , feedPrevIDs = [] + , feedUpdated = Nothing + } + +-- Execute a control command +exec :: MonadIO m => (Error -> m ()) -> Manager -> Command -> State -> m State +exec logError manager command state@State { records = rs } = + case command of + AddFeed label url -> do + rec <- initRec logError manager label url + return state { records = rs ++ [rec] } + 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 } + +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 + +-- Execute all commands waiting in the queue +execAll :: MonadIO m + => (Error -> m ()) + -> Manager + -> CommandQueue + -> State + -> m State +execAll logError manager cq state = do + cmds <- liftIO $ modifyMVar (cqMVar cq) $ \ l -> return ([], l) + foldrM (exec logError manager) state 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 + manager <- liftIO $ newManager tlsManagerSettings + initialRecords <- + mapM (\ (label, url) -> initRec logError manager label url) sources + let initialState = State + { usecInterval = fromInteger $ toMicroseconds interval + , maxItemsPerVisit = maxPerVisit + , records = initialRecords + } + 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 + 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 [] + +-- | Send a command into the queue. +sendCommand :: CommandQueue -> Command -> IO () +sendCommand cq cmd = modifyMVar_ (cqMVar cq) $ \ l -> return $ cmd : l + +-- | Send a series of commands into the queue. +sendCommands :: CommandQueue -> [Command] -> IO () +sendCommands cq cmds = + modifyMVar_ (cqMVar cq) $ \ l -> return $ reverse cmds ++ l + +-- | Add a new feed to watch. +addFeed :: Label -> Url -> Command +addFeed = AddFeed + +-- | Remove a previously added feed. +removeFeed :: Label -> Command +removeFeed = RemoveFeed + +-- | Set whether a given feed should be watched (active) or not (inactive). +feedActive :: Label -> Bool -> Command +feedActive = FeedActive + +-- | Set the interval, in microseconds, between feed scans. +setInterval :: TimeUnit t => t -> Command +setInterval = SetInterval . fromInteger . toMicroseconds + +-- | 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 -> Command +setMaxPerVisit = SetMaxPerVisit