lib/ocaml/src/Thrift.ml

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;;

exception TExn of t_exn;;




module Transport =
struct
  type exn_type = 
      | UNKNOWN
      | NOT_OPEN
      | ALREADY_OPEN
      | TIMED_OUT
      | END_OF_FILE;;

  class exn =
  object
    inherit t_exn
    val mutable typ = UNKNOWN
      method get_type = typ
      method set_type t = typ <- t
  end
  exception TTransportExn of exn
  let raise_TTransportExn message typ =
    let e = new exn in
      e#set_message message;
      e#set_type typ;
      raise (TTransportExn e)

  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
            let e = new exn in
              e#set_message "Cannot read. Remote side has closed.";
              raise (TTransportExn e)
          else ();
          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
           
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



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
      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;;