diff options
Diffstat (limited to 'src/jaegertracing/thrift/lib/ocaml/src/Thrift.ml')
| -rw-r--r-- | src/jaegertracing/thrift/lib/ocaml/src/Thrift.ml | 382 |
1 files changed, 382 insertions, 0 deletions
diff --git a/src/jaegertracing/thrift/lib/ocaml/src/Thrift.ml b/src/jaegertracing/thrift/lib/ocaml/src/Thrift.ml new file mode 100644 index 000000000..063459ba0 --- /dev/null +++ b/src/jaegertracing/thrift/lib/ocaml/src/Thrift.ml @@ -0,0 +1,382 @@ +(* + Licensed to the Apache Software Foundation (ASF) under one + or more contributor license agreements. See the NOTICE file + distributed with this work for additional information + regarding copyright ownership. The ASF licenses this file + to you under the Apache License, Version 2.0 (the + "License"); you may not use this file except in compliance + with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, + software distributed under the License is distributed on an + "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY + KIND, either express or implied. See the License for the + specific language governing permissions and limitations + under the License. +*) + +exception Break;; +exception Thrift_error;; +exception Field_empty of string;; + +class t_exn = +object + val mutable message = "" + method get_message = message + method set_message s = message <- s +end;; + +module Transport = +struct + type exn_type = + | UNKNOWN + | NOT_OPEN + | ALREADY_OPEN + | TIMED_OUT + | END_OF_FILE;; + + exception E of exn_type * string + + class virtual t = + object (self) + method virtual isOpen : bool + method virtual opn : unit + method virtual close : unit + method virtual read : string -> int -> int -> int + method readAll buf off len = + let got = ref 0 in + let ret = ref 0 in + while !got < len do + ret := self#read buf (off+(!got)) (len - (!got)); + if !ret <= 0 then + raise (E (UNKNOWN, "Cannot read. Remote side has closed.")); + got := !got + !ret + done; + !got + method virtual write : string -> int -> int -> unit + method virtual flush : unit + end + + class factory = + object + method getTransport (t : t) = t + end + + class virtual server_t = + object (self) + method virtual listen : unit + method accept = self#acceptImpl + method virtual close : unit + method virtual acceptImpl : t + end + +end;; + + + +module Protocol = +struct + type t_type = + | T_STOP + | T_VOID + | T_BOOL + | T_BYTE + | T_I08 + | T_I16 + | T_I32 + | T_U64 + | T_I64 + | T_DOUBLE + | T_STRING + | T_UTF7 + | T_STRUCT + | T_MAP + | T_SET + | T_LIST + | T_UTF8 + | T_UTF16 + + let t_type_to_i = function + T_STOP -> 0 + | T_VOID -> 1 + | T_BOOL -> 2 + | T_BYTE -> 3 + | T_I08 -> 3 + | T_I16 -> 6 + | T_I32 -> 8 + | T_U64 -> 9 + | T_I64 -> 10 + | T_DOUBLE -> 4 + | T_STRING -> 11 + | T_UTF7 -> 11 + | T_STRUCT -> 12 + | T_MAP -> 13 + | T_SET -> 14 + | T_LIST -> 15 + | T_UTF8 -> 16 + | T_UTF16 -> 17 + + let t_type_of_i = function + 0 -> T_STOP + | 1 -> T_VOID + | 2 -> T_BOOL + | 3 -> T_BYTE + | 6-> T_I16 + | 8 -> T_I32 + | 9 -> T_U64 + | 10 -> T_I64 + | 4 -> T_DOUBLE + | 11 -> T_STRING + | 12 -> T_STRUCT + | 13 -> T_MAP + | 14 -> T_SET + | 15 -> T_LIST + | 16 -> T_UTF8 + | 17 -> T_UTF16 + | _ -> raise Thrift_error + + type message_type = + | CALL + | REPLY + | EXCEPTION + | ONEWAY + + let message_type_to_i = function + | CALL -> 1 + | REPLY -> 2 + | EXCEPTION -> 3 + | ONEWAY -> 4 + + let message_type_of_i = function + | 1 -> CALL + | 2 -> REPLY + | 3 -> EXCEPTION + | 4 -> ONEWAY + | _ -> raise Thrift_error + + class virtual t (trans: Transport.t) = + object (self) + val mutable trans_ = trans + method getTransport = trans_ + (* writing methods *) + method virtual writeMessageBegin : string * message_type * int -> unit + method virtual writeMessageEnd : unit + method virtual writeStructBegin : string -> unit + method virtual writeStructEnd : unit + method virtual writeFieldBegin : string * t_type * int -> unit + method virtual writeFieldEnd : unit + method virtual writeFieldStop : unit + method virtual writeMapBegin : t_type * t_type * int -> unit + method virtual writeMapEnd : unit + method virtual writeListBegin : t_type * int -> unit + method virtual writeListEnd : unit + method virtual writeSetBegin : t_type * int -> unit + method virtual writeSetEnd : unit + method virtual writeBool : bool -> unit + method virtual writeByte : int -> unit + method virtual writeI16 : int -> unit + method virtual writeI32 : Int32.t -> unit + method virtual writeI64 : Int64.t -> unit + method virtual writeDouble : float -> unit + method virtual writeString : string -> unit + method virtual writeBinary : string -> unit + (* reading methods *) + method virtual readMessageBegin : string * message_type * int + method virtual readMessageEnd : unit + method virtual readStructBegin : string + method virtual readStructEnd : unit + method virtual readFieldBegin : string * t_type * int + method virtual readFieldEnd : unit + method virtual readMapBegin : t_type * t_type * int + method virtual readMapEnd : unit + method virtual readListBegin : t_type * int + method virtual readListEnd : unit + method virtual readSetBegin : t_type * int + method virtual readSetEnd : unit + method virtual readBool : bool + method virtual readByte : int + method virtual readI16 : int + method virtual readI32: Int32.t + method virtual readI64 : Int64.t + method virtual readDouble : float + method virtual readString : string + method virtual readBinary : string + (* skippage *) + method skip typ = + match typ with + | T_BOOL -> ignore self#readBool + | T_BYTE + | T_I08 -> ignore self#readByte + | T_I16 -> ignore self#readI16 + | T_I32 -> ignore self#readI32 + | T_U64 + | T_I64 -> ignore self#readI64 + | T_DOUBLE -> ignore self#readDouble + | T_STRING -> ignore self#readString + | T_UTF7 -> () + | T_STRUCT -> ignore ((ignore self#readStructBegin); + (try + while true do + let (_,t,_) = self#readFieldBegin in + if t = T_STOP then + raise Break + else + (self#skip t; + self#readFieldEnd) + done + with Break -> ()); + self#readStructEnd) + | T_MAP -> ignore (let (k,v,s) = self#readMapBegin in + for i=0 to s do + self#skip k; + self#skip v; + done; + self#readMapEnd) + | T_SET -> ignore (let (t,s) = self#readSetBegin in + for i=0 to s do + self#skip t + done; + self#readSetEnd) + | T_LIST -> ignore (let (t,s) = self#readListBegin in + for i=0 to s do + self#skip t + done; + self#readListEnd) + | T_UTF8 -> () + | T_UTF16 -> () + | _ -> raise (Protocol.E (Protocol.INVALID_DATA, "Invalid data")) + end + + class virtual factory = + object + method virtual getProtocol : Transport.t -> t + end + + type exn_type = + | UNKNOWN + | INVALID_DATA + | NEGATIVE_SIZE + | SIZE_LIMIT + | BAD_VERSION + | NOT_IMPLEMENTED + | DEPTH_LIMIT + + exception E of exn_type * string;; + +end;; + + +module Processor = +struct + class virtual t = + object + method virtual process : Protocol.t -> Protocol.t -> bool + end;; + + class factory (processor : t) = + object + val processor_ = processor + method getProcessor (trans : Transport.t) = processor_ + end;; +end + + +(* Ugly *) +module Application_Exn = +struct + type typ= + | UNKNOWN + | UNKNOWN_METHOD + | INVALID_MESSAGE_TYPE + | WRONG_METHOD_NAME + | BAD_SEQUENCE_ID + | MISSING_RESULT + | INTERNAL_ERROR + | PROTOCOL_ERROR + | INVALID_TRANSFORM + | INVALID_PROTOCOL + | UNSUPPORTED_CLIENT_TYPE + + let typ_of_i = function + 0l -> UNKNOWN + | 1l -> UNKNOWN_METHOD + | 2l -> INVALID_MESSAGE_TYPE + | 3l -> WRONG_METHOD_NAME + | 4l -> BAD_SEQUENCE_ID + | 5l -> MISSING_RESULT + | 6l -> INTERNAL_ERROR + | 7l -> PROTOCOL_ERROR + | 8l -> INVALID_TRANSFORM + | 9l -> INVALID_PROTOCOL + | 10l -> UNSUPPORTED_CLIENT_TYPE + | _ -> raise Thrift_error;; + let typ_to_i = function + | UNKNOWN -> 0l + | UNKNOWN_METHOD -> 1l + | INVALID_MESSAGE_TYPE -> 2l + | WRONG_METHOD_NAME -> 3l + | BAD_SEQUENCE_ID -> 4l + | MISSING_RESULT -> 5l + | INTERNAL_ERROR -> 6l + | PROTOCOL_ERROR -> 7l + | INVALID_TRANSFORM -> 8l + | INVALID_PROTOCOL -> 9l + | UNSUPPORTED_CLIENT_TYPE -> 10l + + class t = + object (self) + inherit t_exn + val mutable typ = UNKNOWN + method get_type = typ + method set_type t = typ <- t + method write (oprot : Protocol.t) = + oprot#writeStructBegin "TApplicationExeception"; + if self#get_message != "" then + (oprot#writeFieldBegin ("message",Protocol.T_STRING, 1); + oprot#writeString self#get_message; + oprot#writeFieldEnd) + else (); + oprot#writeFieldBegin ("type",Protocol.T_I32,2); + oprot#writeI32 (typ_to_i typ); + oprot#writeFieldEnd; + oprot#writeFieldStop; + oprot#writeStructEnd + end;; + + let create typ msg = + let e = new t in + e#set_type typ; + e#set_message msg; + e + + let read (iprot : Protocol.t) = + let msg = ref "" in + let typ = ref 0l in + ignore iprot#readStructBegin; + (try + while true do + let (name,ft,id) =iprot#readFieldBegin in + if ft = Protocol.T_STOP + then raise Break + else (); + (match id with + | 1 -> (if ft = Protocol.T_STRING + then msg := (iprot#readString) + else iprot#skip ft) + | 2 -> (if ft = Protocol.T_I32 + then typ := iprot#readI32 + else iprot#skip ft) + | _ -> iprot#skip ft); + iprot#readFieldEnd + done + with Break -> ()); + iprot#readStructEnd; + let e = new t in + e#set_type (typ_of_i !typ); + e#set_message !msg; + e;; + + exception E of t +end;; |