diff --git a/Network/URL/Archiver.hs b/Network/URL/Archiver.hs --- a/Network/URL/Archiver.hs +++ b/Network/URL/Archiver.hs @@ -1,12 +1,12 @@ module Network.URL.Archiver where +import Data.List (isPrefixOf) import Control.Monad (when) import Data.Maybe (fromJust) import Network.Browser (browse, formToRequest, request, Form(..)) import Network.HTTP (getRequest, rspBody, simpleHTTP, RequestMethod(POST)) import Network.URI (isURI, parseURI, uriPath) - -- | Error check the URL and then archive it using 'webciteArchive' and 'alexaArchive' checkArchive :: String -- ^ email for WebCite to send status to -> String -- ^ URL to archive @@ -16,20 +16,23 @@ {- | Request to copy a supplied URL; WebCite does on-demand archiving, unlike Alexa/Internet Archive, and so in practice this is the most useful function. This function throws away any return status from WebCite (which may be changed in the future), so it is suggested that one test with a valid email address. + This and 'alexArchive' ignore any attempt to archive the archive's existing pages, since that is useless. /Warning!/ WebCite has throttling mechanisms; if you request more than 100 URLs per hour, your IP may be banned! It is suggested that one sleep for \~30 seconds between each URL request. -} webciteArchive :: String -> String -> IO () -webciteArchive email url = openURL ("http://www.webcitation.org/archive?url=" ++ url ++ "&email=" ++ email) - >> return () +webciteArchive email url = when (not $ "http://www.webcitation.org" `isPrefixOf` url) $ + void $ openURL ("http://www.webcitation.org/archive?url=" ++ url ++ "&email=" ++ email) where openURL = simpleHTTP . getRequest + void = (>> return ()) -- TODO replace with Control.Monad.void in GHC7 -- | Request to spider a supplied URL. Alexa supplies the Internet Archive's caches. -- TODO: currently broken? Alexa changed pages? is down? alexaArchive :: String -> IO () -alexaArchive url = do let archiveform = Form POST +alexaArchive url = when (not $ "http://www.archive.org" `isPrefixOf` url) $ + do let archiveform = Form POST (fromJust $ parseURI "http://www.alexa.com/help/crawlrequest") [("url", url), ("submit", "")] - (uri, resp) <- browse $ request $ formToRequest archiveform - when (uriPath uri /= "/help/crawlthanks") $ + (uri, resp) <- browse $ request $ formToRequest archiveform + when (uriPath uri /= "/help/crawlthanks") $ print $ "Request failed! Alexa changed webpages? Response:" ++ rspBody resp diff --git a/archiver.cabal b/archiver.cabal --- a/archiver.cabal +++ b/archiver.cabal @@ -1,5 +1,5 @@ name: archiver -version: 0.3.1 +version: 0.4 license: BSD3 license-file: LICENSE @@ -11,15 +11,16 @@ description: archiver is a daemon which will process a specified text file, each line of which is a URL, and will (randomly) one by one request that the URLs be archived or spidered by and - for future reference. + for future reference. (One may optionally specify + an arbitrary `sh` command like "wget --page-requisites" to download URLs locally.) . Because the interface is a simple text file, this can be combined with other scripts; for example, a script using Sqlite to extract visited URLs from Firefox, or a program extracting URLs from Pandoc - documents. (See .) + documents. (See .) . For explanation of the derivation of the code in `Network.URL.Archiver`, - see . + see . build-type: Simple Cabal-Version: >= 1.6 @@ -37,4 +38,4 @@ Executable archiver main-is: archiver.hs - build-depends: base>=4 && < 5, containers, bytestring, random + build-depends: base>=4 && < 5, containers, bytestring, random, process diff --git a/archiver.hs b/archiver.hs --- a/archiver.hs +++ b/archiver.hs @@ -1,13 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Concurrent (threadDelay) import qualified Control.Exception as CE (catch, IOException) -import Control.Monad (liftM, when) +import Control.Monad (liftM, unless, when) import Data.List (delete) import qualified Data.Set as S (fromList, toList) import Data.Maybe (fromMaybe) import Network.HTTP (getRequest, simpleHTTP) import Network.URI (isURI) import System.Environment (getArgs) +import System.Process (runCommand) import qualified Data.ByteString.Char8 as B (count, intercalate, readFile, singleton, split, unpack, writeFile, ByteString) import System.Random @@ -16,25 +17,28 @@ main :: IO () main = do args <- getArgs case args of - (f:[]) -> archivePage Nothing f - (f:e:[]) -> archivePage (Just e) f + (f:[]) -> archivePage f Nothing Nothing + (f:e:[]) -> archivePage f (Just e) Nothing + (f:e:s:[]) -> archivePage f (Just e) (Just s) _ -> error "must supply a filename or a filename and an email address" -archivePage :: Maybe String -> FilePath -> IO () -archivePage usr file = do connectedp <- CE.catch (simpleHTTP (getRequest "http://www.webcitation.org")) (\(_::CE.IOException) -> return (Left undefined)) - case connectedp of - Left _ -> -- Left = ConnError, network not working! sleep for a minute and try again later - threadDelay 90000000 >> archivePage usr file - Right _ -> do -- we have access to the WWW, it seems. proceeding with mission! - contents <- B.readFile file - (url,rest) <- splitRandom contents - let url' = B.unpack url - when (isURI url') $ do checkArchive email url' - print url' - -- banned >=100 requests/hour; choke it - threadDelay 26000000 -- ~26 seconds - when (length rest /= 0) (writePages file url >> archivePage usr file) -- drop to get rid of leading \n - where email = fromMaybe "nobody@mailinator.com" usr +archivePage :: FilePath -> Maybe String -> Maybe String -> IO () +archivePage file email sh = do connectedp <- CE.catch (simpleHTTP (getRequest "http://www.webcitation.org")) (\(_::CE.IOException) -> return (Left undefined)) + case connectedp of + Left _ -> -- Left = ConnError, network not working! sleep for a minute and try again later + threadDelay 90000000 >> archivePage file email sh + Right _ -> do -- we have access to the WWW, it seems. proceeding with mission! + contents <- B.readFile file + (url,rest) <- splitRandom contents + let url' = B.unpack url + let email' = fromMaybe "nobody@mailinator.com" email + when (isURI url') $ do checkArchive email' url' + print url' + -- banned >=100 requests/hour; choke it + threadDelay 26000000 -- ~26 seconds + + maybe (return ()) (\x -> runCommand (x ++ " " ++ url') >> return ()) sh + unless (null rest) (writePages file url >> archivePage file email sh) -- rid of leading \n -- re-reads a possibly modified 'file' from disk, removes the archived URL from it, and writes it back out for 'archivePage' to read immediately writePages :: FilePath -> B.ByteString -> IO ()