(* $Id: nettelnet_client.ml 2195 2015-01-01 12:23:39Z gerd $
 * ----------------------------------------------------------------------
 *
 *)


(* NOTES:
 * - Every Unx or Unix system call wrapped with syscall
 *)


(* TODO:
 * - Sending Synch sequences could be done with higher priority. Currently,
 *   the output_buffer is first processed, then the synch_queue is copied
 *   to the output_buffer (and the output_queue is preempted for the moment).
 *   It is also possible to preempt the output_buffer, but this is much
 *   more complicated.
 *)

module Debug = struct
  let enable = ref false
end

let dlog = Netlog.Debug.mk_dlog "Nettelnet_client" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Nettelnet_client" Debug.enable

let () =
  Netlog.Debug.register_module "Nettelnet_client" Debug.enable


open Printf

exception Telnet_protocol of exn;;

let () =
  Netexn.register_printer
    (Telnet_protocol Not_found)
    (fun e ->
       match e with
	 | Telnet_protocol e' ->
	     "Telnet_client.Telnet_protocol(" ^ Netexn.to_string e' ^ ")"
	 | _ ->
	     assert false
    )


type telnet_command =
    Telnet_data of string
  | Telnet_nop
  | Telnet_dm           (* data mark *)
  | Telnet_brk          (* break *)
  | Telnet_ip           (* interrupt process *)
  | Telnet_ao           (* abort output *)
  | Telnet_ayt          (* are you there? *)
  | Telnet_ec           (* erase character *)
  | Telnet_el           (* erase line *)
  | Telnet_ga           (* Go ahead *)
  | Telnet_sb of char   (* Begin of subnegotiation *)
  | Telnet_se           (* End of subnegotation *)
  | Telnet_will of char (* Acknowledges that option is in effect *)
  | Telnet_wont of char (* Acknowledges that option is rejected *)
  | Telnet_do of char   (* Requests to turn on an option *)
  | Telnet_dont of char (* Requests to turn off an option *)
  | Telnet_unknown of char (* Unknown command *)
  | Telnet_eof          (* End of file *)
  | Telnet_timeout      (* Timeout event *)
;;


let prerr_command cmd =
  match cmd with
      Telnet_data s    -> dlog ("command: Data " ^ s)
    | Telnet_nop       -> dlog "command: NOP";
    | Telnet_dm        -> dlog "command: DM";
    | Telnet_brk       -> dlog "command: BRK";
    | Telnet_ip        -> dlog "command: IP";
    | Telnet_ao        -> dlog "command: AO";
    | Telnet_ayt       -> dlog "command: AYT";
    | Telnet_ec        -> dlog "command: EC";
    | Telnet_el        -> dlog "command: EL";
    | Telnet_ga        -> dlog "command: GA";
    | Telnet_sb c      -> dlog ("command: DB " ^ 
				  string_of_int(Char.code c));
    | Telnet_se        -> dlog "command: SE";
    | Telnet_will c    -> dlog ("command: WILL " ^
				  string_of_int(Char.code c));
    | Telnet_wont c    -> dlog ("command: WONT " ^
				  string_of_int(Char.code c));
    | Telnet_do c      -> dlog ("command: DO " ^
				  string_of_int(Char.code c));
    | Telnet_dont c    -> dlog ("command: DONT " ^
				  string_of_int(Char.code c));
    | Telnet_unknown c -> dlog ("command: unknown command " ^
				  string_of_int(Char.code c));
    | Telnet_eof       -> dlog "command: <eof>";
    | Telnet_timeout   -> dlog "command: <timeout>";
;;


type sockstate =
    Down
  | Up_rw 
  | Up_r
;;


type telnet_options =
    { connection_timeout : float;
      verbose_input : bool;
      verbose_output : bool;
    }
;;


type telnet_negotiated_option =
    Telnet_binary       (* see RFC 856 *)
  | Telnet_echo         (* see RFC 857 *)
  | Telnet_suppress_GA  (* see RFC 858 *)
  | Telnet_status       (* see RFC 859 *)
  | Telnet_timing_mark  (* see RFC 860 *)
  | Telnet_ext_opt_list (* see RFC 861 *)
  | Telnet_end_of_rec   (* see RFC 885 *)
  | Telnet_window_size  (* see RFC 1073 *)
  | Telnet_term_speed   (* see RFC 1079 *)
  | Telnet_term_type    (* see RFC 1091 *)
  | Telnet_X_display    (* see RFC 1096 *)
  | Telnet_linemode     (* see RFC 1184 *)
  | Telnet_flow_ctrl    (* see RFC 1372 *)
  | Telnet_auth         (* see RFC 1416 *)
  | Telnet_new_environ  (* see RFC 1572 and 1571 *)
  | Telnet_option of int   (* all other options *)
;;


type telnet_option_state =
    Not_negotiated
  | Accepted
  | Rejected
;;


let rec syscall f =  (* TODO: move to Aux *)
  (* Invoke system call, and handle EINTR *)
  try
    f()
  with
      Unix.Unix_error(Unix.EINTR,_,_) ->
	(* "interrupted system call": A signal happened while the system
	 * blocked.
	 * Simply restart the call.
	 *)
	syscall f
;;


let char_of_option p =
  match p with
    Telnet_binary       -> '\000'
  | Telnet_echo         -> '\001'
  | Telnet_suppress_GA  -> '\003'
  | Telnet_status       -> '\005'
  | Telnet_timing_mark  -> '\006'
  | Telnet_ext_opt_list -> '\255'
  | Telnet_end_of_rec   -> '\025'
  | Telnet_window_size  -> '\031'
  | Telnet_term_speed   -> '\032'
  | Telnet_term_type    -> '\024'
  | Telnet_X_display    -> '\035'
  | Telnet_linemode     -> '\034'
  | Telnet_flow_ctrl    -> '\033'
  | Telnet_auth         -> '\037'
  | Telnet_new_environ  -> '\039'
  | Telnet_option k     -> Char.chr k
;;


let option_of_char c =
  match c with
      '\000' -> Telnet_binary
    | '\001' -> Telnet_echo
    | '\003' -> Telnet_suppress_GA
    | '\005' -> Telnet_status
    | '\006' -> Telnet_timing_mark
    | '\255' -> Telnet_ext_opt_list
    | '\025' -> Telnet_end_of_rec
    | '\031' -> Telnet_window_size
    | '\032' -> Telnet_term_speed
    | '\024' -> Telnet_term_type
    | '\035' -> Telnet_X_display
    | '\034' -> Telnet_linemode
    | '\033' -> Telnet_flow_ctrl
    | '\037' -> Telnet_auth
    | '\039' -> Telnet_new_environ
    | k      -> Telnet_option (Char.code k)
;;


type telnet_connector =
    Telnet_connect of (string * int)
  | Telnet_socket of Unix.file_descr
;;


class telnet_session =
  object (self)
    val mutable connector = Telnet_connect("",0)

    val mutable esys = Unixqueue.create_unix_event_system()

    val mutable callback =
	    (fun _ -> () : bool -> unit)
	(* the argument indicates whether urgent processing has been requested
	 * or not.
	 *)

    val mutable output_queue = Queue.create()
    val mutable synch_queue = Queue.create()
    val mutable input_queue = Queue.create()

    val mutable output_buffer = Netbuffer.create 8192
    val mutable input_buffer = Netbuffer.create 8192
    val mutable primary_buffer = String.create 8192 
    val mutable send_eof = false
    val mutable sending_urgent_data = false

    val mutable group = None
    val mutable socket = Unix.stdin
    val mutable socket_state = Down
    val mutable socket_style = `Read_write
    val mutable connecting = None
    val mutable polling_wr = false
    val mutable force_rw = None
    val mutable input_timed_out = false
    val mutable output_timed_out = false

    val mutable tls_config = None

    val mutable options = 
	    { connection_timeout = 300.0;
	      verbose_input = false;
	      verbose_output = false;
	    }

    val mutable enabled_local_options = []
    val mutable offered_local_options = []
    val mutable state_local_options = []       
		(* does not contain options with state Not_negotiated *)

    val mutable enabled_remote_options = []
    val mutable requested_remote_options = []
    val mutable state_remote_options = []
		(* does not contain options with state Not_negotiated *)

    val mutable exn_handler = (fun _ -> ())


    initializer
      exn_handler <-
        (fun x ->
	   self # reset ();
	   match x with
	       Telnet_protocol x' ->
		 raise x          (* Never wrap twice *)
	     | _ ->
		 raise (Telnet_protocol x))


    method set_connection c =
      connector <- c
      

    method set_event_system new_ues =
      esys <- new_ues


    method set_callback cb =
      callback <- cb


    method set_exception_handler xh =
      exn_handler <- xh


    method output_queue = output_queue

    method input_queue = input_queue

    method get_options = options

    method set_options p = 
      options <- p

    method reset() =
      self # abort_connection;
      Queue.clear input_queue;
      Queue.clear output_queue;
      Queue.clear synch_queue;
      Netbuffer.clear input_buffer;
      Netbuffer.clear output_buffer;
      send_eof <- false;
      sending_urgent_data <- false;
      socket_state <- Down;
      socket_style <- `Read_write;
      connecting <- None;
      polling_wr <- false;
      force_rw <- None;
      input_timed_out <- false;
      output_timed_out <- false;
      tls_config <- None
      
                        

    method enable_local_option p =
      if not (List.mem p enabled_local_options) then
	enabled_local_options <- p :: enabled_local_options


    method disable_local_option p =
      if List.mem p enabled_local_options then
	enabled_local_options <- List.filter (fun p' -> p <> p) 
	                                     enabled_local_options;
      if self # get_local_option p = Accepted then
	Queue.add (Telnet_wont (char_of_option p)) output_queue;


    method offer_local_option p = 
      if not (List.mem p offered_local_options) &&
	self # get_local_option p <> Accepted  then begin
	offered_local_options <- p :: offered_local_options;
	Queue.add (Telnet_will (char_of_option p)) output_queue
      end


    method enable_remote_option p =
      if not (List.mem p enabled_remote_options) then
	enabled_remote_options <- p :: enabled_remote_options


    method disable_remote_option p =
      if List.mem p enabled_remote_options then
	enabled_remote_options <- List.filter (fun p' -> p <> p) 
	                                       enabled_remote_options;
      if self # get_remote_option p = Accepted then
	Queue.add (Telnet_dont (char_of_option p)) output_queue;


    method request_remote_option p = 
      if not (List.mem p requested_remote_options) &&
	 self # get_remote_option p <> Accepted then begin
	requested_remote_options <- p ::requested_remote_options;
	Queue.add (Telnet_do (char_of_option p)) output_queue
      end


    method reset_local_option p =
      state_local_options <- List.filter 
	                       (fun (p',_) -> p <> p') 
	                       state_local_options


    method reset_remote_option p =
      state_remote_options <- List.filter 
	                       (fun (p',_) -> p <> p') 
	                       state_remote_options


    method get_local_option p =
      try
	List.assoc p state_local_options
      with Not_found -> Not_negotiated


    method get_remote_option p =
      try
	List.assoc p state_remote_options
      with Not_found -> Not_negotiated


    method option_negotiation_is_over =
      offered_local_options = [] && requested_remote_options = []


    method process_option_command cmd =
      match cmd with
	  Telnet_will c ->
	    (* If we previously requested the option, it is now in effect. *)
	    let p = option_of_char c in
	    let new_state =
	      if List.mem p requested_remote_options then begin
		requested_remote_options <- List.filter
		                              (fun p' -> p <> p')
		                              requested_remote_options;
		Accepted
	      end
	      else begin
		(* Otherwise accept the option if enabled, and reject if
		 * disabled.
		 *)
		if List.mem p enabled_remote_options then begin
		  Queue.add (Telnet_do c) output_queue;
		  Accepted
		end
		else begin
		  Queue.add (Telnet_dont c) output_queue;
		  Rejected
		end
	      end
	    in
	    state_remote_options <- (p, new_state) ::
	                            List.filter
		                      (fun (p',_) -> p <> p')
		                      state_remote_options;
	| Telnet_wont c ->
	    (* The option is rejected *)
	    let p = option_of_char c in
	    state_remote_options <- (p, Rejected) ::
	                            List.filter
		                      (fun (p',_) -> p <> p')
		                      state_remote_options;
	    requested_remote_options <- List.filter
		                          (fun p' -> p <> p')
		                          requested_remote_options;
	| Telnet_do c ->
	    (* If we previously offered the option, it is now in effect. *)
	    let p = option_of_char c in
	    let new_state =
	      if List.mem p offered_local_options then begin
		offered_local_options <- List.filter
		                           (fun p' -> p <> p')
		                           offered_local_options;
		Accepted
	      end
	      else begin
		(* Otherwise accept the option if enabled, and reject if
		 * disabled.
		 *)
		if List.mem p enabled_local_options then begin
		  Queue.add (Telnet_will c) output_queue;
		  Accepted
		end
		else begin
		  Queue.add (Telnet_wont c) output_queue;
		  Rejected
		end
	      end
	    in
	    state_local_options <- (p, new_state) ::
	                           List.filter
		                     (fun (p',_) -> p <> p')
		                     state_local_options;
	| Telnet_dont c ->
	    (* The option is rejected *)
	    let p = option_of_char c in
	    state_local_options <- (p, Rejected) ::
	                            List.filter
		                      (fun (p',_) -> p <> p')
		                      state_local_options;
	    offered_local_options <- List.filter
		                       (fun p' -> p <> p')
		                       offered_local_options;
	| _ ->
	    ()


    method fetch_subnegotiation =
      if Queue.length input_queue >= 1 then begin
	let para = ref "" in
	let n = ref 0 in
	let ended = ref false in
	begin 
	  try
	    Queue.iter
	      (function 
		   Telnet_data s ->
		     incr n;
		     para := !para ^ s
		 | Telnet_se ->
		     incr n;
		     ended := true;
		     raise Not_found   (* Exit 'iter' *)
		 | _ ->
		     raise Not_found)  (* Exit 'iter' *)
	      input_queue;
		with
		    Not_found -> ()
	end;
	if !ended then begin
	  (* Discard the first n elements of the queue *)
	  for i = 1 to !n do
	    ignore(Queue.take input_queue)
	  done;
	  Some !para
	end
	else None
      end
      else None


    method attach() =
      if group <> None then
	failwith "Telnet_client: already attached";

      let g = Unixqueue.new_group esys in

      let g1 = Unixqueue.new_group esys in  (* group for deferred 'connect' *)
      Unixqueue.once 
	esys
	g1
	0.0
	(fun () -> 
	   self # connect_server
	     (fun () ->
		dlog "Telnet connection: Connected!";
		(* 'group' must not be set earlier, because it is used as
	         * indicator whether a connection is established or not.
		 *)
		group <- Some g;
		let timeout_value = options.connection_timeout in
		Unixqueue.add_resource esys g (Unixqueue.Wait_in socket, 
					       timeout_value);
		Unixqueue.add_handler esys g (self # handler);
		polling_wr <- false;
		self # maintain_polling
	     )
	     (fun err ->
		dlog "Telnet connection: Connection error!";
		exn_handler err
	     )
	)


    method run() = 
      Unixqueue.run esys


    method update() =
      if group <> None then
	self # maintain_polling;


    method send_synch cmds =
      List.iter
	(fun cmd ->
	   Queue.add cmd synch_queue)
	cmds;
      Queue.add Telnet_dm synch_queue;
      self # update()


    method expect_input flag =
      match group with
	| None ->
	    failwith "Nettelnet_client: not attached"
	| Some g ->
	    Unixqueue.remove_resource esys g (Unixqueue.Wait_in socket);
	    let timeout_value =
	      if flag then 
		options.connection_timeout
	      else
		(-1.0) in
	    Unixqueue.add_resource esys g (Unixqueue.Wait_in socket, 
					   timeout_value)
	    

    method start_tls config ~peer_name =
      tls_config <- Some(config,peer_name);
      force_rw <- Some `W;
      self # enable_tls()

    method private connect_server f_ok f_err =

      begin match connector with
	| Telnet_connect(hostname, port) ->
	    dlog ("Telnet connection: Connecting to server " ^ 
		    hostname);

	    let g1 = Unixqueue.new_group esys in

	    let eng =
	      Uq_client.connect_e
		(`Socket(`Sock_inet_byname(Unix.SOCK_STREAM,
					   hostname,
					   port),
			 Uq_client.default_connect_options))
		esys in
	    
	    connecting <- Some eng;

	    Uq_engines.when_state
	      ~is_done:(function
			  | `Socket(s,_) ->
			      Unixqueue.clear esys g1;
			      socket <- s;
                              socket_style <- Netsys.get_fd_style s;
			      connecting <- None;
			      syscall
				(fun () -> 
				   Unix.setsockopt s Unix.SO_OOBINLINE true);
			      Netlog.Debug.track_fd
				~owner:"Nettelnet_client"
				~descr:("connection to " ^ 
					  hostname ^  ":" ^ string_of_int port)
				s;
                              self # enable_tls();
			      f_ok()
			  | _ -> assert false
		       )
	      ~is_error:(function
			   | err ->
			       Unixqueue.clear esys g1;
			       connecting <- None;
			       f_err err
			)
	      ~is_aborted:(fun () -> 
			     Unixqueue.clear esys g1;
			     connecting <- None
			  )
	      eng;
	    let timeout_value = options.connection_timeout in
	    Unixqueue.once esys g1 timeout_value eng#abort

	| Telnet_socket s ->
	    connecting <- None;
	    syscall(fun () -> Unix.setsockopt s Unix.SO_OOBINLINE true);
	    socket <- s;
            socket_style <- Netsys.get_fd_style s;
	    Netlog.Debug.track_fd
	      ~owner:"Nettelnet_client"
	      ~descr:("connection to " ^ 
			try Netsys.string_of_sockaddr(Netsys.getpeername s)
			with _ -> "(noaddr)")
	      s;
	    dlog "Telnet connection: Got connected socket";
            self # enable_tls();
	    let g1 = Unixqueue.new_group esys in
	    Unixqueue.once esys g1 0.0 f_ok
      end;
      
      socket_state <- Up_rw;
      Netbuffer.clear input_buffer;
      Netbuffer.clear output_buffer;
      Queue.clear input_queue;
      send_eof <- false;
      sending_urgent_data <- false;
      input_timed_out <- false;
      output_timed_out <- false;


    method private enable_tls () =
      match tls_config with
        | None -> ()
        | Some (config, peer_name) ->
             dlog "Telnet connection: enabling TLS";
             let ep =
               Netsys_tls.create_file_endpoint
                 ~role:`Client
                 ~rd:socket
                 ~wr:socket
                 ~peer_name
                 config in
             socket_style <- `TLS ep;
             force_rw <- Some `W


    method private shutdown =
      dlog "Telnet connection: Shutdown!";
      begin match socket_state with
	  Down -> ()
	| (Up_rw | Up_r) -> 
	    dlog "Telnet connection: Closing socket!";
	    Netlog.Debug.release_fd socket;
	    try
	      syscall (fun () -> Unix.close socket)
	    with
		_ -> ()           (* ignore failed 'close' *)
      end;
      socket_state <- Down;
      match group with
	  Some g -> 
	    Unixqueue.clear esys g;
	    group <- None;
	| None ->  ()


    method private abort_connection =
      ( match connecting with
	  | None -> ()
	  | Some eng -> eng#abort()
      );
      match group with
	  Some g -> 
	    Unixqueue.remove_resource esys g (Unixqueue.Wait_in socket);
	    if polling_wr then begin
	      Unixqueue.remove_resource esys g (Unixqueue.Wait_out socket);
	      polling_wr <- false;
	    end;
	    self # shutdown;
	    assert (group = None);
        | None -> 
	    ()


    method private maintain_polling =

      (* If one of the following conditions is true, we need not to poll
       * the write side of the socket:
       * - The write_queue is empty and the synch_queue is empty
       *)

      let timeout_value = options.connection_timeout in

      let need_wr =
        force_rw=Some `W ||
        (force_rw=None &&
           (send_eof ||
              Queue.length output_queue > 0 || 
                Queue.length synch_queue > 0 ||
                  Netbuffer.length output_buffer > 0)) in
      
      dlogr
        (fun () ->
           sprintf "Telnet connection: maintain_polling \
                    force_rw=%s send_eof=%B output_queue=%d synch_queue=%d \
                    output_buffer=%d"
                   (match force_rw with
                      | None -> "none"
                      | Some `W -> "w"
                      | Some `R -> "r"
                   )
                   send_eof (Queue.length output_queue)
                   (Queue.length synch_queue)
                   (Netbuffer.length output_buffer)
        );

      if not need_wr then begin
	if polling_wr then begin
	  let g = match group with
	      Some x -> x
	    | None -> assert false
	  in
(*  prerr_endline "REMOVE";   *)
	  Unixqueue.remove_resource esys g (Unixqueue.Wait_out socket);
	end;
	polling_wr <- false
      end;

      (* On the other hand, all of the following conditions must be true
       * to enable polling again:
       * - The write_queue is not empty or the synch_queue is not empty
       *)

      if need_wr then begin
	if not polling_wr then begin
	  let g = match group with
	      Some x -> x
	    | None -> assert false
	  in
(*  prerr_endline "ADD";    *)
	  Unixqueue.add_resource esys g (Unixqueue.Wait_out socket, 
					 timeout_value
					);
	end;
	polling_wr <- true;
      end;


    method private handler  _ _ ev =
      let g = match group with
	  Some x -> x
	| None -> 
	    (* This is possible while shutting down the socket *)
	    raise Equeue.Reject
      in
      match ev with
	| Unixqueue.Input_arrived (g0,fd0) ->
	    if g0 = g then 
	      try self # handle_input with 
		  Unix.Unix_error(_,_,_) as x -> exn_handler x
	    else raise Equeue.Reject
	| Unixqueue.Output_readiness (g0,fd0) ->
	    if g0 = g then 
	      try self # handle_output with 
		  Unix.Unix_error(_,_,_) as x -> exn_handler x
	    else raise Equeue.Reject
	| Unixqueue.Timeout (g0, op) ->
	    if g0 = g then 
	      try self # handle_timeout op with 
		  Unix.Unix_error(_,_,_) as x -> exn_handler x
	    else raise Equeue.Reject
	| _ ->
	    raise Equeue.Reject

    method tls_session_props =
      match socket_style with
        | `TLS ep ->
             let ep = Nettls_support.squash_file_tls_endpoint ep in
             Some(Nettls_support.get_tls_session_props ep)
        | _ ->
             None

    method tls_session_data =
      match socket_style with
        | `TLS ep ->
             let module EP = (val ep : Netsys_crypto_types.FILE_TLS_ENDPOINT) in
             Some(EP.TLS.get_session_data EP.endpoint)
        | _ ->
             None


    (**********************************************************************)
    (***                    THE TIMEOUT HANDLER                         ***)
    (**********************************************************************)

    method private handle_timeout op =
      begin match op with
	  Unixqueue.Wait_in _  -> input_timed_out  <- true
	| Unixqueue.Wait_out _ -> output_timed_out <- true
	| _ -> ()
      end;

      if input_timed_out && output_timed_out then begin
	(* No network packet arrived for a period of time.
	 * May happen while connecting to a server, or during operation.
	 *)
	if socket_state = Down then
	  raise Equeue.Reject;
	
	Queue.add Telnet_timeout input_queue;
	
	dlog "Telnet connection: Timeout event!";
	
	self # abort_connection;
	
        (* Invoke the callback function: *)

	callback false;
      end


    (**********************************************************************)
    (***                     THE INPUT HANDLER                          ***)
    (**********************************************************************)

    method private handle_input =
      (* Data have arrived on the 'socket'. First we receive as much as we
       * can; then the data are interpreted as sequence of messages.
       *)
      
      (* Ignore this event if the socket is Down (this may happen
       * if the input side is closed while there are still input
       * events in the queue):
       *)
      if socket_state = Down then
	raise Equeue.Reject;

      input_timed_out <- false;
      force_rw <- None;

      dlog "Telnet connection: Input event!";

      let _g = match group with
	  Some x -> x
	| None -> assert false
      in
      
      (* Read data into the primary_buffer *)

      let n, eof =
	syscall
	  (fun () ->
	     try
	       let n =
		 Netsys.gread 
		   socket_style socket 
                   primary_buffer 0 (String.length primary_buffer) in
	       (n, n=0)
	     with
	       | Unix.Unix_error(Unix.EAGAIN,_,_)
	       | Unix.Unix_error(Unix.EINTR,_,_)
               | Netsys_types.EAGAIN_RD -> 
		   (0, false)
               | Netsys_types.EAGAIN_WR ->
                   dlog "Telnet connection: EAGAIN_WR";
                   force_rw <- Some `W;
                   (0, false)
	  ) in

      Netbuffer.add_sub_string input_buffer primary_buffer 0 n;

      (* Interpret the octet stream in 'input_buffer' as sequence of
       * commands
       *)
      
      let length = Netbuffer.length input_buffer in
      let buffer = Netbuffer.unsafe_buffer input_buffer in

      let is_urgent = ref false in

      let finish pos =
	Netbuffer.delete input_buffer 0 pos
      in

      let clear_data_path() =
	(* remove any non-urgent data *)
	let new_queue = Queue.create() in
	let within_sb = ref false in
	Queue.iter
	  (fun cmd ->
	     match cmd with
		(Telnet_nop | Telnet_dm | Telnet_brk | Telnet_ip | Telnet_ao |
		 Telnet_ayt | Telnet_ga | 
		 Telnet_will _ | Telnet_wont _ | Telnet_do _ |
		 Telnet_dont _ | Telnet_unknown _ | Telnet_eof | Telnet_timeout)
		 ->
		   Queue.add cmd new_queue
	       | Telnet_sb c ->
		   Queue.add cmd new_queue;
		   within_sb := true
	       | Telnet_se ->
		   Queue.add cmd new_queue;
		   within_sb := false
	       | _ -> 
		   if !within_sb then Queue.add cmd new_queue;
	  )
	  input_queue;
	input_queue <- new_queue
      in
      
      let rec interpret pos =
	if pos >= length then
	  finish length
	else
	  match buffer.[pos] with
	      '\255' -> 
		(* IAC character *)
		if pos+1 < length then begin
		  match buffer.[pos+1] with
		    | '\240' -> Queue.add Telnet_se input_queue;
			        interpret(pos+2);
		    | '\241' -> Queue.add Telnet_nop input_queue;
			        interpret(pos+2)
		    | '\242' -> clear_data_path();
			        Queue.add Telnet_dm input_queue;
				is_urgent := true;
			        interpret(pos+2)
		    | '\243' -> Queue.add Telnet_brk input_queue;
			        interpret(pos+2)
		    | '\244' -> Queue.add Telnet_ip input_queue;
			        interpret(pos+2)
		    | '\245' -> Queue.add Telnet_ao input_queue;
			        interpret(pos+2)
		    | '\246' -> Queue.add Telnet_ayt input_queue;
			        interpret(pos+2)
		    | '\247' -> Queue.add Telnet_ec input_queue;
			        interpret(pos+2)
      		    | '\248' -> Queue.add Telnet_el input_queue;
			        interpret(pos+2)
		    | '\249' -> Queue.add Telnet_ga input_queue;
			        interpret(pos+2)
		    | '\255' -> Queue.add (Telnet_data(String.make 1 '\255'))
			                  input_queue;
			        interpret(pos+2)
		    | ('\250'..'\254') ->
			if pos+2 < length then begin
			  let option = buffer.[pos+2] in
			  match buffer.[pos+1] with
			    | '\250' -> Queue.add (Telnet_sb option) 
				                  input_queue;
				        interpret(pos+3);
			    | '\251' -> Queue.add (Telnet_will option) 
				                  input_queue;
				        interpret(pos+3);
			    | '\252' -> Queue.add (Telnet_wont option) 
				                  input_queue;
				        interpret(pos+3);
			    | '\253' -> Queue.add (Telnet_do option) 
				                  input_queue;
				        interpret(pos+3);
			    | '\254' -> Queue.add (Telnet_dont option) 
				                  input_queue;
				        interpret(pos+3);
			    | _ -> assert false
			end
			else finish pos
		    | _ -> Queue.add (Telnet_unknown(buffer.[pos+1]))
			             input_queue;
			   interpret(pos+2);
		end
		else finish pos
	    | c ->
		begin try 
		  let pos' = Netbuffer.index_from input_buffer pos '\255' in
		  Queue.add 
		    (Telnet_data(Netbuffer.sub input_buffer pos (pos'-pos)))
		    input_queue;
		  interpret pos'
		with
		    Not_found ->
		      Queue.add 
			(Telnet_data
			   (Netbuffer.sub input_buffer pos (length-pos)))
			input_queue;
		      finish length
		end
      in

      if eof then begin
	dlog "got EOF";
	Queue.add Telnet_eof input_queue;
	self # abort_connection;
      end
      else
	interpret 0;

      if !Debug.enable && options.verbose_input then begin
	dlog "Telnet input queue:";
	Queue.iter prerr_command input_queue;
	dlog "<end of queue>";
      end;


      (* TODO: Find out whether urgent data arrived, and remove all non-
       * commands from the queue.
       *)

      (* Invoke the callback function: *)

      callback !is_urgent;

      (* Now there may be new elements on the write queue. *)

      self # maintain_polling;


    (**********************************************************************)
    (***                     THE OUTPUT HANDLER                         ***)
    (**********************************************************************)

    method private handle_output =

      (* Ignore this event if the socket is not Up_rw (this may happen
       * if the output side is closed while there are still output
       * events in the queue):
       *)
      if socket_state <> Up_rw then
	raise Equeue.Reject;

      output_timed_out <- false;
      force_rw <- None;

      dlog "Telnet connection: Output event!";

      let _g = match group with
	  Some x -> x
	| None -> assert false
      in

      (* If the write buffer is empty, copy new commands from the write
       * queue to the write buffer.
       *)

      let rec copy_string s pos =
	try
	  let pos' = String.index_from s pos '\255' in
	  Netbuffer.add_string output_buffer (String.sub s pos (pos'-pos));
	  Netbuffer.add_string output_buffer "\255\255";
	  copy_string s (pos'+1)
	with
	    Not_found ->
	      if pos = 0 then
		Netbuffer.add_string output_buffer s
	      else
		let l = String.length s in
		Netbuffer.add_sub_string output_buffer s pos (l-pos)
      in

      let q = 
	if Queue.length synch_queue > 0 then	  
	  synch_queue
	else
	  output_queue in

      let rec copy () =
	match Queue.take q with
	    Telnet_data s ->
	      copy_string s 0;
	      copy()
	  | Telnet_nop ->
	      Netbuffer.add_string output_buffer "\255\241";
	      copy();
	  | Telnet_dm ->
	      Netbuffer.add_string output_buffer "\255\242";
	      copy();
	  | Telnet_brk ->
	      Netbuffer.add_string output_buffer "\255\243";
	      copy();
	  | Telnet_ip ->
	      Netbuffer.add_string output_buffer "\255\244";
	      copy();
	  | Telnet_ao ->
	      Netbuffer.add_string output_buffer "\255\245";
	      copy();
	  | Telnet_ayt ->
	      Netbuffer.add_string output_buffer "\255\246";
	      copy();
	  | Telnet_ec ->
	      Netbuffer.add_string output_buffer "\255\247";
	      copy();
	  | Telnet_el ->
	      Netbuffer.add_string output_buffer "\255\248";
	      copy();
	  | Telnet_ga ->
	      Netbuffer.add_string output_buffer "\255\249";
	      copy();
	  | Telnet_sb c ->
	      Netbuffer.add_string output_buffer "\255\250";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_se ->
	      Netbuffer.add_string output_buffer "\255\240";
	      copy();
	  | Telnet_will c ->
	      Netbuffer.add_string output_buffer "\255\251";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_wont c ->
	      Netbuffer.add_string output_buffer "\255\252";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_do c ->
	      Netbuffer.add_string output_buffer "\255\253";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_dont c ->
	      Netbuffer.add_string output_buffer "\255\254";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_unknown c ->
	      Netbuffer.add_string output_buffer "\255";
	      Netbuffer.add_string output_buffer (String.make 1 c);
	      copy();
	  | Telnet_eof ->
	      send_eof <- true;
	      Queue.clear output_queue;
	      Queue.clear synch_queue;
	  | Telnet_timeout ->
	      copy()
      in

      if Netbuffer.length output_buffer = 0 then begin

	if q == synch_queue then begin
	  sending_urgent_data <- true;
	  dlog "Sending urgent data";
	end
	else
	  sending_urgent_data <- false;

	if !Debug.enable && options.verbose_output then begin
	  dlog "Telnet output queue:";
	  Queue.iter prerr_command output_queue;
	  dlog "<end of queue>";
	end;

	try copy() with Queue.Empty -> ()
      end;

      let l = Netbuffer.length output_buffer in
      if l > 0 then begin
	let flags =
	  if sending_urgent_data then [ Unix.MSG_OOB ] else [] in
	let k = 
	  syscall
	    (fun () ->
	       try
                 match socket_style with
                   | `TLS _ ->  (* no support for [flags] *)
		        Netsys.gwrite
		          socket_style socket 
                          (Netbuffer.unsafe_buffer output_buffer) 0 l
                        
                   | _ ->
		        Unix.send
		          socket 
                          (Netbuffer.unsafe_buffer output_buffer) 0 l flags
	       with
		 | Unix.Unix_error(Unix.EAGAIN,_,_)
                 | Unix.Unix_error(Unix.EINTR,_,_)
                 | Netsys_types.EAGAIN_WR -> 0
                 | Netsys_types.EAGAIN_RD ->
                      force_rw <- Some `R; 0
	    ) in
	Netbuffer.delete output_buffer 0 k;
      end;

      if Netbuffer.length output_buffer = 0 && send_eof then begin
        try
          Netsys.gshutdown socket_style socket Unix.SHUTDOWN_SEND;
	  dlog "Telnet connection: Sending EOF";
          send_eof <- false;
          socket_state <- Up_r;
        with
	  | Unix.Unix_error(Unix.EAGAIN,_,_)
          | Unix.Unix_error(Unix.EINTR,_,_)
          | Netsys_types.EAGAIN_RD
          | Netsys_types.EAGAIN_WR -> ()
      end;

      self # maintain_polling;
  end
;;

let () =
  Netsys_signal.init()
