Skip to content
Newer
Older
100644 263 lines (207 sloc) 9.3 KB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (** Wsdl2mlCommon:
19 Common code between wsdl2ml translator and generated code runtime.
20 *)
21
22 module List = Base.List
23 module String = Base.String
24
25 let eprintf = Printf.eprintf
26 let fprintf = Printf.fprintf
27 let sprintf = Printf.sprintf
28
29 (* Tools used by the wsdl2ml translator *)
30
31 type tree = E of Xmlm.tag * tree list | D of string
32
33 let sname ((ns,name):Xmlm.name) = ns^(if ns <> "" then ":" else "")^name
34 let satt ((name,str):Xmlm.attribute) = sname name^"=\""^str^"\""
35 let satts atts = String.sconcat ~left:"[" ~right:"]" "; " (List.map satt atts)
36 let stag ((name,atts):Xmlm.tag) = sname name^(String.concat ";\n" (List.map satt atts))
37 let gtag = function | E (tag,_) -> tag | D _ -> raise (Failure "no tag")
38 let gts = function | E (_,trees) -> trees | D _ -> raise (Failure "no trees")
39
40 let mkname ns name = ((ns,name):Xmlm.name)
41 let mkatt name str = ((name,str):Xmlm.attribute)
42 let mktag name atts = ((name,atts):Xmlm.tag)
43 let mkstag name = mktag (mkname "" name) []
44
45 let in_tree i =
46 let el tag children =
47 (*eprintf "in_tree: tag=%s\n" (stag tag); flush stderr;*)
48 E (tag, children) in
49 let data d = D d in
50 Xmlm.input_doc_tree ~el ~data i
51
52 let out_tree o t =
53 let frag = function
54 | E (tag, children) -> `El (tag, children)
55 | D d -> `Data d
56 in
57 Xmlm.output_doc_tree frag o t
58
59 let string_of_tree ?(hint=1024) t =
60 let b = Buffer.create hint in
61 let o = Xmlm.make_output ~indent:(Some 2) (`Buffer b) in
62 out_tree o t;
63 Buffer.contents b
64
65 let sxml xml = string_of_tree (None,List.hd xml)
66
67 let is_name ((ns1,name1):Xmlm.name) ((ns2,name2):Xmlm.name) = ns1 = ns2 && name1 = name2
68 let is_uqname ((_,name1):Xmlm.name) ((_,name2):Xmlm.name) = name1 = name2
69
70 let find_tag is_tag trees = List.find_opt (function | (E (tag,_)) -> is_tag tag | D _ -> false) trees
71
72 let find_att (name:Xmlm.name) (atts:Xmlm.attribute list) =
73 match List.find_opt (function (n,_) -> is_uqname name n) atts with
74 | Some (_,att) -> Some att
75 | None -> None
76
77 let get_tree_string content =
78 let src = `String (0,content) in
79 let i = Xmlm.make_input ~strip:true src in
80 let t = in_tree i in
81 (*eprintf "xml: %s\n%!" (string_of_tree t);*)
82 t
83
84 let get_tree_filename filename = get_tree_string (File.content filename)
85
86 let null_fold_tree_f = function acc -> function E (_tag, _trees) -> acc | D _str -> acc
87
88 let fold_tree f def tree =
89 let rec aux acc = function
90 | E (tag, trees) ->
91 let acc = f acc (E (tag, trees)) in
92 List.fold_left aux acc trees
93 | D str ->
94 f acc (D str)
95 in
96 aux def tree
97
98 let fold_trees f def trees = List.fold_left (fun acc (_ns,(_dtd,tree)) -> fold_tree f acc tree) def trees
99
100 let find_trees f trees = List.fold_left (fun acc (_ns,(_dtd,tree)) -> if f tree then tree::acc else acc) [] trees
101
102 (* Implementations of types found in XML Schema *)
103
104 (* ws:dateTime *)
105
106 (*'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)?*)
107
108 type t_dateTime = Time.t
109
110 let string_of_dateTime (dT:t_dateTime) =
111 let _msec = Time.gmt_msec dT in
112 let sec = Time.gmt_sec dT in
113 let min = Time.gmt_min dT in
114 let hour = Time.gmt_hour dT in
115 let mday = Time.gmt_mday dT in
116 let mon = Time.gmt_mon dT in
117 let year = Time.gmt_year dT in
118 (*let wday = Time.gmt_wday dT in
119 let yday = Time.gmt_yday dT in
120 let isdst = Time.gmt_isdst dT in*)
121 sprintf "%04d-%02d-%02dT%02d:%02d:%02d.%03dZ" year (mon+1) mday hour min sec _msec
122 (*sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" year (mon+1) mday hour min sec*)
123
124 let dTre = Str.regexp "-?\\([0-9][0-9][0-9][0-9]\\)-\\([01][0-9]\\)-\\([0-3][0-9]\\)T\\([0-2][0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\)\\(\\(\\.\\([0-9]+\\)\\)?\\)\\(\\(\\(\\([+-]\\)\\([0-5][0-9]\\):\\([0-5][0-9]\\)\\)\\|\\(Z\\)\\)?\\)"
125
126 (* FIXME : this is complete rubbish (Timezones are wrong) *)
127
128 let dateTime_of_string str : t_dateTime =
129 if Str.string_match dTre str 0
130 then
131 let yyyy = Str.matched_group 1 str in
132 let mmmm = Str.matched_group 2 str in
133 let dddd = Str.matched_group 3 str in
134 let hh = Str.matched_group 4 str in
135 let mm = Str.matched_group 5 str in
136 let ss = Str.matched_group 6 str in
137 let msec = try Str.matched_group 9 str with Not_found -> "000" in
138 let pm, zhh, zmm =
139 try Str.matched_group 13 str, Str.matched_group 14 str, Str.matched_group 15 str
140 with Not_found -> "Z", "00", "00" in
141 (*yyyy, mmmm, dddd, hh, mm, ss, msec, pm, zhh, zmm*)
142 let conv s mn mx =
143 let i = try int_of_string s with Failure "int_of_string" -> raise (Failure ("dateTime_of_string "^s)) in
144 if i >= mn && i <= mx then i else raise (Failure ("dateTime_of_string "^s))
145 in
146 let year = conv yyyy 0 3000 in
147 let month = conv mmmm 1 12 in
148 let day = conv dddd 1 31 in
149 let h = conv hh 0 24 in
150 let min = conv mm 0 60 in
151 let sec = conv ss 0 60 in
152 let ms = conv msec 0 999 in
153 (*eprintf "start=%02d:%02d\n%!" h min;*)
154 let bt = Time.mktime ~year ~month ~day ~h ~min ~sec ~ms in
155 (*eprintf "start(bt,gmt): %02d:%02d\n%!" (Time.gmt_hour bt) (Time.gmt_min bt);*)
156 (*eprintf "start(bt,local): %02d:%02d\n%!" (Time.local_hour bt) (Time.local_min bt);*)
157 if pm = "Z"
158 then bt
159 else
160 let zhour = conv zhh 0 24 in
161 let zmin = conv zmm 0 60 in
162 (*eprintf "diff: %s%02d:%02d\n%!" pm zhour zmin;*)
163 let t = Time.add (Time.hours zhour) (Time.minutes zmin) in
164 (*eprintf "diff(t,gmt): %02d:%02d\n%!" (Time.gmt_hour t) (Time.gmt_min t);*)
165 (*eprintf "diff(t,local): %02d:%02d\n%!" (Time.local_hour t) (Time.local_min t);*)
166 match pm with
167 | "+" -> Time.difference t bt
168 | "-" -> Time.add bt t
169 | _ -> raise (Failure ("dateTime_of_string: Unknown time modifier "^str))
170 else
171 raise (Failure ("dateTime_of_string "^str))
172
173 (*
174 let str2 = "2011-04-02T07:22:59.138+02:00";;
175 let str3 = "2002-10-10T12:00:00+05:00";;
176 let str4 = "2011-04-02T07:22:59.138Z";;
177 let t = dateTime_of_string str4;;
178 let _ = eprintf "final(gmt): %02d:%02d\n%!" (Time.gmt_hour t) (Time.gmt_min t);;
179 let _ = eprintf "final(local): %02d:%02d\n%!" (Time.local_hour t) (Time.local_min t);;
180 *)
181
182 (* ws:byte *)
183
184 type t_byte = int
185
186 let chk_byte name b = if b < -127 || b > 128 then raise (Failure (sprintf "%s value out of range" name))
187
188 let string_of_byte (b:t_byte) =
189 chk_byte "string_of_byte" b;
190 string_of_int b
191
192 let byte_of_string str : t_byte =
193 try
194 let b = int_of_string str in
195 chk_byte "byte_of_string" b;
196 b
197 with Failure "int_of_string" -> raise (Failure "byte_of_string")
198
199 (* Exceptions generated by generated code *)
200
201 exception Wsdl2mlOccurs of int * int * tree list
202 exception Wsdl2mlNonMtchCon of string
203 exception Wsdl2mlInputFailure of string
204
205 (* Generic converters to be used to fill in blanks created by <any/> *)
206
207 let toxml_string s = [D s]
208 let toxml_int i = [D (string_of_int i)]
209 let toxml_byte b = [D (string_of_byte b)]
210 let toxml_float f = [D (string_of_float f)]
211 let toxml_bool b = [D (string_of_bool b)]
212 let toxml_dateTime dT = [D (string_of_dateTime dT)]
213
214 let fx n os v = try os v with Failure nn when (n^"_of_string") = nn -> raise (Wsdl2mlInputFailure (sprintf "Expected %s" n))
215
216 let fromxml_string = function [D s] -> s | _ -> raise (Wsdl2mlInputFailure "Expected string")
217 let fromxml_int = function [D i] -> fx "int" int_of_string i | _ -> raise (Wsdl2mlInputFailure "Expected int")
218 let fromxml_byte = function [D b] -> fx "byte" byte_of_string b | _ -> raise (Wsdl2mlInputFailure "Expected byte")
219 let fromxml_float = function [D f] -> fx "float" float_of_string f | _ -> raise (Wsdl2mlInputFailure "Expected float")
220 let fromxml_bool = function [D b] -> fx "bool" bool_of_string b | _ -> raise (Wsdl2mlInputFailure "Expected bool")
221 let fromxml_dateTime = function [D dT] -> fx "dateTime" dateTime_of_string dT | _ -> raise (Wsdl2mlInputFailure "Expected dateTime")
222
223 (* Tools used internally by generated code *)
224
225 let find_name name sts =
226 List.fold_left (fun acc -> function E (((_,n),_),_) as e -> if n = name then e::acc else acc | _ -> acc) [] sts
227
228 let find_names names sts =
229 List.fold_left (fun acc -> function E (((_,n),_),_) as e -> if List.mem n names then e::acc else acc | _ -> acc) [] sts
230
231 (* Some support for digging around in the XML *)
232
233 let get_sts name sts =
234 (function
235 | (E (((_,n),_), (sts)))::_ when n = name -> sts
236 | (E (((_,n),_), _))::_ -> raise (Failure ("is actually: "^n))
237 | (D str)::_ -> raise (Failure ("is actually D: "^str))
238 | [] -> raise (Failure "is actually []"))
239 (find_name name sts)
240
241 let sts_names sts = List.map (function
242 | (E (((_,n),_), _)) -> n
243 | (D str) -> ("D:"^str)) sts
244
245 let dig_sts names sts =
246 let rec aux sofar sts = function
247 | name::names ->
248 (try
249 aux (sofar@[name]) (get_sts name sts) names
250 with _ -> (sofar,sts))
251 | [] -> (sofar,sts)
252 in
253 aux [] sts names
254
255 let is_tree_name name = function
256 | (E (((_,n),_), _)) -> n = name
257 | (D _) -> false
258
259 (* End of file wsdl2mlCommon.ml *)
260
261
262
Something went wrong with that request. Please try again.