HXT/Practical/WebSpider

module Main where import Data.List import Data.Maybe import qualified Data.Set as Set import System import Network.HTTP import Network.URI import Text.XML.HXT.Core import Text.XML.HXT.Curl type MyArrow b c = IOStateArrow (Set.Set String) b c main = do [url] <- getArgs lines <- runUrl url mapM_ putStrLn lines split = arr (\x -> (x,x)) {- runUrl takes a seed URL and starts spidering from there, returning a - list of validation or other errors. -} runUrl :: String -> IO [String] runUrl url = runX (constA url >>> setTraceLevel 0 >>> withOtherUserState Set.empty (split >>> checkUrl >. unlines >>> perform (getUserState >>> Set.size ^>> (trace 0 $ arr (\x -> "Checked " ++ show x ++ " urls"))) ) ) {- checkUrl is an arrow taking as input a pair (url, base), and producing - a list of errors encountered. The url could be relative to the base. - This arrow will recursively check additional urls encountered in local - URLs. Remote URLs are only checked for status. -} checkUrl :: MyArrow (String,String) String checkUrl = clearErrStatus >>> first normalizeUrl >>> ifA (first seenUrl) (fst ^>> traceString 1 ("Skipping (seen already) " ++) >>> none) (first markSeen >>> ifP isLocalHtml validateAndSpiderUrl checkUrlStatus) {- readFromDocument uses the external curl program because of a file - descriptor leak in either Network.HTTP or HXT -} validateAndSpiderUrl :: MyArrow (String, String) String validateAndSpiderUrl = arr (\(x,y) -> (x,x)) >>> first ( traceString 0 ("Validating " ++) >>> readFromDocument [ withCurl []] >>> selectLinks >>> traceString 1 ("Found link: " ++) ) -- >>> arr (\(x,y) -> ((x,y),y)) >>> first expandURI >>> (this &&& arr snd) >>> first expandURI >>> checkUrl seenUrl :: MyArrow String String seenUrl = split >>> second getUserState >>> (uncurry Set.member) `guardsP` (arr fst) markSeen :: MyArrow String String markSeen = changeUserState Set.insert normalizeUrl = arrL (maybeToList . removeFragment) where removeFragment u = do uri <- parseURIReference u return $ show uri { uriFragment = ""} selectLinks :: ArrowXml a => a XmlTree String selectLinks = deep (isElem >>> hasName "a" >>> getAttrValue "href" >>> mkText) >>> getText {- Note that we already expanded any relative URLs -} isLocalHtml :: (String, String) -> Bool isLocalHtml (url, base) = haveSameHost url base && isHtmlUrl url where haveSameHost a b = fromMaybe False (do urlA <- parseURI a urlB <- parseURI b authA <- uriAuthority urlA authB <- uriAuthority urlB return $ uriRegName authA == uriRegName authB ) isHtmlUrl url = isSuffixOf ".html" url || isSuffixOf "/" url {- Checks the status of a url and returns an error message if anything - other than a 200 OK response results. -} checkUrlStatus :: MyArrow (String,String) String checkUrlStatus = first (traceString 0 ("Checking status of " ++) >>> arrIO (responseCode) >>> arrL (maybeToList)) >>> arr (\(u,b) -> u ++ " (linked from " ++ b ++ ")") responseCode :: String -> IO (Maybe String) responseCode url = case parseURIReference url of Nothing -> return $ Just ("Bad URL: " ++ url) Just uri -> if uriScheme uri == "http:" then catch (responseCode' uri) (\e -> return $ Just (show uri ++ ": " ++ show e)) else return $ Nothing where responseCode' uri = -- HEAD would be sufficient except that some sites -- (like Amazon) disallow it :-( do result <- simpleHTTP $ Request uri GET [] "" return $ either (Just . ((show uri ++ ": ") ++) . show) (responseMessage uri) result responseMessage uri response = case classifyResponse response of Success -> Nothing Error reason -> Just (show uri ++ ": " ++ reason) Moved loc -> Just (show uri ++ ": moved to " ++ (fromMaybe "unknown location" loc)) -- Network.HTTP v3000.0.0 forgot to expose this type type ResponseCode = (Int, Int, Int) data HttpResponseType = Success | Moved (Maybe String) -- new location | Error String -- reason classifyResponse :: Response -> HttpResponseType classifyResponse response = case rspCode response of (2,0,0) -> Success (3,0,2) -> Success -- Found (3,0,7) -> Success -- Temporary Redirect (3,0,1) -> Moved $ findHeader HdrLocation response _ -> Error $ rspReason response