Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1524 lines (1333 sloc) 57.982 kB
/*
Copyright © 2011, 2012 MLstate
This file is part of Opa.
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.
*/
import-plugin server
import stdlib.core.{iter, web.core, rpc.core, parser, funaction, unification, js}
/**
* {1 About this module}
*
* {1 where should i start?}
*
* {1 what if i need more?}
*/
/**
* {1 Types defined in this module}
*/
/**
* The content of a xhtml event handler
*
* To allow runtime manipulation of Xhtml, e.g. for (de)serialization, xhtml event handlers have two representations,
* depending on where they are computed.
*/
@opacapi
type xhtml_event = { expr: FunAction.t /** An actual function. This can only ever happen if we're on the client, executing code generated by the client.*/
}
/ { value: string /** A pre-compiled JavaScript string containing the code. This happens when we're on the server,
or when the code has been received from the server.*/
}
/*
TODO:
For better security (and performance?), we should replace the [value] case with the following
{ function: string; //The identifier of a toplevel function
args: list( {deserialize: (ty, string)}//Non-optimized case: we should perform full deserialization
/ {parse: string} //Optimized case: we only need to deserialize using JSON.parse
/ {ident: string} //Optimal case: the argument is already on the client
)
*/
//TODO: Rename [xhtml_event] to Xhtml.event_handler
//TODO: We could possibly renormalize to always have [expr] on the client and [value] on the server. I'm not sure it would be useful, though.
/**
* @param 'attributes A set of attributes specific to the XML dialect
*/
@opacapi
type xml('attributes,'extensions) =
{ text : string } /**Text meant to be escaped before any insertion*/
/ { content_unsafe: string } /**Text meant to be inserted without any check or escaping. Absolutely unsafe, of course.*/
/ { fragment : list(xml('attributes,'extensions)) }
/ { namespace : string /** The namespace name */
tag : string
args : list(Xml.attribute)
xmlns : list(Xml.binding)
content : list(xml('attributes,'extensions))
specific_attributes : option('attributes) }
/ { xml_dialect : option('extensions) }
@opacapi
type Xml.attribute = { namespace:string name:string value:string }
@opacapi
type Xml.binding = { name:string uri:string } / {default : string}
@opacapi
type xhtml_href =
{constant:string} /**Constant string, no additional check.*/
/ {untyped:string} /**Untyped string, go through whitelist checking*/
/ {typed:Uri.uri} /**Typed structure, we assume that it has already been checked, so no additional check.*/
/ {none} /**No URI*/
@opacapi
type xhtml_bool_attribute_value =
{string:string}
/ {bool:bool}
/ {none}
@opacapi
type xhtml_bool_attribute = { name:string value:xhtml_bool_attribute_value }
type xhtml_specific_attributes =
{
class:list(string)/**The classes of this element.*/
style:Css.properties /**The style properties of this element*/
bool_attributes:list(xhtml_bool_attribute)
events:list(handle_assoc(xhtml_event)) /**The event handlers associated with this element, as a list of pairs event name (_not_ attribute name) * event handler */
events_options:list(handle_assoc(list(Dom.event_option)))
href: xhtml_href/**Possibly a hyperlink.*/
}
/**
* A precompiled html extract.
*
* Note: We keep html and js separate to avoid any premature evaluation of JS by overzealous browsers.
*/
type xhtml_specific_extensions =
{
html_code_unsafe: string/**The html code. It won't be checked before being inserted, so be sure that it has been checked before. It should not contain any JS code.*/
js_code_unsafe: string/**The JS code.*/
}
@opacapi
type xhtml = xml(xhtml_specific_attributes, xhtml_specific_extensions)
@abstract type empty = void
type xmlns_dialect = empty
type xmlns_specific_attributes = empty
/* FIXME: when universal quantification is available, we should
* have instead
* type xmlns = forall('attributes,'extensions) xml('attributes,'extensions) */
type xmlns = xml(xmlns_specific_attributes,xmlns_dialect)
type xml_header =
{ version : option(float)
encoding : option(string)
standalone : option(bool)
}
type xml_document =
{ header : xml_header
element : xmlns
}
/**
* {1 Functions exported to the global namespace}
*/
/**
* The empty fragment of xhtml
*/
empty_xhtml = {fragment = []} : xhtml
/**
* Convert a data structure to human-readable X(HT)ML
*/
@opacapi
@specialize(Xml.to_xml:xhtml -> xhtml,
Xml.to_xml:xmlns -> xmlns,
Xml.create_fragment:list(xhtml) -> xhtml,
XmlConvert.of_string:string -> xhtml,
XmlConvert.of_int:int -> xhtml,
XmlConvert.of_float:float -> xhtml,
XmlConvert.of_bool:bool -> xhtml,
XmlConvert.of_void:void -> xhtml)
magicToXml = XmlConvert.of_alpha : 'a -> xml
/**
* {1 Xmlns interface}
*/
Xmlns =
{{
/**
* Convert a xmlns structure to xhtml
* FIXME: when xmlns is defined as said above, use [to_xhtml(x:xmlns) : xhtml = x]
*/
to_xhtml(xmlns: xmlns): xhtml = @unsafe_cast(xmlns)
/**
* Convert a xmlns structure into a string, assuming utf-8 encoding
*/
to_string : xmlns -> string = serialize_to_string
/**
* Convert a xhtml structure into a xmlns
* This function returns an option as it may fail
* when html specific features are used
*/
of_xhtml(x) : option(xmlns) =
match x : xhtml with
| ~{text} -> {some = ~{text}}
| ~{content_unsafe} -> {some = ~{content_unsafe}}
| ~{fragment} ->
match List.map_while_opt(of_xhtml,fragment) with
| {none} -> {none}
| {some=fragment} -> {some = ~{fragment}}
end
| {xml_dialect = {none}} as v -> {some = v}
| {xml_dialect = {some=_}} -> {none}
| ~{namespace tag args content xmlns specific_attributes={none}}
| ~{namespace tag args content xmlns specific_attributes={some = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}}}} ->
match List.map_while_opt(of_xhtml,content) with
| {none} -> {none}
| {some=content} ->
{some = ~{namespace tag args content xmlns specific_attributes={none}}}
end
| {namespace=_ ...} -> {none}
get_children(xml) =
match xml : xml with
| { xml_dialect=_ }
| { text=_ }
| { content_unsafe=_} -> []
| { ~fragment } -> List.flatten(List.map(get_children,fragment))
| { ~content ... } -> content
/*
get_children_no_ws(x) =
x |> get_children |> List.filter(x -> not(Xml.is_ws_node(x)),_)
*/
/**
* All the intermediate rules for the xmlns parser
*/
/* identifiers */
name_start = parser [a-zA-Z_] -> {}
name_rest = parser [a-zA-Z_\-.0-9] -> {}
name = parser v=(name_start name_rest*) -> Text.to_string(v)
open_sign = parser "<" Rule.ws -> {}
close_sign = parser Rule.ws ">" -> {}
autoclose = parser Rule.ws "/" close_sign -> {}
char_ref_raw = parser "&#" v=(v=Rule.natural -> v | "x" v=Rule.hexadecimal_number -> v) ";" -> v
regroup_bytes =
| [] -> ""
| [h1|t] ->
match (Cactutf.lenbytes(h1),t) with
| ({some=1},t) -> Cactutf.cons(Cactutf.one_byte(h1)) ^ regroup_bytes(t)
| ({some=2},[h2|t]) -> Cactutf.cons(Cactutf.two_bytes(h1,h2)) ^ regroup_bytes(t)
| ({some=3},[h2,h3|t]) -> Cactutf.cons(Cactutf.three_bytes(h1,h2,h3)) ^ regroup_bytes(t)
| ({some=4},[h2,h3,h4|t]) -> Cactutf.cons(Cactutf.four_bytes(h1,h2,h3,h4)) ^ regroup_bytes(t)
| _ -> /* something is invalid */ "?" ^ regroup_bytes(t)
/* the rule parses all the consecutive entities to be able to regroup them later */
char_ref = parser intl=char_ref_raw+ -> regroup_bytes(intl)
entity_name = parser "quot" -> "\""
| "amp" -> "&"
| "apos" -> "\'"
| "lt" -> "<"
| "gt" -> ">"
xml_entity = parser "&" s=entity_name ";" -> s
escape_sequence = parser s=char_ref -> s
| s=xml_entity -> s
/* */
svalue = parser v=svaluechars* -> Text.to_string(Text.ltconcat(v))
svaluechars = parser s=escape_sequence -> Text.cons(s)
| s=(svaluechar+) -> s
svaluechar = parser !['&] . -> {}
dvalue = parser v=dvaluechars* -> Text.to_string(Text.ltconcat(v))
dvaluechars = parser s=escape_sequence -> Text.cons(s)
| s=(dvaluechar+) -> s
dvaluechar = parser ![\"&] . -> {}
text = parser v=textchars+ -> Text.to_string(Text.ltconcat(v))
textchars = parser s=escape_sequence -> Text.cons(s)
| s=(textchar+) -> s
| s=cdata -> s
textchar = parser ![<&] . -> {}
cdata = parser "<![CDATA[" s=((!"]]>" .)*) "]]>" -> s
/* */
open_tag =
parser open_sign namespace=namespace tag=name Rule.ws ->
~{namespace tag}
open_tag_attributes =
parser nstag=open_tag args=attribute* ->
~{nstag args}
close_tag =
parser open_sign "/" Rule.ws namespace=namespace tag=name close_sign ->
~{namespace tag}
/* */
comment = parser "<!--" (!"-->" .)* "-->" -> {}
/* attributes */
equal = parser Rule.ws "=" Rule.ws -> {}
attribute = parser
| "xmlns:" ~name equal uri=arg_value Rule.ws -> ~{name uri}
| "xmlns" equal uri=arg_value Rule.ws -> {default = uri}
| n=namespace e=name equal v=arg_value Rule.ws -> {namespace=n name=e value=v}
arg_value = parser "'" s=svalue "'" -> s
| "\"" s=dvalue "\"" -> s
quoted_value(parser_) = parser "'" v=parser_ "'" -> v
| "\"" v=parser_ "\"" -> v
/* tag */
tag = parser
| comment Rule.ws t=tag -> t
| v1=open_tag_attributes v2=tail_open_tag {Rule.succeed_if(Xml.matching_tags(v1.nstag,v2.nstag))} ->
{nstag=~{namespace tag} ~args} = v1
~{args xmlns} = List.fold_left(~{xmlns args}, arg ->
match arg
| {default=_} as x | {name=_ uri=_} as x -> {xmlns = [x | xmlns] ~args}
| {namespace=_ name=_ value=_} as a -> {~xmlns args = [a | args]}
, {xmlns=[] args=[]}, args)
{~content nstag=_} = v2
~{namespace tag args content xmlns specific_attributes={none}}
: xmlns
tail_open_tag = parser autoclose -> {content=[] nstag={none}}
| close_sign content=node* nstag=close_tag -> ~{nstag={some=nstag} content}
/* node */
node = parser tag=tag -> tag
| text=text -> ~{text}
/* namespace */
namespace = parser o=real_namespace? -> o ? ""
real_namespace = parser t=name Rule.ws ":" -> t
/* headers */
document = parser prolog=prolog tag=tag misc* -> {header=prolog element=tag}
prolog = parser decl=xmldecl? misc* (doctypedecl misc*)? -> decl ? {version = {none} encoding={none} standalone = {none}}
xmldecl = parser "<?xml" f=versioninfo e=encodingdecl? s=sddecl? Rule.ws "?>" ->
{version = {some = f}; encoding=e; standalone = s}
versioninfo = parser Rule.strict_ws "version" equal v={quoted_value(versionnum)} -> v
versionnum = parser t=("1." [0-9]+) -> Float.of_string(Text.to_string(t))
encodingdecl = parser Rule.strict_ws "encoding" equal v={quoted_value(encname)} -> v
encname = parser t=("UTF"~ "-8") -> Text.to_string(t)
| t=([A-Za-z] [A-Za-z0-9._\-]*) ->
enc = Text.to_string(t)
do Log.warning("xmlparser", "xml was declared with encoding {enc}, treating it as utf-8")
enc
sddecl = parser Rule.strict_ws "standalone" equal b={quoted_value(yes_or_no)} -> b
yes_or_no = parser "yes" -> {true}
| "no" -> {false}
misc = parser comment -> {}
| Rule.strict_ws -> {}
| pi -> {}
pi = parser "<?" s1=pitarget s2=(Rule.strict_ws t=(!"?>" .)* -> t) "?>" -> (s1,Text.ltconcat(s2))
pitarget = parser !(xml (Rule.strict_ws | "?>")) s=name -> s
xml = parser "XML"~ -> {}
/* FIXME */
doctypedecl = parser "<!DOCTYPE" doctypedecl_inside -> {}
doctypedecl_inside = parser (![><] .)* ( "<!" doctypedecl_inside -> {}
| ">" -> {}) -> {}
/**
* The main functions for parsing
*/
parser_ = parser Rule.ws tag=tag Rule.ws comment? -> tag
try_parse(s:string) : option(xmlns) = Parser.try_parse(parser_,s)
parse_with_outcome(s:string) : outcome(xmlns,string) =
match try_parse(s) with
| {none} -> {failure = s}
| ~{some} -> {success = some}
try_parse_document(s:string) : option(xml_document) = Parser.try_parse(document,s)
/**
* A few utility functions for pattern matching
*/
match_star_aux(pattern:XmlParser.t,xmls) =
rec aux(acc,xmls) =
match pattern.parse(xmls, pattern.env) with
| {none} -> (List.rev(acc),xmls)
| {some=(res,xmls)} -> aux([res|acc],xmls)
aux([],xmls)
match_star(pattern:XmlParser.t,xmls) =
{some = match_star_aux(pattern,xmls)}
match_question(pattern:XmlParser.t,xmls) =
match pattern.parse(xmls, pattern.env) with
| {none} -> {some = ({none}, xmls)}
| {some=(res,xmls)} -> {some = ({some=res},xmls)}
match_plus(pattern:XmlParser.t,xmls) =
match pattern.parse(xmls, pattern.env) with
| {none} -> none
| {some=(hd_res,xmls)} ->
(tl_res,xmls) = match_star_aux(pattern,xmls)
{some = ([hd_res|tl_res],xmls)}
match_range(pattern:XmlParser.t,min,max,xmls) =
if max < 0 then {none} else
over(min,acc,xmls) =
if min <= 0 then
{some = (List.rev(acc),xmls)}
else
{none}
rec aux(min,max,acc,xmls) =
if max == 0 then
over(min,acc,xmls)
else
match pattern.parse(xmls, pattern.env) with
| {none} -> over(min,acc,xmls)
| {some=(res,xmls)} -> aux(min-1,max-1,[res|acc],xmls)
aux(min,max,[],xmls)
match_exact(pattern:XmlParser.t,number,xmls) =
match_range(pattern,number,number,xmls)
match_namespace(env:XmlParser.env, pns, xns) =
get_uri(ns, ~{default map}) =
match ns with
| "" -> default
| _ -> StringMap.get(ns, map) ? default
String.equals(get_uri(pns, env.pbind), get_uri(xns, env.xbind))
/**
* The default namespace
*/
default_ns_uri = ""
serialize_to_string(xmlns: xmlns): string =
xhtml = to_xhtml(xmlns)
~{js_code html_code} = Xhtml.prepare_for_export(xhtml,false)
do @assert(js_code == "")
html_code
}}
verbatim_expr(_)=""
/**
* {1 Xml interface}
*/
/**
* The functions that should go in that module are functions that are available
* independently of the specificity of your xml
* Thus, functions like to_string, or parse cannot appear in here
*/
Xml =
{{
/**
* Returns a boolean saying if two tags match
* The second namespace and tag are optional: they are none when saying <div/>
*/
matching_tags(nstag1,nstag2o) =
match nstag2o with
| {none} -> {true}
| {some=nstag2} -> nstag1 == nstag2
create_fragment(fragment : list(xml)) : xml = ~{fragment}
to_xml : xml -> xml = x -> x
/**
* A few functions used by the xml_parser generation pass
*/
find_attr(args,namespace_,name_) =
match List.find({~namespace ~name value=_} ->
name == name_ && namespace == namespace_, args)
with
| {none} -> {none}
| {some = {~value ... }} -> {some = value}
end
/**
* {2 Rule module}
*/
Rule = {{
integer = xml_parser parser v={@toplevel.Rule.integer} -> v
float = xml_parser parser v={@toplevel.Rule.float} -> v
string = xml_parser parser v={@toplevel.Rule.consume} -> v
of_rule(r) = xml_parser parser v=r -> v
}}
// conversion from a list to xml + registering auto-magical conversion from list to xml
@xmlizer(list('a)) list_to_xml(alpha_to_xml, l) =
create_fragment(List.map(alpha_to_xml, l))
// conversion from an option to xml + registering auto-magical conversion from list to xml
@xmlizer(option('a)) option_to_xml(alpha_to_xml, o) =
Option.switch(alpha_to_xml, <></>, o)
// conversion from an iterator to xml + registering auto-magical conversion from iterator to xml
@xmlizer(iter('a)) iterator_to_xml(alpha_to_xml, i) =
create_fragment(Iter.map(alpha_to_xml, i) |> Iter.to_list)
/**
* Fold on every node of the xml
* @param the fold function
* @param the first element of the fold
* @param the xml to fold
*/
fold(fun:(xml('a, 'b), 'c -> 'c), seed:'c, xml:xml): 'c =
match xml with
| { text=_ }
| { content_unsafe=_ }
| { xml_dialect=_ } -> seed
| { ~fragment } -> List.foldl((el, acc -> fold(fun, acc, el) ), fragment, seed)
| { ~content ... } as node ->
res = fun(node, seed)
List.foldl((el, acc -> fold(fun, acc, el) ), content, res)
end
/**
* Apply a transformation function to every element of the given xml
* @param the mapping function
* @param the xml to transform
*/
map(fun:(xml('a,'b) -> xml('c,'d)), element:xml('a,'b)) : xml('c,'d) =
rec aux(elt:xml('a,'b)) =
match elt with
| { text=_ }
| { content_unsafe=_ }
| { xml_dialect=_ } -> fun(elt)
| { ~fragment } -> {fragment = List.map(aux, fragment) }
| { ~content ... } as r ->
content = List.map(aux, content) ;
fun({r with content=content} <: xml )
aux(element)
}}
/**
* {1 Xml_parser interface}
*/
@abstract
type XmlParser.env = {
/* Namespaces bindings of parser */
pbind : XmlNsEnv.t;
/* Namespaces bindings of xml tree */
xbind : XmlNsEnv.t;
}
@opacapi
@abstract
type XmlParser.t('result, 'attributes, 'extensions) = {
/* Parse function take a list of xml, and a map which contains namespaces
bindings */
parse : list(xml('attributes, 'extensions)), XmlParser.env
-> option(('result, list(xml('attributes, 'extensions))))
env : XmlParser.env
}
@opacapi
XmlParser_Env_add_pbinds = XmlParser.Env.add_pbinds
@opacapi
XmlParser_Env_add_xbinds = XmlParser.Env.add_xbinds
@opacapi
XmlParser_make = XmlParser.make
@opacapi
XmlParser_set_env = XmlParser.set_env
@opacapi
XmlParser_raw_parse = XmlParser.raw_parse
Xml_parser = XmlParser
XmlParser = {{
Env = {{
empty:XmlParser.env = {pbind = XmlNsEnv.empty xbind = XmlNsEnv.empty}
add_pbinds(env:XmlParser.env, binds:list(Xml.binding)):XmlParser.env =
{env with pbind = XmlNsEnv.add(env.pbind, binds)}
add_xbinds(env:XmlParser.env, binds:list(Xml.binding)):XmlParser.env =
{env with xbind = XmlNsEnv.add(env.xbind, binds)}
}}
flatten_and_discard_whitespace_aux(xml,acc) =
match xml : xml with
| ~{text} ->
match Parser.try_parse(@toplevel.Rule.ws,text) with
| {none} -> [xml|acc]
| {some} -> acc
end
| ~{fragment} ->
flatten_and_discard_whitespace_aux_list(fragment,acc)
| _ -> [xml|acc]
flatten_and_discard_whitespace_aux_list(xmls,acc) =
List.foldl(flatten_and_discard_whitespace_aux,xmls,acc)
flatten_and_discard_whitespace(xml) =
List.rev(flatten_and_discard_whitespace_aux(xml,[]))
flatten_and_discard_whitespace_list(xmls) =
List.rev(flatten_and_discard_whitespace_aux_list(xmls,[]))
make(parse:list(xml('attributes, 'extensions)), XmlParser.env -> option(('result, list(xml('attributes, 'extensions))))) =
~{parse env = Env.empty} : XmlParser.t
set_env(p:XmlParser.t, env:XmlParser.env):XmlParser.t = {p with ~env}
raw_parse(
p:XmlParser.t('a, 'attributes, 'extensions),
xml:list(xml('attributes, 'extensions))
) = p.parse(xml, p.env)
try_parse(
p:XmlParser.t('a, 'attributes, 'extensions),
xml:xml('attributes, 'extensions)
) =
match raw_parse(p, flatten_and_discard_whitespace(xml)) with
| {none} -> none
| {some=(result,_nodes)} -> {some=result}
}}
@abstract
type XmlNsEnv.t =
{ default : string map : stringmap(string) }
XmlNsEnv = {{
empty:XmlNsEnv.t = {default = "" map = StringMap.empty}
add(x:XmlNsEnv.t, binds:list(Xml.binding)):XmlNsEnv.t =
List.fold_left(~{map default}, bind ->
match bind with
| ~{name uri} -> ~{default map=StringMap.add(name, uri, map)}
| ~{default} -> ~{default map}
, x, binds)
get_uri(name:string, x:XmlNsEnv.t):string =
if name == "" then x.default
else StringMap.get(name, x.map) ? x.default
try_get_uri(name, x:XmlNsEnv.t) =
if name == "" then some(x.default)
else StringMap.get(name, x.map)
}}
/**
* {1 XmlConvert interface}
*/
/**
* Create xml representation of some basic type
*/
XmlConvert = {{
/**
* Return the xml representation of any value
*/
of_alpha(value) =
original_ty = @typeof(value)
rec aux(value, ty : OpaType.ty) =
match ty with
| {TyName_ident = "xml"; ...} | {TyName_ident = "xhtml"; ...} ->
Magic.id(value)
| {TyName_ident = "text"; ...} ->
XmlConvert.of_string(Text.to_string(Magic.id(value)))
| {TyConst = {TyInt}} -> XmlConvert.of_int(Magic.id(value))
| {TyConst = {TyFloat}} -> XmlConvert.of_float(Magic.id(value))
| {TyConst = {TyString}} -> XmlConvert.of_string(Magic.id(value))
| {TyName_ident = "list";
TyName_args =
[{TyName_ident = "xhtml"; TyName_args = (_ : list(OpaType.ty)) }]} ->
Xml.create_fragment(Magic.id(value))
| {TyName_args = args; TyName_ident = ident} ->
OpaValue.todo_magic_container(
%%BslValue.MagicContainer.xmlizer_get%%,
ident, args, (ty -> aux(_, ty)),
aux(_, OpaType.type_of_name(ident, args)),
value, [])
| ty ->
if OpaTypeUnification.is_unifiable(ty, @typeval(list(xhtml))) then
Xml.create_fragment(Magic.id(value))
else {text = "Can't make an xml with {ty}"}
aux(value, original_ty)
: xml
/**
* Return the xml representation of a string
*/
of_string(text) : xml = ~{text}
/**
* Return the xml representation of an integer
*/
of_int(i) = of_string(Int.to_string(i))
/**
* Return the xml representation of a float
*/
of_float(f) = of_string(Float.to_string(f))
/**
* Convert a boolean to a xhtml representation.
*
* @return [<>true</>] or [<>false</>]
*/
of_bool(b: bool) = of_string(Bool.to_string(b))
/**
* Convert [void] to a XHTML representation
*
* @return [<>\{\}</>]
*/
of_void(u) = of_string(Void.to_string(u))
/**
* Convert a list of XHTML fragments to a single XHTML fragment
*
* @return [<>{beg_symbol}{x_1}{sep_symbol}...{sep_symbol}{x_n}{end_symbol}</>]
*/
of_list_using(beg_symbol, end_symbol, sep_symbol, l) =
List.compose((x, y -> <>{x}{y}</>), beg_symbol, end_symbol, sep_symbol, l)
}}
/**
* {1 Xhtml interface}
*/
/**
* This module regroups only xhtml specific functions
* If you want a function that could be defined in Xml instead
* then define it in Xml and make an alias in this module
*/
Xhtml =
{{
/**
* Escapes every html special characters of the given string with &#xxx;
*
* Note: You shouldn't use it by yourself except if you want to insert an
* unsafe html node, and if you be aware of XSS risk.
*/
escape_special_chars =
String.replace_char(_,
(| '&' | '\"' | '\'' | '<' | '>' -> true | _ -> false),
(c -> "&#{c};")
)
default_attributes = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}} : xhtml_specific_attributes
createFragment : list(xhtml) -> xhtml = Xml.create_fragment
to_xhtml(xhtml_: xhtml) = xhtml_
/**
* Convert an XHTML tree to is client-side Dom representation.
*
* Some browsers handle CSS in weird and unexpected ways. Consequently, we cannot apply the styles already.
* Rather, we collect the styles, then store them in a OPA-specific hidden attribute of the Dom representation.
* We only apply the CSS when putting the Dom inside the browser document.
*/
to_dom(xhtml: xhtml) = Dom.from_xhtml(xhtml)
to_text(xhtml: xhtml) =
rec fold(src, acc) = List.fold((i, a -> a^aux(i, "")), src, acc)
and aux(x, a) = match x: xhtml with
| { ~fragment } -> fold(fragment, a)
| { tag=_; ~content; ... } -> fold(content, a)
| { text = t} -> t
| _ -> error("Xhtml.to_text: Not Fully Implemented")
aux(xhtml, "")
of_string : string -> xhtml = XmlConvert.of_string
of_string_unsafe(text:string): xhtml = { content_unsafe = text }
//Private functions, they should move
@private
default_href = sassoc_full("", "href", "javascript:void(0)")
@private
default_alt = sassoc_full("", "alt", ".")
@private
sanitized_uri= "javascript:void(0)/*Sanitized URI*/"
@private
exists_attr(attr, list: list(Xml.attribute)): bool =
oracle(i:Xml.attribute) = i.name == attr
List.exists(oracle, list)
@private
find_attr(attr, list: list(string_assoc(string))): option(string) =
oracle(i:{name:string; namespace: string; value:string}) =
if i.name == attr then some(i.value) else none
List.find_map(oracle, list)
@private
remove_attr(attr, list: list(string_assoc(string))): list(string_assoc(string)) =
oracle(i:Xml.attribute) = i.name == attr
List.remove_p(oracle, list)
@private
iter_tell_me_if_i_am_last(f: 'a,bool -> void, l: list('a)):void =
rec aux =
| [hd ] -> f(hd, true)
| [hd | tl] -> do f(hd, false); aux(tl)
| [] -> void ;
aux(l)
_script_start = "\n<script type=\"text/javascript\">//<![CDATA[\n"
_script_end = "\n//]]>\n</script>\n"
// _script_start = "\n<script type=\"text/javascript\">//<![CDATA[\n(function()\{var js_onready = function() \{var element = document.createElement(\"script\");var content = document.createTextNode(\"";
// _script_end = "\"); document.body.appendChild(element);}; if (window.addEventListener) window.addEventListener(\"load\", js_onready, false); else if (window.attachEvent) window.attachEvent(\"onload\", js_onready); else window.setTimeout(js_onready, 500);\})()\n//]]>\n</script>\n"
/**
* The URI for the XHTML namespace
*/
ns_uri = "http://www.w3.org/1999/xhtml"
@private sassoc_full(namespace, name, value) : Xml.attribute = ~{ namespace name value }
/**
* Convert a xhtml structure into a string, assuming utf-8 encoding
*/
to_string = serialize_to_string
@private
JsEvent = {{
filter_unsafe_inline(f)(v) =
if is_safe_inline_event(v.name)
then
str = inline_content(v.value)
if is_safe_inline_content(str) then
do f(Dom.Event.get_name(v.name),str):void
false
else
true
else
true
inline_handler(eventname,content) = " on{eventname}='{content}'"
inline_content =
| ~{value} -> value
| ~{expr} -> FunAction.serialize(expr)
/* stay sync with jquery.(mlstate)bind */
is_safe_inline_event =
| {click} -> true
| {keydown} -> false // jquery normalisation
| _ -> false
/*
false = {}
true = {v}
none = {}
some(a) = {v:a}
*/
is_safe_inline_content(s) =
match Parser.try_parse(check,s)
{some} ->
// do println("is_safe_inline_content ACCEPTED")
true
{none} ->
// do println("is_safe_inline_content REJECTED {s} at {Parser.partial_parse(debug_check,s)}\n")
false
// CAUTION: the check accept only a very restricted set of chars, take care when extending to not introduce security problem
// the checked string is delimited by ', hence ' is not in the accepted chars set
// e.g. the string f("\"'onready=\"alert(\"toto\")\"") could cause a js injection on some browser
// < and > should not be in the set
// typical event handler is a function call with args that are only datatype (no code)
// * / are here in case of comments
check = parser
| [-_A-Za-z()\"0-9:.,\n\t{}*/]* -> void
debug_check = parser s=(check) -> s
}}
@both_implem new_id = String.fresh(200)
@private
serialize_xmlns(buffer, xmlns) =
List.iter(
| ~{name uri} ->
do Buffer.append(buffer, " xmlns:")
do Buffer.append(buffer, name)
do Buffer.append(buffer, "=\"")
do Buffer.append(buffer, uri)
do Buffer.append(buffer, "\"")
void
| ~{default} ->
do Buffer.append(buffer, " xmlns=\"")
do Buffer.append(buffer, default)
do Buffer.append(buffer, "\"")
void
, xmlns
)
/**
* Convert a [xhtml] subtree to a pair of strings containing the html proper and the corresponding JS code.
*
* Note that event handlers and inline styles are extracted from the html and inserted as JS code, as this
* lets us delegate the handling of browser incompatibilities to the JS library. For instance, our JS
* library can determine dynamically of the browser calls the CSS [float] property as [cssFloat] or [styleFloat].
* Also, setting event handlers from JS code is both the modern way of doing things, and the orthogonal
* way of managing extensions to Dom events, e.g. "onmousewheel", "onnewline", "onready", etc.
*
* @param namespace_map A map from uris to the its identifier in the serialized xhtml
* used to have a predictable name of a given uri, as is needed for facebook
* (if you don't put <fb:sometag xmlns:fb="..."> but <plop:sometag xmlns:plop="...">
* it doesn't work)
* @param xhtml A xhtml {e subtree}, anything that can be inserted inside the [head] or the [body] --
* {e without the tag}. Do not pass anything larger to this function, or the result will be meaningless
* for some browsers.
* @return [~{js_code html_code}], where [html_code] contains the complete structure of the subtree
* (i.e. the tags) and [js_code] contains the event handlers and the style information as a JS
* string.
*/
prepare_for_export(xhtml: xhtml, style_inline : bool): {js_code: string; html_code:string} =
(
html_buffer = Buffer.create(1024)//A buffer for storing the HTML source code
js_buffer = Buffer.create(1024)//A buffer for storing the JS source code -- at the last step, it is inserted in [html_buffer]
jsappend_event_handler(x: xhtml_event) =
code = match x with
| { ~value } -> value
| { ~expr } -> FunAction.serialize(expr)
Buffer.append(js_buffer,code)
/**
* @param depth The current depth in the tree. Used both for pretty-printing and to insert scripts at the correct place
*/
rec handle_xhtml(xhtml: xhtml, depth:int) =
next = depth + 1 //next depth
match xhtml with
| ~{ text } -> Buffer.append(html_buffer,escape_special_chars(text))
| ~{ content_unsafe } -> Buffer.append(html_buffer,content_unsafe)
| ~{ fragment } -> List.iter(x -> handle_xhtml(x, depth), fragment)
| ~{ xml_dialect } ->
match xml_dialect with
| {none} -> void
| {some = ~{js_code_unsafe html_code_unsafe}} ->
do Buffer.append(html_buffer,html_code_unsafe)
Buffer.append(js_buffer,js_code_unsafe)
end
| ~{ namespace tag args content specific_attributes xmlns } ->
tag =
if String.is_empty(namespace) then tag else
namespace ^ ":" ^ tag
//Start handling the tag itself
do Buffer.append(html_buffer,"<")
do Buffer.append(html_buffer,tag)
do serialize_xmlns(html_buffer, xmlns)
//Handle regular attributes
print_arg(~{name namespace=tagns value}) =
do Buffer.append(html_buffer," ")
do if String.is_empty(tagns) then Buffer.append(html_buffer,name)
else
do Buffer.append(html_buffer,tagns)
do Buffer.append(html_buffer,":")
Buffer.append(html_buffer,name)
do Buffer.append(html_buffer,"=\"")
do Buffer.append(html_buffer,escape_special_chars(value))
Buffer.append(html_buffer,"\"")
do List.iter(print_arg,args)
do match specific_attributes with
| {none} -> void
| {some=~{class style bool_attributes events events_options href}} ->
//Normalize tags
do (
match tag with
| "img" -> //Add a default [alt] attribute to <img> tags that don't have one
if not(exists_attr("alt", args)) then print_arg(default_alt)
| "a" | "area" -> //Transform xhtml-specific attribute [href] into a string
// Should match tag_specific_a in opalang/syntax/xml.trx
replacement = match href
| {none} ->
// Hack around incorrect [Xml.to_xhtml]
// TODO: We should rather implement a new, safe Xml.to_xhtml
find_attr("href",args)
| ~{constant}-> {some = constant}
| ~{untyped} -> //Here, insert dynamic filter through uri parser
if Uri.is_secure(untyped) then {some = untyped} //URI was accepted, return original URI
else {some = sanitized_uri} //URI was rejected, replace by default URI
| ~{typed} -> {some = Uri.to_string(typed)}//Here, insert URI serialization
end
match replacement with
| {none} -> print_arg(default_href) //Add a default [href] attribute to <a> tags that don't have one
| ~{some}-> print_arg(sassoc("href", some))
end
| _ -> void
)
do List.iter(~{name value} ->
match value with
| {string=value} -> print_arg(sassoc(name,value))
| {bool=b} -> if b then print_arg(sassoc(name,name)) else void
| {none} -> print_arg(sassoc(name,name))
end,
bool_attributes)
(load_events, other_events) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events)
(_, other_events_options) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events_options)
other_events = // take care of event handler that can be inlined in html attribute
if XhtmlOptions.options.enable_inlined_event then
safe_inline(eventname,content) =
Buffer.append(html_buffer,JsEvent.inline_handler(eventname,content))
List.filter(JsEvent.filter_unsafe_inline(safe_inline), other_events)
else
other_events
//Handle events and style: start
do (if other_events == [] && other_events_options == [] && style == [] then void
else //We need an ID for this node, to be able to attach event handlers
id = match find_attr("id", args) with
| ~{some} -> some
| {none} ->
id = new_id()
do print_arg(sassoc("id", id))
id
end
//Now, generate jQuery-specific code in the jsbuffer, as a chain of JS dot calls on the item
do Buffer.append(js_buffer,"\n$('#")
do Buffer.append(js_buffer,Dom.escape_selector(id))
do Buffer.append(js_buffer,"')\n")
//Handle style -- generate a call to jQuery function [css]
do if style == [] then void
else
css_as_list = Css_printer.to_xhtml_style(style)
if css_as_list != [] then
/* if we printed when css_as_list is empty the css({ would not be closed })*/
if style_inline // style_inline is used e.g. for emails
then
do Buffer.append(html_buffer," style=\"")
iter_tell_me_if_i_am_last((~{name value}, last ->
do Buffer.append(html_buffer,name)
do Buffer.append(html_buffer,":")
do Buffer.append(html_buffer,value)
if last then Buffer.append(html_buffer,"\"")
else Buffer.append(html_buffer,"; ")),
css_as_list
)
else
do Buffer.append(js_buffer,".css(\{ ")
iter_tell_me_if_i_am_last((~{name value}, last ->
do Buffer.append(js_buffer,"'")
do Buffer.append(js_buffer,name)
do Buffer.append(js_buffer,"': '")
do Buffer.append(js_buffer,value)
if last then Buffer.append(js_buffer,"'})\n")
else Buffer.append(js_buffer,"', ")),
css_as_list
)
//Handle non-inlined, non-ready events
do (List.iter(_,other_events)){
~{name value} -> //Generate [.name(function(event({<<serialize_event_handler(value)>>})))]
name = Dom.Event.get_name(name)
content = JsEvent.inline_content(value)
add = ".bind('{name}',(function(event)\{{content}\}))\n"
Buffer.append(js_buffer,add)
}
//Handle non-inlined non-ready events options
do (List.iter(_,other_events_options)){
{name=handle value=options} -> //Generate [.name(function(event({<<serialize_event_handler(value)>>})))]
stop_propagation = List.exists(_ == {stop_propagation}, options)
prevent_default = List.exists(_ == {prevent_default}, options)
if(stop_propagation || prevent_default) then
name = Dom.Event.get_name(handle)
stop_propagation = if stop_propagation then "event.stopPropagation();" else ""
prevent_default = if prevent_default then "event.preventDefault();" else ""
add = ".bind('{name}',(function(event)\{{stop_propagation}{prevent_default}\}))\n"
Buffer.append(js_buffer,add)
}
//Finally, return args with id
void
)
do List.iter(~{name value} ->
match name with
| {ready} ->
do Buffer.append(js_buffer,"\n$(function()\{var event = {JsInterface.default_opa_event};")//In jQuery, the first argument of the callback is [$] itself -- replace by default event
do jsappend_event_handler(value)
do Buffer.append(js_buffer,"\});")
void
| _ -> error("[Xhtml.prepare_for_export] Internal error in xhtml serialization -- at this stage, all events other than [ready] should have been prepared")
end,
load_events)
//Handle events and style: end
//Handle classes
do match class with
| [] -> void
| [name|t] ->
do Buffer.append(html_buffer," class=\"")
do Buffer.append(html_buffer,name)
do List.iter((name -> do Buffer.append(html_buffer," ") Buffer.append(html_buffer,name)),t)
Buffer.append(html_buffer,"\"")
void
//Handle children
do if content == [] && //Auto-close auto-closing tags
(match tag with
| "abbr" | "br" | "col" | "img" | "input" | "link" | "meta" | "param" | "hr" | "area" | "embed" -> true
| _ -> false)
then
Buffer.append(html_buffer,"/>")
else
do if depth == 0 then
// saving the current content of the buffer
start = Buffer.contents(html_buffer)
do Buffer.clear(html_buffer)
// need to first look at the children,
// or else we won't have all their namespaces
do List.iter(x -> handle_xhtml(x, next), content)
content = Buffer.contents(html_buffer)
do Buffer.clear(html_buffer)
// putting back everything into the buffer
do Buffer.append(html_buffer,start)
do Buffer.append(html_buffer,">")
Buffer.append(html_buffer,content)
else
do Buffer.append(html_buffer,">")
List.iter(x -> handle_xhtml(x, next), content)
do Buffer.append(html_buffer,"</")
do Buffer.append(html_buffer,tag)
do Buffer.append(html_buffer,">")
void
void
end
do handle_xhtml(xhtml, 0)
//Now, insert the script
//We surround everything by a CDATA -- which has an effect in xhtml but not in html
//We replace each '>', which we assume cannot be a javascript token at this place,
// (so it happens only in a string) by its utf escaped counterpart
// to prevent both accidental termination via '</script>' tag (when CDATA is not
// operative as in html) or accidental termination of CDATA, ']]>'.
js_code =
str = Buffer.contents(js_buffer)
str = String.replace(">", "\\076", str)
str
{js_code = js_code;
html_code = Buffer.contents(html_buffer)}
)
/**
* Convert xhtml to a readable text
*/
to_readable_string(xhtml: xhtml): string =
(
html_buffer = Buffer.create(1024)//A buffer for storing the HTML source code
// indent(n) = Buffer.append(html_buffer,String.make(n," "))
rec handle_xhtml(xhtml: xhtml, depth:int) =
next = depth + 1 //next depth
match xhtml with
| ~{ text } ->
Buffer.append(html_buffer,text)
| { content_unsafe=_ } -> void
| ~{ fragment } ->
List.iter(x -> handle_xhtml(x, depth), fragment)
| { xml_dialect=_ } -> void
| { namespace=_ ~tag ~args ~content ~specific_attributes xmlns=_ } ->
match tag with
| "img" ->
match find_attr("alt",args) with
| {none} -> void
|~{some} -> do Buffer.append(html_buffer,"[") do Buffer.append(html_buffer,some) Buffer.append(html_buffer,"]")
end
| "a" -> //Transform xhtml-specific attribute [href] into a string
match specific_attributes with
| {none} -> void
|~{some} ->
href = match some.href with
| {none} -> find_attr("href",args)
| ~{constant}-> {some = constant}
| ~{untyped} -> //Here, insert dynamic filter through uri parser
if Uri.is_secure(untyped) then {some = untyped} //URI was accepted, return original URI
else {none}
| ~{typed} -> {some = Uri.to_string(typed)}//Here, insert URI serialization
end
match href with
| {~some} -> do Buffer.append(html_buffer,"[") do Buffer.append(html_buffer,some) do Buffer.append(html_buffer," | ") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"]")
| {none} -> List.iter(handle_xhtml(_,depth),content)
end
end
| "h1" | "h2" | "h3" | "h4" | "h5" | "h6" ->
do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
| "div"| "p"| "pre"| "blocknote"| "adress" ->
do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
| "ul"|"ol"|"dl"|"dir"|"menu" ->
do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,next),content) Buffer.append(html_buffer,"\n")
| "li"|"dt" ->
do Buffer.append(html_buffer,"- ") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
| "br" ->
Buffer.append(html_buffer,"\n\n")
| "hr" -> Buffer.append(html_buffer,"\n---------------------------\n")
| "b" | "i" | "span" | "acronym" | "cite" | "q" | "sup" | "sub" | "strong" | "em"
| "del" | "ins" | "dfn" | "kbd"->
List.iter(handle_xhtml(_,depth),content)
| "html" | "body" ->
List.iter(handle_xhtml(_,depth),content)
| _ -> void
end
end
do handle_xhtml(xhtml, 0)
Buffer.contents(html_buffer)
)
/**
* Same with xhtml fields instead of string
*/
prepare_for_export_as_xml_blocks(xhtml: xhtml) =
~{html_code js_code} = prepare_for_export(xhtml,false)
html = of_string_unsafe(html_code)
js = of_string_unsafe(js_code)
~{html js}
prepare_for_export_as_xml_blocks_non_utf8(xhtml: xhtml) =
~{html_code js_code} = prepare_for_export(xhtml,false)
html = of_string_unsafe(html_code)
js = of_string_unsafe(js_code)
~{html js}
/** Same as to_string */
serialize_to_string(xhtml: xhtml): string =
(
~{js_code html_code} = prepare_for_export(xhtml,false)
if String.is_empty(js_code) then html_code
else
String.flatten([html_code,_script_start,js_code,_script_end])
)
/** Same as to_string but without js_code */
serialize_as_standalone_html(xhtml: xhtml): string =
{js_code=_ ~html_code} = prepare_for_export(xhtml,true)
html_code
/**
* Precompile a html fragment into a form that will be faster to transmit and insert.
*
* @return a dialect of html designed for this purpose
*/
precompile(xhtml: xhtml): xhtml =
{html_code=html_code_unsafe js_code=js_code_unsafe} = prepare_for_export(xhtml,false)
{xml_dialect = some(~{html_code_unsafe js_code_unsafe})}
/**
* Perform the finalization of the js by encapsulation in a secured script construction
* to be used with [prepare_for_xhtml_export]
*/
finalize_js_inline(js:xhtml):xhtml =
match compile(js)
{text=""} {content_unsafe=""} {fragment=[]} -> empty_xhtml
_ -> {fragment = [of_string_unsafe(_script_start), js, of_string_unsafe(_script_end)]}
/**
* Perform the final compilation of a html fragment.
*
* You should never need this function, except if you're tweaking the generation of the original web page.
* @return a string fit to be sent to the browser
*/
compile(xhtml: xhtml): xhtml =
{ content_unsafe = serialize_to_string(xhtml) }
// Should put binds on the first encountred element
add_binds(list : list(handle_assoc(xhtml_event)), o : xhtml) = match o with
| { ~specific_attributes ... } as r ->
attr = Option.default(default_attributes,specific_attributes)
attr = {attr with events= list ++ attr.events}
@opensums({r with specific_attributes={some=attr}}) : xhtml
| _ -> error("add_binds: not fully implemented")
@private id_attr = "id"
/**
* Get the main id of the xhtml value
* Will fail if no id or if several id are possible
*/
get_id(x):option(string)=
match x : xhtml
{fragment=[x]} -> get_id(x)
{~args ...} -> find_attr(id_attr,args)
_ -> none
end
/**
* Add an id to the xhtml when it is not already defined,
* When the future position of the id is not clear (several possible node), it encapsulated everything in a div
*/
add_id(id,x:xhtml):xhtml =
id = id ? new_id()
// aux(id, x) with
rec aux(id,x)=
match x : xhtml
{fragment=[x]} -> aux(id,x)
{text=_}{content_unsafe=_} -> <div id={id}>{x}</div>
{~args ...} as x->
args = if exists_attr(id_attr,args) then args
else [{name=id_attr namespace="" value=id}|args]
@opensums({x with ~args})
_ -> <div id={id}>{x}</div>
end
aux(id,x)
@private add_class(value: string, x:xhtml):xhtml =
rec aux(value,x)=
match x : xhtml
{fragment=[x]} -> aux(value,x)
{text=_}{content_unsafe=_} -> <div class="{value}">{x}</div>
{~specific_attributes ...} as x ->
specific_attributes = specific_attributes ? default_attributes
specific_attributes = some({ specific_attributes with class = specific_attributes.class ++ [value] })
@opensums({x with ~specific_attributes})
_ -> <div class="{value}">{x}</div>
end
aux(value,x)
@private add_href(value: string, x:xhtml):xhtml =
rec aux(value,x)=
match x : xhtml
{fragment=[x]} -> aux(value,x)
{~specific_attributes ...} as x ->
specific_attributes = specific_attributes ? default_attributes
specific_attributes = some({ specific_attributes with href = {untyped=value} })
@opensums({x with ~specific_attributes})
_ -> x
end
aux(value,x)
@private add_style_from_string(value: string, x:xhtml):xhtml =
rec aux(value,x)=
match x : xhtml
{fragment=[x]} -> aux(value,x)
{~specific_attributes ...} as x ->
aux2(acc, s) =
match String.explode(":", s)
[k,v] ->
key = String.strip(k)
value = String.strip(v)
[{not_typed=(key, value)}|acc]
_ -> acc
end
styles = List.fold_left(aux2, [], String.explode(";", value))
specific_attributes = specific_attributes ? default_attributes
specific_attributes = some({ specific_attributes with style = (specific_attributes.style ++ styles) })
@opensums({x with ~specific_attributes})
_ -> x
end
aux(value,x)
@private gen_add_attribute(name: string, value: string, x:xhtml, append:bool):xhtml =
match name
| "class" -> add_class(value, x)
| "href" -> add_href(value, x)
| "style" -> add_style_from_string(value, x)
| _ ->
rec aux(x)=
match x : xhtml
{fragment=[x]} -> aux(x)
{~args ...} as x->
args = match find_attr(name,args) with
{some=val} ->
if not(append) then args
else
value = "{val} {value}"
args = remove_attr(name,args)
[{~name namespace="" ~value}|args]
{none} -> [{~name namespace="" ~value}|args]
@opensums({x with ~args})
_ -> x
end
aux(x)
/**
* Add an attribute to an xhtml node if not already defined
*/
add_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
gen_add_attribute(name, value, x, false)
/**
* Update (by appending) an attribute to an xhtml node, add it if not already present
*/
update_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
gen_add_attribute(name, value, x, true)
/**
* Set an attribute to an xhtml node. Replace if already_exists
*/
set_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
// aux(id, x) with
rec aux(x)=
match x : xhtml
{fragment=[x]} -> aux(x)
{~args ...} as x->
args =
l = remove_attr(name,args)
[{~name namespace="" ~value}|l]
@opensums({x with ~args})
_ -> x
end
aux(x)
/**
* Remove an attribute from an xhtml node.
*/
remove_attribute(name: string, x:xhtml):xhtml =
// aux(id, x) with
rec aux(x)=
match x : xhtml
{fragment=[x]} -> aux(x)
{~args ...} as x->
args = remove_attr(name,args)
@opensums({x with ~args})
_ -> x
end
aux(x)
/**
* Add a title attribute to an xhtml node.
* No verification on wether the xhtml supports title attribute is made
*/
add_title(t:string, x:xhtml) : xhtml = Xhtml.add_attribute_unsafe("title", t, x)
/**
* Add/Update ths class attribute of an xhtml node, by appending a certain class.
* No verification on wether the xhtml supports class attribute is made
*/
update_class(c:string, x:xhtml) : xhtml = Xhtml.update_attribute_unsafe("class", c, x)
/**
* Add style to the xhtml (added to pre-exiting style)
* When the future position of the style is not clear (several possible node), it encapsulated everything in a div
*/
add_style(style,x):xhtml =
match x : xhtml
{fragment=l} -> {fragment=List.map(add_style(style,_),l)}
{text=_}{content_unsafe=_} -> <div style={style}>{x}</div>
{specific_attributes=sa ...} as x->
sa = sa ? default_attributes
style = style ++ sa.style
specific_attributes = some({sa with ~style})
@opensums({x with ~specific_attributes})
_ -> <div style={style}>{x}</div>
/**
* Add a onready event the xhtml
* NEED TO DETAIL BEHAVIOR IF onready ALREADY EXISTING
* DOES NOT WORK ON SERVER SIDE UNTIL CLOSURE SERIALIZATION IS WORKING AND USED ON XHTML
*/
add_onready(f,x):xhtml =
match x : xhtml
{content_unsafe=_}
{text=_} -> <div onready={f}>{x}</div>
{fragment=[]} -> <div onready={f}></div>
{fragment=[x|l]} -> x = add_onready(f,x)
{fragment=[x|l]}
{specific_attributes=sa ...} as x->
sa = sa ? default_attributes
events = [{name={ready} value={expr=f}}|sa.events]
specific_attributes = some({sa with ~events})
@opensums({x with ~specific_attributes})
_ -> <div onready={f}>{x}</div>
/**
* Serializer for xhtml data structures.
* Provides a standard serialization but on server side,
* unserialization checks and replaces unsafe fields by default
* values.
*/
@both_implem @serializer(xhtml) serializer =
ximpl = OpaType.implementation(@typeval(xhtml))
{
f1 = OpaSerialize.partial_serialize_options(_, ximpl, _)
f2 = json -> @sliced_expr({
client = OpaSerialize.finish_unserialize(json, ximpl)
server =
check_args =
List.map({namespace=_ ~name ~value} as a ->
match String.has_prefix("on", name)
| {true} ->
do Log.warning("Xhtml",
"Attribute {name} can be an event handler and contains an unsafe string :
{value}
Replaced by a default value.")
{a with value="/*unsafe attribute from a client*/"}
| _ -> a
, _)
check_sargs({class=_ style=_ bool_attributes=_ ~events events_options=_ href=_} as a) =
{ a with events = List.map(
| ~{name value=~{value}} ->
do Log.warning("Xhtml",
"Receiving from a client an unsafe specific attribute {name} :
{value}
Replaced by a default value.")
~{name value={value="/*unsafe specific attribute from a client*/"}}
| _ as a -> a
, events)
}
Option.map(
| ~{content_unsafe} ->
do Log.warning("Xhtml",
"Receiving from client unsafe content of xhtml :
{content_unsafe}.
Replaced by a default value.")
{text = "unsafe content from a client"} : xhtml
| {namespace=_ tag=_ ~args content=_ ~specific_attributes xmlns=_} as e->
@opensums({e with args=check_args(args) specific_attributes=Option.map(check_sargs, specific_attributes)}) : xhtml
| _ as safe -> safe
, OpaSerialize.finish_unserialize(json, ximpl))
})
}
}}
/* Functions used by xml pattern matching */
@opacapi Xml_find_attr = Xml.find_attr
@opacapi Xml_match_star = Xmlns.match_star
@opacapi Xml_match_plus = Xmlns.match_plus
@opacapi Xml_match_question = Xmlns.match_question
@opacapi Xml_match_number = Xmlns.match_exact
@opacapi Xml_match_range = Xmlns.match_range
@opacapi Xml_match_namespace = Xmlns.match_namespace
// Cannot be in Uri.uri module due to dependencies on this package
@xmlizer(Uri.uri) uri_to_xml(u : Uri.uri) =
<>{"{u}"}</>
Jump to Line
Something went wrong with that request. Please try again.