hxt 9.2.1 → 9.2.2

raw patch · 7 files changed

+121/−48 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hxt.cabal +3/−1
• src/Text/XML/HXT/Arrow/Pickle/Xml.hs +6/−2
• src/Text/XML/HXT/Arrow/ReadDocument.hs +78/−38
• src/Text/XML/HXT/Arrow/XmlState.hs +1/−0
• src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs +2/−0
• src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs +14/−1
• src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs +17/−6

@@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name:           hxt-Version:        9.2.1+Version:        9.2.2 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,6 +15,8 @@                 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 to 9.2.1: user defined mime type handlers added                 .                 Changes to 9.2.0: New warnings from ghc-7.4 removed License:        MIT

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}  -- ------------------------------------------------------------ @@ -69,7 +70,7 @@ import           Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString) import           Text.XML.HXT.Arrow.XmlState -{- just for embedded test cases+{- just for embedded test cases, prefix with -- to activate import           Text.XML.HXT.Arrow.XmlArrow import qualified Control.Arrow.ListArrows         as X -- -}@@ -1262,6 +1263,7 @@                       , \ (Assign n v) -> (n, v)                       ) $                ( xpElem "assign" $+                 xpFilterCont (neg $ hasName "comment" <+> isText) $  -- test case test7: remove uninteresting stuff                  xpPair (xpAttr "name" xpText)                          xpickle                )@@ -1376,6 +1378,8 @@ test4 = test1' (processTopDown (setQName (mkName "xxx")  `X.when` hasName "program")) test5 = test1' (processTopDown (setQName (mkName "xxx")  `X.when` hasName "assign")) test6 = test1' (processTopDownWithAttrl  (txt "xxx"      `X.when` hasText (== "UMinus")))+test7 = test1' (processTopDown (insertComment            `X.when` hasName "assign"))+    where insertComment = replaceChildren (getChildren <+> eelem "comment" <+> txt "zzz")  -- ------------------------------------------------------------ 

@@ -27,6 +27,10 @@  import Control.Arrow.ListArrows +import Data.Maybe                               ( fromMaybe )+import qualified Data.Map                       as M++ import Text.XML.HXT.DOM.Interface  import Text.XML.HXT.Arrow.XmlArrow@@ -118,7 +122,7 @@ >              , withInputEncoding   isoLatin1 >              , withParseByMimeType yes >              , withCurl []->              ] \"http:\/\/localhost\/test.php\"+>              ] "http://localhost/test.php"  reads document \"test.php\", parses it as HTML or XML depending on the mimetype given from the server, but without validation, default encoding 'isoLatin1'. HTTP access is done via libCurl.@@ -200,10 +204,12 @@       >>>       readD $< getSysVar theWithCache     where-    readD True  = constA undefined              -- just for generalizing the signature to: IOStateArrow s b       XmlTree-                  >>>                           -- instead of                              IOStateArrow s XmlTree XmlTree-                  (withoutUserState $< (getSysVar theCacheRead >>^ ($ src)))-    readD False = readDocument'' src+    readD True+        = constA undefined              -- just for generalizing the signature to: IOStateArrow s b       XmlTree+          >>>                           -- instead of                              IOStateArrow s XmlTree XmlTree+          (withoutUserState $< (getSysVar theCacheRead >>^ ($ src)))+    readD False+        = readDocument'' src  readDocument''   :: String -> IOStateArrow s b XmlTree readDocument'' src@@ -227,16 +233,52 @@       >>>       traceTree     where+    processNoneEmptyDoc p+        = ifA (fromLA hasEmptyBody)+              (replaceChildren none)+              p+        where+          hasEmptyBody+              = hasAttrValue transferStatus (/= "200")        -- test on empty response body for not o.k. responses+                `guards`                                      -- e.g. 3xx status values+                ( neg getChildren+                  <+>+                  ( getChildren >>> isWhiteSpace )+                )+     getMimeType         = getAttrValue transferMimeType >>^ stringToLower -    processDoc mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax)))+    applyMimeTypeHandler mt+        = withoutUserState (applyMTH $< getSysVar theMimeTypeHandlers)+        where+          applyMTH mtTable+              = fromMaybe none $+                fmap (\ f -> processNoneEmptyDoc+                             (traceMimeStart >>> f >>> traceMimeEnd)+                     ) $+                M.lookup mt mtTable+          traceMimeStart+              = traceMsg 2 $+                "readDocument: calling user defined document parser"+          traceMimeEnd+              = traceMsg 2 $+                "readDocument: user defined document parser finished"++    processDoc mimeType options         = traceMsg 1 (unwords [ "readDocument:", show src-                              , "(mime type:", show mimeType, ") will be processed"])+                              , "(mime type:", show mimeType, ") will be processed"+                              ]+                     )           >>>-          ( if isAcceptedMimeType acceptedMimeTypes mimeType-            then ( ifA (fromLA hasEmptyBody)-                   ( replaceChildren none )               -- empty response, e.g. in if-modified-since request+          ( applyMimeTypeHandler mimeType       -- try user defined document handlers+            `orElse`+            processDoc' mimeType options+          )++    processDoc' mimeType (parseByMimeType, (parseHtml, (acceptedMimeTypes, validateWithRelax)))+        = ( if isAcceptedMimeType acceptedMimeTypes mimeType+            then ( processNoneEmptyDoc                    ( ( parse $< getSysVar (theValidate              .&&&.                                            theSubstDTDEntities      .&&&.                                            theSubstHTMLEntities     .&&&.@@ -274,18 +316,10 @@             else ( traceMsg 1 (unwords [ "readDocument:", show src                                        , "mime type:", show mimeType, "not accepted"])                    >>>-                   replaceChildren none-                 )                                                                      -- remove contents of not accepted mimetype+                   replaceChildren none         -- 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@@ -373,8 +407,9 @@ -- | -- the arrow version of 'readDocument', the arrow input is the source URI -readFromDocument        :: SysConfigList -> IOStateArrow s String XmlTree-readFromDocument config = applyA ( arr $ readDocument config )+readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree+readFromDocument config+    = applyA ( arr $ readDocument config )  -- ------------------------------------------------------------ @@ -386,18 +421,20 @@ -- -- Default encoding: No encoding is done, the String argument is taken as Unicode string -readString              :: SysConfigList -> String -> IOStateArrow s b XmlTree+readString :: SysConfigList -> String -> IOStateArrow s b XmlTree readString config content-                        = readDocument (withInputEncoding unicodeString : config)-                          (stringProtocol ++ content)+    = readDocument+      (withInputEncoding unicodeString : config)+      (stringProtocol ++ content)  -- ------------------------------------------------------------  -- | -- the arrow version of 'readString', the arrow input is the source URI -readFromString          :: SysConfigList -> IOStateArrow s String XmlTree-readFromString config   = applyA ( arr $ readString config )+readFromString :: SysConfigList -> IOStateArrow s String XmlTree+readFromString config+    = applyA ( arr $ readString config )  -- ------------------------------------------------------------ @@ -410,16 +447,17 @@ -- This is a simpler version of 'readFromString' without any options, -- but it does not run in the IO monad. -hread                   :: ArrowXml a => a String XmlTree-hread                   = fromLA $-                          parseHtmlContent                      -- substHtmlEntityRefs is done in parser-                          >>>                                   -- as well as subst HTML char refs-                          editNTreeA [isError :-> none]         -- ignores all errors+hread :: ArrowXml a => a String XmlTree+hread+    = fromLA $+      parseHtmlContent                      -- substHtmlEntityRefs is done in parser+      >>>                                   -- as well as subst HTML char refs+      editNTreeA [isError :-> none]         -- ignores all errors  {- no longer neccesary, text nodes are merged in parser-                          >>>-                          canonicalizeContents--}+      >>>+      canonicalizeContents+-- -}  -- ------------------------------------------------------------ @@ -427,15 +465,17 @@ -- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree -- This xread arrow delegates all work to the xread parser function in module XmlParsec -xread                   :: ArrowXml a => a String XmlTree-xread                   = parseXmlContent+xread :: ArrowXml a => a String XmlTree+xread+    = parseXmlContent+ {- -- the old version, where the parser does not subst char refs and cdata xread                   = root [] [parseXmlContent]       -- substXmlEntityRefs is done in parser                           >>>                           canonicalizeContents                           >>>                           getChildren--}+-- -}  -- ------------------------------------------------------------ 

@@ -125,6 +125,7 @@     , withInputOption     , withInputOptions     , withMimeTypeFile+    , withMimeTypeHandler     , withNoEmptyElemFor     , withXmlPi     , withOutputEncoding

@@ -21,6 +21,7 @@ import Control.Arrow.ArrowList import Control.Arrow.IOStateListArrow +import Data.Map                                 ( empty ) import Text.XML.HXT.DOM.Interface  import Text.XML.HXT.Arrow.XmlArrow@@ -111,6 +112,7 @@ initialParseConfig              :: XIOParseConfig initialParseConfig              = XIOPcfg                                   { xioMimeTypes                = defaultMimeTypeTable+                                  , xioMimeTypeHandlers         = empty                                   , xioMimeTypeFile             = ""                                   , xioAcceptedMimeTypes        = []                                   , xioFileMimeType             = ""

@@ -20,6 +20,8 @@  import Control.Arrow +import Data.Map                         ( insert )+ import Text.XML.HXT.DOM.Interface  import Text.XML.HXT.Arrow.XmlState.ErrorHandling@@ -39,9 +41,19 @@ withSysAttr                     :: String -> String -> SysConfig withSysAttr n v                 = chgS theAttrList (addEntry n v) +-- | Specify the set of accepted mime types.+--+-- All contents of documents for which the mime type is not found in this list+-- are discarded.+ withAcceptedMimeTypes           :: [String] -> SysConfig withAcceptedMimeTypes           = setS theAcceptedMimeTypes +-- | Specify a content handler for documents of a given mime type++withMimeTypeHandler             :: String -> IOSArrow XmlTree XmlTree -> SysConfig+withMimeTypeHandler mt pa       = chgS theMimeTypeHandlers $ insert mt pa+ -- | @withMimeTypeFile filename@ : input option, -- set the mime type table for @file:@ documents by given file. -- The format of this config file must be in the syntax of a debian linux \"mime.types\" config file@@ -208,7 +220,8 @@ withOutputHTML                  :: SysConfig withOutputHTML                  = setS theOutputFmt HTMLoutput --- | Write XML: quote only special XML chars, don't substitute chars by HTML entities, and don\'t generate empty elements for HTML elements,+-- | Write XML: quote only special XML chars, don't substitute chars by HTML entities,+-- and don\'t generate empty elements for HTML elements, -- which may contain any contents, e.g. @<script src=...></script>@ instead of @<script src=... />@  withOutputXHTML                 :: SysConfig

@@ -51,6 +51,7 @@                                         , idS                                         , (.&&&.)                                         )+import qualified Data.Map               as M  import Text.XML.HXT.DOM.Interface @@ -192,6 +193,7 @@                                   }  data XIOParseConfig     = XIOPcfg { xioMimeTypes                ::   MimeTypeTable+                                  , xioMimeTypeHandlers         ::   MimeTypeHandlers                                   , xioMimeTypeFile             ::   String                                   , xioAcceptedMimeTypes        ::   [String]                                   , xioFileMimeType             ::   String@@ -245,11 +247,13 @@                                   , xioStrictDeserialize        :: ! Bool                                   } +type MimeTypeHandlers   = M.Map String (IOSArrow XmlTree XmlTree)+ type CompressionFct     = ByteString -> ByteString type DeCompressionFct   = ByteString -> ByteString -type SysConfig                  = XIOSysState -> XIOSysState-type SysConfigList              = [SysConfig]+type SysConfig          = XIOSysState -> XIOSysState+type SysConfigList      = [SysConfig]  -- ---------------------------------------- @@ -566,6 +570,13 @@                                     , setS = \ x s -> s { xioMimeTypes = x }                                     } +theMimeTypeHandlers             :: Selector XIOSysState MimeTypeHandlers+theMimeTypeHandlers             = theParseConfig+                                  >>>+                                  S { getS = xioMimeTypeHandlers+                                    , setS = \ x s -> s { xioMimeTypeHandlers = x }+                                    }+ theMimeTypeFile                 :: Selector XIOSysState String theMimeTypeFile                 = theParseConfig                                   >>>@@ -857,9 +868,9 @@  toInt                   :: Int -> String -> Int toInt def s-        | not (null s)-          &&-          all isDigit s = read s-        | otherwise     = def+    | not (null s)+      &&+      all isDigit s     = read s+    | otherwise         = def  -- ------------------------------------------------------------