diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,19 @@ +See also http://pvp.haskell.org/faq + +### 0.3.1.0 + +- New `xmlns_elem_wellformed` predicate for verifying namespace-wellformedness +- New `qnameToText` and `qnameFromText` conversion functions +- Explicitly declare SafeHaskell levels; ensure all public modules are "Safe" +- Fix pure exception bypassing proper failure reporting +- Fix attribute uniqueness violations not being detected +- Fix too lax validation of `PITarget`s +- Improve too lax validation of namespace names +- Fix too lax validation of entity references + +## 0.3.0.0 + +- New `SerializeXMLOptions(serializeSortAttributes)` option +- Add new `Serializexmlroot +- Major refactoring of `Text.XML.Cursor` API +- un-`Maybe` the `QName(qURI)` field diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/X.cabal b/X.cabal --- a/X.cabal +++ b/X.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: X -version: 0.3.0.0 +version: 0.3.1.0 license: BSD-3-Clause AND GPL-3.0-or-later license-files: LICENSE LICENSE.GPLv3 @@ -24,6 +24,9 @@ * . +extra-source-files: + ChangeLog.md + library hs-source-dirs: src exposed-modules: @@ -38,6 +41,8 @@ Common Utils Text.XML.Lexer + Text.XML.NS + Text.XML.Types.Core Text.XML.Types.Internal build-depends: @@ -47,6 +52,7 @@ || ^>= 4.10.0 || ^>= 4.11.0 || ^>= 4.12.0 + || ^>= 4.13.0 , bytestring ^>= 0.10.4 , deepseq ^>= 1.3.0 || ^>= 1.4.0 @@ -56,8 +62,20 @@ ghc-options: -Wall default-language: Haskell2010 other-extensions: + BangPatterns DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + OverloadedStrings + RecordWildCards + Safe + ScopedTypeVariables + Trustworthy TypeSynonymInstances source-repository head diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + -- | -- Module : Common -- Copyright : (c) Herbert Valerio Riedel 2019 @@ -10,6 +12,7 @@ import Control.Applicative as X import Control.DeepSeq as X (NFData (rnf), deepseq) +import Control.Monad as X (guard) import Data.Data as X (Data) import Data.Foldable as X (Foldable) import Data.List as X (sort) @@ -23,4 +26,3 @@ import Data.Typeable as X (Typeable) import Data.Word as X import GHC.Generics as X (Generic) - diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} {- diff --git a/src/Text/XML/Cursor.hs b/src/Text/XML/Cursor.hs --- a/src/Text/XML/Cursor.hs +++ b/src/Text/XML/Cursor.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {- diff --git a/src/Text/XML/Input.hs b/src/Text/XML/Input.hs --- a/src/Text/XML/Input.hs +++ b/src/Text/XML/Input.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} -- | -- Module : Text.XML.Input @@ -31,6 +31,7 @@ import Utils import Text.XML.Lexer +import Text.XML.NS import Text.XML.Types import qualified Data.Text as T @@ -75,10 +76,10 @@ (rootPostElem,ts5) <- mnodes2 ts4 case ts5 of - [] -> pure Root{..} + [] -> pure Root{..} (_:_) -> Left (-1,"unexpected (non-misc) content nodes after root element") where - ts0 = scanXML (dropBOM xs0) + ts0 = scanXML' (dropBOM xs0) -- mnodes :: [Token] -> Either _ ([MiscNodes],[Token]) @@ -101,9 +102,9 @@ | isWsCdata cdata = go acc rest go acc xs = pure (reverse acc, xs) - -isWsCdata :: CData -> Bool -isWsCdata (CData _ t) = T.all isS t + isWsCdata :: CData -> Bool + isWsCdata (CData CDataText t) = T.all isS t + isWsCdata (CData _ _) = False -- | parseXML to a list of 'Content' chunks -- @@ -187,18 +188,22 @@ nodes cur_info ps (TokStart pos t as empty' : ts) = (node : siblings, open, toks) where - new_name = annotName new_info t + new_name = if nsfail then t else annotName new_info t prefixes = filter (/= "xmlns") $ mapMaybe qPrefix (t : [ k | Attr k _ <- as ]) nsfail = any (==Nothing) [ lookup pfx (fst new_info) | pfx <- prefixes ] - rsvnsfail = not (all checkNS as) + rsvnsfail = not (all xmlns_attr_wellformed as) new_info = foldr addNS cur_info as node | rsvnsfail = Failure pos "invalid namespace declaration" | nsfail = Failure pos "undefined namespace prefix" + | Just "xmlns" <- qPrefix t = Failure pos "invalid 'xmlns'-prefixed element name" | otherwise = - ElemF Element { elName = new_name - , elAttribs = map (annotAttr new_info) as - , elContent = children - } + let as' = map (annotAttr new_info) as + in if not (noDupes (map attrKey as')) + then Failure pos "attribute uniqueness violated" + else ElemF Element { elName = new_name + , elAttribs = as' + , elContent = children + } (children,(siblings,open,toks)) | empty' = ([], nodes cur_info ps ts) @@ -240,27 +245,7 @@ addNS :: Attr -> NSInfo -> NSInfo addNS (Attr { attrKey = key, attrVal = val }) (ns,def) = case (qPrefix key, qLName key) of - (Nothing,"xmlns") -> (ns, if T.null val then nullNs else (URI (TS.fromText val))) + (Nothing,"xmlns") -> (ns, if T.null val then nullNs else (URI (TS.fromText val))) (Just "xmlns", "xml") -> (ns,def) - (Just "xmlns", k) -> ((unLName k, URI (TS.fromText val)) : ns, def) - _ -> (ns,def) - --- | Check rules imposed on reserved namespaces by https://www.w3.org/TR/xml-names/ -checkNS :: Attr -> Bool -checkNS = \case - (Attr (QName { qPrefix = Just "xmlns", qLName = "xmlns"}) _ ) -> False - (Attr (QName { qPrefix = Just "xmlns", qLName = "xml"}) uri) -> uri == xmlNamesNS' - (Attr (QName { qPrefix = Just "xmlns", qLName = _}) uri) -> not (T.null uri) && isNotRsvd uri - (Attr (QName { qPrefix = Nothing , qLName = "xmlns"}) "") -> True - (Attr (QName { qPrefix = Nothing , qLName = "xmlns"}) uri) -> isNotRsvd uri - _ -> True - where - xmlNamesNS' = TS.toText (unURI xmlNamesNS) - xmlnsNS' = TS.toText (unURI xmlnsNS) - isNotRsvd uri = not (uri == xmlNamesNS' || uri == xmlnsNS') - -xmlNamesNS :: URI -xmlNamesNS = URI ns_xml_uri - -xmlnsNS :: URI -xmlnsNS = URI ns_xmlns_uri + (Just "xmlns", k) -> ((unLName k, URI (TS.fromText val)) : ns, def) + _ -> (ns,def) diff --git a/src/Text/XML/Lexer.hs b/src/Text/XML/Lexer.hs --- a/src/Text/XML/Lexer.hs +++ b/src/Text/XML/Lexer.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE TypeSynonymInstances #-} {- @@ -75,7 +76,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Short as TS -import Numeric (readHex) nullNs :: URI nullNs = URI mempty @@ -112,6 +112,8 @@ type LChar = (Pos,Char) type LString = [LChar] +type LexCont = LString -> [Token] + -- | XML Lexer token. data Token = TokStart !Pos QName [Attr] Bool -- ^ opening start-tag (the 'Bool' field denotes whether this is an empty tag) @@ -132,12 +134,18 @@ -- | Run XML lexer over 'XmlSource' scanXML :: XmlSource source => source -> [Token] -scanXML = tokens0 . eolNorm . go 0 +scanXML = tokens2 . eolNorm . go 0 where go !n src = case uncons src of Just (c,src') -> (n,c) : go (n+1) src' Nothing -> [] +scanXML' :: XmlSource source => source -> [Token] +scanXML' = tokens1 . eolNorm . go 0 + where + go !n src = case uncons src of + Just (c,src') -> (n,c) : go (n+1) src' + Nothing -> [] {- @@ -155,32 +163,45 @@ eolNorm ((n,'\xD'):cs) = (n,'\xA') : eolNorm cs eolNorm (c:cs) = c : eolNorm cs - - -tokens0 :: LString -> [Token] --- tokens0 ((_,'<'):(_,'?'):(_,'x'):(_,'m'):(_,'l'):(_,c):cs) --- | isS c = go1 (dropSpace cs) --- where --- go1 ((_,'v'):(_,'e'):(_,'r'):(_,'s'):(_,'i'):(_,'o'):(_,'n'):cs) -tokens0 cs = tokens' cs +-- prolog +tokens1 :: LexCont +tokens1 [] = [] +tokens1 ((_,'<') : (_,'!') : cs) = special tokens1 cs +tokens1 ((n,'<') : (_,'?') : cs) = procins tokens1 n cs +tokens1 ((_,'<') : cs) = tag tokens2 cs +tokens1 cs@(_:_) = sData tokens1 cs +sData :: LexCont -> LString -> [Token] +sData lcont [] = lcont [] +sData lcont cs@((n,_):_) + = case breakn (not . isS) cs of + ("",_:_) -> [TokError n "unexpected (non-misc) content nodes before root element"] + (as,bs) -> TokText CData { cdVerbatim = CDataText, cdData = T.pack as } : lcont bs -tokens' :: LString -> [Token] -tokens' ((_,'<') : (_,'!') : cs) = special cs -tokens' ((n,'<') : (_,'?') : cs) = procins n cs -tokens' ((_,'<') : cs) = tag cs -tokens' [] = [] -tokens' cs@((n,_):_) = let (as,bs) = breakn ('<' ==) cs - in foldr cvt (tokens' bs) (decode_text as) +-- after prolog +tokens2 :: LexCont +tokens2 [] = [] +tokens2 ((_,'<') : (_,'!') : cs) = special tokens2 cs +tokens2 ((n,'<') : (_,'?') : cs) = procins tokens2 n cs +tokens2 ((_,'<') : cs) = tag tokens2 cs +tokens2 cs@(_:_) = charData tokens2 cs - -- XXX: Note, some of the lines might be a bit inacuarate +charData :: LexCont -> LString -> [Token] +charData lcont [] = lcont [] +charData lcont cs@((n,_):_) + = let (as,bs) = breakn ('<' ==) cs + in foldr cvt (lcont bs) (decode_text as) where + cvt :: Txt -> ([Token] -> [Token]) + -- XXX: Note, some of the lines might be a bit inacuarate cvt (TxtBit x) cont + | T.isInfixOf "]]>" dat = [TokError n "invalid literal ']]>' sequence in text content"] | T.all isChar dat = TokText CData { cdVerbatim = CDataText, cdData = dat } : cont | otherwise = [TokError n "invalid code-point in text content"] where dat = T.pack x - cvt (CRefBit x) cont = case cref_to_char x of + cvt (CRefBit _ False) _ = [TokError n "invalid character reference"] + cvt (CRefBit x True) cont = case cref_to_char x of Just c | isChar c -> TokText CData { cdVerbatim = CDataText, cdData = T.singleton c } : cont | otherwise -> [TokError n "invalid character reference"] @@ -189,17 +210,18 @@ -- -- PI ::= '' Char*)))? '?>' -- PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) -procins :: Pos -> LString -> [Token] -procins n0 = go "" +procins :: LexCont -> Pos -> LString -> [Token] +procins lcont n0 = go "" where - go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (tokens' ds) + go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (lcont ds) go acc ((_,c) : ds) = go (c:acc) ds go _ [] = eofErr mkPI :: String -> [Token] -> [Token] mkPI s0 ts | tgt == "xml" = mkXMLDecl s' ts - | map toLower (TS.unpack tgt) == "xml" = [TokError (n0+2) "Invalid PI name"] + | map toLower tgt0 == "xml" || not (isNCName tgt0) = [TokError (n0+2) "Invalid PI name"] + | not (T.all isChar payload) = [TokError (n0+2) "invalid code-point in PI data"] | otherwise = TokPI n0 (PI tgt payload) : ts where (tgt0,s') = break isS s0 @@ -238,9 +260,9 @@ | otherwise = [TokError n0 "Bad 'standalone' value in XML declaration"] go3 enc rest = go4 enc Nothing rest - go4 enc sd [] = TokXmlDecl (XmlDeclaration enc sd) : ts + go4 enc sd [] = TokXmlDecl (XmlDeclaration enc sd) : ts go4 enc sd [""] = TokXmlDecl (XmlDeclaration enc sd) : ts - go4 _ _ _ = [TokError n0 "unexpected or malformed attribute in XML declaration"] + go4 _ _ _ = [TokError n0 "unexpected or malformed attribute in XML declaration"] isEnc [] = False isEnc (c:cs) = (isAsciiLower c || isAsciiUpper c) && @@ -255,32 +277,35 @@ unbrack _ = Nothing -special :: LString -> [Token] +special :: LexCont -> LString -> [Token] -- ' -special ((_,'-') : (_,'-') : cs) = go "" cs +special lcont ((n0,'-') : (_,'-') : cs) = go "" cs where go acc ((n,'-') : (_,'-') : (_,x) : ds) - | x == '>' = TokComment (Comment $ T.pack (reverse acc)) : tokens' ds + | x == '>' = let dat = T.pack (reverse acc) + in if T.all isChar dat + then TokComment (Comment dat) : lcont ds + else [TokError (n0-2) "invalid code-point in comment"] | otherwise = [TokError n "double hyphen within comment"] go acc ((_,c) : ds) = go (c:acc) ds go _ [] = eofErr -- ') : ds) = ([],ds) - cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) - cdata [] = ([],[]) + cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) + cdata [] = ([],[]) -- ') : ds) | nesting == (0::Int) = (acc,ds) @@ -289,8 +314,8 @@ munch acc n ((_,x) : ds) = munch (x:acc) n ds munch acc _ [] = (acc,[]) -- unterminated DTD markup -special ((n,_):_) = [TokError (n-1) "invalid element name"] -special [] = eofErr +special _ ((n,_):_) = [TokError (n-1) "invalid element name"] +special _ [] = eofErr qualName :: LString -> (QName,LString) qualName xs = (QName { qURI = nullNs @@ -314,46 +339,52 @@ Attribute ::= Name Eq AttValue -} -tag :: LString -> [Token] -tag ((p,'/') : cs) +tag :: LexCont -> LString -> [Token] +tag lcont ((p,'/') : cs) | isValidQName n = TokEnd p n : case dropSpace ds of - (_,'>') : es -> tokens' es + (_,'>') : es -> lcont es -- tag was not properly closed... (p',_) : _ -> [TokError p' "expected '>'"] [] -> eofErr | otherwise = [TokError p "invalid element name"] where - (n,ds) = qualName (dropSpace cs) -tag [] = eofErr -tag cs@((pos,_):_) - | not (isValidQName n) = [TokError pos "invalid element name"] + (n,ds) = qualName cs +tag _ [] = eofErr +tag lcont cs@((pos,_):_) + | not (isValidQName n) = [TokError pos "invalid element name"] | not (all (isValidQName . attrKey) as) = [TokError pos "invalid attribute name"] | not (all (T.all isChar . attrVal) as) = [TokError pos "invalid attribute value"] - | otherwise = TokStart pos n as b : ts + | otherwise = TokStart pos n as b : ts where (n,ds) = qualName cs - (as,b,ts) = attribs (dropSpace ds) + (as,b,ts) = attribs lcont ds +attribs :: LexCont -> LString -> ([Attr], Bool, [Token]) +attribs lcont = go + where + go cs = case (isS' cs, dropSpace cs) of + (_,(_,'>') : ds) -> ([], False, lcont ds) + (_,(_,'/') : ds) -> ([], True, case ds of + (_,'>') : es -> lcont es + (pos,_) : _ -> [TokError pos "expected '>'"] + [] -> eofErr) + (_,(_,'?') : (_,'>') : ds) -> ([], True, lcont ds) -attribs :: LString -> ([Attr], Bool, [Token]) -attribs cs = case cs of - (_,'>') : ds -> ([], False, tokens' ds) - (_,'/') : ds -> ([], True, case ds of - (_,'>') : es -> tokens' es - (pos,_) : _ -> [TokError pos "expected '>'"] - [] -> eofErr) - (_,'?') : (_,'>') : ds -> ([], True, tokens' ds) + -- doc ended within a tag.. + (_,[]) -> ([],False,eofErr) - -- doc ended within a tag.. - [] -> ([],False,eofErr) + (True,cs') -> let (a,cs1) = attrib cs' + (as,b,ts) = go cs1 + in (a:as,b,ts) - _ -> let (a,cs1) = attrib cs - (as,b,ts) = attribs cs1 - in (a:as,b,ts) + (False,(pos,_):_) -> ([], False, [TokError pos "expected whitespace"]) + isS' ((_,c):_) = isS c + isS' [] = False + attrib :: LString -> (Attr,LString) -attrib cs = ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2) +attrib cs = ((Attr ks (fromString $ decode_attr vs)),cs2) where (vs,cs2) = attr_val (dropSpace cs1) (ks,cs1) = qualName cs @@ -389,42 +420,46 @@ decode_attr cs = concatMap cvt (decode_text cs) where cvt (TxtBit x) = norm x - cvt (CRefBit x) + cvt (CRefBit _ False) = "\0" + cvt (CRefBit x True) | Just c <- cref_to_char x = [c] - | otherwise = "\0" -- triggers error lateron + | otherwise = "\0" -- triggers error lateron (we can't represent refs in att-values) norm [] = [] norm ('\x9':xs) = '\x20' : norm xs norm ('\xA':xs) = '\x20' : norm xs + norm ('<':xs) = '<' : '\0' : norm xs -- hack: trigger error; literal '<'s are not allowed here norm (x:xs) = x : norm xs -data Txt = TxtBit String | CRefBit String deriving Show +data Txt = TxtBit String + | CRefBit String Bool decode_text :: [Char] -> [Txt] -decode_text xs@('&' : cs) = case break (';' ==) cs of - (as,_:bs) -> CRefBit as : decode_text bs - _ -> [TxtBit xs] +decode_text ('&' : cs) = case break (';' ==) cs of + (as,_:bs) -> CRefBit as True : decode_text bs + (as,"") -> [CRefBit as False] decode_text [] = [] decode_text cs = let (as,bs) = break ('&' ==) cs in TxtBit as : decode_text bs cref_to_char :: [Char] -> Maybe Char cref_to_char cs = case cs of - '#' : ds -> num_esc ds + '#' : ds -> maybe (Just '\0') Just $ -- trigger error lateron + num_esc ds "lt" -> Just '<' "gt" -> Just '>' "amp" -> Just '&' "apos" -> Just '\'' "quot" -> Just '"' - _ -> Nothing + "" -> Just '\0' -- trigger error + (x:xs) | isNameStartChar x, all isNameChar xs -> Nothing + | otherwise -> Just '\0' -- invalid name + num_esc :: String -> Maybe Char num_esc cs = case cs of - 'x' : ds -> check (readHex ds) - _ -> check (reads cs) - - where check [(n,"")] = cvt_char n - check _ = Nothing + 'x' : ds -> decodeCharRefHex ds + _ -> decodeCharRefDec cs cvt_char :: Int -> Maybe Char cvt_char x @@ -436,8 +471,10 @@ simpleTokenize :: String -> [String] simpleTokenize [] = [] simpleTokenize (c:cs) - | isSorEQ c = let (sep,rest) = span isSorEQ (c:cs) - in (if ('=' `elem` sep) then "=" else "") : simpleTokenize rest + | isSorEQ c = case span isS (c:cs) of + (_,'=':rest) -> "=" : simpleTokenize (dropWhile isS rest) + (_:_,rest) -> "" : simpleTokenize rest + ([],_) -> error "impossible" | c == '\'' = case break (== '\'') cs of (_,"") -> [c:cs] @@ -454,4 +491,3 @@ isValidQName :: QName -> Bool isValidQName (QName { qPrefix = Just pfx, qLName = LName ln }) = isNCName (TS.unpack pfx) && isNCName (TS.unpack ln) isValidQName (QName { qPrefix = Nothing, qLName = LName ln }) = isNCName (TS.unpack ln) - diff --git a/src/Text/XML/NS.hs b/src/Text/XML/NS.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/NS.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + +{- + +Copyright (c) 2019 Herbert Valerio Riedel + + This file is free software: you may copy, redistribute and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation, either version 3 of the License, or (at your + option) any later version. + + This file is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program (see `LICENSE.GPLv3`). If not, see + . + +-} + +-- | +-- Module : Text.XML.NS +-- Copyright : (c) Herbert Valerio Riedel 2019 +-- SPDX-License-Identifier: GPL-3.0-or-later +-- +-- XML Namespace related helpers +-- +module Text.XML.NS + ( xmlns_attr + , xmlns_def_attr + , xmlns_from_attr + + , ns_xmlns_uri, xmlNamesNS + , ns_xml_uri, xmlnsNS + + , xmlns_attr_wellformed + + , xmlns_elem_wellformed + , xmlns_elem_wellformed' + ) where + +import Common +import Data.Char +import Data.Either (partitionEithers) +import qualified Data.Text as T +import qualified Data.Text.Short as TS +import Text.XML.Types.Core +import Utils + +xmlNamesNS :: URI +xmlNamesNS = URI ns_xml_uri + +xmlnsNS :: URI +xmlnsNS = URI ns_xmlns_uri + +{-# NOINLINE ns_xml_uri #-} +ns_xml_uri :: ShortText +ns_xml_uri = "http://www.w3.org/XML/1998/namespace" + +-- | Smart constructor for @xmlns:\ = \@ +-- +-- Invariant: @\@ MUST be non-empty for non-empty prefixes +-- +-- @since 0.3.0 +xmlns_attr :: ShortText -- ^ namespace prefix (if empty, denotes the default namespace; see also 'xmlns_def_attr') + -> URI -- ^ Namespace URI + -> Attr +xmlns_attr pfx uri + | TS.null pfx = xmlns_def_attr uri + | not (isNCName (TS.unpack pfx)) = error "Text.XML.xmlns_attr: non-empty prefix is not a proper NCName" + | isNullURI uri = error "Text.XML.xmlns_attr: empty namespace URI for non-empty prefix" + | otherwise = Attr (QName { qPrefix = Just (TS.pack "xmlns"), qLName = LName pfx, qURI = xmlnsNS }) (TS.toText (unURI uri)) + +-- | Smart constructor for @xmlns = [\|""]@ (i.e. for declaring the default namespace) +-- +-- prop> xmlns_attr "" ns == xmlns_def_attr ns +-- +-- @since 0.3.0 +xmlns_def_attr :: URI -- ^ Default namespace URI (use /empty/ 'URI' to reset default namespace) + -> Attr +xmlns_def_attr uri + = Attr (QName { qPrefix = Nothing, qLName = LName (TS.pack "xmlns"), qURI = xmlnsNS }) + (if isNullURI uri then mempty else TS.toText (unURI uri)) + +-- | Convert @xmlns@ 'Attr' into a @(prefix,namespace-uri)@ pair; returns 'Nothing' if the argument isn't a @xmlns@ attribute. +-- +-- An empty prefix denotes the default-namespace +-- +-- prop> xmlns_from_attr (xmlns_attr pfx ns) == Just (pfx,ns) +-- +-- @since 0.3.0 +xmlns_from_attr :: Attr -> Maybe (ShortText,URI) +xmlns_from_attr (Attr (QName ln ns pfx) ns') + | ns /= URI ns_xmlns_uri = Nothing + | otherwise = Just $ case pfx of + Nothing -> (mempty, URI (TS.fromText ns')) + Just _ -> (unLName ln, URI (TS.fromText ns')) + +-- not public API yet +-- | Check rules imposed on reserved namespaces by +-- as well as other basic +-- constraints. +xmlns_attr_wellformed :: Attr -> Bool +xmlns_attr_wellformed = \case + (Attr (QName { qPrefix = Just "xmlns", qLName = "xmlns"}) _ ) -> False + (Attr (QName { qPrefix = Just "xmlns", qLName = "xml"}) uri) -> uri == xmlNamesNS' + (Attr (QName { qPrefix = Just "xmlns", qLName = _}) uri) -> not (T.null uri) && isNotRsvd uri && validURI uri + (Attr (QName { qPrefix = Nothing , qLName = "xmlns"}) "") -> True + (Attr (QName { qPrefix = Nothing , qLName = "xmlns"}) uri) -> isNotRsvd uri && (T.null uri || validURI uri) + _ -> True -- not an attribute covered by xml-names + where + xmlNamesNS' = TS.toText (unURI xmlNamesNS) + xmlnsNS' = TS.toText (unURI xmlnsNS) + isNotRsvd uri = not (uri == xmlNamesNS' || uri == xmlnsNS') + + -- simple heuristic; TODO: implement proper RFC3986 syntax test + validURI = T.all validUriChar + + -- as per RFC3986 + validUriChar c = isAsciiLower c || isAsciiUpper c || isDigit c || + c `elem` ("%-._~:/?#[]@!$&'()*+,;=" :: [Char]) + +-- | Verify whether sub-tree is wellformed with respect to namespaces +-- +-- The first argument denotes an optional parent context of +-- @xmlns@-declarations that are in scope (where 'ShortText' and 'URI' +-- have the same semantics as for the arguments of 'xmlns_attr'). In +-- case of duplicate prefixes, earlier entries shadow later entries. +-- +-- __NOTE__: This function doesn't take into account the namespace +-- prefixes of @xs:QName@-valued text-nodes or attributes; if you need +-- to handle such cases, see the 'xmlns_elem_wellformed'' function. +-- +-- @since 0.3.1 +xmlns_elem_wellformed :: [(ShortText,URI)] -> Element -> Bool +xmlns_elem_wellformed parentScope curElement = and + [ qnameWF False (elName curElement) + , all xmlns_attr_wellformed (elAttribs curElement) + , noDupes xmlnsAttrs + , all (qnameWF True . attrKey) nonXmlnsAttrs + , noDupes nonXmlnsAttrs + -- recurse into children + , all (xmlns_elem_wellformed curScope0) children + ] + where + (xmlnsAttrs, nonXmlnsAttrs) = + partitionEithers . + map (\attr -> maybe (Right attr) Left (xmlns_from_attr attr)) $ + elAttribs curElement + + curScope0 = xmlnsAttrs ++ parentScope + curScope1 = ("xml",xmlNamesNS):("xmlns",xmlnsNS):curScope0 + + curDefNS = fromMaybe "" (lookup "" curScope0) + + qnameWF False (QName _ uri Nothing) = uri == curDefNS + qnameWF True (QName _ uri Nothing) = isNullURI uri -- attributes are agnostic to xmlns=... + qnameWF _ (QName _ uri (Just pfx)) + | Just uri' <- lookup pfx curScope1 = uri == uri' + | otherwise = False + + children :: [Element] + children = [ el | Elem el <- elContent curElement ] + +-- | Variant of 'xmlns_elem_wellformed' which supports introspecting @xs:QName@ valued attributes and text-nodes. +-- +-- The first argument is a function for extracting a (possibly empty) list of 'QName's from attribute values and text-nodes: +-- +-- - Its first @'Either' 'Attr' ['Content']@ argument denotes either a (non-empty) attribute or an element's children which contain at least one non-empty text-node fragment. +-- +-- - The second argument of type @['QName']@ denotes the path of element 'QName's in reverse order (i.e. the top-level element of the traversal is last item in this list) leading to the currently focused attribute or text-node. +-- +-- This 'QName' extracing function may return a list to accomodate for test fields which may contain multiple @xs:QName@ such as e.g. for +-- +-- > +-- +-- The 'Text.XML.Types.qnameFromText' function can be useful for decoding @xs:QName@s text values. +-- +-- prop> xmlns_elem_wellformed' (\_ _ -> []) topns el = xmlns_elem_wellformed topns el +-- +-- @since 0.3.1 +xmlns_elem_wellformed' :: (Either Attr [Content] -> [QName] -> [QName]) + -> [(ShortText,URI)] -> Element -> Bool +xmlns_elem_wellformed' qnameMatcher = go [] + where + go parentPath parentScope curElement = and + [ qnameWF False (elName curElement) + , all xmlns_attr_wellformed (elAttribs curElement) + , noDupes xmlnsAttrs + , all (qnameWF True . attrKey) nonXmlnsAttrs + , noDupes nonXmlnsAttrs + -- xs:QName in text-nodes and attrib values + , all (qnameWF False) cdataQName + , all (qnameWF False) attrQNames + -- recurse into children + , all (go curPath curScope0) children + ] + where + curPath = elName curElement : parentPath + + cdataQName = if and [ T.all isS (cdData cd) | Text cd <- elContent curElement ] + then [] + else qnameMatcher (Right (elContent curElement)) curPath + + attrQNames = concat [ qnameMatcher (Left attr) curPath + | attr@(Attr _ v) <- nonXmlnsAttrs, not (T.all isS v) ] + + (xmlnsAttrs, nonXmlnsAttrs) = + partitionEithers . + map (\attr -> maybe (Right attr) Left (xmlns_from_attr attr)) $ + elAttribs curElement + + curScope0 = xmlnsAttrs ++ parentScope + curScope1 = ("xml",xmlNamesNS):("xmlns",xmlnsNS):curScope0 + + curDefNS = fromMaybe "" (lookup "" curScope0) + + qnameWF False (QName _ uri Nothing) = uri == curDefNS + qnameWF True (QName _ uri Nothing) = isNullURI uri -- attributes are agnostic to xmlns=... + qnameWF _ (QName _ uri (Just pfx)) + | Just uri' <- lookup pfx curScope1 = uri == uri' + | otherwise = False + + children :: [Element] + children = [ el | Elem el <- elContent curElement ] diff --git a/src/Text/XML/Output.hs b/src/Text/XML/Output.hs --- a/src/Text/XML/Output.hs +++ b/src/Text/XML/Output.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} {- @@ -122,7 +123,7 @@ maybeToList xmldecl ++ map bMisc rootPreElem ++ (case rootDoctype of - Nothing -> [] + Nothing -> [] Just (dtd,moreMisc) -> (" TLB.fromText dtd <+> ">") : map bMisc moreMisc ) ++ [TLB.fromString (ppElementS sopts rootElement "")] ++ diff --git a/src/Text/XML/Proc.hs b/src/Text/XML/Proc.hs --- a/src/Text/XML/Proc.hs +++ b/src/Text/XML/Proc.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- Copyright (c) 2019 Herbert Valerio Riedel diff --git a/src/Text/XML/Types.hs b/src/Text/XML/Types.hs --- a/src/Text/XML/Types.hs +++ b/src/Text/XML/Types.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} {- @@ -23,295 +18,56 @@ along with this program (see `LICENSE.GPLv3`). If not, see . -This file incorporates work covered by the following copyright and -permission notice: - - (c) 2007 Galois Inc. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. 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. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. - -} -- | -- Module : Text.XML.Types --- Copyright : (c) Galois, Inc. 2007 --- (c) Herbert Valerio Riedel 2019 --- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later +-- Copyright : (c) Herbert Valerio Riedel 2019 +-- SPDX-License-Identifier: GPL-3.0-or-later -- -- Basic XML types. -- -module Text.XML.Types where - -import Common -import qualified Data.Text.Short as TS -import Utils - -type Root = Root' Content - --- | Represents the implicit root node of an XML document --- --- @since 0.2.0 -data Root' cnode = Root - { rootXmlDeclaration :: Maybe XmlDeclaration -- ^ (optional) XML declaration - , rootPreElem :: MiscNodes -- ^ Miscellaneous nodes before root element & DOCTYPE declaration - , rootDoctype :: Maybe (Text,MiscNodes) -- ^ optional DOCTYPE declaration and more miscellaneous nodes between DOCTYPE and root element - , rootElement :: Element' cnode -- ^ The single root document element - , rootPostElem :: MiscNodes -- ^ Miscellaneous nodes after root element - } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) - -instance NFData cnode => NFData (Root' cnode) - --- | Sequence of \"miscellaneous\" nodes --- --- @since 0.2.0 -type MiscNodes = [Either Comment PI] - --- | Denotes the @\@ declaration --- --- @since 0.2.0 -data XmlDeclaration = XmlDeclaration (Maybe ShortText) (Maybe Bool) - deriving (Show, Typeable, Data, Generic) - -instance NFData XmlDeclaration - --- | Processing instruction --- --- @since 0.2.0 -data PI = PI - { piTarget :: !ShortText -- ^ Invariant: MUST not be @[Xx][Mm][Ll]@ - , piData :: !Text -- ^ Invariant: MUST not contain @?>@ - } deriving (Show, Typeable, Data, Generic) - -instance NFData PI - --- | Represents a XML comment --- --- Invariant: SHOULD not contain @--@ (occurences of @--@ will be automatically substituted by @-~@ on serialization) --- --- @since 0.2.0 -newtype Comment = Comment Text - deriving (Show, Typeable, Data, Generic, NFData) - --- | XML content --- --- @since 0.2.0 -data Content - = Elem Element - | Text CData - | CRef !ShortText - | Proc PI - | Comm Comment - deriving (Show, Typeable, Data, Generic) - -instance NFData Content - -type Element = Element' Content - --- | XML elements -data Element' cnode = Element - { elName :: !QName - , elAttribs :: [Attr] - , elContent :: [cnode] - } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) - -instance NFData cnode => NFData (Element' cnode) - --- | XML attributes -data Attr = Attr - { attrKey :: !QName - , attrVal :: !Text - } deriving (Eq, Ord, Show, Typeable, Data, Generic) - -instance NFData Attr - --- | XML CData -data CData = CData - { cdVerbatim :: !CDataKind - , cdData :: !Text - } deriving (Show, Typeable, Data, Generic) - -instance NFData CData - -data CDataKind - = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. - | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in --- --- NB: Among other properties this means that an 'NCName' shall never be the empty string. --- --- @since 0.2.0 -type NCName = ShortText - --- | XML (expanded) qualified names --- -data QName = QName - { qLName :: !LName -- ^ Local name part - , qURI :: !URI -- ^ Invariant: the `qURI' field MUST always be populated with the proper namespace. Specifically, entities belonging to the or must have the 'qURI' field accordingly - , qPrefix :: Maybe NCName -- ^ Invariant: MUST be a proper - } deriving (Show, Typeable, Data, Generic) - -instance NFData QName - --- | Compares namespace URI and local name for equality (i.e. the namespace prefix is ignored) --- --- @since 0.3.0 -instance Eq QName where - q1 == q2 = xn q1 == xn q2 - where - xn (QName ln ns _) = (ns,ln) - --- | Compares namespace URI and local name for equality (i.e. the namespace prefix is effectively ignored) --- --- The namespace is considered less than any other namespace (including the null namespace) --- --- @since 0.3.0 -instance Ord QName where - compare = comparing sortKey - where - sortKey (QName ln ns pfx) = (not isXmlns,ns,key2) - where - isXmlns = URI ns_xmlns_uri == ns - key2 - | isXmlns = if isNothing pfx then LName mempty else ln - | otherwise = ln - --- | XML local names --- --- Invariant: MUST be a proper -newtype LName = LName { unLName :: NCName } - deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) - --- due to the IsString instance we can just drop the constructor name -instance Show LName where - showsPrec p (LName s) = showsPrec p s - --- | URIs resembling @anyURI@ --- --- Invariant: MUST be a valid @URI-reference@ as defined in --- -newtype URI = URI { unURI :: ShortText } - deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) - --- | Test for /empty/ 'URI' --- --- >>> isNullURI (URI mempty) --- True --- --- >>> isNullURI (URI "") --- True --- --- >>> isNullURI (URI " ") --- False --- --- @since 0.3.0 -isNullURI :: URI -> Bool -isNullURI (URI u) = TS.null u +module Text.XML.Types + ( -- * Root node representation + Root, Root'(..) + , MiscNodes + , XmlDeclaration(..) --- due to the IsString instance we can just drop the constructor name -instance Show URI where - showsPrec p (URI s) = showsPrec p s + -- * Element nodes + , Element + , Element'(..) + , blank_element --- | Position expressed in number of code-points --- --- A negative value denotes EOF -type Pos = Int + , xmlns_elem_wellformed + , xmlns_elem_wellformed' --- blank elements -------------------------------------------------------------- + -- ** Element attributes + , Attr(..) --- | Blank names -blank_name :: QName -blank_name = QName - { qLName = LName mempty - , qURI = URI mempty - , qPrefix = Nothing - } + , xmlns_attr + , xmlns_def_attr + , xmlns_from_attr --- | Blank cdata -blank_cdata :: CData -blank_cdata = CData - { cdVerbatim = CDataText - , cdData = mempty - } + -- * Non-element content nodes + , Content(..) + , PI(..) + , CData(..), CDataKind(..), blank_cdata + , Comment(..) --- | Blank elements -blank_element :: Element -blank_element = Element - { elName = blank_name - , elAttribs = mempty - , elContent = mempty - } + -- * Namespace-qualified names + , QName(..), blank_name + , qnameToText + , qnameFromText --- | Smart constructor for @xmlns:\ = \@ --- --- Invariant: @\@ MUST be non-empty for non-empty prefixes --- --- @since 0.3.0 -xmlns_attr :: ShortText -- ^ namespace prefix (if empty, denotes the default namespace; see also 'xmlns_def_attr') - -> URI -- ^ Namespace URI - -> Attr -xmlns_attr pfx uri - | TS.null pfx = xmlns_def_attr uri - | not (isNCName (TS.unpack pfx)) = error "Text.XML.xmlns_attr: non-empty prefix is not a proper NCName" - | isNullURI uri = error "Text.XML.xmlns_attr: empty namespace URI for non-empty prefix" - | otherwise = Attr (QName { qPrefix = Just (TS.pack "xmlns"), qLName = LName pfx, qURI = xmlnsNS }) (TS.toText (unURI uri)) - where - xmlnsNS = URI ns_xmlns_uri + -- ** Components of 'QName's + , NCName + , LName(..) + , URI(..), isNullURI --- | Smart constructor for @xmlns = [\|""]@ (i.e. for declaring the default namespace) --- --- prop> xmlns_attr "" ns == xmlns_def_attr ns --- --- @since 0.3.0 -xmlns_def_attr :: URI -- ^ Default namespace URI (use /empty/ 'URI' to reset default namespace) - -> Attr -xmlns_def_attr uri - = Attr (QName { qPrefix = Nothing, qLName = LName (TS.pack "xmlns"), qURI = xmlnsNS }) - (if isNullURI uri then mempty else TS.toText (unURI uri)) - where - xmlnsNS = URI ns_xmlns_uri + -- * Miscellaneous + , Pos + ) where --- | Convert @xmlns@ 'Attr' into a @(prefix,namespace-uri)@ pair; returns 'Nothing' if the argument isn't a @xmlns@ attribute. --- --- An empty prefix denotes the default-namespace --- --- prop> xmlns_from_attr (xmlns_attr pfx ns) == Just (pfx,ns) --- --- @since 0.3.0 -xmlns_from_attr :: Attr -> Maybe (ShortText,URI) -xmlns_from_attr (Attr (QName ln ns pfx) ns') - | ns /= URI ns_xmlns_uri = Nothing - | otherwise = Just $ case pfx of - Nothing -> (mempty, URI (TS.fromText ns')) - Just _ -> (unLName ln, URI (TS.fromText ns')) +import Text.XML.NS +import Text.XML.Types.Core +import Text.XML.Types.Internal diff --git a/src/Text/XML/Types/Core.hs b/src/Text/XML/Types/Core.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Types/Core.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} + +{- + +Copyright (c) 2019 Herbert Valerio Riedel + + This file is free software: you may copy, redistribute and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation, either version 3 of the License, or (at your + option) any later version. + + This file is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program (see `LICENSE.GPLv3`). If not, see + . + +This file incorporates work covered by the following copyright and +permission notice: + + (c) 2007 Galois Inc. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. 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. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. + +-} + +-- | +-- Module : Text.XML.Types +-- Copyright : (c) Galois, Inc. 2007 +-- (c) Herbert Valerio Riedel 2019 +-- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later +-- +-- Basic XML types. +-- +module Text.XML.Types.Core where + +import Common +import qualified Data.Text.Short as TS + +{-# NOINLINE ns_xmlns_uri #-} +ns_xmlns_uri :: ShortText +ns_xmlns_uri = "http://www.w3.org/2000/xmlns/" + +type Root = Root' Content + +-- | Represents the implicit root node of an XML document +-- +-- @since 0.2.0 +data Root' cnode = Root + { rootXmlDeclaration :: Maybe XmlDeclaration -- ^ (optional) XML declaration + , rootPreElem :: MiscNodes -- ^ Miscellaneous nodes before root element & DOCTYPE declaration + , rootDoctype :: Maybe (Text,MiscNodes) -- ^ optional DOCTYPE declaration and more miscellaneous nodes between DOCTYPE and root element + , rootElement :: Element' cnode -- ^ The single root document element + , rootPostElem :: MiscNodes -- ^ Miscellaneous nodes after root element + } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) + +instance NFData cnode => NFData (Root' cnode) + +-- | Sequence of \"miscellaneous\" nodes +-- +-- @since 0.2.0 +type MiscNodes = [Either Comment PI] + +-- | Denotes the @\@ declaration +-- +-- @since 0.2.0 +data XmlDeclaration = XmlDeclaration (Maybe ShortText) (Maybe Bool) + deriving (Show, Typeable, Data, Generic) + +instance NFData XmlDeclaration + +-- | Processing instruction +-- +-- @since 0.2.0 +data PI = PI + { piTarget :: !ShortText -- ^ Invariant: MUST be a 'NCName' but not be @[Xx][Mm][Ll]@ (see also and ) + , piData :: !Text -- ^ Invariant: MUST not contain @?>@ + } deriving (Show, Typeable, Data, Generic) + +instance NFData PI + +-- | Represents a XML comment +-- +-- Invariant: SHOULD not contain @--@ (occurences of @--@ will be automatically substituted by @-~@ on serialization) +-- +-- @since 0.2.0 +newtype Comment = Comment Text + deriving (Show, Typeable, Data, Generic, NFData) + +-- | XML content +-- +-- @since 0.2.0 +data Content + = Elem Element + | Text CData + | CRef !ShortText + | Proc PI + | Comm Comment + deriving (Show, Typeable, Data, Generic) + +instance NFData Content + +type Element = Element' Content + +-- | XML elements +data Element' cnode = Element + { elName :: !QName + , elAttribs :: [Attr] + , elContent :: [cnode] + } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) + +instance NFData cnode => NFData (Element' cnode) + +-- | XML attributes +data Attr = Attr + { attrKey :: !QName -- ^ Note that the default namespace doesn't apply to unprefixed names + , attrVal :: !Text + } deriving (Eq, Ord, Show, Typeable, Data, Generic) + +instance NFData Attr + +-- | XML CData +data CData = CData + { cdVerbatim :: !CDataKind + , cdData :: !Text + } deriving (Show, Typeable, Data, Generic) + +instance NFData CData + +data CDataKind + = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. + | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in +-- +-- NB: Among other properties this means that an 'NCName' shall never be the empty string. +-- +-- @since 0.2.0 +type NCName = ShortText + +-- | XML (expanded) namespace-qualified names +-- +-- Used by 'attrKey' and 'elName'. +data QName = QName + { qLName :: !LName -- ^ Local name part + , qURI :: !URI -- ^ Invariant: the `qURI' field MUST always be populated with the proper namespace. Specifically, entities belonging to the or must have the 'qURI' field set accordingly. The special empty 'URI' (see also 'isNullURI') is only allowed /iff/ 'qPrefix' is 'Nothing' (i.e. when the name is /unprefixed/) + , qPrefix :: Maybe NCName + -- ^ 'Nothing' denotes an unprefixed name; 'Just' denotes a prefixed name. + -- + -- Invariant: MUST be a proper (unless 'Nothing') + } deriving (Show, Typeable, Data, Generic) + +instance NFData QName + +-- | Compares namespace URI and local name for equality (i.e. the namespace prefix is ignored) +-- +-- @since 0.3.0 +instance Eq QName where + q1 == q2 = xn q1 == xn q2 + where + xn (QName ln ns _) = (ns,ln) + +-- | Compares namespace URI and local name for equality (i.e. the namespace prefix is effectively ignored) +-- +-- The namespace is considered less than any other namespace (including the null namespace) +-- +-- @since 0.3.0 +instance Ord QName where + compare = comparing sortKey + where + sortKey (QName ln ns pfx) = (not isXmlns,ns,key2) + where + isXmlns = URI ns_xmlns_uri == ns + key2 + | isXmlns = if isNothing pfx then LName mempty else ln + | otherwise = ln + +-- | XML local names +-- +-- Invariant: MUST be a proper +newtype LName = LName { unLName :: NCName } + deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) + +-- due to the IsString instance we can just drop the constructor name +instance Show LName where + showsPrec p (LName s) = showsPrec p s + +-- | URIs resembling @anyURI@ +-- +-- Invariant: MUST be a valid @URI-reference@ as defined in +-- +-- __NOTE__: The special empty 'URI' is valid for denoting 'QName's that aren't in any namespace. +newtype URI = URI { unURI :: ShortText } + deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) + +-- | Test for /empty/ 'URI' +-- +-- >>> isNullURI (URI mempty) +-- True +-- +-- >>> isNullURI (URI "") +-- True +-- +-- >>> isNullURI (URI " ") +-- False +-- +-- @since 0.3.0 +isNullURI :: URI -> Bool +isNullURI (URI u) = TS.null u + +-- due to the IsString instance we can just drop the constructor name +instance Show URI where + showsPrec p (URI s) = showsPrec p s + +-- | Position expressed in number of code-points +-- +-- A negative value denotes EOF +type Pos = Int + +-- blank elements -------------------------------------------------------------- + +-- TODO: consider removing these in X-0.4.0 + +-- | Blank names +-- +-- __NOTE__: This value is not a proper 'QName'. +blank_name :: QName +blank_name = QName + { qLName = LName mempty + , qURI = URI mempty + , qPrefix = Nothing + } + +-- | Empty text-node +blank_cdata :: CData +blank_cdata = CData + { cdVerbatim = CDataText + , cdData = mempty + } + +-- | Blank elements +-- +-- __NOTE: This value is not a propler 'Element'. +blank_element :: Element +blank_element = Element + { elName = blank_name + , elAttribs = mempty + , elContent = mempty + } diff --git a/src/Text/XML/Types/Internal.hs b/src/Text/XML/Types/Internal.hs --- a/src/Text/XML/Types/Internal.hs +++ b/src/Text/XML/Types/Internal.hs @@ -29,7 +29,10 @@ module Text.XML.Types.Internal where import Common -import Text.XML.Types +import qualified Data.Text as T +import qualified Data.Text.Short as TS +import Text.XML.Types.Core +import Utils -- | Convenience class for converting to/from 'Content' values -- @@ -92,3 +95,61 @@ toContent = either toContent toContent fromContent c = (Left <$> fromContent c) <|> (Right <$> fromContent c) toElem = either toElem toElem + +-- | Convert a 'QName' to its text-representation, i.e. +-- +-- > QName ::= PrefixedName | UnprefixedName +-- > PrefixedName ::= Prefix ':' LocalPart +-- > UnprefixedName ::= LocalPart +-- > Prefix ::= NCName +-- > LocalPart ::= NCName +-- +-- See also 'NCName' +-- +-- >>> qnameToText (QName "foo" "urn:example.org:bar" (Just "doo")) +-- "doo:foo" +-- +-- >>> qnameToText (QName "foo" "urn:example.org:bar" Nothing) +-- "foo" +-- +-- See also 'qnameFromText' +-- +-- @since 0.3.1 +qnameToText :: QName -> Text +qnameToText (QName (LName ln) _uri Nothing) = TS.toText ln +qnameToText (QName (LName ln) _uri (Just pfx)) = TS.toText (mconcat [pfx, TS.singleton ':', ln]) + +-- | Decode a 'QName' from its text-representation (see 'qnameToText') +-- +-- This is the inverse to the 'qnameToText' function. However, +-- 'qnameToText' is a lossy conversion, therefore this function needs +-- to reconstruct the namespace (i.e. 'qURI') with the help of a +-- lookup function provided in the first argument: The lookup +-- functions takes a 'ShortText' which can be either +-- +-- - the empty string (i.e. @""@) which denotes an unprefixed name, or +-- - a non-empty @NCName@ string which denotes a prefixed name. +-- +-- The result of this function shall be the respective namespace 'URI' +-- to associate with this QName. An empty 'URI' may be returned In +-- case of unprefixed names to denote the name being in no namespace. +-- +-- Finally, this function returns 'Nothing' in case of syntax errors +-- or when the prefix lookup function returns an empty 'URI' (see +-- 'isNullURI') for a /prefixed/ name. +-- +-- @since 0.3.1 +qnameFromText :: (ShortText -> URI) -> Text -> Maybe QName +qnameFromText nslup txt + = case T.split (==':') txt of + [ln] | isName ln -> Just (QName (LName (TS.fromText ln)) (nslup mempty) Nothing) + [ln,pfx] | isName ln, isName pfx -> do + let pfx' = TS.fromText pfx + uri = nslup pfx' + guard (not (isNullURI uri)) + pure (QName (LName (TS.fromText ln)) uri (Just pfx')) + _ -> Nothing + where + isName t + | Just (c,t') <- T.uncons t = isNameStartChar c && T.all isNameChar t' + | otherwise = False diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} {- @@ -46,7 +47,7 @@ isS _ = False isNCName :: String -> Bool -isNCName [] = False +isNCName [] = False isNCName (c:cs) = isNameStartChar c && c /= ':' && all (\c' -> isNameChar c' && c' /= ':') cs -- | @@ -166,12 +167,62 @@ bUnlines (x:xs@(_:_)) = x <+> TLB.singleton '\n' <+> bUnlines xs -{-# NOINLINE ns_xmlns_uri #-} -ns_xmlns_uri :: ShortText -ns_xmlns_uri = "http://www.w3.org/2000/xmlns/" +{-# INLINEABLE noDupes #-} +-- | Return 'True' if list contains duplicate values +noDupes :: Ord a => [a] -> Bool +noDupes [] = True +noDupes [_] = True +noDupes [x,y] = x /= y +noDupes [x,y,z] = x /= y && x /= z && y /= z +noDupes xs0 + = case sort xs0 of + [] -> True -- unreachable + (x:xs) -> go x xs + where + go _ [] = True + go x1 (x2:xs) + | x1 == x2 = False + | otherwise = go x2 xs -{-# NOINLINE ns_xml_uri #-} -ns_xml_uri :: ShortText -ns_xml_uri = "http://www.w3.org/XML/1998/namespace" +-- decode numeric char-reference taking into account 'isChar' +decodeCharRefHex :: [Char] -> Maybe Char +decodeCharRefHex = go 0 . dropWhile (=='0') -- NB: U+00 is invalid + where + go acc _ | acc > 0x10ffff = Nothing + go acc [] = let c = toEnum acc + in if isChar c then Just c else Nothing + go acc (c:cs) + | n < 0 = Nothing + | otherwise = go ((acc*16) + n) cs + where + n = c2n c + c2n :: Char -> Int + c2n c + | fromEnum '0' <= n, n <= fromEnum '9' = n - fromEnum '0' + | fromEnum 'a' <= n, n <= fromEnum 'f' = n - (fromEnum 'a' - 10) + | fromEnum 'A' <= n, n <= fromEnum 'F' = n - (fromEnum 'A' - 10) + | otherwise = -1 + where + n = fromEnum c + + +decodeCharRefDec :: [Char] -> Maybe Char +decodeCharRefDec = go 0 . dropWhile (=='0') -- NB: U+00 is invalid + where + go acc _ | acc > 0x10ffff = Nothing + go acc [] = let c = toEnum acc + in if isChar c then Just c else Nothing + go acc (c:cs) + | n < 0 = Nothing + | otherwise = go ((acc*10) + n) cs + where + n = c2n c + + c2n :: Char -> Int + c2n c + | fromEnum '0' <= n, n <= fromEnum '9' = n - fromEnum '0' + | otherwise = -1 + where + n = fromEnum c