1(* 2 Licensed to the Apache Software Foundation (ASF) under one 3 or more contributor license agreements. See the NOTICE file 4 distributed with this work for additional information 5 regarding copyright ownership. The ASF licenses this file 6 to you under the Apache License, Version 2.0 (the 7 "License"); you may not use this file except in compliance 8 with the License. You may obtain a copy of the License at 9 10 http://www.apache.org/licenses/LICENSE-2.0 11 12 Unless required by applicable law or agreed to in writing, 13 software distributed under the License is distributed on an 14 "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 15 KIND, either express or implied. See the License for the 16 specific language governing permissions and limitations 17 under the License. 18*) 19 20exception Break;; 21exception Thrift_error;; 22exception Field_empty of string;; 23 24class t_exn = 25object 26 val mutable message = "" 27 method get_message = message 28 method set_message s = message <- s 29end;; 30 31module Transport = 32struct 33 type exn_type = 34 | UNKNOWN 35 | NOT_OPEN 36 | ALREADY_OPEN 37 | TIMED_OUT 38 | END_OF_FILE;; 39 40 exception E of exn_type * string 41 42 class virtual t = 43 object (self) 44 method virtual isOpen : bool 45 method virtual opn : unit 46 method virtual close : unit 47 method virtual read : string -> int -> int -> int 48 method readAll buf off len = 49 let got = ref 0 in 50 let ret = ref 0 in 51 while !got < len do 52 ret := self#read buf (off+(!got)) (len - (!got)); 53 if !ret <= 0 then 54 raise (E (UNKNOWN, "Cannot read. Remote side has closed.")); 55 got := !got + !ret 56 done; 57 !got 58 method virtual write : string -> int -> int -> unit 59 method virtual flush : unit 60 end 61 62 class factory = 63 object 64 method getTransport (t : t) = t 65 end 66 67 class virtual server_t = 68 object (self) 69 method virtual listen : unit 70 method accept = self#acceptImpl 71 method virtual close : unit 72 method virtual acceptImpl : t 73 end 74 75end;; 76 77 78 79module Protocol = 80struct 81 type t_type = 82 | T_STOP 83 | T_VOID 84 | T_BOOL 85 | T_BYTE 86 | T_I08 87 | T_I16 88 | T_I32 89 | T_U64 90 | T_I64 91 | T_DOUBLE 92 | T_STRING 93 | T_UTF7 94 | T_STRUCT 95 | T_MAP 96 | T_SET 97 | T_LIST 98 | T_UTF8 99 | T_UTF16 100 101 let t_type_to_i = function 102 T_STOP -> 0 103 | T_VOID -> 1 104 | T_BOOL -> 2 105 | T_BYTE -> 3 106 | T_I08 -> 3 107 | T_I16 -> 6 108 | T_I32 -> 8 109 | T_U64 -> 9 110 | T_I64 -> 10 111 | T_DOUBLE -> 4 112 | T_STRING -> 11 113 | T_UTF7 -> 11 114 | T_STRUCT -> 12 115 | T_MAP -> 13 116 | T_SET -> 14 117 | T_LIST -> 15 118 | T_UTF8 -> 16 119 | T_UTF16 -> 17 120 121 let t_type_of_i = function 122 0 -> T_STOP 123 | 1 -> T_VOID 124 | 2 -> T_BOOL 125 | 3 -> T_BYTE 126 | 6-> T_I16 127 | 8 -> T_I32 128 | 9 -> T_U64 129 | 10 -> T_I64 130 | 4 -> T_DOUBLE 131 | 11 -> T_STRING 132 | 12 -> T_STRUCT 133 | 13 -> T_MAP 134 | 14 -> T_SET 135 | 15 -> T_LIST 136 | 16 -> T_UTF8 137 | 17 -> T_UTF16 138 | _ -> raise Thrift_error 139 140 type message_type = 141 | CALL 142 | REPLY 143 | EXCEPTION 144 | ONEWAY 145 146 let message_type_to_i = function 147 | CALL -> 1 148 | REPLY -> 2 149 | EXCEPTION -> 3 150 | ONEWAY -> 4 151 152 let message_type_of_i = function 153 | 1 -> CALL 154 | 2 -> REPLY 155 | 3 -> EXCEPTION 156 | 4 -> ONEWAY 157 | _ -> raise Thrift_error 158 159 class virtual t (trans: Transport.t) = 160 object (self) 161 val mutable trans_ = trans 162 method getTransport = trans_ 163 (* writing methods *) 164 method virtual writeMessageBegin : string * message_type * int -> unit 165 method virtual writeMessageEnd : unit 166 method virtual writeStructBegin : string -> unit 167 method virtual writeStructEnd : unit 168 method virtual writeFieldBegin : string * t_type * int -> unit 169 method virtual writeFieldEnd : unit 170 method virtual writeFieldStop : unit 171 method virtual writeMapBegin : t_type * t_type * int -> unit 172 method virtual writeMapEnd : unit 173 method virtual writeListBegin : t_type * int -> unit 174 method virtual writeListEnd : unit 175 method virtual writeSetBegin : t_type * int -> unit 176 method virtual writeSetEnd : unit 177 method virtual writeBool : bool -> unit 178 method virtual writeByte : int -> unit 179 method virtual writeI16 : int -> unit 180 method virtual writeI32 : Int32.t -> unit 181 method virtual writeI64 : Int64.t -> unit 182 method virtual writeDouble : float -> unit 183 method virtual writeString : string -> unit 184 method virtual writeBinary : string -> unit 185 (* reading methods *) 186 method virtual readMessageBegin : string * message_type * int 187 method virtual readMessageEnd : unit 188 method virtual readStructBegin : string 189 method virtual readStructEnd : unit 190 method virtual readFieldBegin : string * t_type * int 191 method virtual readFieldEnd : unit 192 method virtual readMapBegin : t_type * t_type * int 193 method virtual readMapEnd : unit 194 method virtual readListBegin : t_type * int 195 method virtual readListEnd : unit 196 method virtual readSetBegin : t_type * int 197 method virtual readSetEnd : unit 198 method virtual readBool : bool 199 method virtual readByte : int 200 method virtual readI16 : int 201 method virtual readI32: Int32.t 202 method virtual readI64 : Int64.t 203 method virtual readDouble : float 204 method virtual readString : string 205 method virtual readBinary : string 206 (* skippage *) 207 method skip typ = 208 match typ with 209 | T_BOOL -> ignore self#readBool 210 | T_BYTE 211 | T_I08 -> ignore self#readByte 212 | T_I16 -> ignore self#readI16 213 | T_I32 -> ignore self#readI32 214 | T_U64 215 | T_I64 -> ignore self#readI64 216 | T_DOUBLE -> ignore self#readDouble 217 | T_STRING -> ignore self#readString 218 | T_UTF7 -> () 219 | T_STRUCT -> ignore ((ignore self#readStructBegin); 220 (try 221 while true do 222 let (_,t,_) = self#readFieldBegin in 223 if t = T_STOP then 224 raise Break 225 else 226 (self#skip t; 227 self#readFieldEnd) 228 done 229 with Break -> ()); 230 self#readStructEnd) 231 | T_MAP -> ignore (let (k,v,s) = self#readMapBegin in 232 for i=0 to s do 233 self#skip k; 234 self#skip v; 235 done; 236 self#readMapEnd) 237 | T_SET -> ignore (let (t,s) = self#readSetBegin in 238 for i=0 to s do 239 self#skip t 240 done; 241 self#readSetEnd) 242 | T_LIST -> ignore (let (t,s) = self#readListBegin in 243 for i=0 to s do 244 self#skip t 245 done; 246 self#readListEnd) 247 | T_UTF8 -> () 248 | T_UTF16 -> () 249 | _ -> raise (Protocol.E (Protocol.INVALID_DATA, "Invalid data")) 250 end 251 252 class virtual factory = 253 object 254 method virtual getProtocol : Transport.t -> t 255 end 256 257 type exn_type = 258 | UNKNOWN 259 | INVALID_DATA 260 | NEGATIVE_SIZE 261 | SIZE_LIMIT 262 | BAD_VERSION 263 | NOT_IMPLEMENTED 264 | DEPTH_LIMIT 265 266 exception E of exn_type * string;; 267 268end;; 269 270 271module Processor = 272struct 273 class virtual t = 274 object 275 method virtual process : Protocol.t -> Protocol.t -> bool 276 end;; 277 278 class factory (processor : t) = 279 object 280 val processor_ = processor 281 method getProcessor (trans : Transport.t) = processor_ 282 end;; 283end 284 285 286(* Ugly *) 287module Application_Exn = 288struct 289 type typ= 290 | UNKNOWN 291 | UNKNOWN_METHOD 292 | INVALID_MESSAGE_TYPE 293 | WRONG_METHOD_NAME 294 | BAD_SEQUENCE_ID 295 | MISSING_RESULT 296 | INTERNAL_ERROR 297 | PROTOCOL_ERROR 298 | INVALID_TRANSFORM 299 | INVALID_PROTOCOL 300 | UNSUPPORTED_CLIENT_TYPE 301 302 let typ_of_i = function 303 0l -> UNKNOWN 304 | 1l -> UNKNOWN_METHOD 305 | 2l -> INVALID_MESSAGE_TYPE 306 | 3l -> WRONG_METHOD_NAME 307 | 4l -> BAD_SEQUENCE_ID 308 | 5l -> MISSING_RESULT 309 | 6l -> INTERNAL_ERROR 310 | 7l -> PROTOCOL_ERROR 311 | 8l -> INVALID_TRANSFORM 312 | 9l -> INVALID_PROTOCOL 313 | 10l -> UNSUPPORTED_CLIENT_TYPE 314 | _ -> raise Thrift_error;; 315 let typ_to_i = function 316 | UNKNOWN -> 0l 317 | UNKNOWN_METHOD -> 1l 318 | INVALID_MESSAGE_TYPE -> 2l 319 | WRONG_METHOD_NAME -> 3l 320 | BAD_SEQUENCE_ID -> 4l 321 | MISSING_RESULT -> 5l 322 | INTERNAL_ERROR -> 6l 323 | PROTOCOL_ERROR -> 7l 324 | INVALID_TRANSFORM -> 8l 325 | INVALID_PROTOCOL -> 9l 326 | UNSUPPORTED_CLIENT_TYPE -> 10l 327 328 class t = 329 object (self) 330 inherit t_exn 331 val mutable typ = UNKNOWN 332 method get_type = typ 333 method set_type t = typ <- t 334 method write (oprot : Protocol.t) = 335 oprot#writeStructBegin "TApplicationExeception"; 336 if self#get_message != "" then 337 (oprot#writeFieldBegin ("message",Protocol.T_STRING, 1); 338 oprot#writeString self#get_message; 339 oprot#writeFieldEnd) 340 else (); 341 oprot#writeFieldBegin ("type",Protocol.T_I32,2); 342 oprot#writeI32 (typ_to_i typ); 343 oprot#writeFieldEnd; 344 oprot#writeFieldStop; 345 oprot#writeStructEnd 346 end;; 347 348 let create typ msg = 349 let e = new t in 350 e#set_type typ; 351 e#set_message msg; 352 e 353 354 let read (iprot : Protocol.t) = 355 let msg = ref "" in 356 let typ = ref 0l in 357 ignore iprot#readStructBegin; 358 (try 359 while true do 360 let (name,ft,id) =iprot#readFieldBegin in 361 if ft = Protocol.T_STOP 362 then raise Break 363 else (); 364 (match id with 365 | 1 -> (if ft = Protocol.T_STRING 366 then msg := (iprot#readString) 367 else iprot#skip ft) 368 | 2 -> (if ft = Protocol.T_I32 369 then typ := iprot#readI32 370 else iprot#skip ft) 371 | _ -> iprot#skip ft); 372 iprot#readFieldEnd 373 done 374 with Break -> ()); 375 iprot#readStructEnd; 376 let e = new t in 377 e#set_type (typ_of_i !typ); 378 e#set_message !msg; 379 e;; 380 381 exception E of t 382end;; 383
