diff --git a/hxt.cabal b/hxt.cabal --- a/hxt.cabal +++ b/hxt.cabal @@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt -Version: 9.2.2 +Version: 9.3.0.1 Synopsis: A collection of tools for processing XML with Haskell. Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell. @@ -15,10 +15,14 @@ hxt-curl, hxt-tagsoup, hxt-relaxng, hxt-xpath, hxt-xslt, hxt-regex-xmlschema contain the extensions. hxt-unicode contains encoding and decoding functions, hxt-charproperties char properties for unicode and XML. + . + Changes from 9.3.0: upper bound for network set to be < 2.4 (URI signatures changed in 2.4) . - Changes to 9.2.1: user defined mime type handlers added + Changes from 9.2.2: XMLSchema validation integrated . - Changes to 9.2.0: New warnings from ghc-7.4 removed + Changes from 9.2.1: user defined mime type handlers added + . + Changes from 9.2.0: New warnings from ghc-7.4 removed License: MIT License-file: LICENSE Author: Uwe Schmidt, Martin Schmidt, Torben Kuseler @@ -176,7 +180,7 @@ parsec >= 2.1 && < 4, HUnit >= 1.2 && < 2, mtl >= 2 && < 3, - network >= 2.1 && < 3, + network >= 2.1 && < 2.4, deepseq >= 1.1 && < 2, bytestring >= 0.9 && < 1, binary >= 0.5 && < 1, diff --git a/src/Text/XML/HXT/Arrow/Pickle.hs b/src/Text/XML/HXT/Arrow/Pickle.hs --- a/src/Text/XML/HXT/Arrow/Pickle.hs +++ b/src/Text/XML/HXT/Arrow/Pickle.hs @@ -53,7 +53,7 @@ , showPickled , PU(..) - , XmlPickler + , XmlPickler(..) , xp4Tuple , xp5Tuple @@ -95,7 +95,6 @@ , xpElemWithAttrValue , xpFilterAttr , xpFilterCont - , xpickle , xpInt , xpLift , xpLiftEither diff --git a/src/Text/XML/HXT/Arrow/ProcessDocument.hs b/src/Text/XML/HXT/Arrow/ProcessDocument.hs --- a/src/Text/XML/HXT/Arrow/ProcessDocument.hs +++ b/src/Text/XML/HXT/Arrow/ProcessDocument.hs @@ -105,7 +105,7 @@ ( ifA (fromLA getDTDSubset) ( processDTDandEntities >>> - ( if validate' -- validation only possible if DTD there + ( if validate' -- validation only possible if there is a DTD then validateDocument else this ) diff --git a/src/Text/XML/HXT/Arrow/ReadDocument.hs b/src/Text/XML/HXT/Arrow/ReadDocument.hs --- a/src/Text/XML/HXT/Arrow/ReadDocument.hs +++ b/src/Text/XML/HXT/Arrow/ReadDocument.hs @@ -55,7 +55,8 @@ {- | the main document input filter -this filter can be configured by a list of configuration options, a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' +this filter can be configured by a list of configuration options, +a value of type 'Text.XML.HXT.XmlState.TypeDefs.SysConfig' for all available options see module 'Text.XML.HXT.XmlState.SystemConfig' @@ -72,7 +73,8 @@ - @withSubstHTMLEntities yes\/no@ : switch on\/off entity substitution for general entities defined in HTML validation. Default is @no@. - Switching this option on and the validation and substDTDEntities off can lead to faster parsing, in that case + Switching this option on and the validation and substDTDEntities off can lead to faster parsing, + in that case reading the DTD documents is not longer necessary, HTML general entities are still substituted. Only used with XML parsed documents, not with HTML parsing. @@ -222,7 +224,8 @@ getSysVar (theParseByMimeType .&&&. theParseHTML .&&&. theAcceptedMimeTypes .&&&. - theRelaxValidate + theRelaxValidate .&&&. + theXmlSchemaValidate ) ) ) @@ -276,7 +279,12 @@ processDoc' mimeType options ) - processDoc' mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax))) + processDoc' mimeType ( parseByMimeType + , ( parseHtml + , ( acceptedMimeTypes + , ( validateWithRelax + , validateWithXmlSchema + )))) = ( if isAcceptedMimeType acceptedMimeTypes mimeType then ( processNoneEmptyDoc ( ( parse $< getSysVar (theValidate .&&&. @@ -307,7 +315,7 @@ ) ) >>> - relax + relaxOrXmlSchema ) else this ) @@ -339,7 +347,13 @@ (mi == mis || mis == "*") ) || r - parse (validate, (substDTD, (substHTML, (removeNoneXml, (withTagSoup', withExpat'))))) + parse ( validate + , ( substDTD + , ( substHTML + , ( removeNoneXml + , ( withTagSoup' + , withExpat' + ))))) | not isXmlOrHtml = if removeNoneXml then replaceChildren none -- don't parse, if mime type is not XML nor HTML else this -- but remove contents when option is set @@ -352,7 +366,11 @@ | isXml = if withExpat' then parseXmlDocumentWithExpat - else parseXmlDocument validate substDTD substHTML validateWithRelax + else parseXmlDocument + validate + substDTD + substHTML + validateWithRelax -- parse as XML | otherwise = this -- suppress warning @@ -363,25 +381,35 @@ | withNamespaces || - validateWithRelax = propagateAndValidateNamespaces -- RelaxNG requires correct namespaces + validateWithRelax + || + validateWithXmlSchema + = propagateAndValidateNamespaces -- RelaxNG and XML Schema require correct namespaces | otherwise = this canonicalize (preserveCmt, (canonicalize', withTagSoup')) | withTagSoup' = this -- tagsoup already removes redundant stuff - | validateWithRelax = canonicalizeAllNodes + | validateWithRelax + || + validateWithXmlSchema = canonicalizeAllNodes -- no comments in schema validation + | canonicalize' && preserveCmt = canonicalizeForXPath | canonicalize' = canonicalizeAllNodes | otherwise = this - relax + relaxOrXmlSchema + | validateWithXmlSchema = withoutUserState $< getSysVar theXmlSchemaValidator | validateWithRelax = withoutUserState $< getSysVar theRelaxValidator | otherwise = this whitespace (removeWS, withTagSoup') - | removeWS + | ( removeWS + || + validateWithXmlSchema -- XML Schema does not like WS + ) && not withTagSoup' = removeDocWhiteSpace -- tagsoup already removes whitespace | otherwise = this diff --git a/src/Text/XML/HXT/Arrow/XmlRegex.hs b/src/Text/XML/HXT/Arrow/XmlRegex.hs --- a/src/Text/XML/HXT/Arrow/XmlRegex.hs +++ b/src/Text/XML/HXT/Arrow/XmlRegex.hs @@ -11,7 +11,7 @@ Regular Expression Matcher working on lists of XmlTrees - It's intendet to import this module with an explicit + It's intended to import this module with an explicit import declaration for not spoiling the namespace with these somewhat special arrows @@ -24,6 +24,7 @@ , mkZero , mkUnit , mkPrim + , mkPrim' , mkPrimA , mkDot , mkStar @@ -34,6 +35,9 @@ , mkRep , mkRng , mkOpt + , mkPerm + , mkPerms + , mkMerge , nullable , delta , matchXmlRegex @@ -50,6 +54,7 @@ import Data.Maybe import Text.XML.HXT.DOM.Interface +import Text.XML.HXT.DOM.ShowXml ( xshow ) -- ------------------------------------------------------------ -- the exported regex arrows @@ -88,13 +93,15 @@ data XmlRegex = Zero String | Unit - | Sym (XmlTree -> Bool) + | Sym (XmlTree -> Bool) String -- optional external repr. of predicate | Dot - | Star XmlRegex - | Alt XmlRegex XmlRegex - | Seq XmlRegex XmlRegex - | Rep Int XmlRegex -- 1 or more repetitions - | Rng Int Int XmlRegex -- n..m repetitions + | Star XmlRegex + | Alt XmlRegex XmlRegex + | Seq XmlRegex XmlRegex + | Rep Int XmlRegex -- 1 or more repetitions + | Rng Int Int XmlRegex -- n..m repetitions + | Perm XmlRegex XmlRegex + | Merge XmlRegex XmlRegex -- ------------------------------------------------------------ @@ -106,7 +113,7 @@ instance Inv XmlRegex where inv (Zero _) = True inv Unit = True - inv (Sym p) = p holds for some XmlTrees + inv (Sym p _) = p holds for some XmlTrees inv Dot = True inv (Star e) = inv e inv (Alt e1 e2) = inv e1 && @@ -116,6 +123,8 @@ inv (Rep i e) = i > 0 && inv e inv (Rng i j e) = (i < j || (i == j && i > 1)) && inv e + inv (Perm e1 e2) = inv e1 && + inv e2 -} -- ------------------------------------------------------------ -- @@ -128,8 +137,11 @@ mkUnit = Unit mkPrim :: (XmlTree -> Bool) -> XmlRegex -mkPrim = Sym +mkPrim p = Sym p "" +mkPrim' :: (XmlTree -> Bool) -> String -> XmlRegex +mkPrim' = Sym + mkPrimA :: LA XmlTree XmlTree -> XmlRegex mkPrimA a = mkPrim (not . null . runLA a) @@ -155,9 +167,14 @@ mkAlt (Zero _) e2 = e2 -- {} u e2 = e2 mkAlt e1@(Star Dot) _e2 = e1 -- A* u e1 = A* mkAlt _e1 e2@(Star Dot) = e2 -- e1 u A* = A* -mkAlt (Sym p1) (Sym p2) = mkPrim $ \ x -> p1 x || p2 x -- melting of predicates -mkAlt e1 e2@(Sym _) = mkAlt e2 e1 -- symmetry: predicates always first -mkAlt e1@(Sym _) (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates +mkAlt (Sym p1 e1) (Sym p2 e2) = mkPrim' (\ x -> p1 x || p2 x) (e e1 e2) -- melting of predicates + where + e "" x2 = x2 + e x1 "" = x1 + e x1 x2 = x1 ++ "|" ++ x2 +mkAlt e1 e2@(Sym _ _) = mkAlt e2 e1 -- symmetry: predicates always first +mkAlt e1@(Sym _ _) (Alt e2@(Sym _ _) e3) + = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates mkAlt (Alt e1 e2) e3 = mkAlt e1 (mkAlt e2 e3) -- associativity mkAlt e1 e2 = Alt e1 e2 @@ -195,12 +212,30 @@ mkOpt :: XmlRegex -> XmlRegex mkOpt = mkRng 0 1 +mkPerm :: XmlRegex -> XmlRegex -> XmlRegex +mkPerm e1@(Zero _) _ = e1 +mkPerm _ e2@(Zero _) = e2 +mkPerm Unit e2 = e2 +mkPerm e1 Unit = e1 +mkPerm e1 e2 = Perm e1 e2 + +mkPerms :: [XmlRegex] -> XmlRegex +mkPerms = foldr mkPerm mkUnit + +mkMerge :: XmlRegex -> XmlRegex -> XmlRegex +mkMerge e1@(Zero _) _ = e1 +mkMerge _ e2@(Zero _) = e2 +mkMerge Unit e2 = e2 +mkMerge e1 Unit = e1 +mkMerge e1 e2 = Merge e1 e2 + -- ------------------------------------------------------------ instance Show XmlRegex where show (Zero s) = "{err:" ++ s ++ "}" show Unit = "()" - show (Sym _p) = "{single tree pred}" + show (Sym _p "") = "" + show (Sym _p r ) = r show Dot = "." show (Star e) = "(" ++ show e ++ ")*" show (Alt e1 e2) = "(" ++ show e1 ++ "|" ++ show e2 ++ ")" @@ -209,13 +244,28 @@ show (Rep i e) = "(" ++ show e ++ "){" ++ show i ++ ",}" show (Rng 0 1 e) = "(" ++ show e ++ ")?" show (Rng i j e) = "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}" + show (Perm e1 e2) = "(" ++ show e1 ++ show e2 ++ "|" ++ show e2 ++ show e1 ++ ")" + show (Merge e1 e2) = "(" ++ show e1 ++ "&" ++ show e2 ++ ")" -- ------------------------------------------------------------ +unexpected :: XmlTree -> String -> String +unexpected t e = emsg e ++ (cut 80 . xshow) [t] + where + emsg "" = "unexpected: " + emsg s = "expected: " ++ s ++ ", but got: " + cut n s + | null rest = s' + | otherwise = s' ++ "..." + where + (s', rest) = splitAt n s + +-- ------------------------------------------------------------ + nullable :: XmlRegex -> Bool nullable (Zero _) = False nullable Unit = True -nullable (Sym _p) = False -- assumption: p holds for at least one tree +nullable (Sym _p _) = False -- assumption: p holds for at least one tree nullable Dot = False nullable (Star _) = True nullable (Alt e1 e2) = nullable e1 || @@ -225,25 +275,34 @@ nullable (Rep _i e) = nullable e nullable (Rng i _ e) = i == 0 || nullable e +nullable (Perm e1 e2) = nullable e1 && + nullable e2 +nullable (Merge e1 e2) = nullable e1 && + nullable e2 -- ------------------------------------------------------------ delta :: XmlRegex -> XmlTree -> XmlRegex -delta e@(Zero _) _ = e -delta Unit c = mkZero $ - "unexpected char " ++ show c -delta (Sym p) c +delta e@(Zero _) _ = e +delta Unit c = mkZero $ unexpected c "" +delta (Sym p e) c | p c = mkUnit - | otherwise = mkZero $ - "unexpected tree " ++ show c -delta Dot _ = mkUnit -delta e@(Star e1) c = mkSeq (delta e1 c) e -delta (Alt e1 e2) c = mkAlt (delta e1 c) (delta e2 c) -delta (Seq e1 e2) c + | otherwise = mkZero $ unexpected c e +delta Dot _ = mkUnit +delta e@(Star e1) c = mkSeq (delta e1 c) e +delta (Alt e1 e2) c = mkAlt (delta e1 c) (delta e2 c) +delta (Seq e1 e2) c | nullable e1 = mkAlt (mkSeq (delta e1 c) e2) (delta e2 c) | otherwise = mkSeq (delta e1 c) e2 -delta (Rep i e) c = mkSeq (delta e c) (mkRep (i-1) e) -delta (Rng i j e) c = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e) +delta (Rep i e) c = mkSeq (delta e c) (mkRep (i-1) e) +delta (Rng i j e) c = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e) +delta (Perm e1 e2) c = case e1' of + (Zero _) -> mkPerm e1 (delta e2 c) + _ -> mkPerm e1' e2 + where + e1' = delta e1 c +delta (Merge e1 e2) c = mkAlt (mkMerge (delta e1 c) e2) + (mkMerge e1 (delta e2 c)) -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Arrow/XmlState.hs b/src/Text/XML/HXT/Arrow/XmlState.hs --- a/src/Text/XML/HXT/Arrow/XmlState.hs +++ b/src/Text/XML/HXT/Arrow/XmlState.hs @@ -104,7 +104,7 @@ , setMimeTypeTable , setMimeTypeTableFromFile - , -- System Configuration and options + , -- * System Configuration and Options yes , no diff --git a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs --- a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs +++ b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs @@ -95,6 +95,7 @@ , xioParseConfig = initialParseConfig , xioOutputConfig = initialOutputConfig , xioRelaxConfig = initialRelaxConfig + , xioXmlSchemaConfig = initialXmlSchemaConfig , xioCacheConfig = initialCacheConfig } @@ -158,6 +159,13 @@ , xioRelaxValidator = dummyRelaxValidator } +initialXmlSchemaConfig :: XIOXmlSchemaConfig +initialXmlSchemaConfig = XIOScc + { xioXmlSchemaValidate = False + , xioXmlSchemaSchema = "" + , xioXmlSchemaValidator = dummyXmlSchemaValidator + } + initialCacheConfig :: XIOCacheConfig initialCacheConfig = XIOCch { xioBinaryCompression = id @@ -208,6 +216,14 @@ [ "RelaxNG validator not configured," , "please install package hxt-relaxng" , " and use 'withRelaxNG' config option from this package" + ] + +dummyXmlSchemaValidator :: IOSArrow b b +dummyXmlSchemaValidator = issueFatal $ + unlines $ + [ "XML Schema validator not configured," + , "please install package hxt-xmlschema" + , " and use 'withXmlSchema' config option from this package" ] dummyCacheRead :: String -> IOSArrow b b diff --git a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs --- a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs +++ b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs @@ -180,6 +180,7 @@ , xioParseConfig :: ! XIOParseConfig , xioOutputConfig :: ! XIOOutputConfig , xioRelaxConfig :: ! XIORelaxConfig + , xioXmlSchemaConfig :: ! XIOXmlSchemaConfig , xioCacheConfig :: ! XIOCacheConfig } @@ -237,6 +238,11 @@ , xioRelaxValidator :: IOSArrow XmlTree XmlTree } +data XIOXmlSchemaConfig = XIOScc { xioXmlSchemaValidate :: ! Bool + , xioXmlSchemaSchema :: String + , xioXmlSchemaValidator :: IOSArrow XmlTree XmlTree + } + data XIOCacheConfig = XIOCch { xioBinaryCompression :: CompressionFct , xioBinaryDeCompression :: DeCompressionFct , xioWithCache :: ! Bool @@ -495,12 +501,42 @@ , setS = \ x s -> s { xioRelaxCollectErrors = x} } -theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree) -theRelaxValidator = theRelaxConfig - >>> - S { getS = xioRelaxValidator - , setS = \ x s -> s { xioRelaxValidator = x} - } +theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree) +theRelaxValidator = theRelaxConfig + >>> + S { getS = xioRelaxValidator + , setS = \ x s -> s { xioRelaxValidator = x} + } + +-- ---------------------------------------- + +theXmlSchemaConfig :: Selector XIOSysState XIOXmlSchemaConfig +theXmlSchemaConfig = theSysEnv + >>> + S { getS = xioXmlSchemaConfig + , setS = \ x s -> s { xioXmlSchemaConfig = x} + } + +theXmlSchemaValidate :: Selector XIOSysState Bool +theXmlSchemaValidate = theXmlSchemaConfig + >>> + S { getS = xioXmlSchemaValidate + , setS = \ x s -> s { xioXmlSchemaValidate = x} + } + +theXmlSchemaSchema :: Selector XIOSysState String +theXmlSchemaSchema = theXmlSchemaConfig + >>> + S { getS = xioXmlSchemaSchema + , setS = \ x s -> s { xioXmlSchemaSchema = x} + } + +theXmlSchemaValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree) +theXmlSchemaValidator = theXmlSchemaConfig + >>> + S { getS = xioXmlSchemaValidator + , setS = \ x s -> s { xioXmlSchemaValidator = x} + } -- ---------------------------------------- diff --git a/src/Text/XML/HXT/DOM/QualifiedName.hs b/src/Text/XML/HXT/DOM/QualifiedName.hs --- a/src/Text/XML/HXT/DOM/QualifiedName.hs +++ b/src/Text/XML/HXT/DOM/QualifiedName.hs @@ -181,6 +181,9 @@ && -- and prefixes are not set or they are equal px1 == px2 +instance Ord QName where + compare x y = compare (qualifiedName x) (qualifiedName y) + instance NFData QName instance WNFData QName diff --git a/src/Text/XML/HXT/IO/GetFILE.hs b/src/Text/XML/HXT/IO/GetFILE.hs --- a/src/Text/XML/HXT/IO/GetFILE.hs +++ b/src/Text/XML/HXT/IO/GetFILE.hs @@ -31,8 +31,8 @@ import System.IO.Error ( ioeGetErrorString ) import System.Directory ( doesFileExist - , getPermissions - , readable + -- , getPermissions + -- , readable ) import Text.XML.HXT.DOM.XmlKeywords @@ -66,8 +66,9 @@ case source'' of Nothing -> return $ fileErr "file not found" Just fn -> do - perm <- getPermissions fn - if not (readable perm) + -- perm <- getPermissions fn -- getPermission may fail + -- if not (readable perm) + if False then return $ fileErr "file not readable" else do c <- try $ diff --git a/src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs b/src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs --- a/src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs +++ b/src/Text/XML/HXT/XMLSchema/DataTypeLibW3CNames.hs @@ -26,7 +26,6 @@ w3cNS :: String w3cNS = "http://www.w3.org/2001/XMLSchema-datatypes" - xsd_string , xsd_normalizedString , xsd_token @@ -58,8 +57,21 @@ , xsd_unsignedLong , xsd_unsignedInt , xsd_unsignedShort - , xsd_unsignedByte :: String + , xsd_unsignedByte + , xsd_boolean + , xsd_float + , xsd_double + , xsd_time + , xsd_duration + , xsd_date + , xsd_dateTime + , xsd_gDay + , xsd_gMonth + , xsd_gMonthDay + , xsd_gYear + , xsd_gYearMonth :: String + xsd_string = "string" xsd_normalizedString = "normalizedString" xsd_token = "token" @@ -93,6 +105,18 @@ xsd_unsignedShort = "unsignedShort" xsd_unsignedByte = "unsignedByte" +xsd_boolean = "boolean" +xsd_float = "float" +xsd_double = "double" +xsd_time = "time" +xsd_duration = "duration" +xsd_date = "date" +xsd_dateTime = "dateTime" +xsd_gDay = "gDay" +xsd_gMonth = "gMonth" +xsd_gMonthDay = "gMonthDay" +xsd_gYear = "gYear" +xsd_gYearMonth = "gYearMonth" xsd_length , xsd_maxLength @@ -104,7 +128,8 @@ , xsd_totalDigits , xsd_fractionDigits , xsd_pattern - , xsd_enumeration :: String + , xsd_enumeration + , xsd_whiteSpace :: String xsd_length = "length" xsd_maxLength = "maxLength" @@ -120,5 +145,7 @@ xsd_pattern = "pattern" xsd_enumeration = "enumeration" + +xsd_whiteSpace = "whiteSpace" -- ----------------------------------------