| 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 |
| |
| let message_type_to_i = function |
| | CALL -> 1 |
| | REPLY -> 2 |
| | EXCEPTION -> 3 |
| |
| let message_type_of_i = function |
| | 1 -> CALL |
| | 2 -> REPLY |
| | 3 -> EXCEPTION |
| | _ -> 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 : int -> 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: int |
| 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_STOP -> () |
| | T_VOID -> () |
| | 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 -> () |
| end |
| |
| class virtual factory = |
| object |
| method virtual getProtocol : Transport.t -> t |
| end |
| |
| type exn_type = |
| | UNKNOWN |
| | INVALID_DATA |
| | NEGATIVE_SIZE |
| | SIZE_LIMIT |
| | BAD_VERSION |
| |
| 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 |
| |
| let typ_of_i = function |
| 0 -> UNKNOWN |
| | 1 -> UNKNOWN_METHOD |
| | 2 -> INVALID_MESSAGE_TYPE |
| | 3 -> WRONG_METHOD_NAME |
| | 4 -> BAD_SEQUENCE_ID |
| | 5 -> MISSING_RESULT |
| | _ -> raise Thrift_error;; |
| let typ_to_i = function |
| | UNKNOWN -> 0 |
| | UNKNOWN_METHOD -> 1 |
| | INVALID_MESSAGE_TYPE -> 2 |
| | WRONG_METHOD_NAME -> 3 |
| | BAD_SEQUENCE_ID -> 4 |
| | MISSING_RESULT -> 5 |
| |
| 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 0 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;; |