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.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 diff --git a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs --- a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs +++ b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs @@ -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") -- ------------------------------------------------------------ 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 @@ -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 --} +-- -} -- ------------------------------------------------------------ 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 @@ -125,6 +125,7 @@ , withInputOption , withInputOptions , withMimeTypeFile + , withMimeTypeHandler , withNoEmptyElemFor , withXmlPi , withOutputEncoding 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 @@ -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 = "" diff --git a/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs b/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs --- a/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs +++ b/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs @@ -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. @@ instead of @