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.1.0.0 +version: 0.2.0.0 license: BSD-3-Clause AND GPL-3.0-or-later license-files: LICENSE LICENSE.GPLv3 @@ -11,11 +11,18 @@ synopsis: A light-weight XML library category: Text, XML -bug-reports: https://github.com/hvr/issues +bug-reports: https://github.com/hvr/X/issues description: Light-weight XML library derived from the [`xml` package](http://hackage.haskell.org/package/xml) for simple parsing and creation of XML documents. It only depends on @base@, @deepseq@, @bytestring@, @text@, and @text-short@. + . + This library provides support for the following specifications: + . + * + . + * + . library hs-source-dirs: src @@ -29,6 +36,7 @@ other-modules: Common + Utils Text.XML.Lexer build-depends: diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -13,10 +13,11 @@ import Data.Data as X (Data) import Data.Foldable as X (Foldable) import Data.Maybe as X -import Data.Monoid as X (Monoid (mappend, mempty)) +import Data.Monoid as X (Monoid (mappend, mconcat, mempty)) import Data.String as X (IsString (fromString)) import Data.Text as X (Text) import Data.Text.Short as X (ShortText) import Data.Traversable as X (Traversable, traverse) import Data.Typeable as X (Typeable) 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,5 +1,59 @@ {-# LANGUAGE FlexibleInstances #-} --------------------------------------------------------------------- + +{- + +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 -- Copyright : (c) Galois, Inc. 2007 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 @@ -1,7 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} --------------------------------------------------------------------- +{- + +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.Cursor -- Copyright : (c) Galois, Inc. 2008 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,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Text.XML.Input @@ -16,6 +18,7 @@ ( -- * High-level DOM Parser parseXML , parseXMLDoc + , parseXMLRoot -- * Token Scanner , XmlSource(uncons) @@ -25,29 +28,95 @@ ) where import Common +import Utils import Text.XML.Lexer -import Text.XML.Proc import Text.XML.Types import qualified Data.Text as T import qualified Data.Text.Short as TS --- | parseXMLDoc, parse a XML document to an 'Element' +-- | Parse a XML document to an 'Element' +-- +-- If you need access to the prolog and epilog use 'parseXMLRoot' +-- +-- An optional (single) leading BOM (@U+FEFF@) character will be discard (and not counted in the source positions). parseXMLDoc :: XmlSource s => s -> Either (Pos,String) Element -parseXMLDoc xs0 = parseXML xs0 >>= strip +parseXMLDoc xs0 = rootElement <$> parseXMLRoot xs0 + +-- | Parse a XML document +-- +-- An optional (single) leading BOM (@U+FEFF@) character will be discard (and not counted in the source positions). +parseXMLRoot :: XmlSource s => s -> Either (Pos,String) Root +parseXMLRoot xs0 = do + (rootXmlDeclaration,ts1) <- case ts0 of + TokXmlDecl xd : rest -> pure (Just xd, rest) + rest -> pure (Nothing, rest) + + (rootPreElem,ts2) <- mnodes ts1 + + (rootDoctype,ts3) <- case ts2 of + TokDTD dtd : ts3a -> do + (ns,rest) <- mnodes ts3a + pure (Just (dtd,ns), rest) + rest -> pure (Nothing, rest) + + (rootElement,ts4) <- case ts3 of + TokStart {} : _ -> case parse ts3 of + ElemF el : rest -> case traverse fromContentF el of + Right e' -> pure (e',rest) + Left err -> Left err + _ -> Left (-1,"empty document (i.e. missing root element)") + + _:_ -> Left (-1,"unexpected (non-misc) content nodes after root element") + [] -> Left (-1,"empty document (i.e. missing root element)") + + (rootPostElem,ts5) <- mnodes2 ts4 + + case ts5 of + [] -> pure Root{..} + (_:_) -> Left (-1,"unexpected (non-misc) content nodes after root element") where - strip cs = case onlyElems cs of - e : es - | "?xml" `TS.isPrefixOf` unLName (qLName (elName e)) - -> strip (map Elem es) - | otherwise -> Right e - [] -> Left (-1,"empty document") + ts0 = scanXML (dropBOM xs0) + -- mnodes :: [Token] -> Either _ ([MiscNodes],[Token]) + + mnodes = go [] + where + go _ (TokError n e : _) = Left (n,e) + go acc (TokComment x : rest) = go (Left x:acc) rest + go acc (TokPI _ x : rest) = go (Right x:acc) rest + go acc (TokText cdata : rest) + | isWsCdata cdata = go acc rest + go acc xs = pure (reverse acc, xs) + + + mnodes2 = go [] + where + go _ (Failure n e : _) = Left (n,e) + go acc (CommF x : rest) = go (Left x:acc) rest + go acc (ProcF x : rest) = go (Right x:acc) rest + go acc (TextF cdata : rest) + | isWsCdata cdata = go acc rest + go acc xs = pure (reverse acc, xs) + + +isWsCdata :: CData -> Bool +isWsCdata (CData _ t) = T.all isS t + -- | parseXML to a list of 'Content' chunks +-- +-- __NOTE__: As opposed to 'parseXMLDoc', this function will /not/ discard any BOM characters. parseXML :: XmlSource s => s -> Either (Pos,String) [Content] parseXML = traverse fromContentF . parse . scanXML +-- | Drop a single leading @U+FEFF@ character +dropBOM :: XmlSource s => s -> s +dropBOM s0 = case uncons s0 of + Just ('\xFEFF',s1) -> s1 + Just _ -> s0 + Nothing -> s0 + ------------------------------------------------------------------------ -- | Variant of 'Content' that can encode parser 'Failure's @@ -55,6 +124,8 @@ = ElemF (Element' ContentF) | TextF CData | CRefF !ShortText + | ProcF PI + | CommF Comment | Failure !Int String deriving (Show, Typeable, Data, Generic) @@ -63,6 +134,8 @@ fromContentF :: ContentF -> Either (Pos,String) Content fromContentF (CRefF ref) = Right (CRef ref) fromContentF (TextF cd) = Right (Text cd) +fromContentF (ProcF x) = Right (Proc x) +fromContentF (CommF x) = Right (Comm x) fromContentF (ElemF el) = Elem <$> traverse fromContentF el fromContentF (Failure pos err) = Left (pos,err) @@ -70,7 +143,7 @@ parse :: [Token] -> [ContentF] parse [] = [] -parse ts = let (es,_,ts1) = nodes ([],Nothing) [] ts +parse ts = let (es,_,ts1) = nodes nsinfo0 [] ts in es ++ parse ts1 -- Information about namespaces. @@ -78,17 +151,30 @@ -- the second is the URI for the default namespace, if one was provided. type NSInfo = ([(ShortText,URI)],Maybe URI) +nsinfo0 :: NSInfo +nsinfo0 = ([("xml",xmlNamesNS),("xmlns",xmlnsNS)],Nothing) nodes :: NSInfo -> [QName] -> [Token] -> ([ContentF], [QName], [Token]) - nodes ns ps (TokError pos msg : _) = let (es,qs,ts1) = nodes ns ps [] in (Failure pos msg : es, qs, ts1) +-- TODO +nodes ns ps (TokXmlDecl _ : ts) = nodes ns ps ts +nodes ns ps (TokDTD _ : ts) = nodes ns ps ts + nodes ns ps (TokCRef ref : ts) = let (es,qs,ts1) = nodes ns ps ts in (CRefF ref : es, qs, ts1) +nodes ns ps (TokComment x : ts) = + let (es,qs,ts1) = nodes ns ps ts + in (CommF x : es, qs, ts1) + +nodes ns ps (TokPI _ x : ts) = + let (es,qs,ts1) = nodes ns ps ts + in (ProcF x : es, qs, ts1) + nodes ns ps (TokText txt : ts) = let (es,qs,ts1) = nodes ns ps ts (more,es1) = case es of @@ -98,11 +184,17 @@ in (TextF txt { cdData = cdData txt `T.append` more } : es1, qs, ts1) -nodes cur_info ps (TokStart _ t as empty' : ts) = (node : siblings, open, toks) +nodes cur_info ps (TokStart pos t as empty' : ts) = (node : siblings, open, toks) where new_name = 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) new_info = foldr addNS cur_info as - node = ElemF Element { elName = new_name + node | rsvnsfail = Failure pos "invalid namespace declaration" + | nsfail = Failure pos "undefined namespace prefix" + | otherwise = + ElemF Element { elName = new_name , elAttribs = map (annotAttr new_info) as , elContent = children } @@ -133,15 +225,37 @@ annotAttr :: NSInfo -> Attr -> Attr annotAttr ns a@(Attr { attrKey = k}) = case (qPrefix k, qLName k) of + -- see https://www.w3.org/2000/xmlns/ + (Nothing, "xmlns") -> a { attrKey = k { qURI = Just xmlnsNS } } -- Do not apply the default name-space to unqualified -- attributes. See Section 6.2 of . (Nothing, _) -> a _ -> a { attrKey = annotName ns k } - 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 Nothing else Just (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 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 @@ -2,8 +2,63 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} +{- + +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.Lexer -- Copyright : (c) Galois, Inc. 2007 @@ -14,11 +69,13 @@ import Common import Text.XML.Types +import Utils -import qualified Data.Text as TS -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Numeric (readHex) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, toLower) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Short as TS +import Numeric (readHex) class XmlSource s where uncons :: s -> Maybe (Char,s) @@ -27,8 +84,8 @@ uncons (c:s) = Just (c,s) uncons "" = Nothing -instance XmlSource TS.Text where - uncons = TS.uncons +instance XmlSource T.Text where + uncons = T.uncons instance XmlSource TL.Text where uncons = TL.uncons @@ -59,6 +116,10 @@ | TokCRef ShortText -- ^ character entity reference | TokText CData -- ^ character data | TokError !Pos String -- ^ Lexer error + | TokXmlDecl XmlDeclaration + | TokComment Comment + | TokPI !Pos PI + | TokDTD Text deriving (Show,Data,Typeable,Generic) instance NFData Token @@ -68,63 +129,166 @@ -- | Run XML lexer over 'XmlSource' scanXML :: XmlSource source => source -> [Token] -scanXML = tokens' . go 0 +scanXML = tokens0 . eolNorm . go 0 where go !n src = case uncons src of Just (c,src') -> (n,c) : go (n+1) src' Nothing -> [] +{- + +> [XML 1.0] 2.11 End-of-Line Handling +> +> [...] the XML processor must behave as if it normalized all line breaks +> in external parsed entities (including the document entity) on input, +> before parsing, by translating both the two-character sequence #xD #xA +> and any #xD that is not followed by #xA to a single #xA character. + +-} +eolNorm :: LString -> LString +eolNorm [] = [] +eolNorm ((_,'\xD'):c@(_,'\xA'):cs) = c : eolNorm cs +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 + + tokens' :: LString -> [Token] -tokens' ((_,'<') : c@(_,'!') : cs) = special c cs +tokens' ((_,'<') : (_,'!') : cs) = special cs +tokens' ((n,'<') : (_,'?') : cs) = procins n cs tokens' ((_,'<') : cs) = tag cs tokens' [] = [] -tokens' cs@((_,_):_) = let (as,bs) = breakn ('<' ==) cs - in map cvt (decode_text as) ++ tokens' bs +tokens' cs@((n,_):_) = let (as,bs) = breakn ('<' ==) cs + in foldr cvt (tokens' bs) (decode_text as) -- XXX: Note, some of the lines might be a bit inacuarate - where cvt (TxtBit x) = TokText CData { cdVerbatim = CDataText - , cdData = fromString x - } - cvt (CRefBit x) = case cref_to_char x of - Just c -> TokText CData { cdVerbatim = CDataText - , cdData = T.singleton c - } - Nothing -> TokCRef (fromString x) + where + cvt (TxtBit x) cont + | 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 + Just c + | isChar c -> TokText CData { cdVerbatim = CDataText, cdData = T.singleton c } : cont + | otherwise -> [TokError n "invalid character reference"] + Nothing -> TokCRef (fromString x) : cont +-- +-- PI ::= '' Char*)))? '?>' +-- PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) +procins :: Pos -> LString -> [Token] +procins n0 = go "" + where + go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (tokens' ds) + go acc ((_,c) : ds) = go (c:acc) ds + go _ [] = eofErr -special :: LChar -> LString -> [Token] -special (_,_) ((_,'-') : (_,'-') : cs) = skip cs + mkPI :: String -> [Token] -> [Token] + mkPI s0 ts + | tgt == "xml" = mkXMLDecl s' ts + | map toLower (TS.unpack tgt) == "xml" = [TokError (n0+2) "Invalid PI name"] + | otherwise = TokPI n0 (PI tgt payload) : ts + where + (tgt0,s') = break isS s0 + tgt = TS.fromString tgt0 + payload = T.pack (dropWhile isS s') + + {- + XMLDecl ::= '' + VersionInfo ::= S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"') + EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" ) + SDDecl ::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) + + Eq ::= S? '=' S? + + VersionNum ::= '1.0' + EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')* + + -} + + -- needs serious rewrite... + mkXMLDecl s0 ts + | n0 > 0 = [TokError n0 "XML declaration allowed only at the start of the document"] + | otherwise = go1 (simpleTokenize s0) + where + go1 ("":"version":"=":ver:rest) + | Just "1.0" <- unbrack ver = go2 rest + go1 _ = [TokError n0 "Unsupported or missing 'version' in XML declaration"] + + go2 ("":"encoding":"=":enc:rest) + | Just enc' <- unbrack enc, isEnc enc' = go3 (Just $ TS.pack enc') rest + | otherwise = [TokError n0 "Bad 'encoding' value in XML declaration"] + go2 rest = go3 Nothing rest + + go3 enc ("":"standalone":"=":sd:rest) + | Just sd' <- unbrack sd, Just sd'' <- isBoo sd' = go4 enc (Just sd'') rest + | 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 _ _ _ = [TokError n0 "unexpected or malformed attribute in XML declaration"] + + isEnc [] = False + isEnc (c:cs) = (isAsciiLower c || isAsciiUpper c) && + all (\c' -> isAsciiLower c' || isAsciiUpper c' || isDigit c' || c' `elem` ['.','_','-']) cs + + isBoo "yes" = Just True + isBoo "no" = Just False + isBoo _ = Nothing + + unbrack ('\'':xs) | Just (s,'\'') <- unsnoc xs = Just s + unbrack ('"':xs) | Just (s,'"') <- unsnoc xs = Just s + unbrack _ = Nothing + + +special :: LString -> [Token] +-- ' +special ((_,'-') : (_,'-') : cs) = go "" cs where - skip ((pos,'-') : (_,'-') : (_,x) : ds) - | x == '>' = tokens' ds - | otherwise = [TokError pos "double hyphen within comment"] - skip (_ : ds) = skip ds - skip [] = eofErr + go acc ((n,'-') : (_,'-') : (_,x) : ds) + | x == '>' = TokComment (Comment $ T.pack (reverse acc)) : tokens' ds + | otherwise = [TokError n "double hyphen within comment"] + go acc ((_,c) : ds) = go (c:acc) ds + go _ [] = eofErr -special _ ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) = +-- ') : ds) = ([],ds) - cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) - cdata [] = ([],[]) + dat = T.pack xs + in if T.all isChar dat then TokText CData { cdVerbatim = CDataVerbatim, cdData = dat } : tokens' ts + else [TokError (n-2) "invalid code-point in CDATA block"] + where + cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds) + cdata ((_,d) : ds) = let (xs,ys) = cdata ds in (d:xs,ys) + cdata [] = ([],[]) -special _ cs = - let (xs,ts) = munch "" 0 cs - in TokText CData { cdVerbatim = CDataRaw - , cdData = fromString ('<':'!':reverse xs) - } : tokens' ts - where munch acc nesting ((_,'>') : ds) - | nesting == (0::Int) = ('>':acc,ds) - | otherwise = munch ('>':acc) (nesting-1) ds - munch acc nesting ((_,'<') : ds) - = munch ('<':acc) (nesting+1) ds - munch acc n ((_,x) : ds) = munch (x:acc) n ds - munch acc _ [] = (acc,[]) -- unterminated DTD markup ---special c cs = tag (c : cs) -- invalid specials are processed as tags +-- ') : ds) + | nesting == (0::Int) = (acc,ds) + | otherwise = munch ('>':acc) (nesting-1) ds + munch acc nesting ((_,'<') : ds) = munch ('<':acc) (nesting+1) ds + 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 + qualName :: LString -> (QName,LString) qualName xs = (QName { qURI = Nothing , qPrefix = fmap fromString q @@ -136,7 +300,7 @@ (q1,_:n1) -> (Just q1, n1) _ -> (Nothing, as) - endName x = isSpace x || x == '=' || x == '>' || x == '/' + endName x = isS x || x == '=' || x == '>' || x == '/' {- @@ -149,41 +313,47 @@ -} tag :: LString -> [Token] tag ((p,'/') : cs) + | isValidQName n = TokEnd p n : case dropSpace ds of (_,'>') : es -> tokens' 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 - = TokStart (fst (head cs)) n as b : ts +tag 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 where (n,ds) = qualName cs (as,b,ts) = attribs (dropSpace 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) +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) - _ -> let (a,cs1) = attrib cs - (as,b,ts) = attribs cs1 - in (a:as,b,ts) + _ -> let (a,cs1) = attrib cs + (as,b,ts) = attribs cs1 + in (a:as,b,ts) -attrib :: LString -> (Attr,LString) -attrib cs = let (ks,cs1) = qualName cs - (vs,cs2) = attr_val (dropSpace cs1) - in ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2) +attrib :: LString -> (Attr,LString) +attrib cs = ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2) + where + (vs,cs2) = attr_val (dropSpace cs1) + (ks,cs1) = qualName cs {- AttValue ::= '"' ([^<&"] | Reference)* '"' @@ -192,28 +362,16 @@ attr_val :: LString -> (String,LString) attr_val ((_,'=') : cs0) = string (dropSpace cs0) where - -- | Match the value for an attribute. For malformed XML we do - -- our best to guess the programmer's intention. + -- | Match the value for an attribute. string :: LString -> (String,LString) - string ((_,'"') : cs) = break' ('"' ==) cs - string ((_,'\'') : cs) = break' ('\'' ==) cs - -- Allow attributes that are not enclosed by anything. - string cs = breakn eos cs - where eos x = isSpace x || x == '>' || x == '/' -attr_val cs = ("",cs) - - -{- - -S ::= (#x20 | #x9 | #xD | #xA)+ + string ((_,'"') : cs) = break' ('"' ==) cs + string ((_,'\'') : cs) = break' ('\'' ==) cs + -- hack: inject invalid \0 character to trigger failure in caller + string cs = ("\0",cs) +attr_val cs = ("\0",cs) --} dropSpace :: LString -> LString -dropSpace = dropWhile (isSpace . snd) - -isSpace :: Char -> Bool -isSpace = (`elem` "\x20\x09\x0D\x0A") - +dropSpace = dropWhile (isS . snd) break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) break' p xs = let (as,bs) = breakn p xs @@ -224,14 +382,19 @@ breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l - decode_attr :: String -> String decode_attr cs = concatMap cvt (decode_text cs) - where cvt (TxtBit x) = x - cvt (CRefBit x) = case cref_to_char x of - Just c -> [c] - Nothing -> '&' : x ++ ";" + where + cvt (TxtBit x) = norm x + cvt (CRefBit x) + | Just c <- cref_to_char x = [c] + | otherwise = "\0" -- triggers error lateron + norm [] = [] + norm ('\x9':xs) = '\x20' : norm xs + norm ('\xA':xs) = '\x20' : norm xs + norm (x:xs) = x : norm xs + data Txt = TxtBit String | CRefBit String deriving Show decode_text :: [Char] -> [Txt] @@ -265,3 +428,27 @@ | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char) = Just (toEnum x) | otherwise = Nothing + + +simpleTokenize :: String -> [String] +simpleTokenize [] = [] +simpleTokenize (c:cs) + | isSorEQ c = let (sep,rest) = span isSorEQ (c:cs) + in (if ('=' `elem` sep) then "=" else "") : simpleTokenize rest + + | c == '\'' = case break (== '\'') cs of + (_,"") -> [c:cs] + (str,_:rest) -> (c:str++"'") : simpleTokenize rest + | c == '"' = case break (== '"') cs of + (_,"") -> [c:cs] + (str,_:rest) -> (c:str++"\"") : simpleTokenize rest + | otherwise = let (t,rest) = break isSorEQ (c:cs) + in t : simpleTokenize rest + where + isSorEQ x = isS x || x == '=' + + +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/Output.hs b/src/Text/XML/Output.hs --- a/src/Text/XML/Output.hs +++ b/src/Text/XML/Output.hs @@ -1,6 +1,60 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------- +{- + +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.Output -- Copyright : (c) Galois, Inc. 2007 @@ -13,104 +67,103 @@ module Text.XML.Output ( serializeXML , serializeXMLDoc + , serializeXMLRoot + , SerializeXMLOptions(..), defaultSerializeXMLOptions ) where import Common -import Data.Char -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Short as TS +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Short as TS import Text.XML.Types +import Utils + -- | Serialize XML 1.0 document prefixed by the XML prologue -- \"@\@\" -- serializeXMLDoc :: Element -> TL.Text -serializeXMLDoc = TL.pack . showTopElement +serializeXMLDoc el + = serializeXMLRoot defaultSerializeXMLOptions + (Root (Just (XmlDeclaration Nothing Nothing)) [] Nothing el []) -- | Serialize a sequence of XML 'Content' nodes serializeXML :: [Content] -> TL.Text -serializeXML = TL.pack . foldr (ppContentS defaultConfigPP "") "" +serializeXML = TL.pack . foldr (ppContentS defaultSerializeXMLOptions) "" --- | The XML 1.0 header -xml_header :: String -xml_header = "" --------------------------------------------------------------------------------- -data ConfigPP = ConfigPP - { prettify :: !Bool +-- | Default rendering options +-- +-- * Allow empty tags for all non-special elements +-- +-- * Don't insert newlines between prolog/epilog nodes +-- +defaultSerializeXMLOptions :: SerializeXMLOptions +defaultSerializeXMLOptions = SerializeXMLOptions + { serializeAllowEmptyTag = const True + , serializeProEpilogAddNLs = False } --- | Default pretty printing configuration. --- * Always use abbreviate empty tags. -defaultConfigPP :: ConfigPP -defaultConfigPP = ConfigPP { prettify = False } - -{- --- | A configuration that tries to make things pretty --- (possibly at the cost of changing the semantics a bit --- through adding white space.) -prettyConfigPP :: ConfigPP -prettyConfigPP = defaultConfigPP { prettify = True } +-- | Options for tweaking XML serialization output +data SerializeXMLOptions = SerializeXMLOptions + { serializeAllowEmptyTag :: QName -> Bool + , serializeProEpilogAddNLs :: Bool + } --- | Pretty printing renders XML documents faithfully, --- with the exception that whitespace may be added\/removed --- in non-verbatim character data. -ppTopElement :: Element -> String -ppTopElement = ppcTopElement prettyConfigPP +-- | Serialize a XML 'Root' +serializeXMLRoot :: SerializeXMLOptions -> Root -> TL.Text +serializeXMLRoot sopts Root{..} = TLB.toLazyText $ + (if serializeProEpilogAddNLs sopts then bUnlines else mconcat) $ + maybeToList xmldecl ++ + map bMisc rootPreElem ++ + (case rootDoctype of + Nothing -> [] + Just (dtd,moreMisc) -> (" TLB.fromText dtd <+> ">") : map bMisc moreMisc + ) ++ + [TLB.fromString (ppElementS sopts rootElement "")] ++ + map bMisc rootPostElem + where + xmldecl = case rootXmlDeclaration of + Nothing -> Nothing + Just (XmlDeclaration Nothing Nothing) -> Just "" + Just (XmlDeclaration menc mstand) -> Just $ + (") $ + (maybe id (\enc cont -> " encoding=\"" <+> bFromShortText enc <+> "\"" <+> cont) menc) $ + (maybe id (\b cont -> " standalone=\"" <+> (if b then "yes" else "no") <+> "\"" <+> cont) mstand) $ + "?>" --- | Pretty printing renders XML documents faithfully, --- with the exception that whitespace may be added\/removed --- in non-verbatim character data. -ppcTopElement :: ConfigPP -> Element -> String -ppcTopElement c e = unlines [xml_header,ppcElement c e] + bMisc (Left (Comment t)) = "" + bMisc (Right (PI tgt dat)) = " bFromShortText tgt <+> (if T.null dat then mempty else " ") <+> TLB.fromText dat <+> "?>" --- | Pretty printing elements -ppcElement :: ConfigPP -> Element -> String -ppcElement c e = ppElementS c "" e "" --} +-------------------------------------------------------------------------------- -- | Pretty printing content using ShowS -ppContentS :: ConfigPP -> String -> Content -> ShowS -ppContentS c i x xs = case x of - Elem e -> ppElementS c i e xs - Text t -> ppCDataS c i t xs - CRef r -> showCRefS r xs +ppContentS :: SerializeXMLOptions -> Content -> ShowS +ppContentS c x xs = case x of + Elem e -> ppElementS c e xs + Text t -> showCDataS t xs + CRef r -> showCRefS r xs + Proc p -> ppProcS p xs + Comm t -> ppCommS t xs -ppElementS :: ConfigPP -> String -> Element -> ShowS -ppElementS c i e xs = i ++ (tagStart (elName e) (elAttribs e) $ - case elContent e of - [] | "?" `TS.isPrefixOf` unLName (qLName name) -> " ?>" ++ xs - | otherwise -> " />" ++ xs - [Text t] -> ">" ++ ppCDataS c "" t (tagEnd name xs) - cs -> '>' : nl ++ foldr ppSub (i ++ tagEnd name xs) cs - where ppSub e1 = ppContentS c (sp ++ i) e1 . showString nl - (nl,sp) = if prettify c then ("\n"," ") else ("","") - ) +ppElementS :: SerializeXMLOptions -> Element -> ShowS +ppElementS c e xs = tagStart (elName e) (elAttribs e) $ case elContent e of + [] | allowEmpty -> "/>" ++ xs + [Text t] -> ">" ++ showCDataS t (tagEnd name xs) + cs -> '>' : foldr (ppContentS c) (tagEnd name xs) cs where name = elName e + allowEmpty = serializeAllowEmptyTag c name -ppCDataS :: ConfigPP -> String -> CData -> ShowS -ppCDataS c i t xs = i ++ if cdVerbatim t /= CDataText || not (prettify c) - then showCDataS t xs - else foldr cons xs (showCData t) +ppCommS :: Comment -> ShowS +ppCommS (Comment t) xs = "" ++ xs - where cons :: Char -> String -> String - cons '\n' ys = "\n" ++ i ++ ys - cons y ys = y : ys +ppProcS :: PI -> ShowS +ppProcS (PI tgt dat) xs = "" ++ xs -------------------------------------------------------------------------------- --- | Adds the header. -showTopElement :: Element -> String -showTopElement c = xml_header ++ showElement c - -showElement :: Element -> String -showElement c = ppElementS defaultConfigPP "" c "" - -showCData :: CData -> String -showCData c = ppCDataS defaultConfigPP "" c "" - -- Note: crefs should not contain '&', ';', etc. showCRefS :: ShortText -> ShowS showCRefS r xs = '&' : TS.unpack r ++ ';' : xs @@ -124,32 +177,39 @@ . showString "]]>" CDataRaw -> \ xs -> T.unpack (cdData cd) ++ xs --------------------------------------------------------------------------------- -escCData :: String -> ShowS +-- escape text in `` blocks +escCData :: String -> ShowS escCData (']' : ']' : '>' : cs) = showString "]]]]>" . escCData cs escCData (c : cs) = showChar c . escCData cs escCData [] = id -escChar :: Char -> ShowS +-- escape char in text-nodes +escChar :: Char -> ShowS escChar c = case c of - '<' -> showString "<" - '>' -> showString ">" - '&' -> showString "&" - '"' -> showString """ - -- we use ' instead of ' because IE apparently has difficulties - -- rendering ' in xhtml. - -- Reported by Rohan Drape . - '\'' -> showString "'" + '<' -> showString "<" -- MUST + '>' -> showString ">" -- MUST ("for compatibility") + '&' -> showString "&" -- MUST + '\x0D' -> showString " " -- MUST (due to EOL normalization) + _ -> showChar c - -- NOTE: We escape '\r' explicitly because otherwise they get lost - -- when parsed back in because of then end-of-line normalization rules. - _ | isPrint c || c == '\n' -> showChar c - | otherwise -> showString "&#" . shows oc . showChar ';' - where oc = ord c +-- escape char in attribute value +escCharAttr :: Char -> ShowS +escCharAttr c = case c of + '<' -> showString "<" -- MUST + '&' -> showString "&" -- MUST + '"' -> showString """ -- MUST (for attr enclosed by ") + '\x09' -> showString " " -- MUST (due to attr WS normalization) + '\x0A' -> showString " " -- MUST (due to attr WS normalization) + '\x0D' -> showString " " -- MUST (due to EOL normalization) + _ -> showChar c + escStr :: String -> ShowS escStr cs rs = foldr escChar rs cs +escStrAttr :: String -> ShowS +escStrAttr cs rs = foldr escCharAttr rs cs + tagEnd :: QName -> ShowS tagEnd qn rs = '<':'/':showQName qn ++ '>':rs @@ -158,7 +218,7 @@ where as_str = if null as then "" else ' ' : unwords (map showAttr as) showAttr :: Attr -> String -showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr (T.unpack v) "\"" +showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStrAttr (T.unpack v) "\"" showQName :: QName -> String showQName q = pre ++ showLName (qLName q) 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,11 +1,63 @@ --------------------------------------------------------------------- +{- + +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.Proc -- Copyright : (c) Galois, Inc. 2007 -- (c) Herbert Valerio Riedel 2019 -- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later -- --------------------------------------------------------------------- module Text.XML.Proc where 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 @@ -5,7 +5,60 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- +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 @@ -17,12 +70,64 @@ 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 @@ -62,11 +167,18 @@ instance NFData CDataKind --- | XML qualified names +-- | A +-- +-- 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 , qURI :: Maybe URI - , qPrefix :: Maybe ShortText + , qPrefix :: Maybe NCName -- ^ Invariant: MUST be a proper } deriving (Show, Typeable, Data, Generic) instance NFData QName @@ -83,13 +195,25 @@ x -> x -- | XML local names -newtype LName = LName { unLName :: ShortText } - deriving (Show, Ord, Eq, Typeable, Data, IsString, NFData, Generic) +-- +-- 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 not be @""@ newtype URI = URI { unURI :: ShortText } - deriving (Show, Ord, Eq, Typeable, Data, IsString, NFData, Generic) + deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) +-- 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 @@ -120,3 +244,26 @@ , elAttribs = mempty , elContent = mempty } + +-- | Smart constructor for @xmlns:\ = \@ +-- +-- @since 0.2.0 +xmlns_attr :: NCName -- ^ non-empty namespace prefix + -> URI -- ^ Namespace URI + -> Attr +xmlns_attr pfx (URI uri) + | TS.null pfx = error "Text.XML.xmlns_attr: empty namespace prefix" + | otherwise = Attr (QName { qPrefix = Just (TS.pack "xmlns"), qLName = LName pfx, qURI = Just xmlnsNS }) (TS.toText uri) + where + xmlnsNS = URI ns_xmlns_uri + +-- | Smart constructor for @xmlns = [\|""]@ +-- +-- @since 0.2.0 +xmlns_def_attr :: Maybe URI -- ^ Default namespace URI (or 'Nothing' to reset default namespace) + -> Attr +xmlns_def_attr muri + = Attr (QName { qPrefix = Nothing, qLName = LName (TS.pack "xmlns"), qURI = Just xmlnsNS }) + (case muri of { Nothing -> mempty; Just (URI uri) -> TS.toText uri}) + where + xmlnsNS = URI ns_xmlns_uri diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- + +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 : Utils +-- Copyright : (c) Herbert Valerio Riedel 2019 +-- SPDX-License-Identifier: GPL-3.0-or-later +-- +-- Internal helpers +-- + +module Utils where + +import Common +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Short as TS + +-- | +-- +-- > S ::= (#x20 | #x9 | #xD | #xA)+ +-- +isS :: Char -> Bool +isS '\x20' = True +isS '\x09' = True +isS '\x0D' = True +isS '\x0A' = True +isS _ = False + +isNCName :: String -> Bool +isNCName [] = False +isNCName (c:cs) = isNameStartChar c && c /= ':' && all (\c' -> isNameChar c' && c' /= ':') cs + +-- | +-- +-- Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] +-- +isChar :: Char -> Bool +isChar c + | c < '\x20' = c == '\x0A' || c == '\x09' || c == '\x0D' + | c < '\xD800' = True + | c < '\xE000' = False + | c == '\xFFFE' = False + | c == '\xFFFF' = False + | otherwise = True + +-- | +-- +-- NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF] +-- +-- NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040] +-- +-- Name ::= NameStartChar (NameChar)* +-- +isNameStartChar :: Char -> Bool +isNameStartChar c + | c == ':' = True + | c < 'A' = False + | c <= 'Z' = True + | c == '_' = True + | c < 'a' = False + | c <= 'z' = True + | c < '\xC0' = False + | c <= '\xD6' = True + | c < '\xD8' = False + | c <= '\xF6' = True + | c < '\xF8' = False + | c <= '\x2FF' = True + | c < '\x370' = False + | c <= '\x37D' = True + | c < '\x37F' = False + | c <= '\x1FFF' = True + | c < '\x200C' = False + | c <= '\x200D' = True + | c < '\x2070' = False + | c <= '\x218F' = True + | c < '\x2C00' = False + | c <= '\x2FEF' = True + | c < '\x3001' = False + | c <= '\xD7FF' = True + | c < '\xF900' = False + | c <= '\xFDCF' = True + | c < '\xFDF0' = False + | c <= '\xFFFD' = True + | c < '\x10000' = False + | c <= '\xEFFFF' = True + | otherwise = False + +-- | See 'isNameStartChar' +isNameChar :: Char -> Bool +isNameChar c + | c == '.' = True + | c == '-' = True + | c < '0' = False + | c <= ':' = True + | c < 'A' = False + | c <= 'Z' = True + | c == '_' = True + | c < 'a' = False + | c <= 'z' = True + | c == '\xB7' = True + | c < '\xC0' = False + | c <= '\xD6' = True + | c < '\xD8' = False + | c <= '\xF6' = True + | c < '\xF8' = False + | c <= '\x2FF' = True + | c < '\x300' = False + | c <= '\x37D' = True + | c < '\x37F' = False + | c <= '\x1FFF' = True + | c < '\x200C' = False + | c <= '\x200D' = True + | c < '\x203F' = False + | c <= '\x2040' = True + | c < '\x2070' = False + | c <= '\x218F' = True + | c < '\x2C00' = False + | c <= '\x2FEF' = True + | c < '\x3001' = False + | c <= '\xD7FF' = True + | c < '\xF900' = False + | c <= '\xFDCF' = True + | c < '\xFDF0' = False + | c <= '\xFFFD' = True + | c < '\x10000' = False + | c <= '\xEFFFF' = True + | otherwise = False + + + +unsnoc :: [x] -> Maybe ([x],x) +unsnoc [] = Nothing +unsnoc xs = Just (init xs, last xs) + + +infixr 6 <+> + +(<+>) :: TLB.Builder -> TLB.Builder -> TLB.Builder +(<+>) = mappend + +bFromShortText :: ShortText -> TLB.Builder +bFromShortText = TLB.fromText . TS.toText + +bUnlines :: [TLB.Builder] -> TLB.Builder +bUnlines [] = mempty +bUnlines [x] = x +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/" + +{-# NOINLINE ns_xml_uri #-} +ns_xml_uri :: ShortText +ns_xml_uri = "http://www.w3.org/XML/1998/namespace" + +