Merge pull request #1553 from samply/fix-handling-control-chars-xml

Fix XML Output for Resources with Control Chars
samply · Mar 14, 2024 · 39d577d · 39d577d
2 parents f3a0006 + 8a81f5a
commit 39d577d
Show file tree

Hide file tree

Showing 11 changed files with 297 additions and 140 deletions.
diff --git a/modules/fhir-structure/.clj-kondo/config.edn b/modules/fhir-structure/.clj-kondo/config.edn
@@ -18,4 +18,6 @@
   {:level :off}
 
   :unused-private-var
-  {:exclude [blaze.fhir.spec.type/at-utc]}}}
+  {:exclude [blaze.fhir.spec.type/at-utc]}}
+
+ :exclude-files "src/blaze/fhir/spec/type.clj"}
diff --git a/modules/fhir-structure/src/blaze/fhir/spec/impl.clj b/modules/fhir-structure/src/blaze/fhir/spec/impl.clj
@@ -52,7 +52,7 @@
   (intern/intern-value identity))
 
 (def uri-matcher-form
-  `(specs/regex #"\S*" intern-string))
+  `(specs/regex #"[\u0021-\uFFFF]*" intern-string))
 
 (def conform-xml-value
   "Takes the value out of an XML element."
@@ -172,7 +172,7 @@
       :spec-form
       (case path
         ("Quantity.unit" "Coding.version" "Coding.display" "CodeableConcept.text")
-        `(specs/json-regex-primitive #"[ \r\n\t\S]+" type/intern-string)
+        `(specs/json-regex-primitive #"[\r\n\t\u0020-\uFFFF]+" type/intern-string)
         (keyword "fhir.json" (:code type)))}
      (cond->
       {:key (path-parts->key' "fhir.xml" (split-path path))
@@ -184,7 +184,7 @@
        :spec-form
        (case path
          ("Quantity.unit" "Coding.version" "Coding.display" "CodeableConcept.text")
-         (xml/primitive-xml-form #"[ \r\n\t\S]+" `type/xml->InternedString)
+         (xml/primitive-xml-form #"[\r\n\t\u0020-\uFFFF]+" `type/xml->InternedString)
          (keyword (if rep "fhir.json" "fhir.xml") (:code type)))}
        rep
        (assoc :representation rep))
@@ -679,32 +679,38 @@
     (case name
       "boolean" `(specs/json-pred-primitive boolean? type/boolean)
       "integer" `(specs/json-pred-primitive int? type/integer)
-      "string" `(specs/json-regex-primitive ~pattern type/string)
+      "string" `(specs/json-regex-primitive #"[\r\n\t\u0020-\uFFFF]+" type/string)
       "decimal" `(specs/json-pred-primitive decimal-or-int? type/decimal)
-      "uri" `(specs/json-regex-primitive ~pattern type/uri)
-      "url" `(specs/json-regex-primitive ~pattern type/url)
-      "canonical" `(specs/json-regex-primitive ~pattern type/canonical)
+      "uri" `(specs/json-regex-primitive #"[\u0021-\uFFFF]*" type/uri)
+      "url" `(specs/json-regex-primitive #"[\u0021-\uFFFF]*" type/url)
+      "canonical" `(specs/json-regex-primitive #"[\u0021-\uFFFF]*" type/canonical)
       "base64Binary" `(specs/json-regex-primitive ~pattern type/base64Binary)
       "instant" `(specs/json-regex-primitive ~pattern type/instant)
       "date" `(specs/json-regex-primitive ~pattern type/date)
       "dateTime" `(specs/json-regex-primitive ~pattern type/dateTime)
       "time" `(specs/json-regex-primitive ~pattern type/time)
-      "code" `(specs/json-regex-primitive ~pattern type/code)
+      "code" `(specs/json-regex-primitive #"[\u0021-\uFFFF]+([ \t\n\r][\u0021-\uFFFF]+)*" type/code)
       "oid" `(specs/json-regex-primitive ~pattern type/oid)
       "id" `(specs/json-regex-primitive ~pattern type/id)
-      "markdown" `(specs/json-regex-primitive ~pattern type/markdown)
+      "markdown" `(specs/json-regex-primitive #"[\r\n\t\u0020-\uFFFF]+" type/markdown)
       "unsignedInt" `(specs/json-pred-primitive int? type/unsignedInt)
       "positiveInt" `(specs/json-pred-primitive int? type/positiveInt)
       "uuid" `(specs/json-regex-primitive ~pattern type/uuid)
       "xhtml" `(s/and string? (s/conformer type/->Xhtml identity))
       (throw (ex-info (format "Unknown primitive type `%s`." name) {})))))
 
 (defn- xml-spec-form [name {:keys [element]}]
-  (let [regex (type-regex (value-type element))
+  (let [pattern (type-regex (value-type element))
         constructor (str "xml->" (su/capital name))]
     (case name
+      "string" (xml/primitive-xml-form #"[\r\n\t\u0020-\uFFFF]+" `type/xml->String)
+      "uri" (xml/primitive-xml-form #"[\u0021-\uFFFF]*" `type/xml->Uri)
+      "url" (xml/primitive-xml-form #"[\u0021-\uFFFF]*" `type/xml->Url)
+      "canonical" (xml/primitive-xml-form #"[\u0021-\uFFFF]*" `type/xml->Canonical)
+      "code" (xml/primitive-xml-form #"[\u0021-\uFFFF]+([ \t\n\r][\u0021-\uFFFF]+)*" `type/xml->Code)
+      "markdown" (xml/primitive-xml-form #"[\r\n\t\u0020-\uFFFF]+" `type/xml->Markdown)
       "xhtml" `(s/and xml/element? (s/conformer type/xml->Xhtml type/to-xml))
-      (xml/primitive-xml-form regex (symbol "blaze.fhir.spec.type" constructor)))))
+      (xml/primitive-xml-form pattern (symbol "blaze.fhir.spec.type" constructor)))))
 
 (defn- cbor-spec-form [name _]
   (case name

diff --git a/modules/fhir-structure/src/blaze/fhir/spec/type.clj b/modules/fhir-structure/src/blaze/fhir/spec/type.clj
@@ -818,6 +818,7 @@
 
 (declare markdown?)
 (declare markdown)
+(declare xml->Markdown)
 
 (def-primitive-type Markdown [value] :hash-num 16)
 

diff --git a/modules/fhir-structure/src/blaze/fhir/spec/type/system.clj b/modules/fhir-structure/src/blaze/fhir/spec/type/system.clj
@@ -487,7 +487,7 @@
     (-lower-bound (.atStartOfDay date)))
   LocalDateTime
   (-lower-bound [date-time]
-    (-lower-bound (.atOffset date-time (ZoneOffset/UTC))))
+    (-lower-bound (.atOffset date-time ZoneOffset/UTC)))
   OffsetDateTime
   (-lower-bound [date-time]
     (.toEpochSecond date-time)))
@@ -527,7 +527,7 @@
     (-upper-bound (.atTime date 23 59 59)))
   LocalDateTime
   (-upper-bound [date-time]
-    (-upper-bound (.atOffset date-time (ZoneOffset/UTC))))
+    (-upper-bound (.atOffset date-time ZoneOffset/UTC)))
   OffsetDateTime
   (-upper-bound [date-time]
     (.toEpochSecond date-time)))

diff --git a/modules/fhir-structure/test/blaze/fhir/spec/impl_test.clj b/modules/fhir-structure/test/blaze/fhir/spec/impl_test.clj
@@ -90,12 +90,12 @@
            [{:key :fhir/string
              :spec-form `type/string?}
             {:key :fhir.json/string
-             :spec-form `(specs/json-regex-primitive "[ \\r\\n\\t\\S]+" type/string)}
+             :spec-form `(specs/json-regex-primitive "[\\r\\n\\t\\u0020-\\uFFFF]+" type/string)}
             {:key :fhir.xml/string
              :spec-form
              `(s2/and
                xml/element?
-               (fn [~'e] (xml/value-matches? "[ \\r\\n\\t\\S]+" ~'e))
+               (fn [~'e] (xml/value-matches? "[\\r\\n\\t\\u0020-\\uFFFF]+" ~'e))
                (s2/conformer xml/remove-character-content xml/set-extension-tag)
                (s2/schema {:content (s2/coll-of :fhir.xml/Extension)})
                (s2/conformer type/xml->String type/to-xml))}
@@ -127,12 +127,12 @@
            [{:key :fhir/uri
              :spec-form `type/uri?}
             {:key :fhir.json/uri
-             :spec-form `(specs/json-regex-primitive "\\S*" type/uri)}
+             :spec-form `(specs/json-regex-primitive "[\\u0021-\\uFFFF]*" type/uri)}
             {:key :fhir.xml/uri
              :spec-form
              `(s2/and
                xml/element?
-               (fn [~'e] (xml/value-matches? "\\S*" ~'e))
+               (fn [~'e] (xml/value-matches? "[\\u0021-\\uFFFF]*" ~'e))
                (s2/conformer xml/remove-character-content xml/set-extension-tag)
                (s2/schema {:content (s2/coll-of :fhir.xml/Extension)})
                (s2/conformer type/xml->Uri type/to-xml))}
@@ -145,12 +145,12 @@
            [{:key :fhir/canonical
              :spec-form `type/canonical?}
             {:key :fhir.json/canonical
-             :spec-form `(specs/json-regex-primitive "\\S*" type/canonical)}
+             :spec-form `(specs/json-regex-primitive "[\\u0021-\\uFFFF]*" type/canonical)}
             {:key :fhir.xml/canonical
              :spec-form
              `(s2/and
                xml/element?
-               (fn [~'e] (xml/value-matches? "\\S*" ~'e))
+               (fn [~'e] (xml/value-matches? "[\\u0021-\\uFFFF]*" ~'e))
                (s2/conformer xml/remove-character-content xml/set-extension-tag)
                (s2/schema {:content (s2/coll-of :fhir.xml/Extension)})
                (s2/conformer type/xml->Canonical type/to-xml))}
@@ -181,12 +181,12 @@
            [{:key :fhir/code
              :spec-form `type/code?}
             {:key :fhir.json/code
-             :spec-form `(specs/json-regex-primitive "[^\\s]+(\\s[^\\s]+)*" type/code)}
+             :spec-form `(specs/json-regex-primitive "[\\u0021-\\uFFFF]+([ \\t\\n\\r][\\u0021-\\uFFFF]+)*" type/code)}
             {:key :fhir.xml/code
              :spec-form
              `(s2/and
                xml/element?
-               (fn [~'e] (xml/value-matches? "[^\\s]+(\\s[^\\s]+)*" ~'e))
+               (fn [~'e] (xml/value-matches? "[\\u0021-\\uFFFF]+([ \\t\\n\\r][\\u0021-\\uFFFF]+)*" ~'e))
                (s2/conformer xml/remove-character-content xml/set-extension-tag)
                (s2/schema {:content (s2/coll-of :fhir.xml/Extension)})
                (s2/conformer type/xml->Code type/to-xml))}
@@ -420,11 +420,11 @@
   (testing "XML representation of Extension"
     (given (group-by :key (impl/struct-def->spec-def (complex-type "Extension")))
       [:fhir.Extension/url 0 :spec-form regexes->str]
-      := `(s2/and string? (specs/regex "\\S*" impl/intern-string))
+      := `(s2/and string? (specs/regex "[\\u0021-\\uFFFF]*" impl/intern-string))
       [:fhir.json.Extension/url 0 :spec-form regexes->str]
-      := `(s2/and string? (specs/regex "\\S*" impl/intern-string))
+      := `(s2/and string? (specs/regex "[\\u0021-\\uFFFF]*" impl/intern-string))
       [:fhir.xml.Extension/url 0 :spec-form regexes->str]
-      := `(s2/and string? (specs/regex "\\S*" impl/intern-string))
+      := `(s2/and string? (specs/regex "[\\u0021-\\uFFFF]*" impl/intern-string))
       [:fhir.xml.Extension/url 0 :representation] := :xmlAttr))
 
   (testing "XML representation of Coding"
@@ -461,14 +461,14 @@
   (testing "JSON representation of Quantity.unit"
     (given (group-by :key (impl/struct-def->spec-def (complex-type "Quantity")))
       [:fhir.json.Quantity/unit 0 :spec-form regexes->str]
-      := `(specs/json-regex-primitive "[ \\r\\n\\t\\S]+" type/intern-string)))
+      := `(specs/json-regex-primitive "[\\r\\n\\t\\u0020-\\uFFFF]+" type/intern-string)))
 
   (testing "XML representation of Quantity.unit"
     (given (group-by :key (impl/struct-def->spec-def (complex-type "Quantity")))
       [:fhir.xml.Quantity/unit 0 :spec-form regexes->str]
       := `(s2/and
            xml/element?
-           (fn [~'e] (xml/value-matches? "[ \\r\\n\\t\\S]+" ~'e))
+           (fn [~'e] (xml/value-matches? "[\\r\\n\\t\\u0020-\\uFFFF]+" ~'e))
            (s2/conformer xml/remove-character-content xml/set-extension-tag)
            (s2/schema {:content (s2/coll-of :fhir.xml/Extension)})
            (s2/conformer type/xml->InternedString type/to-xml))))

diff --git a/modules/fhir-structure/test/blaze/fhir/spec/type/system_test.clj b/modules/fhir-structure/test/blaze/fhir/spec/type/system_test.clj
@@ -305,7 +305,7 @@
       #system/date-time"2020-01"
       #system/date-time"2020-01-01"
       (system/date-time 2020 1 1 0 0 0 0)
-      (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)))
+      (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC))
 
     (are [x] (not (system/date-time? x))
       nil
@@ -379,14 +379,14 @@
           nil (system/date-time 2020 1 1 0 0 1 0) nil?
           nil nil nil?
 
-          (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) true?
-          (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) false?
-          (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) nil nil?
-          (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) false?
-          (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) true?
-          (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) nil nil?
-          nil (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) nil?
-          nil (system/date-time 2020 1 1 0 0 1 0 (ZoneOffset/UTC)) nil?
+          (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) true?
+          (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) false?
+          (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) nil nil?
+          (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) false?
+          (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) true?
+          (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) nil nil?
+          nil (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) nil?
+          nil (system/date-time 2020 1 1 0 0 1 0 ZoneOffset/UTC) nil?
           nil nil nil?))
 
       (testing "with date"
@@ -405,8 +405,8 @@
           #system/date-time"2020-01" #system/date-time"2020" nil?
           #system/date-time"2020-01" #system/date-time"2020-01-01" nil?
           #system/date-time"2020-01-01" #system/date-time"2020-01" nil?
-          (system/date-time 2020 1 1 0 0 0 0) (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) nil?
-          (system/date-time 2020 1 1 0 0 0 0 (ZoneOffset/UTC)) (system/date-time 2020 1 1 0 0 0 0) nil?))
+          (system/date-time 2020 1 1 0 0 0 0) (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) nil?
+          (system/date-time 2020 1 1 0 0 0 0 ZoneOffset/UTC) (system/date-time 2020 1 1 0 0 0 0) nil?))
 
       (testing "with date"
         (are [a b pred] (pred (system/equals a b))