diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2024 Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/hspec/Main.hs b/src/hspec/Main.hs new file mode 100644 --- /dev/null +++ b/src/hspec/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/hspec/XmlTypesContentSpec.hs b/src/hspec/XmlTypesContentSpec.hs new file mode 100644 --- /dev/null +++ b/src/hspec/XmlTypesContentSpec.hs @@ -0,0 +1,90 @@ +module XmlTypesContentSpec (spec) where + +import qualified Data.ByteString.Lazy +import qualified Data.Text as Text +import Data.XML.Types +import LawfulConversions +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Property +import qualified Text.XML +import qualified Text.XML.Stream.Parse +import qualified Text.XML.Unresolved +import qualified XmlTypesContent +import Prelude + +spec :: Spec +spec = do + describe "textNodes" do + prop "Produces nodes that decode to the source" do + -- For some reason xml-conduit remaps '\r' to '\n', so we simply work around that. + text <- suchThat arbitrary (not . elem '\r' . Text.unpack) + pure case extractTextContentFromXml (textXml text) of + Right decodedText -> + if decodedText == text + then succeeded + else failed {Test.QuickCheck.Property.reason} + where + reason = + [ show text, + "\n =/=\n", + show decodedText, + "\nXML:\n", + to @_ @Text (from (textXml text)) + ] + & mconcat + Left parsingErr -> + failed {Test.QuickCheck.Property.reason} + where + reason = + [ "Failed to parse due to: ", + parsingErr, + "\n", + "XML:\n", + from (textXml text) + ] + & mconcat + & to + +textXml :: Text -> Data.ByteString.Lazy.ByteString +textXml = nodesXml . fmap NodeContent . XmlTypesContent.textContents + +nodesXml :: [Data.XML.Types.Node] -> Data.ByteString.Lazy.ByteString +nodesXml = + buildLbs . buildDocument . buildRootElement + where + buildRootElement elementNodes = + Data.XML.Types.Element + { elementName = "a", + elementAttributes = [], + elementNodes + } + buildDocument documentRoot = + Data.XML.Types.Document + { documentPrologue = + Data.XML.Types.Prologue [] Nothing [], + documentEpilogue = + [], + documentRoot + } + buildLbs = + Text.XML.Unresolved.renderLBS Text.XML.Unresolved.def + +extractTextContentFromXml :: Data.ByteString.Lazy.ByteString -> Either Text Text +extractTextContentFromXml = parseLbs >=> parseAst + where + parseLbs = + first (fromString . displayException) . Text.XML.parseLBS settings + where + settings = + Text.XML.def + { Text.XML.Stream.Parse.psDecodeIllegalCharacters = Just . chr + } + parseAst = + parseNodes . Text.XML.elementNodes . Text.XML.documentRoot + where + parseNodes = \case + [Text.XML.NodeContent content] -> pure content + [] -> pure "" + _ -> Left "Invalid nodes" diff --git a/src/library/XmlTypesContent.hs b/src/library/XmlTypesContent.hs new file mode 100644 --- /dev/null +++ b/src/library/XmlTypesContent.hs @@ -0,0 +1,95 @@ +module XmlTypesContent + ( textContents, + ) +where + +import Data.Char +import Data.Function +import Data.Text (Text) +import qualified Data.Text as Text +import Data.XML.Types +import qualified TextBuilderDev +import Prelude + +-- | +-- Convert 'Text' into 'Content' list, escaping undefined Unicode chars as described in https://www.w3.org/TR/xml11/#charsets. +textContents :: Text -> [Content] +textContents text = + case Text.span charNeedsNoEscaping text of + (prefix, remainder) -> + if Text.null prefix + then entityAndTail + else ContentText prefix : entityAndTail + where + entityAndTail = + case Text.uncons remainder of + Nothing -> [] + Just (charToEscape, nextText) -> + charEntityContent charToEscape : textContents nextText + +charEntityContent :: Char -> Content +charEntityContent = ContentEntity . codepointEntityText . ord + +codepointEntityText :: Int -> Text +codepointEntityText = \case + 62 -> "gt" + 60 -> "lt" + 38 -> "amp" + 34 -> "quot" + 39 -> "apos" + codepoint -> codepointDecimalEntityText codepoint + +codepointDecimalEntityText :: Int -> Text +codepointDecimalEntityText codepoint = + TextBuilderDev.fromTextBuilder ("#" <> TextBuilderDev.unsignedDecimal codepoint) + +charNeedsNoEscaping :: Char -> Bool +charNeedsNoEscaping = codepointNeedsNoEscaping . ord + +codepointNeedsNoEscaping :: Int -> Bool +codepointNeedsNoEscaping codepoint = + isNotControl && isNotUndefined + where + isNotControl = + not (elem codepoint controlCodepoints) + isNotUndefined = + undefinedUnicodeRanges + & fmap (\(a, b) -> codepoint < a || b < codepoint) + & and + +controlCodepoints :: [Int] +controlCodepoints = + [ 62, -- > + 60, -- < + 38, -- & + 34, -- " + 39 -- ' + ] + +-- | +-- Source: https://www.w3.org/TR/xml11/#charsets. +undefinedUnicodeRanges :: [(Int, Int)] +undefinedUnicodeRanges = + [ (0x1, 0x8), + (0xB, 0xC), + (0xE, 0x1F), + (0x7F, 0x84), + (0x86, 0x9F), + (0xFDD0, 0xFDDF), + (0x1FFFE, 0x1FFFF), + (0x2FFFE, 0x2FFFF), + (0x3FFFE, 0x3FFFF), + (0x4FFFE, 0x4FFFF), + (0x5FFFE, 0x5FFFF), + (0x6FFFE, 0x6FFFF), + (0x7FFFE, 0x7FFFF), + (0x8FFFE, 0x8FFFF), + (0x9FFFE, 0x9FFFF), + (0xAFFFE, 0xAFFFF), + (0xBFFFE, 0xBFFFF), + (0xCFFFE, 0xCFFFF), + (0xDFFFE, 0xDFFFF), + (0xEFFFE, 0xEFFFF), + (0xFFFFE, 0xFFFFF), + (0x10FFFE, 0x10FFFF) + ] diff --git a/xml-types-content.cabal b/xml-types-content.cabal new file mode 100644 --- /dev/null +++ b/xml-types-content.cabal @@ -0,0 +1,70 @@ +cabal-version: 3.0 +name: xml-types-content +version: 0.0.1 +synopsis: Utilities for dealing with Content-values of "xml-types" +description: + The `Content` type in "xml-types" is tricky and naive usage of it can lead to bugs. + You cannot simply construct `ContentText` from any textual value. + You must encode certain character ranges via entities. + This library does that for you by providing mappers from `Text` to `[Content]`. + +homepage: https://github.com/nikita-volkov/xml-types-content +bug-reports: https://github.com/nikita-volkov/xml-types-content/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2024 Nikita Volkov +license: MIT +license-file: LICENSE + +source-repository head + type: git + location: git://github.com/nikita-volkov/xml-types-content.git + +common base + default-language: Haskell2010 + default-extensions: + BlockArguments + DefaultSignatures + FlexibleContexts + FlexibleInstances + LambdaCase + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + ScopedTypeVariables + TypeApplications + UndecidableSuperClasses + +library + import: base + hs-source-dirs: src/library + exposed-modules: + XmlTypesContent + + build-depends: + base >=4.13 && <5, + text >=1.2 && <3, + text-builder-dev ^>=0.3.9, + xml-types ^>=0.3.8, + +test-suite hspec + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: src/hspec + main-is: Main.hs + other-modules: + XmlTypesContentSpec + + build-tool-depends: + hspec-discover:hspec-discover >=2 && <3 + + build-depends: + QuickCheck >=2.13 && <3, + hspec >=2.11 && <3, + lawful-conversions ^>=0.1.5, + rerebase >=1 && <2, + xml-conduit ^>=1.9, + xml-types ^>=0.3.8, + xml-types-content,