diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,102 @@ +import Control.Concurrent (forkIO) +import Control.Monad (liftM, forM_) +import Data.Char (intToDigit) +import Data.List (isInfixOf, isPrefixOf, foldl', deleteBy, nubBy) +import Data.Maybe (fromJust) +import Network.HTTP hiding (port) +import Network.Stream (ConnError) +import Network.URI +import System.Environment (getArgs) + +import Text.HTML.TagSoup (parseTags, Tag(TagOpen)) + +import Text.Feed.Import (parseFeedString) +import Text.Feed.Types (Feed(RSSFeed)) +import Text.RSS.Syntax (rssChannel, rssItems, RSSItem(..)) + +main :: IO () +main = do args <- getArgs + -- Webcite requires a valid email, and they filter out public + -- emails like mailinator.com. So we demand an email from the user. + let email = head args + -- This is largely intended for the English Wikipedia, so we default to En's NewPages + -- but we let the user override; any second argument is assumed to be a MediaWiki RSS + let url = if length args > 1 then args !! 1 + else "http://en.wikipedia.org/w/index.php?title=Special:NewPages&feed=rss" + reader email url + +-- inspiried by rss2irc +-- | wait on an RSS thread, updating every so often. Each RSS item links to some diff or page, +-- in addition to whatever other content the RSS item may contain (date, summary, etc.) +-- This runs 'archiveBot' on just that link, ignoring the rest. +reader :: String -> String -> IO () +reader email url = items url >>= go + where + go old = do new <- items url + -- remove duplicates + let diff = foldl' (flip $ deleteBy matchingTitles) new old + forM_ (take 100 diff) $ \itm -> + case rssItemLink itm of + Nothing -> return () + Just t -> ignore $ forkIO $ archiveBot email t + go new + + matchingTitles :: RSSItem -> RSSItem -> Bool + matchingTitles x y = let title = (fromJust . rssItemTitle) in title x == title y + + -- Actually fetch a RSS feed and turn it from String to [RSSItem] + items :: String -> IO [RSSItem] + items rurl = do s <- get' rurl + let RSSFeed r = fromJust $ parseFeedString s + return $ nubBy matchingTitles $ rssItems $ rssChannel r + +-- | Given the URL of an article, we suck down the HTML, grep it for http:// links, +-- filter out certain links that we don't want to archive (boilerplate links, interwiki links) +-- and then fire off an archive request for each link left. +archiveBot :: String -> String -> IO () +archiveBot email ls = liftM uniq (fetchArticleURLs ls) >>= mapM_ (archiveURL email) + where uniq :: [String] -> [String] -- So hideous + uniq = filter (\x ->not $ any (flip isInfixOf x) exceptions) + exceptions :: [String] + exceptions = ["wikimediafoundation", "http://www.mediawiki.org/", "wikipedia", + "&curid=", "index.php?title=", "&action="] + +-- | Run 'extractURLs' on some page's raw HTML +fetchArticleURLs :: String -> IO [String] +fetchArticleURLs = fmap extractURLs . get' + +-- | Use the TagSoup library to extract all the hyperlinks in a page. This is really parsing the HTML, +-- so hopefully there won't be any spurious links. +extractURLs :: String -> [String] +extractURLs arg = [x | TagOpen "a" atts <- parseTags arg, (_,x) <- atts, "http://" `isPrefixOf` x] + +-- | Webcitation.org is set up so one can archive a url just by doing a request for 'webcitation.org/archive?url=url&email=email' +-- So it's very easy, given a URL and an email, to archive a page. You don't even need to see what the response was. +archiveURL :: String -> String -> IO () +archiveURL email url = print url' >> ignore (get' url') + where url' = "http://www.webcitation.org/archive?url=" ++ escapeURIString isAllowedInURI url ++ "&email=" ++ email + +-- | Convenient wrapper over the complexity of Network.HTTP. Given a URL, we get the raw HTML. No fuss, no muss. +-- Of course, this means we paper over a bunch of possible errors and issues, but we've no time for them! There are links to archive! +get' :: String -> IO String +get' = get . fromJust . parseURI + where get :: URI -> IO String + get uri = do resp <- simpleHTTP (request uri) >>= handleE (error . show) + case rspCode resp of + (2,0,0) -> return (rspBody resp) + _ -> error (httpError resp) + where + httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp + showRspCode (a,b,c) = map intToDigit [a,b,c] + + request :: URI -> Request String + request ur = Request{rqURI=ur, rqMethod=GET, rqHeaders=[], rqBody=""} + + handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a + handleE h (Left e) = h e + handleE _ (Right v) = return v + +-- | Convenience function. 'forkIO' and 'forM_' demand return types of 'IO ()', but most interesting +-- IO functions don't return void. So one adds a call to 'return ()'; this just factors it out. +ignore ::(Monad m) => m a -> m () +ignore x = x >> return () diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/wp-archivebot.cabal b/wp-archivebot.cabal new file mode 100644 --- /dev/null +++ b/wp-archivebot.cabal @@ -0,0 +1,34 @@ +name: wp-archivebot +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Gwern +maintainer: gwern0@gmail.com +stability: Experimental +tested-with: GHC==6.10.2 +category: Network +synopsis: Subscribe to a wiki's RSS feed and archive external links +description: A MediaWiki's RecentChanges or NewPages links to every new edit or article; this bot will + poll the corresponding RSS feeds (easier and more reliable than parsing the HTML), follow + the links to the new edit/article, and then use TagSoup to filter out every off-wiki link + (eg. to http://cnn.com). + . + With this list of external links, the bot will then fire off requests to http://webcitation.org/, + which will make a backup (similar to the Internet Archive, but on-demand). + . + Example: to archive links from every article in the English Wikipedia's RecentChanges: + . + > wp-archivebot gwern0@gmail.com 'http://en.wikipedia.org/w/index.php?title=Special:RecentChanges&feed=rss' + . +cabal-version: >= 1.2 +build-type: Simple + +executable wp-archivebot + main-is: Main.hs + + build-depends: feed, + tagsoup, + network, + HTTP + build-depends: base >= 3 && < 4, parallel + ghc-options: -Wall