HXT/Practical/Google1

{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} import Text.XML.HXT.Core import Text.Printf import Network.URI import Network.HTTP import Data.List import Data.Char import System.Environment import Control.Monad (forM_) -- Search Google and retrieve the results into some -- nicer data structure. This is an exercise in -- munging the HTML output of Google. -- A number of possible functions are demonstrated, -- to show some different ways of going about the task, -- only one is really needed. -- Personally, I favor the 2nd version, selectGoogleResultsToXML. -- I think this is a good demonstration of a case where the -- ordinary Haskell combinators are clearer than the special -- Arrow syntax. -------------------------------------------------- -- First example: Select pairs of (url, title) -- There isn't any help, from Google, in picking out the results, -- so I've poked around and came up with this: -- look for -- <h3> ... <a href="..." ...> -- and the results will be contained within the anchor. selectGoogleResults = atTagCase "h3" >>> atTagCase "a" >>> (getAttrValue "href" &&& -- The title may be broken up into multiple text nodes. -- So, we collect it as a list and then lift 'concat' -- to combine it. (listA (deep isText >>> getText) >>> arr concat)) -- Or, select the data into a simpler XML document selectGoogleResultsToXML = selem "results" [ atTagCase "h3" >>> atTagCase "a" >>> selem "result" [ selem "url" [getAttrValue "href" >>> mkText] , selem "title" [deep isText] ] ] -- The above function shows construction of XML, -- -- selem tag body = mkelem tag [] body -- constructs an element without attributes. -- -- Note that 'body' is a list containing XmlTree arrows, -- that is why you can mix selection and construction. -------------------------------------------------- -- Alternative versions, using the special Arrow -- syntax. selectGoogleResults' = atTagCase "h3" >>> atTagCase "a" >>> proc r -> do url <- getAttrValue "href" -< r title <- listA (getText <<< deep isText) -< r returnA -< (url, concat title) selectGoogleResultsToXML' = proc x -> do res <- listA (atTagCase "h3" >>> atTagCase "a" >>> selectResult) -< x selem "results" (map constA res) -<< () where selectResult = proc r -> do url <- getAttrValue "href" -< r title <- listA (getText <<< deep isText) -< r selem "result" [ selem "url" [txt url] , selem "title" [txt (concat title)] ] -<< () -- This last example introduces some new syntax, -- namely -<<. According to the GHC Arrow docs, -- you cannot use locally bound variables on the -- left-hand side of -<. In brief, the -<< syntax is -- a variation which permits this, while introducing -- a dependency on the ArrowApply class. -- The reason why 'selem' is on the LHS in the -- first place is because, if you check the type -- of 'selem', you will see that it is already -- in the Arrow (so to speak). Injecting it -- with 'returnA' would simply create an extra -- layer of Arrow that is not wanted. -- Since 'selem' is not processing anything, the RHS -- of -<< in this case is simply (). googleURLFormat = "http://www.google.com/search?%s" constructGoogleURL q = printf googleURLFormat $ urlEncodeVars [("q",q)] -- case-insensitive tag matching atTagCase tag = deep (isElem >>> hasNameWith ((== tag') . upper . localPart)) where tag' = upper tag upper = map toUpper parseHTML = readString [ withValidate no , withParseHTML yes , withWarnings no ] -- Pretend to be a user of Mozilla Firefox, because Google -- will not display results for unknown user agents. userAgent = "Mozilla/5.0 (en-US) Firefox/2.0.0.6667" get :: URI -> IO String get uri = do let req = Request uri GET [] "" eresp <- simpleHTTP $ insertHeader HdrUserAgent userAgent req case eresp of Left er -> error $ show er Right res -> return $ rspBody res main = do args <- getArgs case parseURI (constructGoogleURL (unwords args)) of Nothing -> putStrLn "Invalid search" Just uri -> do body <- get uri -- tuple version links <- runX (parseHTML body >>> selectGoogleResults) forM_ links $ \ (url,title) -> printf "%s <url:%s>\n" title url -- XML version [xml] <- runX (parseHTML body >>> -- At the top of a document is a hidden "root" node -- which encompasses all the top-level siblings. root [] [selectGoogleResultsToXML] >>> writeDocumentToString [withIndent yes]) putStrLn xml