hxt 8.5.0 → 8.5.1

raw patch · 8 files changed

+164/−82 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hxt.cabal +1/−1
• src/Data/Atom.hs +1/−1
• src/Text/XML/HXT/Arrow/ReadDocument.hs +48/−33
• src/Text/XML/HXT/Arrow/XmlIOStateArrow.hs +65/−41
• src/Text/XML/HXT/DOM/MimeTypes.hs +4/−0
• src/Text/XML/HXT/DOM/XmlKeywords.hs +5/−1
• src/Text/XML/HXT/IO/GetHTTPLibCurl.hs +39/−4
• src/Text/XML/HXT/Version.hs +1/−1

@@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file name: hxt-version: 8.5.0+version: 8.5.1 license: OtherLicense license-file: LICENCE maintainer: Uwe Schmidt <uwe@fh-wedel.de>

@@ -64,7 +64,7 @@  import           Data.ByteString.Internal       ( toForeignPtr, c2w, w2c ) import           Data.ByteString                ( ByteString, pack, unpack )-import qualified Data.Map                 as M+import qualified Data.Map                 	as M import           Data.Typeable  import           System.IO.Unsafe               ( unsafePerformIO )

@@ -28,6 +28,7 @@  import Control.Arrow.ListArrows +import Data.Char				( isDigit ) import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlIOStateArrow@@ -120,6 +121,9 @@  - 'a_mime_types' : set the mime type table for file input with given file. The format of this config file must be in the syntax of a debian linux \"mime.types\" config file +- 'a_if_modified_since' : read document conditionally, only if the document is newer than the given date and time argument, the contents is delivered,+                          else just the root node with the meta data is returned. The date and time must be given in "System.Locale.rfc822DateFormat".+ - curl options : the HTTP interface with libcurl can be configured with a lot of options. To support these options in an easy way, there is a naming convetion:                  Every option, which has the prefix @curl@ and the rest of the name forms an option as described in the curl man page, is passed to the curl binding lib.                  See 'Text.XML.HXT.IO.GetHTTPLibCurl.getCont' for examples. Currently most of the options concerning HTTP requests are implemented.@@ -180,9 +184,19 @@  readDocument	:: Attributes -> String -> IOStateArrow s b XmlTree readDocument userOptions src-    = traceLevel-      >>>-      addInputOptionsToSystemState+    = case getTraceLev of+      Nothing	->                    readDocument' userOptions src+      Just l    -> withTraceLevel l $ readDocument' userOptions src+    where+    getTraceLev = do+                  s <- lookup a_trace $ userOptions+                  if not (null s) && all isDigit s+                      then return (read s)+                      else fail "not a number"++readDocument'	:: Attributes -> String -> IOStateArrow s b XmlTree+readDocument' userOptions src+    = loadMineTypes (lookup1 a_mime_types userOptions)       >>>       getDocumentContents options src       >>>@@ -213,18 +227,8 @@ 	  , ( a_accept_mimetypes,         ""  ) 	  ] -    traceLevel-	= maybe this (setTraceLevel . read) . lookup a_trace $ options--    addInputOptionsToSystemState-	= addSysOptions options-	  >>>-	  loadMineTypes (lookup1 a_mime_types userOptions)-	  where-	  addSysOptions-	      = seqA . map (uncurry setParamString)-	  loadMineTypes ""	= this-	  loadMineTypes f	= setMimeTypeTableFromFile f+    loadMineTypes ""	= this+    loadMineTypes f	= setMimeTypeTableFromFile f      getMimeType 	= getAttrValue transferMimeType >>^ stringToLower@@ -234,29 +238,40 @@ 			      , "(mime type:", show mimeType, ") will be processed"]) 	  >>> 	  ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType-	    then ( parse-		   >>>-		   ( if isXmlOrHtml-		     then ( checknamespaces-			    >>>-                            rememberDTDAttrl-                            >>>-			    canonicalize-			    >>>-			    whitespace-			    >>>-			    relax-			  )-		     else this+	    then ( ifA (fromLA hasEmptyBody)+                   ( replaceChildren none )					-- empty response, e.g. in if-modified-since request+                   ( parse+		     >>>+		     ( if isXmlOrHtml+		       then ( checknamespaces+			      >>>+                              rememberDTDAttrl+                              >>>+			      canonicalize+			      >>>+			      whitespace+			      >>>+			      relax+			    )+		       else this+		     ) 		   )-		 )+                 ) 	    else ( traceMsg 1 (unwords [ "readDocument:", show src 				       , "mime type:", show mimeType, "not accepted"]) 		   >>> 		   replaceChildren none-		 )								-- remove contents of not accepted mimetype+		 )									-- remove contents of not accepted mimetype 	  ) 	where+        hasEmptyBody			:: LA XmlTree XmlTree+        hasEmptyBody			= hasAttrValue transferStatus (/= "200")	-- test on empty response body for not o.k. responses+                                          `guards`					-- e.g. 3xx status values+                                          ( neg getChildren+                                            <+>+                                            ( getChildren >>> isWhiteSpace )+                                          )+ 	isAcceptedMimeType		:: String -> String -> Bool 	isAcceptedMimeType mts mt 	    | null mts@@ -298,11 +313,11 @@ 	      validateWithRelax		= propagateAndValidateNamespaces 	    | otherwise			= this 	canonicalize-	    | withTagSoup		= this					-- tagsoup already removes redundant struff+	    | withTagSoup		= this					-- tagsoup already removes redundant stuff 	    | validateWithRelax		= canonicalizeAllNodes 	    | hasOption a_canonicalize 	      &&-	      preserveCmt			= canonicalizeForXPath+	      preserveCmt		= canonicalizeForXPath 	    | hasOption a_canonicalize	= canonicalizeAllNodes 	    | otherwise			= this 	relax

@@ -2,13 +2,12 @@  {- |    Module     : Text.XML.HXT.Arrow.XmlIOStateArrow-   Copyright  : Copyright (C) 2005 Uwe Schmidt+   Copyright  : Copyright (C) 2010 Uwe Schmidt    License    : MIT     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)-   Stability  : experimental+   Stability  : stable    Portability: portable-   Version    : $Id: XmlIOStateArrow.hs,v 1.39 2006/11/09 20:27:42 hxml Exp $     the basic state arrows for XML processing @@ -99,6 +98,8 @@       setTraceLevel,       getTraceLevel,       withTraceLevel,+      setTraceCmd,+      getTraceCmd,       trace,       traceMsg,       traceValue,@@ -134,45 +135,41 @@ import Control.Arrow.ArrowIO import Control.Arrow.IOStateListArrow -import Control.Monad				( mplus )+import Control.Monad			( mzero+					, mplus ) import Control.DeepSeq  import Text.XML.HXT.DOM.Interface import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.Edit-    ( addHeadlineToXmlDoc-    , treeRepOfXmlDoc-    , indentDoc-    )+import Text.XML.HXT.Arrow.Edit		( addHeadlineToXmlDoc+					, treeRepOfXmlDoc+					, indentDoc+					)  import Data.Maybe -import Network.URI-    ( URI-    , escapeURIChar-    , isUnescapedInURI-    , nonStrictRelativeTo-    , parseURIReference-    , uriAuthority-    , uriFragment-    , uriPath-    , uriPort-    , uriQuery-    , uriRegName-    , uriScheme-    , uriUserInfo-    )+import Network.URI			( URI+					, escapeURIChar+					, isUnescapedInURI+					, nonStrictRelativeTo+					, parseURIReference+					, uriAuthority+					, uriFragment+					, uriPath+					, uriPort+					, uriQuery+					, uriRegName+					, uriScheme+					, uriUserInfo+					) -import System.IO-    ( hPutStrLn-    , hFlush-    , stderr-    )+import System.IO			( hPutStrLn+					, hFlush+					, stderr+					) -import System.Directory-    ( getCurrentDirectory-    )+import System.Directory			( getCurrentDirectory )  -- ------------------------------------------------------------ {- $datatypes -}@@ -183,6 +180,7 @@ -- system functions, like trace, error handling, ...  data XIOSysState	= XIOSys  { xio_trace			:: ! Int+                                  , xio_traceCmd		::   Int -> String -> IO () 				  , xio_errorStatus		:: ! Int 				  , xio_errorModule		:: ! String 				  , xio_errorMsgHandler		::   String -> IO ()@@ -195,7 +193,7 @@ 				  }  instance NFData XIOSysState where-    rnf (XIOSys tr es em _emh emc eml bu du al _mt)+    rnf (XIOSys tr _trc es em _emh emc eml bu du al _mt) 	= rnf tr `seq` rnf es `seq` rnf em `seq` rnf emc `seq` rnf eml `seq` rnf bu `seq` rnf du `seq` rnf al  -- |@@ -232,6 +230,7 @@  initialSysState	:: XIOSysState initialSysState	= XIOSys { xio_trace		= 0+                         , xio_traceCmd		= traceOutputToStderr 			 , xio_errorStatus	= c_ok 			 , xio_errorModule	= "" 			 , xio_errorMsgHandler	= hPutStrLn stderr@@ -737,6 +736,18 @@ getTraceLevel     = getSysParam xio_trace +-- | set the global trace command. This command does the trace output++setTraceCmd	:: (Int -> String -> IO ()) -> IOStateArrow s b b+setTraceCmd c+    = changeSysParam (\ _ s -> s { xio_traceCmd = c } )++-- | acces the command for trace output+ +getTraceCmd	:: IOStateArrow a b (Int -> String -> IO ())+getTraceCmd+    = getSysParam xio_traceCmd+ -- | run an arrow with a given trace level, the old trace level is restored after the arrow execution  withTraceLevel	:: Int -> IOStateArrow s b c -> IOStateArrow s b c@@ -759,17 +770,21 @@ trace level trc     = perform ( trc 		>>>-		arrIO (\ s -> ( do-				hPutStrLn stderr s-				hFlush stderr-			      )-		      )+                ( getTraceCmd &&& this )+                >>>+		arrIO (\ (cmd, msg) -> cmd level msg) 	      )       `when` ( getTraceLevel 	       >>> 	       isA (>= level) 	     ) +traceOutputToStderr	:: Int -> String -> IO ()+traceOutputToStderr _level msg+    = do+      hPutStrLn stderr msg+      hFlush stderr+ -- | trace the current value transfered in a sequence of arrows. -- -- The value is formated by a string conversion function. This is a substitute for@@ -851,16 +866,25 @@  -- ---------------------------------------------------------- --- | parse a URI reference, in case of a failure try to escape special chars+-- | parse a URI reference, in case of a failure,+-- try to escape unescaped chars, convert backslashes to slashes for windows paths, -- and try parsing again  parseURIReference'	:: String -> Maybe URI parseURIReference' uri     = parseURIReference uri       `mplus`-      parseURIReference uri'+      ( if unesc+	then parseURIReference uri'+	else mzero+      )     where-    uri' = concatMap ( escapeURIChar isUnescapedInURI) uri+    unesc	= not . all isUnescapedInURI $ uri++    escape '\\'	= "/"+    escape c	= escapeURIChar isUnescapedInURI c++    uri' 	= concatMap escape uri  -- | compute the absolut URI for a given URI and a base URI 

@@ -45,6 +45,8 @@  application_xml_external_parsed_entity,  application_xml_dtd,  text_html,+ text_pdf,+ text_plain,  text_xml,  text_xml_external_parsed_entity	:: String @@ -54,6 +56,8 @@ application_xml_dtd			= "application/xml-dtd"  text_html				= "text/html"+text_pdf				= "text/pdf"+text_plain				= "text/plain" text_xml				= "text/xml" text_xml_external_parsed_entity		= "text/xml-external-parsed-entity" 

@@ -47,6 +47,7 @@  a_error,  a_error_log,  a_help,+ a_if_modified_since,  a_ignore_encoding_errors,  a_ignore_none_xml_contents,  a_indent,@@ -98,6 +99,7 @@  v_0,				-- attribute values  v_1,+ v_2,  v_yes,  v_no,  v_any,@@ -162,6 +164,7 @@ a_error				= "error" a_error_log			= "errorLog" a_help				= "help"+a_if_modified_since		= "if-modified-since" a_ignore_encoding_errors	= "ignore-encoding-errors" a_ignore_none_xml_contents	= "ignore-none-xml-contents" a_indent			= "indent"@@ -213,8 +216,9 @@  v_yes		= "yes" v_no		= "no"-v_1		= "1" v_0		= "0"+v_1		= "1"+v_2		= "2"  v_any		= k_any v_children	= "children"

@@ -27,6 +27,9 @@ import Control.Concurrent.MVar import Control.Monad			( when ) +import qualified Data.ByteString        as B+import qualified Data.ByteString.Char8  as C+ import Data.Char			( isDigit 					, isSpace 					)@@ -54,6 +57,8 @@ isInitCurl	:: MVar Bool isInitCurl	= unsafePerformIO $ newMVar False +{-# NOINLINE isInitCurl #-}+ initCurl	:: IO () initCurl     = do@@ -66,6 +71,21 @@  -- ------------------------------------------------------------ +-- The curl lib is not thread save++curlResource	:: MVar ()+curlResource	= unsafePerformIO $ newMVar ()++{-# NOINLINE curlResource #-}++requestCurl	:: IO ()+requestCurl	= takeMVar curlResource++releaseCurl	:: IO ()+releaseCurl	= putMVar curlResource ()++-- ------------------------------------------------------------+ -- -- the http protocol handler implemented by calling libcurl -- (<http://curl.haxx.se/>)@@ -87,9 +107,13 @@ getCont options uri     = do       initCurl+      requestCurl       resp <- curlGetResponse_ uri curlOptions+      let resp' = evalResponse resp+      resp' `seq`+            releaseCurl       -- dumpResponse-      return $ evalResponse resp+      return resp'     where     _dumpResponse r 	= do@@ -129,9 +153,15 @@ 		     ++ show rsl 		   ) 	| otherwise-	    = Right ( contentT rsh ++ headers, respBody r+	    = B.length body+              `seq`+              Right ( contentT rsh ++ headers+                    , C.unpack body 		    ) 	where+        body :: B.ByteString+        body = respBody r+ 	mkH x y	= (x, dropWhile isSpace y)  	headers@@ -211,7 +241,8 @@     | k `elem` ["-R", "--remote-time"]  = [CurlFiletime            $ isTrue  v]     | k `elem` ["-u", "--user"]		= [CurlUserPwd                       v]     | k `elem` ["-U", "--proxy-user"]	= [CurlProxyUserPwd                  v]-    | k `elem` ["-x", "--proxy"]        =  proxyOptions+    | k `elem` ["-x", "--proxy", a_proxy]+				        =  proxyOptions     | k `elem` ["-X", "--request"]      = [CurlCustomRequest                 v]     | k `elem` ["-y", "--speed-time"]       &&@@ -219,7 +250,11 @@     | k `elem` ["-Y", "--speed-limit"]       &&       isIntArg v			= [CurlLowSpeed            $ read    v]-    | k `elem` ["-z", "--time-cond"]	=  ifModifiedOptions+    | k `elem` ["-z", "--time-cond", a_if_modified_since]+					=  ifModifiedOptions++    | k == a_if_modified_since		= [CurlHttpHeaders	   $ ["If-Modified-Since: " ++ v] ]+					-- CurlTimeValue seems to be buggy, therefore this workaround     | k == "--max-redirs"       &&       isIntArg v			= [CurlMaxRedirs           $ read    v]

@@ -1,4 +1,4 @@ module Text.XML.HXT.Version where hxt_version :: String-hxt_version = "8.5.0"+hxt_version = "8.5.1"