XmlRuntime.fs

// --------------------------------------------------------------------------------------
// XML type provider - methods & types used by the generated erased code
// --------------------------------------------------------------------------------------

namespace FSharp.Data.Runtime.BaseTypes

open System.ComponentModel
open System.IO
open System.Xml
open System.Xml.Linq

#nowarn "10001"

/// Underlying representation of types generated by XmlProvider
[<StructuredFormatDisplay("{_Print}")>]
type XmlElement =

    // NOTE: Using a record here to hide the ToString, GetHashCode & Equals
    // (but since this is used across multiple files, we have explicit Create method)
    { XElement: XElement }

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    member x._Print =
        let str = x.ToString()

        if str.Length > 512 then
            str.Substring(0, 509) + "..."
        else
            str

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    override x.ToString() = x.XElement.ToString()

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    static member Create(element) = { XElement = element }

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    static member Create(reader: TextReader) = XmlElement.Create(reader, "Prohibit")

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    static member CreateList(reader: TextReader) =
        XmlElement.CreateList(reader, "Prohibit")

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    static member Create(reader: TextReader, dtdProcessing: string) =
        use reader = reader

        let dtd =
            match dtdProcessing with
            | "Ignore" -> DtdProcessing.Ignore
            | "Parse" -> DtdProcessing.Parse
            | _ -> DtdProcessing.Prohibit

        let xmlReaderSettings =
            new XmlReaderSettings(DtdProcessing = dtd, XmlResolver = null, MaxCharactersFromEntities = 1024L * 1024L)

        use xmlReader = XmlReader.Create(reader, xmlReaderSettings)
        let element = XDocument.Load(xmlReader, LoadOptions.PreserveWhitespace).Root
        { XElement = element }

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    static member CreateList(reader: TextReader, dtdProcessing: string) =
        use reader = reader
        let text = reader.ReadToEnd()

        let dtd =
            match dtdProcessing with
            | "Ignore" -> DtdProcessing.Ignore
            | "Parse" -> DtdProcessing.Parse
            | _ -> DtdProcessing.Prohibit

        let xmlReaderSettings =
            new XmlReaderSettings(DtdProcessing = dtd, XmlResolver = null, MaxCharactersFromEntities = 1024L * 1024L)

        let parseWithReader xmlText =
            use stringReader = new StringReader(xmlText)
            use xmlReader = XmlReader.Create(stringReader, xmlReaderSettings)
            XDocument.Load(xmlReader, LoadOptions.PreserveWhitespace)

        try
            (parseWithReader text).Root.Elements()
            |> Seq.map (fun value -> { XElement = value })
            |> Seq.toArray
        with _ when text.TrimStart().StartsWith("<", System.StringComparison.Ordinal) ->
            (parseWithReader ("<root>" + text + "</root>")).Root.Elements()
            |> Seq.map (fun value -> { XElement = value })
            |> Seq.toArray

// --------------------------------------------------------------------------------------

namespace FSharp.Data.Runtime

open System
open System.IO
open System.Xml.Linq
open FSharp.Data.Runtime.BaseTypes

/// Static helper methods called from the generated code for working with XML
type XmlRuntime =

    // Operations for getting node values and values of attributes

    static member TryGetValue(xml: XmlElement) =
        if String.IsNullOrEmpty(xml.XElement.Value) then
            None
        else
            Some xml.XElement.Value

    static member TryGetAttribute(xml: XmlElement, nameWithNS) =
        let attr = xml.XElement.Attribute(XName.Get(nameWithNS))
        if isNull attr then None else Some attr.Value

    // Operations that obtain children - depending on the inference, we may
    // want to get an array, option (if it may or may not be there) or
    // just the value (if we think it is always there)

    static member private GetChildrenArray(value: XmlElement, nameWithNS: string) =
        let namesWithNS = nameWithNS.Split '|'
        let mutable current = value.XElement

        for i = 0 to namesWithNS.Length - 2 do
            if not (isNull current) then
                current <- current.Element(XName.Get namesWithNS.[i])

        let value = current

        if isNull value then
            [||]
        else
            [| for c in value.Elements(XName.Get namesWithNS.[namesWithNS.Length - 1]) -> { XElement = c } |]

    static member private GetChildOption(value: XmlElement, nameWithNS) =
        match XmlRuntime.GetChildrenArray(value, nameWithNS) with
        | [| it |] -> Some it
        | [||] -> None
        | array -> failwithf "XML mismatch: Expected zero or one '%s' child, got %d" nameWithNS array.Length

    static member GetChild(value: XmlElement, nameWithNS) =
        match XmlRuntime.GetChildrenArray(value, nameWithNS) with
        | [| it |] -> it
        | array -> failwithf "XML mismatch: Expected exactly one '%s' child, got %d" nameWithNS array.Length

    // Functions that transform specified chidlrens using a transformation
    // function - we need a version for array and option
    // (This is used e.g. when transforming `<a>1</a><a>2</a>` to `int[]`)

    static member ConvertArray<'R>(xml: XmlElement, nameWithNS, f: Func<XmlElement, 'R>) : 'R[] =
        XmlRuntime.GetChildrenArray(xml, nameWithNS) |> Array.map f.Invoke

    static member ConvertOptional<'R>(xml: XmlElement, nameWithNS, f: Func<XmlElement, 'R>) =
        XmlRuntime.GetChildOption(xml, nameWithNS) |> Option.map f.Invoke

    static member ConvertOptional2<'R>(xml: XmlElement, nameWithNS, f: Func<XmlElement, 'R option>) =
        XmlRuntime.GetChildOption(xml, nameWithNS) |> Option.bind f.Invoke

    /// Returns Some if the specified XmlElement has the specified name
    /// (otherwise None is returned). This is used when the current element
    /// can be one of multiple elements.
    static member ConvertAsName<'R>(xml: XmlElement, nameWithNS, f: Func<XmlElement, 'R>) =
        if xml.XElement.Name = XName.Get(nameWithNS) then
            Some(f.Invoke xml)
        else
            None

    /// Returns the contents of the element as a JsonValue
    static member GetJsonValue(xml) =
        match XmlRuntime.TryGetValue(xml) with
        | Some jsonStr -> JsonDocument.Create(new StringReader(jsonStr))
        | None -> failwithf "XML mismatch: Element doesn't contain value: %A" xml

    /// Tries to return the contents of the element as a JsonValue
    static member TryGetJsonValue(xml) =
        match XmlRuntime.TryGetValue(xml) with
        | Some jsonStr ->
            try
                JsonDocument.Create(new StringReader(jsonStr)) |> Some
            with _ ->
                None
        | None -> None

    /// Creates a XElement with a scalar value and wraps it in a XmlElement
    static member CreateValue(nameWithNS, value: obj, cultureStr) =
        XmlRuntime.CreateRecord(nameWithNS, [||], [| "", value |], cultureStr)

    // Creates a XElement with the given attributes and elements and wraps it in a XmlElement
    static member CreateRecord(nameWithNS, attributes: _[], elements: _[], cultureStr) =
        let cultureInfo = TextRuntime.GetCulture cultureStr

        let toXmlContent (v: obj) =
            let inline strWithCulture v =
                (^a: (member ToString: IFormatProvider -> string) (v, cultureInfo))

            let serialize (v: obj) =
                match v with
                | :? XmlElement as v ->
                    let xElement =
                        if isNull v.XElement.Parent then
                            v.XElement
                        else
                            // clone, as element is connected to previous parent
                            XElement(v.XElement)

                    box xElement
                | _ ->
                    match v with
                    | :? string as v -> v
                    | :? DateTime as v ->
                        if v.TimeOfDay = TimeSpan.Zero then
                            v.ToString("yyyy-MM-dd")
                        else
                            v.ToString("O", cultureInfo)
                    | :? DateTimeOffset as v -> v.ToString("O", cultureInfo)
                    | :? TimeSpan as v -> v.ToString("g", cultureInfo)
#if NET6_0_OR_GREATER
                    | :? DateOnly as v -> v.ToString("yyyy-MM-dd")
                    | :? TimeOnly as v -> v.ToString("HH:mm:ss", cultureInfo)
#endif
                    | :? int as v -> strWithCulture v
                    | :? int64 as v -> strWithCulture v
                    | :? float as v -> strWithCulture v
                    | :? decimal as v -> strWithCulture v
                    | :? bool as v -> if v then "true" else "false"
                    | :? Guid as v -> v.ToString()
                    | :? IJsonDocument as v -> v.JsonValue.ToString()
                    | _ -> failwithf "Unexpected value: %A" v
                    |> box

            let inline optionToArray f =
                function
                | Some x -> [| f x |]
                | None -> [||]

            match v with
            | :? Array as v -> [| for elem in v -> serialize elem |]
            | :? option<XmlElement> as v -> optionToArray serialize v
            | :? option<string> as v -> optionToArray serialize v
            | :? option<DateTime> as v -> optionToArray serialize v
            | :? option<DateTimeOffset> as v -> optionToArray serialize v
            | :? option<TimeSpan> as v -> optionToArray serialize v
#if NET6_0_OR_GREATER
            | :? option<DateOnly> as v -> optionToArray serialize v
            | :? option<TimeOnly> as v -> optionToArray serialize v
#endif
            | :? option<int> as v -> optionToArray serialize v
            | :? option<int64> as v -> optionToArray serialize v
            | :? option<float> as v -> optionToArray serialize v
            | :? option<decimal> as v -> optionToArray serialize v
            | :? option<bool> as v -> optionToArray serialize v
            | :? option<Guid> as v -> optionToArray serialize v
            | :? option<IJsonDocument> as v -> optionToArray serialize v
            | v -> [| box (serialize v) |]

        let createElement (parent: XElement) (nameWithNS: string) =
            let namesWithNS = nameWithNS.Split '|'

            (parent, namesWithNS)
            ||> Array.fold (fun parent nameWithNS ->
                let xname = XName.Get nameWithNS

                if isNull parent then
                    XElement xname
                else
                    let element =
                        if nameWithNS = Seq.last namesWithNS then
                            null
                        else
                            parent.Element(xname)

                    if isNull element then
                        let element = XElement xname
                        parent.Add element
                        element
                    else
                        element)

        let element = createElement null nameWithNS

        for nameWithNS, value in attributes do
            let xname = XName.Get nameWithNS

            match toXmlContent value with
            | [||] -> ()
            | [| v |] when v :? string && isNull (element.Attribute xname) -> element.SetAttributeValue(xname, v)
            | _ -> failwithf "Unexpected attribute value: %A" value

        let parents = System.Collections.Generic.Dictionary()

        for nameWithNS, value in elements do
            if nameWithNS = "" then // it's the value
                match toXmlContent value with
                | [||] -> ()
                | [| v |] when v :? string && element.Value = "" -> element.Add v
                | _ -> failwithf "Unexpected content value: %A" value
            else
                for value in toXmlContent value do
                    match value with
                    | :? XElement as v ->
                        let parentNames = nameWithNS.Split('|') |> Array.rev

                        if v.Name.ToString() <> parentNames.[0] then
                            failwithf "Unexpected element: %O" v

                        let v =
                            (v, Seq.skip 1 parentNames |> Seq.mapi (fun x i -> x, i))
                            ||> Seq.fold (fun element ((_, nameWithNS) as key) ->
                                if isNull element.Parent then
                                    let parent =
                                        match parents.TryGetValue key with
                                        | true, parent -> parent
                                        | false, _ ->
                                            let parent = createElement null nameWithNS
                                            parents.Add(key, parent)
                                            parent

                                    parent.Add element
                                    parent
                                else
                                    if element.Parent.Name.ToString() <> nameWithNS then
                                        failwithf "Unexpected element: %O" v

                                    element.Parent)

                        if isNull v.Parent then
                            element.Add v
                    | :? string as v ->
                        let child = createElement element nameWithNS
                        child.Value <- v
                    | _ -> failwithf "Unexpected content for child %s: %A" nameWithNS value

        XmlElement.Create element

module XmlSchema =
    open System.Xml
    open System.Xml.Schema

    /// A custom XmlResolver is needed for included files because we get the contents of the main file
    /// directly as a string from the FSharp.Data infrastructure. Hence the default XmlResolver is not
    /// able to find the location of included schema files.
    type ResolutionFolderResolver(resolutionFolder: string) =
        inherit XmlUrlResolver()

        let cache =
            Caching.createInternetFileCache "XmlSchema" (System.TimeSpan.FromMinutes 30.0)

        let uri = // Uri must end with separator (maybe there's a better way)
            if resolutionFolder = "" then
                ""
            elif
                resolutionFolder.EndsWith("/", StringComparison.Ordinal)
                || resolutionFolder.EndsWith("\\", StringComparison.Ordinal)
            then
                resolutionFolder
            else
                resolutionFolder + "/"

        let useResolutionFolder (baseUri: System.Uri) =
            resolutionFolder <> "" && (isNull baseUri || baseUri.OriginalString = "")

        let getEncoding xmlText = // peek encoding definition
            let settings = XmlReaderSettings(ConformanceLevel = ConformanceLevel.Fragment)
            use reader = XmlReader.Create(new System.IO.StringReader(xmlText), settings)

            if reader.Read() && reader.NodeType = XmlNodeType.XmlDeclaration then
                match reader.GetAttribute "encoding" with
                | null -> System.Text.Encoding.UTF8
                | attr -> System.Text.Encoding.GetEncoding attr
            else
                System.Text.Encoding.UTF8

        override _this.ResolveUri(baseUri, relativeUri) =
            let u = System.Uri(relativeUri, System.UriKind.RelativeOrAbsolute)

            if u.IsAbsoluteUri && (not <| u.IsFile) then
                base.ResolveUri(baseUri, relativeUri)
            elif useResolutionFolder baseUri then
                base.ResolveUri(System.Uri uri, relativeUri)
            else
                base.ResolveUri(baseUri, relativeUri)


        override _this.GetEntity(absoluteUri, role, ofObjectToReturn) =
            if IO.isWeb absoluteUri then
                let uri = absoluteUri.OriginalString

                match cache.TryRetrieve(uri) with
                | Some value -> value
                | None ->
                    let value = FSharp.Data.Http.RequestString uri
                    cache.Set(uri, value)
                    value
                |> fun value ->
                    // the best solution would be to have the cache store the raw bytes
                    // instead of going back and forth from bytes to text
                    let bytes = getEncoding(value).GetBytes value
                    new System.IO.MemoryStream(bytes) :> obj
            else
                base.GetEntity(absoluteUri, role, ofObjectToReturn)


    let parseSchemaFromTextReader resolutionFolder (textReader: TextReader) =
        let schemaSet =
            XmlSchemaSet(XmlResolver = ResolutionFolderResolver resolutionFolder)

        let readerSettings =
            XmlReaderSettings(CloseInput = true, DtdProcessing = DtdProcessing.Ignore)

        use reader = XmlReader.Create(textReader, readerSettings)
        schemaSet.Add(null, reader) |> ignore
        schemaSet.Compile()
        schemaSet

    let parseSchema resolutionFolder xsdText =
        new System.IO.StringReader(xsdText)
        |> parseSchemaFromTextReader resolutionFolder