Skip to content
Permalink
v0.1.0-beta-001
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
256 lines (221 sloc) 7.5 KB
/// ---------------------------
/// Attribution to original authors of this code
/// ---------------------------
/// This code has been originally ported from Suave with small modifications afterwards.
///
/// The original code has been authored by
/// * Henrik Feldt (https://github.com/haf)
/// * Ademar Gonzalez (https://github.com/ademar)
///
/// You can find the original implementation here:
/// https://github.com/SuaveIO/suave/blob/master/src/Experimental/Html.fs
///
/// Thanks to Suave (https://github.com/SuaveIO/suave) for letting us borrow their code
/// and thanks to Florian Verdonck (https://github.com/nojaf) for porting it to Giraffe.
module Giraffe.XmlViewEngine
open System
open System.Net
/// ---------------------------
/// Definition of different HTML content
///
/// For more info check:
/// - https://developer.mozilla.org/en-US/docs/Web/HTML/Element
/// - https://www.w3.org/TR/html5/syntax.html#void-elements
/// ---------------------------
type XmlAttribute =
| KeyValue of string * string
| Boolean of string
type XmlElement = string * XmlAttribute[] // Name * XML attributes
type XmlNode =
| ParentNode of XmlElement * XmlNode list // An XML element which contains nested XML elements
| VoidElement of XmlElement // An XML element which cannot contain nested XML (e.g. <hr /> or <br />)
| EncodedText of string // XML encoded text content
| RawText of string // Raw text content
/// ---------------------------
/// Building blocks
/// ---------------------------
let attr (key : string) (value : string) = KeyValue (key, value)
let flag (key : string) = Boolean key
let tag (tagName : string)
(attributes : XmlAttribute list)
(contents : XmlNode list) =
ParentNode ((tagName, Array.ofList attributes), contents)
let voidTag (tagName : string)
(attributes : XmlAttribute list) =
VoidElement (tagName, Array.ofList attributes)
let encodedText (content : string) = EncodedText content
let rawText (content : string) = RawText content
let emptyText = rawText ""
let comment (content : string) = rawText (sprintf "<!-- %s -->" content)
/// ---------------------------
/// Default HTML elements
/// ---------------------------
/// Main root
let html = tag "html"
/// Document metadata
let ``base`` = tag "base"
let head = tag "head"
let link attr = voidTag "link" attr
let meta attr = voidTag "meta" attr
let style = tag "style"
let title = tag "title"
/// Content sectioning
let body = tag "body"
let address = tag "address"
let article = tag "article"
let aside = tag "aside"
let footer = tag "footer"
let hgroup = tag "hgroup"
let h1 = tag "h1"
let h2 = tag "h2"
let h3 = tag "h3"
let h4 = tag "h4"
let h5 = tag "h5"
let h6 = tag "h6"
let header = tag "header"
let nav = tag "nav"
let section = tag "section"
/// Text content
let dd = tag "dd"
let div = tag "div"
let dl = tag "dl"
let dt = tag "dt"
let figcaption = tag "figcaption"
let figure = tag "figure"
let hr = voidTag "hr"
let li = tag "li"
let main = tag "main"
let ol = tag "ol"
let p = tag "p"
let pre = tag "pre"
let ul = tag "ul"
/// Inline text semantics
let a = tag "a"
let abbr = tag "abbr"
let b = tag "b"
let bdi = tag "bdi"
let bdo = tag "bdo"
let br = voidTag "br"
let cite = tag "cite"
let code = tag "code"
let data = tag "data"
let dfn = tag "dfn"
let em = tag "em"
let i = tag "i"
let kbd = tag "kbd"
let mark = tag "mark"
let q = tag "q"
let rp = tag "rp"
let rt = tag "rt"
let rtc = tag "rtc"
let ruby = tag "ruby"
let s = tag "s"
let samp = tag "samp"
let small = tag "small"
let span = tag "span"
let strong = tag "strong"
let sub = tag "sub"
let sup = tag "sup"
let time = tag "time"
let u = tag "u"
let var = tag "var"
let wbr = voidTag "wbr"
/// Image and multimedia
let area = voidTag "area"
let audio = tag "audio"
let img = voidTag "img"
let map = tag "map"
let track = voidTag "track"
let video = tag "video"
/// Embedded content
let embed = voidTag "embed"
let object = tag "object"
let param = voidTag "param"
let source = voidTag "source"
/// Scripting
let canvas = tag "canvas"
let noscript = tag "noscript"
let script = tag "script"
/// Demarcating edits
let del = tag "del"
let ins = tag "ins"
/// Table content
let caption = tag "caption"
let col = voidTag "col"
let colgroup = tag "colgroup"
let table = tag "table"
let tbody = tag "tbody"
let td = tag "td"
let tfoot = tag "tfoot"
let th = tag "th"
let thead = tag "thead"
let tr = tag "tr"
/// Forms
let button = tag "button"
let datalist = tag "datalist"
let fieldset = tag "fieldset"
let form = tag "form"
let input = voidTag "input"
let label = tag "label"
let legend = tag "legend"
let meter = tag "meter"
let optgroup = tag "optgroup"
let option = tag "option"
let output = tag "output"
let progress = tag "progress"
let select = tag "select"
let textarea = tag "textarea"
/// Interactive elements
let details = tag "details"
let dialog = tag "dialog"
let menu = tag "menu"
let menuitem = voidTag "menuitem"
let summary = tag "summary"
/// ---------------------------
/// Render XML string
/// ---------------------------
let rec private nodeToString (htmlStyle : bool) (node : XmlNode) =
let startElementToString selfClosing (elemName, attributes : XmlAttribute array) =
let closingBracket =
match selfClosing with
| false -> ">"
| true ->
match htmlStyle with
| false -> " />"
| true -> ">"
match attributes with
| [||] -> sprintf "<%s%s" elemName closingBracket
| _ ->
attributes
|> Array.map (fun attr ->
match attr with
| KeyValue (k, v) -> sprintf " %s=\"%s\"" k (WebUtility.HtmlEncode v)
| Boolean k -> sprintf " %s" k)
|> String.Concat
|> sprintf "<%s%s%s" elemName
<| closingBracket
let endElementToString (elemName, _) = sprintf "</%s>" elemName
let parentNodeToString (elem : XmlElement, nodes : XmlNode list) =
let innerContent = nodes |> List.map (nodeToString htmlStyle) |> String.Concat
let startTag = elem |> startElementToString false
let endTag = elem |> endElementToString
sprintf "%s%s%s" startTag innerContent endTag
match node with
| EncodedText text -> WebUtility.HtmlEncode text
| RawText text -> text
| ParentNode (e, nodes) -> parentNodeToString (e, nodes)
| VoidElement e -> startElementToString true e
let renderXmlNode = nodeToString false
let renderXmlNodes (nodes : XmlNode list) =
nodes
|> List.map renderXmlNode
|> String.Concat
let renderHtmlNode = nodeToString true
let renderHtmlNodes (nodes : XmlNode list) =
nodes
|> List.map renderHtmlNode
|> String.Concat
let renderHtmlDocument (document : XmlNode) =
document
|> renderHtmlNode
|> sprintf "<!DOCTYPE html>%s%s" Environment.NewLine