packages feed

tagsoup 0.1 → 0.4

raw patch · 15 files changed

+1442/−559 lines, 15 filesdep +mtldep ~basesetup-changednew-component:exe:tagsoup

Dependencies added: mtl

Dependency ranges changed: base

Files

− Data/Html/Download.hs 
@@ -1,70 +0,0 @@-{-|-    Module      :  Data.Html.Download-    Copyright   :  (c) Neil Mitchell 2006-2007-    License     :  BSD-style--    Maintainer  :  http://www.cs.york.ac.uk/~ndm/-    Stability   :  unstable-    Portability :  portable--    This module simply downloads a page off the internet. It is very restricted,-    and it not intended for proper use. The primary purpose is to allow more-    interesting examples for the "Data.Html.TagSoup" module.-    -    The original version was by Alistair Bayley, with additional help from-    Daniel McAllansmith. It is taken from the Haskell-Cafe mailing list-    \"Simple HTTP lib for Windows?\", 18 Jan 2007.-    <http://thread.gmane.org/gmane.comp.lang.haskell.cafe/18443/>--}--module Data.Html.Download(openURL) where--import System.IO-import Network-import Data.List---- | This function opens a URL on the internet.---   Any @http:\/\/@ prefix is ignored.------ > openURL "www.haskell.org/haskellwiki/Haskell"------ Known Limitations:------ * Only HTTP on port 80------ * Outputs the HTTP Headers as well------ * Does not work with all servers------ It is hoped that a more reliable version of this function will be--- placed in a new HTTP library at some point!-openURL :: String -> IO String-openURL url | "http://" `isPrefixOf` url = openURL (drop 7 url)-openURL url = client server 80 (if null path then "/" else path)-    where (server,path) = break (== '/') url---client :: [Char] -> PortNumber -> [Char] -> IO String-client server port page = withSocketsDo $ do-    hndl <- connectTo server (PortNumber port)-    let out x = hPutStrLn hndl (x ++ "\r")-    hSetBuffering hndl NoBuffering--    out $ "GET " ++ page ++ " HTTP/1.1"-    out $ "Host: " ++ server ++ ""-    out $ "Connection: close"-    out ""-    out ""-    readResponse hndl---readResponse :: Handle -> IO String-readResponse hndl = do-    closed <- hIsClosed hndl-    eof <- hIsEOF hndl-    if closed || eof-        then return []-        else do-            c <- hGetChar hndl-            cs <- readResponse hndl-            return (c:cs)
− Data/Html/TagSoup.hs 
@@ -1,184 +0,0 @@-{-|-    Module      :  Data.Html.TagSoup-    Copyright   :  (c) Neil Mitchell 2006-2007-    License     :  BSD-style--    Maintainer  :  http://www.cs.york.ac.uk/~ndm/-    Stability   :  moving towards stable-    Portability :  portable--    This module is for extracting information out of unstructured HTML code,-    sometimes known as tag-soup. This is for situations where the author of-    the HTML is not cooperating with the person trying to extract the information,-    but is also not trying to hide the information.-    -    The standard practice is to parse a String to 'Tag's using 'parseTags', then-    operate upon it to extract the necessary information.--}---module Data.Html.TagSoup(-    -- * Data structures and parsing-    Tag(..), Attribute, parseTags,-    module Data.Html.Download,-    -    -- * Tag Combinators-    (~==), (~/=),-    isTagOpen, isTagClose, isTagText,-    fromTagText, fromAttrib,-    isTagOpenName, isTagCloseName,-    sections, partitions-    ) where--import Data.Char-import Data.List-import Data.Maybe-import Data.Html.Download----- | An HTML attribute @id=\"name\"@ generates @(\"id\",\"name\")@-type Attribute = (String,String)---- | An HTML element, a document is @[Tag]@.---   There is no requirement for 'TagOpen' and 'TagClose' to match-data Tag = TagOpen String [Attribute]  -- ^ An open tag with 'Attribute's in their original order.-         | TagClose String             -- ^ A closing tag-         | TagText String              -- ^ A text node, guranteed not to be the empty string-           deriving (Show, Eq, Ord)----- | Parse an HTML document to a list of 'Tag'.--- Automatically expands out escape characters.-parseTags :: String -> [Tag]-parseTags [] = []--parseTags ('<':'/':xs) = TagClose tag : parseTags trail-    where-        (tag,rest) = span isAlphaNum xs-        trail = drop 1 $ dropWhile (/= '>') rest--parseTags ('<':xs)-        | "/>" `isPrefixOf` rest2 = res : TagClose tag : parseTags (drop 2 rest2)-        | ">" `isPrefixOf` rest2 = res : parseTags (drop 1 rest2)-        | otherwise = res : parseTags (drop 1 $ dropWhile (/= '>') rest2)-    where-        res = TagOpen tag attrs-        (tag,rest) = span isAlphaNum xs-        (attrs,rest2) = parseAttributes rest--parseTags (x:xs) = [TagText $ parseString pre | not $ null pre] ++ parseTags post-    where (pre,post) = break (== '<') (x:xs)---parseAttributes :: String -> ([Attribute], String)-parseAttributes (x:xs) | isSpace x = parseAttributes xs-                       | not $ isAlpha x = ([], x:xs)-                       | otherwise = ((parseString lhs, parseString rhs):attrs, over)-    where-        (attrs,over) = parseAttributes (dropWhile isSpace other)-    -        (lhs,rest) = span isAlphaNum (x:xs)-        rest2 = dropWhile isSpace rest-        (rhs,other) = if "=" `isPrefixOf` rest2 then parseValue (dropWhile isSpace $ tail rest2) else ("", rest2)-        --parseValue :: String -> (String, String)-parseValue ('\"':xs) = (a, drop 1 b)-    where (a,b) = break (== '\"') xs-parseValue x = span isValid x-    where isValid x = isAlphaNum x || x `elem` "_-"----escapes = [("gt",">")-          ,("lt","<")-          ,("amp","&")-          ,("quot","\"")-          ]---parseEscape :: String -> Maybe String-parseEscape ('#':xs) | all isDigit xs = Just [chr $ read xs]-parseEscape xs = lookup xs escapes----parseString :: String -> String-parseString ('&':xs) = case parseEscape a of-                            Nothing -> '&' : parseString xs-                            Just x -> x ++ parseString (drop 1 b)-    where (a,b) = break (== ';') xs-parseString (x:xs) = x : parseString xs-parseString [] = []----- | Test if a 'Tag' is a 'TagOpen'-isTagOpen :: Tag -> Bool-isTagOpen (TagOpen {})  = True; isTagOpen  _ = False---- | Test if a 'Tag' is a 'TagClose'-isTagClose :: Tag -> Bool-isTagClose (TagClose {}) = True; isTagClose _ = False---- | Test if a 'Tag' is a 'TagText'-isTagText :: Tag -> Bool-isTagText (TagText {})  = True; isTagText  _ = False---- | Extract the string from within 'TagText', crashes if not a 'TagText'-fromTagText :: Tag -> String-fromTagText (TagText x) = x---- | Extract an attribute, crashes if not a 'TagOpen'.---   Returns "" if no attribute present.-fromAttrib :: String -> Tag -> String-fromAttrib att (TagOpen _ atts) = fromMaybe "" $ lookup att atts---- | Returns True if the 'Tag' is 'TagOpen' and matches the given name-isTagOpenName :: String -> Tag -> Bool-isTagOpenName name (TagOpen n _) = n == name-isTagOpenName _ _ = False---- | Returns True if the 'Tag' is 'TagClose' and matches the given name-isTagCloseName :: String -> Tag -> Bool-isTagCloseName name (TagClose n) = n == name-isTagCloseName _ _ = False----- | Performs an inexact match, the first item should be the thing to match.--- If the second item is a blank string, that is considered to match anything.--- For example:------ > (TagText "test" ~== TagText ""    ) == True--- > (TagText "test" ~== TagText "test") == True--- > (TagText "test" ~== TagText "soup") == False------ For 'TagOpen' missing attributes on the right are allowed.-(~==) :: Tag -> Tag -> Bool-(TagText y) ~== (TagText x) = null x || x == y-(TagClose y) ~== (TagClose x) = null x || x == y-(TagOpen y ys) ~== (TagOpen x xs) = (null x || x == y) && all f xs-    where-        f ("",val) = val `elem` map snd ys-        f (name,"") = name `elem` map fst ys-        f nameval = nameval `elem` ys-_ ~== _ = False---- | Negation of '~=='-(~/=) :: Tag -> Tag -> Bool-(~/=) a b = not (a ~== b)----- | This function takes a list, and returns all initial lists whose---   first item matches the function.-sections :: (a -> Bool) -> [a] -> [[a]]-sections f [] = []-sections f (x:xs) = [x:xs | f x] ++ sections f xs---- | This function is similar to 'sections', but splits the list---   so no element appears in any two partitions-partitions :: (a -> Bool) -> [a] -> [[a]]-partitions f xs = g $ dropWhile (not . f) xs-    where-        g [] = []-        g (x:xs) = (x:a) : g b-            where (a,b) = break f xs
Example/Example.hs view
@@ -1,12 +1,33 @@  module Example.Example where -import Data.Html.TagSoup+import Text.HTML.TagSoup+import Text.HTML.Download+ import Control.Monad import Data.List import Data.Char  +grab :: String -> IO ()+grab x = openItem x >>= putStr++parse :: String -> IO ()+parse x = openItem x >>= putStr . show2 . parseTags+    where+        show2 [] = "[]"+        show2 xs = "[" ++ concat (intersperseNotBroken "\n," $ map show xs) ++ "\n]"+++-- the standard intersperse has a strictness bug which sucks!+intersperseNotBroken :: a -> [a] -> [a]+intersperseNotBroken _ [] = []+intersperseNotBroken sep (x:xs) = x : is xs+    where+        is [] = []+        is (y:ys) = sep : y : is ys++ {- <div class="printfooter"> <p>Retrieved from "<a href="http://haskell.org/haskellwiki/Haskell">http://haskell.org/haskellwiki/Haskell</a>"</p>@@ -17,7 +38,7 @@ haskellHitCount :: IO () haskellHitCount = do         tags <- liftM parseTags $ openURL "http://haskell.org/haskellwiki/Haskell"-        let count = fromFooter $ head $ sections (~== TagOpen "div" [("class","printfooter")]) tags+        let count = fromFooter $ head $ sections (~== "<div class=printfooter>") tags         putStrLn $ "haskell.org has been hit " ++ show count ++ " times"     where         fromFooter x = read (filter isDigit num) :: Int@@ -25,7 +46,7 @@                 num = ss !! (i - 1)                 Just i = findIndex (== "times.") ss                 ss = words s-                TagText s = sections (isTagOpenName "p") x !! 1 !! 1+                TagText s = sections (~== "<p>") x !! 1 !! 1   {-@@ -35,29 +56,23 @@ googleTechNews :: IO () googleTechNews = do         tags <- liftM parseTags $ openURL "http://news.google.com/?ned=us&topic=t"-        let links = map extract $ sections match tags+        let links = [ x+                    | TagOpen "a" atts:_:TagText x:_ <- tails tags+                    , ("id",'r':val) <- atts, 'i' `notElem` val]         putStr $ unlines links-    where-        extract xs = fromTagText (xs !! 2)-        -        match (TagOpen "a" y)-            = case lookup "id" y of-                   Just z -> "r" `isPrefixOf` z && 'i' `notElem` z-                   _ -> False-        match _ = False   spjPapers :: IO () spjPapers = do         tags <- liftM parseTags $ openURL "http://research.microsoft.com/~simonpj/"-        let links = map f $ sections (isTagOpenName "a") $-                    takeWhile (~/= TagOpen "a" [("name","haskell")]) $-                    drop 5 $ dropWhile (~/= TagOpen "a" [("name","current")]) tags+        let links = map f $ sections (~== "<a>") $+                    takeWhile (~/= "<a name=haskell>") $+                    drop 5 $ dropWhile (~/= "<a name=current>") tags         putStr $ unlines links     where         f :: [Tag] -> String         f = dequote . unwords . words . fromTagText . head . filter isTagText-        +         dequote ('\"':xs) | last xs == '\"' = init xs         dequote x = x @@ -65,15 +80,65 @@ ndmPapers :: IO () ndmPapers = do         tags <- liftM parseTags $ openURL "http://www-users.cs.york.ac.uk/~ndm/downloads/"-        let papers = map f $ sections (~== TagOpen "li" [("class","paper")]) tags+        let papers = map f $ sections (~== "<li class=paper>") tags         putStr $ unlines papers     where         f :: [Tag] -> String         f xs = fromTagText (xs !! 2)-     + currentTime :: IO () currentTime = do         tags <- liftM parseTags $ openURL "http://www.timeanddate.com/worldclock/city.html?n=136"-        let time = fromTagText (dropWhile (~/= TagOpen "strong" [("id","ct")]) tags !! 1)+        let time = fromTagText (dropWhile (~/= "<strong id=ct>") tags !! 1)         putStrLn time++++type Section = String+data Package = Package {name :: String, desc :: String, href :: String}+               deriving Show++hackage :: IO [(Section,[Package])]+hackage = do+    tags <- liftM parseTags $ openURL "http://hackage.haskell.org/packages/archive/pkg-list.html"+    return $ map parseSect $ partitions (~== "<h3>") tags+    where+        parseSect xs = (nam, packs)+            where+                nam = fromTagText $ xs !! 2+                packs = map parsePackage $ partitions (~== "<li>") xs++        parsePackage xs =+           Package+              (fromTagText $ xs !! 2)+              (drop 2 $ dropWhile (/= ':') $ fromTagText $ xs !! 4)+              (fromAttrib "href" $ xs !! 1)++-- rssCreators Example: prints names of story contributors on+-- sequence.complete.org. This content is RSS (not HTML), and the selected+-- tag uses a different XML namespace "dc:creator".+rssCreators :: IO ()+rssCreators = do+    tags <- liftM parseTags $ openURL "http://sequence.complete.org/node/feed"+    putStrLn $ unlines $ map names $ partitions (~== "<dc:creator>") tags+    where+      names xs = fromTagText $ xs !! 1+++validate :: String -> IO ()+validate x = putStr . unlines . g . f . parseTagsOptions opts =<< openItem x+    where+        opts = options{optTagPosition=True, optTagWarning=True}++        f :: [Tag] -> [String]+        f (TagPosition row col:TagWarning warn:rest) =+            ("Warning (" ++ show row ++ "," ++ show col ++ "): " ++ warn) : f rest+        f (TagWarning warn:rest) =+            ("Warning (?,?): " ++ warn) : f rest+        f (_:rest) = f rest+        f [] = []++        g xs = xs ++ [if n == 0 then "Success, no warnings"+                      else "Failed, " ++ show n ++ " warning" ++ ['s'|n>1]]+            where n = length xs
+ Example/Regress.hs view
@@ -0,0 +1,143 @@++module Example.Regress (regress) where++import Text.HTML.TagSoup+import Text.HTML.TagSoup.Entity+import qualified Text.HTML.TagSoup.Match as Match+import Control.Exception++-- * The Test Monad++data Test a = Pass+instance Monad Test where+    a >> b = a `seq` b+    return = error "No return for Monad Test"+    (>>=) = error "No bind (>>=) for Monad Test"+instance Show (Test a) where+    show x = x `seq` "All tests passed"++pass :: Test ()+pass = Pass++(===) :: (Show a, Eq a) => a -> a -> Test ()+a === b = if a == b then pass else fail $ "Does not equal: " ++ show a ++ " =/= " ++ show b++-- * The Main section++regress :: IO ()+regress = print $ do+    parseTests+    combiTests+    entityTests+    lazyTags == lazyTags `seq` pass+    matchCombinators+++{- |+This routine tests the laziness of the TagSoup parser.+For each critical part of the parser we provide a test input+with a token of infinite size.+Then the output must be infinite too.+If the laziness is broken, then the output will stop early.+We collect the thousandth character of the output of each test case.+If computation of the list stops somewhere,+you have found a laziness stopper.+-}+++lazyTags :: [Char]+lazyTags =+   map ((!!1000) . show . parseTags) $+      (cycle "Rhabarber") :+      (repeat '&') :+      ("<"++cycle "html") :+      ("<html "++cycle "na!me=value ") :+      ("<html name="++cycle "value") :+      ("<html name=\""++cycle "value") :+      ("<html name="++cycle "val!ue") :+      ("<html "++cycle "name") :+      ("</"++cycle "html") :+      ("<!-- "++cycle "comment") :+      ("<!"++cycle "doctype") :+      ("<!DOCTYPE"++cycle " description") :+      (cycle "1<2 ") :+      +      -- need further analysis+      ("<html name="++cycle "val&ue") :+      ("<html name="++cycle "va&l!ue") :+      ("&" ++ cycle "t") :+      (cycle "&amp; test") :++      -- i don't see how this can work unless the junk gets into the AST?+      --("</html "++cycle "junk") :++      []++++matchCombinators :: Test ()+matchCombinators = assert (and tests) pass+    where+        tests =+            Match.tagText (const True) (TagText "test") :+            Match.tagText ("test"==) (TagText "test") :+            Match.tagText ("soup"/=) (TagText "test") :+            Match.tagOpenNameLit "table"+               (TagOpen "table" [("id", "name")]) :+            Match.tagOpenLit "table" (Match.anyAttrLit ("id", "name"))+               (TagOpen "table" [("id", "name")]) :+            Match.tagOpenLit "table" (Match.anyAttrNameLit "id")+               (TagOpen "table" [("id", "name")]) :+            not (Match.tagOpenLit "table" (Match.anyAttrLit ("id", "name"))+                  (TagOpen "table" [("id", "other name")])) :+            []+++parseTests :: Test ()+parseTests = do+    parseTags "<!DOCTYPE TEST>" === [TagOpen "!DOCTYPE" [("TEST","")]]+    parseTags "<test \"foo bar\">" === [TagOpen "test" [("","foo bar")]]+    parseTags "<test \'foo bar\'>" === [TagOpen "test" [("","foo bar")]]+    parseTags "<:test \'foo bar\'>" === [TagOpen ":test" [("","foo bar")]]+    parseTags "hello &amp; world" === [TagText "hello & world"]+    parseTags "hello &#64; world" === [TagText "hello @ world"]+    parseTags "hello &#x40; world" === [TagText "hello @ world"]+    parseTags "hello &haskell; world" === [TagText "hello &haskell; world"]+    parseTags "hello \n\t world" === [TagText "hello \n\t world"]++    parseTags "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" ===+        [TagOpen "!DOCTYPE" [("HTML",""),("PUBLIC",""),("","-//W3C//DTD HTML 4.01//EN"),("","http://www.w3.org/TR/html4/strict.dtd")]]+    parseTags "<script src=\"http://edge.jobthread.com/feeds/jobroll/?s_user_id=100540&subtype=slashdot\">" ===+        [TagOpen "script" [("src","http://edge.jobthread.com/feeds/jobroll/?s_user_id=100540&subtype=slashdot")]]++    parseTags "<a title='foo'bar' href=correct>text" === [TagOpen "a" [("title", "foo"),+                                                                       ("bar",   ""),+                                                                       ("href", "correct")],+                                                         TagText "text"]+++entityTests :: Test ()+entityTests = do+    lookupNumericEntity "65" === Just 'A'+    lookupNumericEntity "x41" === Just 'A'+    lookupNumericEntity "x4E" === Just 'N'+    lookupNumericEntity "x4e" === Just 'N'+    lookupNumericEntity "Haskell" === Nothing+    lookupNumericEntity "" === Nothing+    lookupNumericEntity "89439085908539082" === Nothing+    lookupNamedEntity "amp" === Just '&'+    lookupNamedEntity "haskell" === Nothing+    escapeXMLChar 'a' === Nothing+    escapeXMLChar '&' === Just "amp"+++combiTests :: Test ()+combiTests = do+    (TagText "test" ~== TagText ""    ) === True+    (TagText "test" ~== TagText "test") === True+    (TagText "test" ~== TagText "soup") === False+    (TagText "test" ~== "test") === True+    (TagOpen "test" [] ~== "<test>") === True+    (TagOpen "test" [] ~== "<soup>") === False+    (TagOpen "test" [] ~/= "<soup>") === True+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2007.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ Main.hs view
@@ -0,0 +1,56 @@++module Main(main) where++import System.Environment+import Example.Example+import Example.Regress+import Data.Char(toLower)+++helpMsg :: IO ()+helpMsg = putStr $ unlines $+    ["TagSoup, (C) Neil Mitchell 2006-2008"+    ,""+    ,"  tagsoup arguments"+    ,""+    ,"<url> may either be a local file, or a http:// page"+    ,""+    ] ++ map f res+    where+        width = maximum $ map (length . fst) res+        res = map g actions++        g (nam,msg,Left  _) = (nam,msg)+        g (nam,msg,Right _) = (nam ++ " <url>",msg)++        f (lhs,rhs) = "  " ++ lhs ++ replicate (4 + width - length lhs) ' ' ++ rhs+            ++actions :: [(String, String, Either (IO ()) (String -> IO ()))]+actions = [("regress","Run the regression tests",Left regress)+          ,("grab","Grab a web page",Right grab)+          ,("parse","Parse a web page",Right parse)+          ,("validate","Validate a page",Right validate)+          ,("hitcount","Get the Haskell.org hit count",Left haskellHitCount)+          ,("spj","Simon Peyton Jones' papers",Left spjPapers)+          ,("ndm","Neil Mitchell's papers",Left ndmPapers)+          ,("time","Current time",Left currentTime)+          ,("google","Google Tech News",Left googleTechNews)+          ,("sequence","Creators on sequence.complete.org",Left rssCreators)+          ,("help","This help message",Left helpMsg)+          ]++main :: IO ()+main = do+    args <- getArgs+    case (args, lookup (map toLower $ head args) $ map (\(a,_,c) -> (a,c)) actions) of+        ([],_) -> helpMsg+        (x:_,Nothing) -> putStrLn ("Error: unknown command " ++ x) >> helpMsg+        ([_],Just (Left a)) -> a+        (x:xs,Just (Left a)) -> do+            putStrLn $ "Warning: expected no arguments to " ++ x ++ " but got: " ++ unwords xs+            a+        ([_,y],Just (Right a)) -> a y+        (x:xs,Just (Right _)) -> do+            putStrLn $ "Error: expected exactly one argument to " ++ x ++ " but got: " ++ unwords xs+            helpMsg
Setup.hs view
@@ -1,2 +1,3 @@+#!/usr/bin/runhaskell import Distribution.Simple main = defaultMain
+ Text/HTML/Download.hs view
@@ -0,0 +1,77 @@+{-|+    Module      :  Text.HTML.Download+    Copyright   :  (c) Neil Mitchell 2006-2007+    License     :  BSD-style++    Maintainer  :  http://www.cs.york.ac.uk/~ndm/+    Stability   :  unstable+    Portability :  portable++    This module simply downloads a page off the internet. It is very restricted,+    and it not intended for proper use. The primary purpose is to allow more+    interesting examples for the "Data.Html.TagSoup" module.+    +    The original version was by Alistair Bayley, with additional help from+    Daniel McAllansmith. It is taken from the Haskell-Cafe mailing list+    \"Simple HTTP lib for Windows?\", 18 Jan 2007.+    <http://thread.gmane.org/gmane.comp.lang.haskell.cafe/18443/>+-}++module Text.HTML.Download(openURL, openItem) where++import System.IO+import System.IO.Unsafe+import Network+import Data.List++-- | This function opens a URL on the internet.+--   Any @http:\/\/@ prefix is ignored.+--+-- > openURL "www.haskell.org/haskellwiki/Haskell"+--+-- Known Limitations:+--+-- * Only HTTP on port 80+--+-- * Outputs the HTTP Headers as well+--+-- * Does not work with all servers+--+-- It is hoped that a more reliable version of this function will be+-- placed in a new HTTP library at some point!+openURL :: String -> IO String+openURL url | "http://" `isPrefixOf` url = openURL (drop 7 url)+openURL url = client server 80 (if null path then "/" else path)+    where (server,path) = break (== '/') url+++client :: [Char] -> PortNumber -> [Char] -> IO String+client server port page = withSocketsDo $ do+    hndl <- connectTo server (PortNumber port)+    let out x = hPutStrLn hndl (x ++ "\r")+    hSetBuffering hndl NoBuffering++    out $ "GET " ++ page ++ " HTTP/1.1"+    out $ "Host: " ++ server ++ ""+    out $ "Connection: close"+    out ""+    out ""+    readResponse hndl+++readResponse :: Handle -> IO String+readResponse hndl = do+    closed <- hIsClosed hndl+    eof <- hIsEOF hndl+    if closed || eof+        then return []+        else do+            c <- hGetChar hndl+            cs <- unsafeInterleaveIO $ readResponse hndl+            return (c:cs)+++-- | Open a URL (if it starts with @http:\/\/@) or a file otherwise+openItem :: String -> IO String+openItem x | "http://" `isPrefixOf` x = openURL x+           | otherwise = readFile x
+ Text/HTML/TagSoup.hs view
@@ -0,0 +1,115 @@+{-|+    Module      :  Text.HTML.TagSoup+    Copyright   :  (c) Neil Mitchell 2006-2007+    License     :  BSD-style++    Maintainer  :  http://www.cs.york.ac.uk/~ndm/+    Stability   :  unstable+    Portability :  portable++    This module is for extracting information out of unstructured HTML code,+    sometimes known as tag-soup. This is for situations where the author of+    the HTML is not cooperating with the person trying to extract the information,+    but is also not trying to hide the information.++    The standard practice is to parse a String to 'Tag's using 'parseTags',+    then operate upon it to extract the necessary information.+-}++module Text.HTML.TagSoup(+    -- * Data structures and parsing+    Tag(..), Attribute,+    Options(..), options,+    parseTags, parseTagsOptions,+    canonicalizeTags,++    -- * Tag identification+    isTagOpen, isTagClose, isTagText, isTagWarning,+    isTagOpenName, isTagCloseName,++    -- * Extraction+    fromTagText, fromAttrib,+    maybeTagText, maybeTagWarning,+    innerText,++    -- * Utility+    sections, partitions,+    +    -- * Combinators+    TagRep, IsChar, (~==),(~/=)+    ) where++import Text.HTML.TagSoup.Parser+import Text.HTML.TagSoup.Type+import Data.Char+import Data.List+++{- |+Turns all tag names to lower case and+converts DOCTYPE to upper case.+-}+canonicalizeTags :: [Tag] -> [Tag]+canonicalizeTags = map f+    where+        f (TagOpen name attrs) | "!" `isPrefixOf` name = TagOpen (map toUpper name) attrs+        f (TagOpen name attrs) | otherwise             = TagOpen (map toLower name) attrs+        f (TagClose name) = TagClose (map toLower name)+        f a = a+++-- | Define a class to allow String's or Tag's to be used as matches+class TagRep a where+    toTagRep :: a -> Tag++instance TagRep Tag where toTagRep = id++class    IsChar a    where toChar :: a -> Char+instance IsChar Char where toChar =  id++instance IsChar c => TagRep [c] where+    toTagRep x = case parseTags s of+                     [a] -> a+                     _ -> error $ "When using a TagRep it must be exactly one tag, you gave: " ++ s+        where s = map toChar x++++-- | Performs an inexact match, the first item should be the thing to match.+-- If the second item is a blank string, that is considered to match anything.+-- For example:+--+-- > (TagText "test" ~== TagText ""    ) == True+-- > (TagText "test" ~== TagText "test") == True+-- > (TagText "test" ~== TagText "soup") == False+--+-- For 'TagOpen' missing attributes on the right are allowed.+(~==) :: TagRep t => Tag -> t -> Bool+(~==) a b = f a (toTagRep b)+    where+        f (TagText y) (TagText x) = null x || x == y+        f (TagClose y) (TagClose x) = null x || x == y+        f (TagOpen y ys) (TagOpen x xs) = (null x || x == y) && all g xs+            where+                g (name,val) | null name = val  `elem` map snd ys+                             | null val  = name `elem` map fst ys+                g nameval = nameval `elem` ys+        f _ _ = False++-- | Negation of '~=='+(~/=) :: TagRep t => Tag -> t -> Bool+(~/=) a b = not (a ~== b)++++-- | This function takes a list, and returns all suffixes whose+--   first item matches the predicate.+sections :: (a -> Bool) -> [a] -> [[a]]+sections p = filter (p . head) . init . tails++-- | This function is similar to 'sections', but splits the list+--   so no element appears in any two partitions.+partitions :: (a -> Bool) -> [a] -> [[a]]+partitions p =+   let notp = not . p+   in  groupBy (const notp) . dropWhile notp
+ Text/HTML/TagSoup/Entity.hs view
@@ -0,0 +1,337 @@+-- this should be in Text.HTML but then we provoke name clashes+module Text.HTML.TagSoup.Entity(+    lookupEntity, lookupNamedEntity, lookupNumericEntity,+    escapeXMLChar,+    xmlEntities, htmlEntities+    ) where++import Data.Char+import Data.Ix+import Control.Monad+import Numeric+++-- | Lookup an entity, using 'lookupNumericEntity' if it starts with+--   @#@ and 'lookupNamedEntity' otherwise+lookupEntity :: String -> Maybe Char+lookupEntity ('#':xs) = lookupNumericEntity xs+lookupEntity xs = lookupNamedEntity xs++-- | Lookup a numeric entity, the leading @\'#\'@ must have already been removed.+--+-- > lookupNumericEntity "65" == Just 'A'+-- > lookupNumericEntity "x41" == Just 'A'+-- > lookupNumericEntity "x4E" === Just 'N'+-- > lookupNumericEntity "x4e" === Just 'N'+-- > lookupNumericEntity "Haskell" == Nothing+-- > lookupNumericEntity "" == Nothing+-- > lookupNumericEntity "89439085908539082" == Nothing+lookupNumericEntity :: String -> Maybe Char+lookupNumericEntity = f+        -- entity = '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'+    where+        f ('x':xs) = g [('0','9'),('a','f'),('A','F')] readHex xs+        f xs = g [('0','9')] reads xs++        g :: [(Char,Char)] -> ReadS Integer -> String -> Maybe Char+        g valid reader xs = do+            let test b = if b then Just () else Nothing+            test $ isValid valid xs+            test $ not $ null xs+            case reader xs of+                [(a,"")] -> do+                    test $ inRange (toInteger $ ord minBound, toInteger $ ord maxBound) a+                    return $ chr $ fromInteger a+                _ -> Nothing++        isValid :: [(Char,Char)] -> String -> Bool+        isValid valid xs = all (\x -> any (`inRange` x) valid) xs+++-- | Lookup a named entity, using 'htmlEntities'+--+-- > lookupNamedEntity "amp" == Just '&'+-- > lookupNamedEntity "haskell" == Nothing+lookupNamedEntity :: String -> Maybe Char+lookupNamedEntity x = liftM chr $ lookup x htmlEntities+++-- | Escape a character before writing it out to XML.+--+-- > escapeXMLChar 'a' == Nothing+-- > escapeXMLChar '&' == Just "amp"+escapeXMLChar :: Char -> Maybe String+escapeXMLChar x = case [a | (a,b) <- xmlEntities, b == ord x] of+                       (y:_) -> Just y+                       _ -> Nothing+++-- | A table mapping XML entity names to code points.+--   Does /not/ include @apos@ as Internet Explorer does not know about it.+xmlEntities :: [(String, Int)]+xmlEntities =+   ("quot",     ord '"') :+   ("amp",      ord '&') :+--   ("apos",   ord '\'') :   Internet Explorer does not know that+   ("lt",       ord '<') :+   ("gt",       ord '>') :+   []++-- | A table mapping HTML entity names to code points+htmlEntities :: [(String, Int)]+htmlEntities =+   xmlEntities +++   ("apos",   ord '\'') : -- quirky IE!!!++   ("nbsp",     160) :+   ("iexcl",    161) :+   ("cent",     162) :+   ("pound",    163) :+   ("curren",   164) :+   ("yen",      165) :+   ("brvbar",   166) :+   ("sect",     167) :+   ("uml",      168) :+   ("copy",     169) :+   ("ordf",     170) :+   ("laquo",    171) :+   ("not",      172) :+   ("shy",      173) :+   ("reg",      174) :+   ("macr",     175) :+   ("deg",      176) :+   ("plusmn",   177) :+   ("sup2",     178) :+   ("sup3",     179) :+   ("acute",    180) :+   ("micro",    181) :+   ("para",     182) :+   ("middot",   183) :+   ("cedil",    184) :+   ("sup1",     185) :+   ("ordm",     186) :+   ("raquo",    187) :+   ("frac14",   188) :+   ("frac12",   189) :+   ("frac34",   190) :+   ("iquest",   191) :+   ("Agrave",   192) :+   ("Aacute",   193) :+   ("Acirc",    194) :+   ("Atilde",   195) :+   ("Auml",     196) :+   ("Aring",    197) :+   ("AElig",    198) :+   ("Ccedil",   199) :+   ("Egrave",   200) :+   ("Eacute",   201) :+   ("Ecirc",    202) :+   ("Euml",     203) :+   ("Igrave",   204) :+   ("Iacute",   205) :+   ("Icirc",    206) :+   ("Iuml",     207) :+   ("ETH",      208) :+   ("Ntilde",   209) :+   ("Ograve",   210) :+   ("Oacute",   211) :+   ("Ocirc",    212) :+   ("Otilde",   213) :+   ("Ouml",     214) :+   ("times",    215) :+   ("Oslash",   216) :+   ("Ugrave",   217) :+   ("Uacute",   218) :+   ("Ucirc",    219) :+   ("Uuml",     220) :+   ("Yacute",   221) :+   ("THORN",    222) :+   ("szlig",    223) :+   ("agrave",   224) :+   ("aacute",   225) :+   ("acirc",    226) :+   ("atilde",   227) :+   ("auml",     228) :+   ("aring",    229) :+   ("aelig",    230) :+   ("ccedil",   231) :+   ("egrave",   232) :+   ("eacute",   233) :+   ("ecirc",    234) :+   ("euml",     235) :+   ("igrave",   236) :+   ("iacute",   237) :+   ("icirc",    238) :+   ("iuml",     239) :+   ("eth",      240) :+   ("ntilde",   241) :+   ("ograve",   242) :+   ("oacute",   243) :+   ("ocirc",    244) :+   ("otilde",   245) :+   ("ouml",     246) :+   ("divide",   247) :+   ("oslash",   248) :+   ("ugrave",   249) :+   ("uacute",   250) :+   ("ucirc",    251) :+   ("uuml",     252) :+   ("yacute",   253) :+   ("thorn",    254) :+   ("yuml",     255) :++   ("OElig",    338) :+   ("oelig",    339) :+   ("Scaron",   352) :+   ("scaron",   353) :+   ("Yuml",     376) :+   ("circ",     710) :+   ("tilde",    732) :++   ("ensp",     8194) :+   ("emsp",     8195) :+   ("thinsp",   8201) :+   ("zwnj",     8204) :+   ("zwj",      8205) :+   ("lrm",      8206) :+   ("rlm",      8207) :+   ("ndash",    8211) :+   ("mdash",    8212) :+   ("lsquo",    8216) :+   ("rsquo",    8217) :+   ("sbquo",    8218) :+   ("ldquo",    8220) :+   ("rdquo",    8221) :+   ("bdquo",    8222) :+   ("dagger",   8224) :+   ("Dagger",   8225) :+   ("permil",   8240) :+   ("lsaquo",   8249) :+   ("rsaquo",   8250) :+   ("euro",     8364) :++   ("fnof",     402) :+   ("Alpha",    913) :+   ("Beta",     914) :+   ("Gamma",    915) :+   ("Delta",    916) :+   ("Epsilon",  917) :+   ("Zeta",     918) :+   ("Eta",      919) :+   ("Theta",    920) :+   ("Iota",     921) :+   ("Kappa",    922) :+   ("Lambda",   923) :+   ("Mu",       924) :+   ("Nu",       925) :+   ("Xi",       926) :+   ("Omicron",  927) :+   ("Pi",       928) :+   ("Rho",      929) :+   ("Sigma",    931) :+   ("Tau",      932) :+   ("Upsilon",  933) :+   ("Phi",      934) :+   ("Chi",      935) :+   ("Psi",      936) :+   ("Omega",    937) :+   ("alpha",    945) :+   ("beta",     946) :+   ("gamma",    947) :+   ("delta",    948) :+   ("epsilon",  949) :+   ("zeta",     950) :+   ("eta",      951) :+   ("theta",    952) :+   ("iota",     953) :+   ("kappa",    954) :+   ("lambda",   955) :+   ("mu",       956) :+   ("nu",       957) :+   ("xi",       958) :+   ("omicron",  959) :+   ("pi",       960) :+   ("rho",      961) :+   ("sigmaf",   962) :+   ("sigma",    963) :+   ("tau",      964) :+   ("upsilon",  965) :+   ("phi",      966) :+   ("chi",      967) :+   ("psi",      968) :+   ("omega",    969) :+   ("thetasym", 977) :+   ("upsih",    978) :+   ("piv",      982) :+   ("bull",     8226) :+   ("hellip",   8230) :+   ("prime",    8242) :+   ("Prime",    8243) :+   ("oline",    8254) :+   ("frasl",    8260) :+   ("weierp",   8472) :+   ("image",    8465) :+   ("real",     8476) :+   ("trade",    8482) :+   ("alefsym",  8501) :+   ("larr",     8592) :+   ("uarr",     8593) :+   ("rarr",     8594) :+   ("darr",     8595) :+   ("harr",     8596) :+   ("crarr",    8629) :+   ("lArr",     8656) :+   ("uArr",     8657) :+   ("rArr",     8658) :+   ("dArr",     8659) :+   ("hArr",     8660) :+   ("forall",   8704) :+   ("part",     8706) :+   ("exist",    8707) :+   ("empty",    8709) :+   ("nabla",    8711) :+   ("isin",     8712) :+   ("notin",    8713) :+   ("ni",       8715) :+   ("prod",     8719) :+   ("sum",      8721) :+   ("minus",    8722) :+   ("lowast",   8727) :+   ("radic",    8730) :+   ("prop",     8733) :+   ("infin",    8734) :+   ("ang",      8736) :+   ("and",      8743) :+   ("or",       8744) :+   ("cap",      8745) :+   ("cup",      8746) :+   ("int",      8747) :+   ("there4",   8756) :+   ("sim",      8764) :+   ("cong",     8773) :+   ("asymp",    8776) :+   ("ne",       8800) :+   ("equiv",    8801) :+   ("le",       8804) :+   ("ge",       8805) :+   ("sub",      8834) :+   ("sup",      8835) :+   ("nsub",     8836) :+   ("sube",     8838) :+   ("supe",     8839) :+   ("oplus",    8853) :+   ("otimes",   8855) :+   ("perp",     8869) :+   ("sdot",     8901) :+   ("lceil",    8968) :+   ("rceil",    8969) :+   ("lfloor",   8970) :+   ("rfloor",   8971) :+   ("lang",     9001) :+   ("rang",     9002) :+   ("loz",      9674) :+   ("spades",   9824) :+   ("clubs",    9827) :+   ("hearts",   9829) :+   ("diams",    9830) :+   []
+ Text/HTML/TagSoup/Match.hs view
@@ -0,0 +1,88 @@+module Text.HTML.TagSoup.Match where++import Text.HTML.TagSoup.Type (Tag(..), Attribute)+import Data.List+++-- | match an opening tag+tagOpen :: (String -> Bool) -> ([Attribute] -> Bool) -> Tag -> Bool+tagOpen pName pAttrs (TagOpen name attrs) =+   pName name && pAttrs attrs+tagOpen _ _ _ = False++-- | match an closing tag+tagClose :: (String -> Bool) -> Tag -> Bool+tagClose pName (TagClose name) = pName name+tagClose _ _ = False++-- | match a text+tagText :: (String -> Bool) -> Tag -> Bool+tagText p (TagText text) = p text+tagText _ _ = False++tagComment :: (String -> Bool) -> Tag -> Bool+tagComment p (TagComment text) = p text+tagComment _ _ = False+++-- | match a opening tag's name literally+tagOpenLit :: String -> ([Attribute] -> Bool) -> Tag -> Bool+tagOpenLit name = tagOpen (name==)++-- | match a closing tag's name literally+tagCloseLit :: String -> Tag -> Bool+tagCloseLit name = tagClose (name==)++tagOpenAttrLit :: String -> Attribute -> Tag -> Bool+tagOpenAttrLit name attr =+   tagOpenLit name (anyAttrLit attr)++{- |+Match a tag with given name, that contains an attribute+with given name, that satisfies a predicate.+If an attribute occurs multiple times,+all occurrences are checked.+-}+tagOpenAttrNameLit :: String -> String -> (String -> Bool) -> Tag -> Bool+tagOpenAttrNameLit tagName attrName pAttrValue =+   tagOpenLit tagName+      (anyAttr (\(name,value) -> name==attrName && pAttrValue value))+++-- | Check if the 'Tag' is 'TagOpen' and matches the given name+tagOpenNameLit :: String -> Tag -> Bool+tagOpenNameLit name = tagOpenLit name (const True)++-- | Check if the 'Tag' is 'TagClose' and matches the given name+tagCloseNameLit :: String -> Tag -> Bool+tagCloseNameLit name = tagCloseLit name+++++anyAttr :: ((String,String) -> Bool) -> [Attribute] -> Bool+anyAttr = any++anyAttrName :: (String -> Bool) -> [Attribute] -> Bool+anyAttrName p = any (p . fst)++anyAttrValue :: (String -> Bool) -> [Attribute] -> Bool+anyAttrValue p = any (p . snd)+++anyAttrLit :: (String,String) -> [Attribute] -> Bool+anyAttrLit attr = anyAttr (attr==)++anyAttrNameLit :: String -> [Attribute] -> Bool+anyAttrNameLit name = anyAttrName (name==)++anyAttrValueLit :: String -> [Attribute] -> Bool+anyAttrValueLit value = anyAttrValue (value==)++++getTagContent :: String -> ([Attribute] -> Bool) -> [Tag] -> [Tag]+getTagContent name pAttrs =+   takeWhile (not . tagCloseLit name) . drop 1 .+   head . sections (tagOpenLit name pAttrs)+    where sections p = filter (p . head) . init . tails
+ Text/HTML/TagSoup/Parser.hs view
@@ -0,0 +1,391 @@+{-# OPTIONS_GHC -w #-}++{-+The XML spec is done mainly from memory. The only special bits are:++Attributes+----------++"foo" as an attribute comes out as an attribute with a value and no text+to allow DOCTYPE tags to get parsed as normal.++References (aka Character and Entity References)+----------++A character reference is one of:++entity = '&#' [0-9]+ ';' +       | '&#x' [0-9a-fA-F]+ ';'+       | '&' name ';'++The maximum character reference is 0x10FFFF++name = (letter | '_' | ':') (namechar)*+namechar = letter | digit | '.' | '-' | '_' | ':' | combiningchar | extender+combiningchar and extender are assumed to be empty+letter = isAlpha+digit = isDigit+-}+++module Text.HTML.TagSoup.Parser(+    parseTags, parseTagsOptions,+    Options(..), options+    ) where++import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Entity+import Control.Monad.State+import Data.Char+import Data.List+import Data.Maybe+++infix 9 ?->++(?->) :: Bool -> [x] -> [x]+(?->) b true = if b then true else []++---------------------------------------------------------------------+-- * Options++data Options = Options+    {optTagPosition :: Bool -- ^ Should 'TagPosition' values be given before every item+    ,optTagWarning :: Bool -- ^ Should 'TagWarning' values be given+    ,optLookupEntity :: String -> [Tag] -- ^ How to lookup an entity+    ,optMaxEntityLength :: Maybe Int -- ^ The maximum length of an entities content+                                     --   (Nothing for no maximum, default to 10)+    }+++-- Default 'Options' structure+options :: Options+options = Options False False f (Just 10)+    where+        f x = case lookupEntity x of+                  Nothing -> [TagText $ "&" ++ x ++ ";", TagWarning $ "Unknown entity: &" ++ x ++ ";"]+                  Just x -> [TagText [x]]+++parseTags :: String -> [Tag]+parseTags = parseTagsOptions options++tagWarn :: Options -> String -> [Tag]+tagWarn opts x = [TagWarning x | optTagWarning opts]++---------------------------------------------------------------------+-- * Positions++-- All positions are stored as a row and a column, with (1,1) being the+-- top-left position++data Position = Position !Row !Column+++updateOnString :: Position -> String -> Position+updateOnString = foldl' updateOnChar++updateOnChar   :: Position -> Char -> Position+updateOnChar (Position r c) x = case x of+    '\n' -> Position (r+1) c+    '\t' -> Position r (c + 8 - mod (c-1) 8)+    _    -> Position r (c+1)+++tagPos :: Options -> Position -> [Tag]+tagPos opts (Position r c) = [TagPosition r c | optTagPosition opts]++tagPosWarn :: Options -> Position -> String -> [Tag]+tagPosWarn opts p x = optTagWarning opts ?-> (tagPos opts p ++ [TagWarning x])++tagPosWarnFix :: Options -> Position -> [Tag] -> [Tag]+tagPosWarnFix opts p = addPositions . remWarnings+    where+        remWarnings = if optTagWarning opts then id else filter (not . isTagWarning)+        addPositions = concatMap (\x -> tagPos opts p ++ [x])+    ++---------------------------------------------------------------------+-- * Driver++parseTagsOptions :: Options -> String -> [Tag]+parseTagsOptions opts x = mergeTexts $ evalState (parse opts) $ Value x (Position 0 0)+++-- | Combine adjacent text nodes.+--+--   If two text nodes are separated only a position node, delete the position.+--   If two text nodes are separated only by a warning, move the warning afterwards.+--   If a position immediately proceeds a warning, count that into the warning.+--+--   Note: this function leaks stack on Hugs.+mergeTexts :: [Tag] -> [Tag]+mergeTexts (TagText x:xs) = (TagText $ concat $ x:texts) : warns ++ mergeTexts rest+    where+        (texts,warns,rest) = f xs++        f (TagText x:xs) = (x:a,b,c)+            where (a,b,c) = f xs+        f (TagPosition _ _:TagText x:xs) = (x:a,b,c)+            where (a,b,c) = f xs++        f (p@TagPosition{}:TagWarning y:xs) = (a,p:TagWarning y:b,c)+            where (a,b,c) = f xs+        f (TagWarning x:xs) = (a,TagWarning x:b,c)+            where (a,b,c) = f xs++        f xs = ([],[],xs)++mergeTexts (x:xs) = x : mergeTexts xs+mergeTexts [] = []+++---------------------------------------------------------------------+-- * Combinators++data Value = Value String !Position++type Parser a = State Value a+++isNameCharFirst x = isAlphaNum x || x `elem` "_:"+isNameChar x = isAlphaNum x || x `elem` "-_:."++-- Read and consume n characters from the stream, updating the position.+-- Highly likely to be a potential for space leaks from this, unless @n@ is bounded.+consume :: Int -> Parser ()+consume n = do+    Value s p <- get+    let (a,b) = splitAt n s+    put $ Value b (updateOnString p a)+++-- Break once an end string is encountered.+-- Return the string before, and a boolean indicating if the end was matched.+breakOn :: String -> Parser (String,Bool)+breakOn end = do+    Value s p <- get+    if null s then+        return ("",True)+     else if end `isPrefixOf` s then+        consume (length end) >> return ("",False)+     else do+        consume 1+        ~(a,b) <- breakOn end+        return (head s:a,b)++-- Break after an HTML name (entity, attribute or tag name)+-- Note: potential space leak with consume at the end+breakName :: Parser String+breakName = do+    Value s p <- get+    if not (null s) && isNameCharFirst (head s) then do+        let (a,b) = span isNameChar s+        consume (length a)+        return a+     else+        return ""++-- Break after a number has been read+-- Note: potential space leak with consume at the end+breakNumber :: Parser (Maybe Int)+breakNumber = do+    Value s p <- get+    if not (null s) && isDigit (head s) then do+        let (a,b) = span isDigit s+        consume (length a)+        return $ Just $ read a+     else+        return Nothing+++-- Drop a number of spaces+-- Note: potential space leak with consume at the end+dropSpaces :: Parser ()+dropSpaces = do+    Value s p <- get+    let n = length $ takeWhile isSpace s+    consume n+++---------------------------------------------------------------------+-- * Parser++parse :: Options -> Parser [Tag]+parse opts = do+    Value s p <- get+    case s of+        '<':'!':'-':'-':_ -> consume 4 >> comment opts p+        '<':'/':_         -> consume 2 >> close opts p+        '<':_             -> consume 1 >> open opts p+        []                -> return []+        '&':_             -> do+            consume 1+            s <- entity opts p+            rest <- parse opts+            return $ s ++ rest+        s:ss              -> do+            consume 1+            rest <- parse opts+            return $ tagPos opts p ++ [TagText [s]] ++ rest++-- have read "<!--"+comment opts p1 = do+    ~(inner,bad) <- breakOn "-->"+    rest <- parse opts+    return $ tagPos opts p1 ++ [TagComment inner] +++             (bad ?-> tagPosWarn opts p1 "Unexpected end when looking for \"-->\"") +++             rest+++close opts p1 = do+        name <- breakName+        dropSpaces+        ~(Value s p) <- get+        rest <- f s+        return $ tagPos opts p1 ++ [TagClose name] +++                 (null name ?-> tagPosWarn opts p1 "Empty name in close tag") +++                 rest+    where+        f ('>':s) = do+            consume 1+            rest <- parse opts+            return rest++        f _ = do+            ~(_,bad) <- breakOn ">"+            rest <- parse opts+            return $ tagPosWarn opts p1 "Junk in closing tag" +++                     bad ?-> tagPosWarn opts p1 "Unexpected end when looking for \">\"" +++                     rest+++-- an open tag, perhaps <? or <!+open opts p1 = do+    Value s p <- get+    prefix <- if take 1 s `elem` ["!","?"] then consume 1 >> return [head s] else return ""+    name <- liftM (prefix++) breakName+    if null name then do+        rest <- parse opts+        return $ tagPos opts p1 ++ [TagText ('<':prefix)] ++ tagPosWarn opts p1 "Expected name of tag" ++ rest+     else do+        ~(atts,shut,warns) <- attribs opts p1+        rest <- parse opts+        return $ tagPos opts p1 ++ [TagOpen name atts] +++                 shut ?-> (tagPos opts p1 ++ [TagClose name]) +++                 warns ++ rest+++-- read a list of attributes+-- return (the attributes read, if the tag is self-shutting, any warnings) +attribs :: Options -> Position -> Parser ([Attribute],Bool,[Tag])+attribs opts p1 = do+    dropSpaces+    Value s p <- get+    case s of+        '/':'>':_ -> consume 2 >> return ([],True ,[])+        '>':_     -> consume 1 >> return ([],False,[])+        x:xs | x `elem` "'\"" -> do+            ~(val,warns1) <- value opts+            ~(atts,shut,warns2) <- attribs opts p1+            return (("",val):atts,shut,warns1++warns2)+        []        -> return ([],False,tagPosWarn opts p1 "Unexpected end when looking for \">\"")+        _ -> attrib opts p1+++-- read a single attribute+-- return (the attributes read, if the tag is self-shutting, any warnings) +attrib :: Options -> Position -> Parser ([Attribute],Bool,[Tag])+attrib opts p1 = do+    name <- breakName+    if null name then do+        consume 1+        ~(atts,shut,warns) <- attribs opts p1+        return (atts,shut,tagPosWarn opts p1 "Junk character in tag" ++ warns)+     else do+        ~(Value s p) <- get+        ~(val,warns1) <- f s+        ~(atts,shut,warns2) <- attribs opts p1+        return ((name,val):atts,shut,warns1++warns2)+    where+        f ('=':s) = consume 1 >> value opts+        f xs | not $ junk xs = return ([], [])+             | otherwise = do+                ~(Value s p) <- get+                dropJunk+                return ([], tagPosWarn opts p "Junk character in tag")++        junk ('/':'>':_) = False+        junk ('>':_) = False+        junk (c:cs) | not $ isSpace c = True+        junk _ = False+        +        dropJunk = do+            ~(Value s p) <- get+            when (junk s) $ consume 1 >> dropJunk+++-- read a single value+-- return (value,warnings)+value :: Options -> Parser (String,[Tag])+value opts = do+    Value s p <- get+    case s of+        '\"':_ -> consume 1 >> f p True "\""+        '\'':_ -> consume 1 >> f p True "\'"+        _ -> f p False " />"+    where+        f p1 quote end = do+            Value s p <- get+            case s of+                '&':_ -> do+                    consume 1+                    ~(cs1,warns1) <- entityString opts p+                    ~(cs2,warns2) <- f p1 quote end+                    return (cs1++cs2,warns1++warns2)+                c:_ | c `elem` end -> do+                    if quote then consume 1 else return ()+                    return ([],[])+                c:_ -> do+                    consume 1+                    ~(cs,warns) <- f p1 quote end+                    return (c:cs,warns)+                [] -> return ([],tagPosWarn opts p1 "Unexpected end in attibute value")++++-- have seen an &, and have consumed it+-- return a [Tag] to go in a tag stream+entity :: Options -> Position -> Parser [Tag]+entity opts p1 = do+    Value s p <- get+    case s of+        '#':'x':_ -> f "#x" isHexDigit +        '#':_     -> f "#"  isDigit+        _         -> f ""   isNameChar+    where+        f prefix match = do+            consume (length prefix)+            g match (reverse prefix) (fromMaybe maxBound (optMaxEntityLength opts))+        +        g match buf bound | bound < 0 = return $+            tagPos opts p1 ++ [TagText ('&':reverse buf)] +++            tagPosWarn opts p1 "Unexpected '&' not in an entity"++        g match buf bound = do+            Value s p <- get+            case s of+                ';':_ -> do+                    consume 1+                    return $ tagPosWarnFix opts p1 $ optLookupEntity opts (reverse buf)+                x:xs | match x -> consume 1 >> g match (x:buf) (bound-1) +                _ -> g match buf (-1)+            +++-- return the tag and some position information+entityString :: Options -> Position -> Parser (String,[Tag])+entityString opts p = do+    tags <- entity opts p+    let warnings = tagPosWarnFix opts p $ filter isTagWarning tags+    return (innerText tags, warnings)
+ Text/HTML/TagSoup/Type.hs view
@@ -0,0 +1,90 @@+-- | The central type in TagSoup++module Text.HTML.TagSoup.Type(+    -- * Data structures and parsing+    Tag(..), Attribute, Row, Column,++    -- * Tag identification+    isTagOpen, isTagClose, isTagText, isTagWarning,+    isTagOpenName, isTagCloseName,++    -- * Extraction+    fromTagText, fromAttrib,+    maybeTagText, maybeTagWarning,+    innerText,+    ) where+++import Data.Char+import Data.Maybe+++-- | An HTML attribute @id=\"name\"@ generates @(\"id\",\"name\")@+type Attribute = (String,String)++type Row = Int+type Column = Int++-- | An HTML element, a document is @[Tag]@.+--   There is no requirement for 'TagOpen' and 'TagClose' to match+data Tag =+     TagOpen String [Attribute]  -- ^ An open tag with 'Attribute's in their original order.+   | TagClose String             -- ^ A closing tag+   | TagText String              -- ^ A text node, guaranteed not to be the empty string+   | TagComment String           -- ^ A comment+   | TagWarning String           -- ^ Meta: Mark a syntax error in the input file+   | TagPosition !Row !Column    -- ^ Meta: The position of a parsed element+     deriving (Show, Eq, Ord)+++-- | Test if a 'Tag' is a 'TagOpen'+isTagOpen :: Tag -> Bool+isTagOpen (TagOpen {})  = True; isTagOpen  _ = False++-- | Test if a 'Tag' is a 'TagClose'+isTagClose :: Tag -> Bool+isTagClose (TagClose {}) = True; isTagClose _ = False++-- | Test if a 'Tag' is a 'TagText'+isTagText :: Tag -> Bool+isTagText (TagText {})  = True; isTagText  _ = False++-- | Extract the string from within 'TagText', otherwise 'Nothing'+maybeTagText :: Tag -> Maybe String+maybeTagText (TagText x) = Just x+maybeTagText _ = Nothing++-- | Extract the string from within 'TagText', crashes if not a 'TagText'+fromTagText :: Tag -> String+fromTagText (TagText x) = x+fromTagText x = error ("(" ++ show x ++ ") is not a TagText")++-- | Extract all text content from tags (similar to Verbatim found in HaXml)+innerText :: [Tag] -> String+innerText = concat . mapMaybe maybeTagText++-- | Test if a 'Tag' is a 'TagWarning'+isTagWarning :: Tag -> Bool+isTagWarning (TagWarning {})  = True; isTagWarning _ = False++-- | Extract the string from within 'TagWarning', otherwise 'Nothing'+maybeTagWarning :: Tag -> Maybe String+maybeTagWarning (TagWarning x) = Just x+maybeTagWarning _ = Nothing++-- | Extract an attribute, crashes if not a 'TagOpen'.+--   Returns @\"\"@ if no attribute present.+fromAttrib :: String -> Tag -> String+fromAttrib att (TagOpen _ atts) = fromMaybe [] $ lookup att atts+fromAttrib _ x = error ("(" ++ show x ++ ") is not a TagOpen")+++-- | Returns True if the 'Tag' is 'TagOpen' and matches the given name+isTagOpenName :: String -> Tag -> Bool+isTagOpenName name (TagOpen n _) = n == name+isTagOpenName _ _ = False++-- | Returns True if the 'Tag' is 'TagClose' and matches the given name+isTagCloseName :: String -> Tag -> Bool+isTagCloseName name (TagClose n) = n == name+isTagCloseName _ _ = False
tagsoup.cabal view
@@ -1,13 +1,34 @@ Name:           tagsoup-Version:        0.1-License:        BSD3+Version:        0.4+Copyright:      2006-8, Neil Mitchell+Maintainer:     ndmitchell@gmail.com Author:         Neil Mitchell-Homepage:       http://www-users.cs.york.ac.uk/~ndm/projects/libraries.php-Build-Depends:  base, network+Homepage:       http://www-users.cs.york.ac.uk/~ndm/tagsoup/+License:        BSD3+Category:       XML+License-File:   LICENSE+Build-Depends:  base, network, mtl+Build-type:     Simple Synopsis:       Parsing and extracting information from (possibly malformed) HTML documents+Description:+    TagSoup is a library for extracting information out of unstructured HTML code,+    sometimes known as tag-soup. The HTML does not have to be well formed, or render+    properly within any particular framework. This library is for situations where+    the author of the HTML is not cooperating with the person trying to extract the+    information, but is also not trying to hide the information.++GHC-Options:    -Wall Exposed-modules:-        Data.Html.TagSoup-        Data.Html.Download-Extra-Source-Files:-		tagsoup.htm-		Example/Example.hs+    Text.HTML.TagSoup+    Text.HTML.TagSoup.Entity+    Text.HTML.TagSoup.Match+    Text.HTML.TagSoup.Parser+    Text.HTML.TagSoup.Type+    Text.HTML.Download++Executable:     tagsoup+GHC-Options:    -Wall+Main-Is:        Main.hs+Other-Modules:+    Example.Example+    Example.Regress
− tagsoup.htm 
@@ -1,277 +0,0 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"-        "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>-    <head>-        <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />-        <title>Drinking TagSoup by Example</title>-        <style type="text/css">-pre {-    border: 2px solid gray;-    padding: 1px;-    padding-left: 5px;-    margin-left: 10px;-    background-color: #eee;-}--pre.define {-    background-color: #ffb;-    border-color: #cc0;-}--body {-    font-family: sans-serif;-}--h1, h2, h3 {-    font-family: serif;-}--h1 {-    color: rgb(23,54,93);-    border-bottom: 1px solid rgb(79,129,189);-    padding-bottom: 2px;-    font-variant: small-caps;-    text-align: center;-}--a {-    color: rgb(54,95,145);-}--h2 {-    color: rgb(54,95,145);-}--h3 {-    color: rgb(79,129,189);-}--p.rule {-    background-color: #ffb;-	padding: 3px;-	margin-left: 50px;-	margin-right: 50px;-}-        </style>-    </head>-    <body>--<h1>Drinking TagSoup by Example</h1>--<p style="text-align:right;margin-bottom:25px;">-    by <a href="http://www.cs.york.ac.uk/~ndm/">Neil Mitchell</a>-</p>--<p>-	TagSoup is a library for extracting information out of unstructured HTML code, sometimes known as tag-soup. The HTML does not have to be well formed, or render properly within any particular framework. This library is for situations where the author of the HTML is not cooperating with the person trying to extract the information,-    but is also not trying to hide the information.-</p>-<p>-	This document gives two particular examples, and two more may be found in the <a href="http://www.cs.york.ac.uk/fp/darcs/tagsoup/Example/Example.hs">Example</a> file from the darcs repository. The examples we give are:-</p>-<ol>-    <li>Obtaining the Hit Count from Haskell.org</li>-    <li>Obtaining a list of Simon Peyton-Jones' latest papers</li>-    <li>A brief overview of some other examples</li>-</ol>-<p>-	The intial version of this library was written in Javascript and has been used for various commercial projects involving screen scraping. In the examples general hints on screen scraping are included, learnt from bitter experience. It should be noted that if you depend on data which someone else may change at any given time, you may be in for a shock!-</p>-<p>-	This library was written without knowledge of the Java version of <a href="http://home.ccil.org/~cowan/XML/tagsoup/">TagSoup</a>. They have made a very different design decision, to ensure default attributes are present and to properly nest parsed tags. We do not do this - tags are merely a list devoid of nesting information.-</p>--<h3>Acknowledgements</h3>--<p>-    Thanks to Mike Dodds for persuading me to write this up as a library.-</p>--<h2>Potential Bugs</h2>--<p>-    There are two things that may go wrong with these examples:-</p>-<ul>-    <li>-        <i>The Websites being scraped may change.</i> There is nothing I can do about this, but if you suspect this is the case let me know, and I'll update the examples and tutorials. I have already done so once or twice, its only a few minutes work.-    </li>-    <li>-        <i>The <tt>openURL</tt> method may not work.</i> This happens quite regularly, and depending on your server, proxies and direction of the wind, they may not work. The solution is to use <tt>wget</tt> to download the page locally, then use <tt>readFile</tt> instead. Hopefully a decent Haskell HTTP library will emerge, and that can be used instead.-    </li>-</ul>---<h2>Haskell Hit Count</h2>--<p>-    Our goal is to develop a program that displays the Haskell.org hit count. This example covers all the basics in designing a basic web-scraping application.-</p>--<h3>Finding the Page</h3>--<p>-	We first need to find where the information is displayed, and in what format. Taking a look at the <a href="http://www.haskell.org/haskellwiki/Haskell">front web page</a>, when not logged in, you may notice that there is no hit count. However, looking at the source shows us:-</p>-<pre>-&lt;div class="printfooter"&gt;-&lt;p&gt;Retrieved from "&lt;a href="http://www.haskell.org/haskellwiki/Haskell"&gt;-http://www.haskell.org/haskellwiki/Haskell&lt;/a&gt;"&lt;/p&gt;--&lt;p&gt;This page has been accessed 615,165 times.-This page was last modified 15:44, 15 March 2007.-Recent content is available under &lt;a href="/haskellwiki/HaskellWiki:Copyrights"-title="HaskellWiki:Copyrights"&gt;a simple permissive license&lt;/a&gt;.&lt;/p&gt;-</pre>-<p>-	So we see that the hit count is available, but not shown. This leads us to rule 1:-</p>-<p class="rule">-	<b>Rule 1:</b><br/>-	Scrape from what the page returns, not what a browser renders, or what view-source gives.-</p>-<p>-	Some web servers will serve different content depending on the user agent, some browsers will have scripting modify their displayed HTML, some pages will display differently depending on your cookies. Before you can start to figure out how to start scraping, first decide what the input to your program will be. The usual step is to write a simple program:-</p>-<pre>-import Data.Html.TagSoup--main = do src <- openURL "http://haskell.org/haskellwiki/Haskell"-	      writeFile "temp.htm" src-</pre>-<p>-	The function <tt>openURL</tt> comes from Data.Html.Download, part of the TagSoup library. Now open <tt>temp.htm</tt>, check this fragment of HTML is in it, and see what has been returned. Only now do we consider how to extract the information.-</p>--<h3>Finding the Information</h3>--<p>-	Now we examine both the fragment that contains our snippet of information, and the wider page. What does the fragment has that nothing else has? What algorithm would we use to obtain that particular element? How can we still return the element as the content changes? What if the design changes? But wait, before going any further:-</p>-<p class="rule">-	<b>Rule 2:</b><br/>-	Do not be robust to design changes, do not even consider the possibility when writing the code.-</p>-<p>-	If the user changes their website, they will do so in unpredictable ways. They may move the page, they may put the information somewhere else, they may remove the information entirely. If you want something robust talk to the site owner, or buy the data from someone. If you try and think about design changes, you will complicate your design, and it still won't work. It is better to write an extraction method quickly, and happily rewrite it when things change.-</p>-<p>-	So now, lets consider the fragment from above. It is useful to find a tag which is unique just above your snippet - something with a nice "id" property, or a "class" - something which is unlikely to occur multiple times. In the above example, "printfooter" as the class seems perfect. We decide that to find the snippet, we will start at a "div" tag, with a "class" attribute with the value "printfooter".-</p>-<pre>-haskellHitCount = do-	tags <- liftM parseTags $ openURL "http://haskell.org/haskellwiki/Haskell"-	let count = fromFooter $ head $ sections (~== TagOpen "div" [("class","printfooter")]) tags-	putStrLn $ "haskell.org has been hit " ++ show count ++ " times"-</pre>-<p>-	Now we start writing the code! The first thing to do is open the required URL, then we parse the code into a list of <tt>Tag</tt>s. We then apply the <tt>sections</tt> function, which returns all the lists whose first element matches the query. We use the <tt>(~==)</tt> operator to construct the query - in this case asking for the "div" we mentioned earlier. This <tt>(~==)</tt> operator is very different from standard equality, it allows additional attributes to be present but does not match them. If we just wanted any open tag with the given class we could have written <tt>(~== TagOpen "" [("class","printfooter")])</tt> and this would have matched. Any empty strings in the second element of the match are considered as wildcards.-</p>-<p>-	Once we have a list of all matching prefixes, we take the <tt>head</tt> - assuming that only one will match. Then we apply <tt>fromFooter</tt> which needs to perform the traversal from the "printfooter" attribute onwards to the actual hit count data.-</p>--<h3>Extracting the Information</h3>--<p>-	Now we have a stream starting at the right place, we generally mangle the code using standard list operators:-</p>-<pre>-fromFooter x = read (filter isDigit num) :: Int-	where-		num = ss !! (i - 1)-		Just i = findIndex (== "times.") ss-		ss = words s-		TagText s = sections (isTagOpenName "p") x !! 1 !! 1-</pre>-<p>-	This code finds <tt>s</tt>, the text inside the appropriate paragraph by knowing that its the second (<tt>!! 1</tt>) paragraph, and within that paragraph, its the second tag - the actual text. We then split up the text using <tt>words</tt>, find the message that comes after hit count, and read all the digits we can find - filtering out the comma. This code may seem slightly messy, and indeed it is - often that is the nature of extracting information from a tag soup.-</p>-<p class="rule">-	<b>Rule 3:</b><br/>-	TagSoup is for extracting information where structure has been lost, use more structured information if it is available.-</p>---<h2>Simon's Papers</h2>--<p>-	Our next very important task is to extract a list of all Simon Peyton Jones' recent research papers off his <a href="http://research.microsoft.com/~simonpj/">home page</a>. The largest change to the previous example is that now we desire a list of papers, rather than just a single result.-</p>-<p>-	As before we first start by writing a simple program that downloads the appropriate page, and look for common patterns. This time we want to look for all patterns which occur every time a paper is mentioned, but no where else. The other difference from last time is that previous we grabbed an automatically generated piece of information - this time the information is entered in a more freeform way by a human.-</p>-<p>-	First we spot that the page helpfully has named anchors, there is a current work anchor, and after that is one for Haskell. We can extract all the information between them with a simple <tt>take</tt>/<tt>drop</tt> pair:-</p>-<pre>-takeWhile (~/= TagOpen "a" [("name","haskell")]) $-drop 5 $ dropWhile (~/= TagOpen "a" [("name","current")]) tags-</pre>-<p>-	This code drops until you get to the "current" section, then takes until you get to the "haskell" section, ensuring we only look at the important bit of the page. Next we want to find all hyperlinks within this section:-</p>-<pre>-map f $ sections (isTagOpenName "a") $ ...-</pre>-<p>-	The function to select all tags with name "a" could have been written as <tt>(~== TagOpen "a" [])</tt>, but we choose to use <tt>isTagOpenName</tt> instead. Afterwards we map each item with an <tt>f</tt> function. This function needs to take the tags starting just after the link, and find the text inside the link.-</p>-<pre>-f = dequote . unwords . words . fromTagText . head . filter isTagText-</pre>-<p>-	Here the complexity of interfacing to human written markup comes through. Some of the links are in italic, some are not - the <tt>filter</tt> drops all those that are not, until we find a pure text node. The <tt>unwords . words</tt> deletes all multiple spaces, replaces tabs and newlines with spaces and trims the front and back - a neat trick when dealing with text which has spacing at the source code but not when displayed. The final thing to take account of is that some papers are given with quotes around the name, some are not - dequote will remove the quotes if they exist.-</p>-<p>-	For completeness, we now present the entire example:-</p>-<pre>-spjPapers :: IO ()-spjPapers = do-        tags <- liftM parseTags $ openURL "http://research.microsoft.com/~simonpj/"-        let links = map f $ sections (isTagOpenName "a") $-                    takeWhile (~/= TagOpen "a" [("name","haskell")]) $-                    drop 5 $ dropWhile (~/= TagOpen "a" [("name","current")]) tags-        putStr $ unlines links-    where-        f :: [Tag] -> String-        f = dequote . unwords . words . fromTagText . head . filter isTagText--        dequote ('\"':xs) | last xs == '\"' = init xs-        dequote x = x-</pre>---<h2>Other Examples</h2>--<p>-	Two more examples are given in the Example file, obtaining the (short) list of papers from my site, and getting the current time. Both use very much the same style as presented here - writing screen scrapers follow a standard pattern. We present the code for enjoyment only.-</p>--<h3>My Papers</h3>--<pre>-ndmPapers :: IO ()-ndmPapers = do-        tags <- liftM parseTags $ openURL "http://www-users.cs.york.ac.uk/~ndm/downloads/"-        let papers = map f $ sections (~== TagOpen "li" [("class","paper")]) tags-        putStr $ unlines papers-    where-        f :: [Tag] -> String-        f xs = fromTagText (xs !! 2)-</pre>--<h3>UK Time</h3>--<pre>-currentTime :: IO ()-currentTime = do-        tags <- liftM parseTags $ openURL "http://www.timeanddate.com/worldclock/city.html?n=136"-        let time = fromTagText (dropWhile (~/= TagOpen "strong" [("id","ct")]) tags !! 1)-        putStrLn time-</pre>---    </body>-</html>