Skip to content
This repository
tag: v45
Fetching contributors…

Cannot retrieve contributors at this time

file 259 lines (207 sloc) 9.528 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(** Wsdl2mlCommon:
Common code between wsdl2ml translator and generated code runtime.
*)

module List = Base.List
module String = Base.String

let eprintf = Printf.eprintf
let fprintf = Printf.fprintf
let sprintf = Printf.sprintf

(* Tools used by the wsdl2ml translator *)

type tree = E of Xmlm.tag * tree list | D of string

let sname ((ns,name):Xmlm.name) = ns^(if ns <> "" then ":" else "")^name
let satt ((name,str):Xmlm.attribute) = sname name^"=\""^str^"\""
let satts atts = String.sconcat ~left:"[" ~right:"]" "; " (List.map satt atts)
let stag ((name,atts):Xmlm.tag) = sname name^(String.concat ";\n" (List.map satt atts))
let gtag = function | E (tag,_) -> tag | D _ -> raise (Failure "no tag")
let gts = function | E (_,trees) -> trees | D _ -> raise (Failure "no trees")

let mkname ns name = ((ns,name):Xmlm.name)
let mkatt name str = ((name,str):Xmlm.attribute)
let mktag name atts = ((name,atts):Xmlm.tag)
let mkstag name = mktag (mkname "" name) []

let in_tree i =
  let el tag children =
    (*eprintf "in_tree: tag=%s\n" (stag tag); flush stderr;*)
    E (tag, children) in
  let data d = D d in
  Xmlm.input_doc_tree ~el ~data i

let out_tree o t =
  let frag = function
  | E (tag, children) -> `El (tag, children)
  | D d -> `Data d
  in
  Xmlm.output_doc_tree frag o t

let string_of_tree ?(hint=1024) t =
  let b = Buffer.create hint in
  let o = Xmlm.make_output ~indent:(Some 2) (`Buffer b) in
  out_tree o t;
  Buffer.contents b

let sxml xml = string_of_tree (None,List.hd xml)

let is_name ((ns1,name1):Xmlm.name) ((ns2,name2):Xmlm.name) = ns1 = ns2 && name1 = name2
let is_uqname ((_,name1):Xmlm.name) ((_,name2):Xmlm.name) = name1 = name2

let find_tag is_tag trees = List.find_opt (function | (E (tag,_)) -> is_tag tag | D _ -> false) trees

let find_att (name:Xmlm.name) (atts:Xmlm.attribute list) =
  match List.find_opt (function (n,_) -> is_uqname name n) atts with
  | Some (_,att) -> Some att
  | None -> None

let get_tree_string content =
  let src = `String (0,content) in
  let i = Xmlm.make_input ~strip:true src in
  let t = in_tree i in
  (*eprintf "xml: %s\n%!" (string_of_tree t);*)
  t

let get_tree_filename filename = get_tree_string (File.content filename)

let null_fold_tree_f = function acc -> function E (_tag, _trees) -> acc | D _str -> acc

let fold_tree f def tree =
  let rec aux acc = function
    | E (tag, trees) ->
        let acc = f acc (E (tag, trees)) in
        List.fold_left aux acc trees
    | D str ->
        f acc (D str)
  in
  aux def tree

let fold_trees f def trees = List.fold_left (fun acc (_ns,(_dtd,tree)) -> fold_tree f acc tree) def trees

let find_trees f trees = List.fold_left (fun acc (_ns,(_dtd,tree)) -> if f tree then tree::acc else acc) [] trees

(* Implementations of types found in XML Schema *)

(* ws:dateTime *)

(*'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)?*)

type t_dateTime = Time.t

let string_of_dateTime (dT:t_dateTime) =
  let _msec = Time.gmt_msec dT in
  let sec = Time.gmt_sec dT in
  let min = Time.gmt_min dT in
  let hour = Time.gmt_hour dT in
  let mday = Time.gmt_mday dT in
  let mon = Time.gmt_mon dT in
  let year = Time.gmt_year dT in
  (*let wday = Time.gmt_wday dT in
let yday = Time.gmt_yday dT in
let isdst = Time.gmt_isdst dT in*)
  sprintf "%04d-%02d-%02dT%02d:%02d:%02d.%03dZ" year (mon+1) mday hour min sec _msec
  (*sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" year (mon+1) mday hour min sec*)

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\\)\\)?\\)"

(* FIXME : this is complete rubbish (Timezones are wrong) *)

let dateTime_of_string str : t_dateTime =
  if Str.string_match dTre str 0
  then
    let yyyy = Str.matched_group 1 str in
    let mmmm = Str.matched_group 2 str in
    let dddd = Str.matched_group 3 str in
    let hh = Str.matched_group 4 str in
    let mm = Str.matched_group 5 str in
    let ss = Str.matched_group 6 str in
    let msec = try Str.matched_group 9 str with Not_found -> "000" in
    let pm, zhh, zmm =
      try Str.matched_group 13 str, Str.matched_group 14 str, Str.matched_group 15 str
      with Not_found -> "Z", "00", "00" in
    (*yyyy, mmmm, dddd, hh, mm, ss, msec, pm, zhh, zmm*)
    let conv s mn mx =
      let i = try int_of_string s with Failure "int_of_string" -> raise (Failure ("dateTime_of_string "^s)) in
      if i >= mn && i <= mx then i else raise (Failure ("dateTime_of_string "^s))
    in
    let year = conv yyyy 0 3000 in
    let month = conv mmmm 1 12 in
    let day = conv dddd 1 31 in
    let h = conv hh 0 24 in
    let min = conv mm 0 60 in
    let sec = conv ss 0 60 in
    let ms = conv msec 0 999 in
    (*eprintf "start=%02d:%02d\n%!" h min;*)
    let bt = Time.mktime ~year ~month ~day ~h ~min ~sec ~ms in
    (*eprintf "start(bt,gmt): %02d:%02d\n%!" (Time.gmt_hour bt) (Time.gmt_min bt);*)
    (*eprintf "start(bt,local): %02d:%02d\n%!" (Time.local_hour bt) (Time.local_min bt);*)
    if pm = "Z"
    then bt
    else
      let zhour = conv zhh 0 24 in
      let zmin = conv zmm 0 60 in
      (*eprintf "diff: %s%02d:%02d\n%!" pm zhour zmin;*)
      let t = Time.add (Time.hours zhour) (Time.minutes zmin) in
      (*eprintf "diff(t,gmt): %02d:%02d\n%!" (Time.gmt_hour t) (Time.gmt_min t);*)
      (*eprintf "diff(t,local): %02d:%02d\n%!" (Time.local_hour t) (Time.local_min t);*)
      match pm with
      | "+" -> Time.difference t bt
      | "-" -> Time.add bt t
      | _ -> raise (Failure ("dateTime_of_string: Unknown time modifier "^str))
  else
    raise (Failure ("dateTime_of_string "^str))

(*
let str2 = "2011-04-02T07:22:59.138+02:00";;
let str3 = "2002-10-10T12:00:00+05:00";;
let str4 = "2011-04-02T07:22:59.138Z";;
let t = dateTime_of_string str4;;
let _ = eprintf "final(gmt): %02d:%02d\n%!" (Time.gmt_hour t) (Time.gmt_min t);;
let _ = eprintf "final(local): %02d:%02d\n%!" (Time.local_hour t) (Time.local_min t);;
*)

(* ws:byte *)

type t_byte = int

let chk_byte name b = if b < -127 || b > 128 then raise (Failure (sprintf "%s value out of range" name))

let string_of_byte (b:t_byte) =
  chk_byte "string_of_byte" b;
  string_of_int b

let byte_of_string str : t_byte =
  try
    let b = int_of_string str in
    chk_byte "byte_of_string" b;
    b
  with Failure "int_of_string" -> raise (Failure "byte_of_string")

(* Exceptions generated by generated code *)

exception Wsdl2mlOccurs of int * int * tree list
exception Wsdl2mlNonMtchCon of string
exception Wsdl2mlInputFailure of string

(* Generic converters to be used to fill in blanks created by <any/> *)

let toxml_string s = [D s]
let toxml_int i = [D (string_of_int i)]
let toxml_byte b = [D (string_of_byte b)]
let toxml_float f = [D (string_of_float f)]
let toxml_bool b = [D (string_of_bool b)]
let toxml_dateTime dT = [D (string_of_dateTime dT)]

let fx n os v = try os v with Failure nn when (n^"_of_string") = nn -> raise (Wsdl2mlInputFailure (sprintf "Expected %s" n))

let fromxml_string = function [D s] -> s | _ -> raise (Wsdl2mlInputFailure "Expected string")
let fromxml_int = function [D i] -> fx "int" int_of_string i | _ -> raise (Wsdl2mlInputFailure "Expected int")
let fromxml_byte = function [D b] -> fx "byte" byte_of_string b | _ -> raise (Wsdl2mlInputFailure "Expected byte")
let fromxml_float = function [D f] -> fx "float" float_of_string f | _ -> raise (Wsdl2mlInputFailure "Expected float")
let fromxml_bool = function [D b] -> fx "bool" bool_of_string b | _ -> raise (Wsdl2mlInputFailure "Expected bool")
let fromxml_dateTime = function [D dT] -> fx "dateTime" dateTime_of_string dT | _ -> raise (Wsdl2mlInputFailure "Expected dateTime")

(* Tools used internally by generated code *)

let find_name name sts =
  List.fold_left (fun acc -> function E (((_,n),_),_) as e -> if n = name then e::acc else acc | _ -> acc) [] sts

let find_names names sts =
  List.fold_left (fun acc -> function E (((_,n),_),_) as e -> if List.mem n names then e::acc else acc | _ -> acc) [] sts

(* Some support for digging around in the XML *)

let get_sts name sts =
  (function
   | (E (((_,n),_), (sts)))::_ when n = name -> sts
   | (E (((_,n),_), _))::_ -> raise (Failure ("is actually: "^n))
   | (D str)::_ -> raise (Failure ("is actually D: "^str))
   | [] -> raise (Failure "is actually []"))
  (find_name name sts)

let sts_names sts = List.map (function
   | (E (((_,n),_), _)) -> n
   | (D str) -> ("D:"^str)) sts

let dig_sts names sts =
  let rec aux sofar sts = function
    | name::names ->
        (try
           aux (sofar@[name]) (get_sts name sts) names
         with _ -> (sofar,sts))
    | [] -> (sofar,sts)
  in
  aux [] sts names

let is_tree_name name = function
  | (E (((_,n),_), _)) -> n = name
  | (D _) -> false

(* End of file wsdl2mlCommon.ml *)
Something went wrong with that request. Please try again.