(* Lightweight thread library for Objective Caml
* http://www.ocsigen.org/lwt
* Program Connect
* Copyright (C) 2011 Jérémie Dimino
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as
* published by the Free Software Foundation, with linking exceptions;
* either version 2.1 of the License, or (at your option) any later
* version. See COPYING file for details.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA.
*)
(* A simple graphical telnet. *)
open Lwt
(* +-----------------------------------------------------------------+
| Utils |
+-----------------------------------------------------------------+ *)
let show_error fmt =
Printf.ksprintf
(fun message ->
let dialog = GWindow.message_dialog ~message_type:`ERROR ~buttons:GWindow.Buttons.ok ~message () in
ignore (dialog#connect#response (function
| `DELETE_EVENT -> ()
| `OK -> dialog#destroy ()));
dialog#show ())
fmt
(* +-----------------------------------------------------------------+
| Connection |
+-----------------------------------------------------------------+ *)
(* Either [None] if we are not connected, either [Some (ic, oc,
thread)] if we are connected. In this last case [thread] is the
thread reading data from the connection. *)
let connection = ref None
(* Read continously data from [ic] and write them to [view]. *)
let read ic (view : GText.view) =
let rec loop () =
match_lwt Lwt_io.read_line_opt ic with
| Some line ->
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["recv"] (line ^ "\n");
loop ()
| None ->
view#buffer#insert ~iter:view#buffer#end_iter "end of connection\n";
Lwt_io.close ic
in
try_lwt
loop ()
with Unix.Unix_error (error, _, _) ->
show_error "reading error: %s" (Unix.error_message error);
return ()
(* Function called when the user active the [connect] menu
item. [view] is the text view used to display data received from
the connection. *)
let connect (view : GText.view) =
(* Create a popup for asking the address and port to connect to. *)
let dialog = GWindow.dialog ~title:"connection" () in
dialog#add_button_stock `OK `OK;
dialog#add_button_stock `CANCEL `CANCEL;
let hbox = GPack.hbox ~packing:dialog#vbox#add () in
ignore (GMisc.label ~packing:hbox#add ~text:"host: " ());
let host = GEdit.entry ~packing:hbox#add ~text:"127.0.0.1" () in
ignore (GMisc.label ~packing:hbox#add ~text:" port: " ());
let port = GEdit.spin_button ~digits:0 ~numeric:true ~packing:hbox#add () in
port#adjustment#set_bounds ~lower:0. ~upper:(float max_int) ~step_incr:1. ();
(* Thread waiting for the popup to be closed. *)
let waiter, wakener = wait () in
(* Wakeup the thread when the popup is closed. *)
ignore (dialog#connect#response (wakeup wakener));
dialog#show ();
ignore (
match_lwt waiter with
| `DELETE_EVENT ->
return ()
| `CANCEL ->
dialog#destroy ();
return ()
| `OK ->
let host = host#text and port = int_of_float port#value in
dialog#destroy ();
try_lwt
(* Resolve the address. *)
lwt entry = Lwt_unix.gethostbyname host in
if Array.length entry.Unix.h_addr_list = 0 then begin
show_error "no address found for host %S" host;
return ()
end else begin
lwt ic, oc = Lwt_io.open_connection (Unix.ADDR_INET (entry.Unix.h_addr_list.(0), port)) in
(* Close the previous connection. *)
lwt () =
match !connection with
| None ->
return ()
| Some (ic, oc, thread) ->
cancel thread;
try_lwt
Lwt_io.close ic <&> Lwt_io.close oc
with Unix.Unix_error (error, _, _) ->
show_error "cannot close the connection: %s" (Unix.error_message error);
return ()
in
(* Clear the buffer. *)
view#buffer#delete view#buffer#start_iter view#buffer#end_iter;
connection := Some (ic, oc, read ic view);
return ()
end
with
| Unix.Unix_error (error, _, _) ->
show_error "cannot establish the connection: %s" (Unix.error_message error);
return ()
| Not_found ->
show_error "host %S not found" host;
return ()
)
(* Send some data. *)
let write (view : GText.view) (entry : GEdit.entry) =
let text = entry#text in
entry#set_text "";
match !connection with
| Some (ic, oc, thread) ->
view#buffer#insert ~iter:view#buffer#end_iter ~tag_names:["send"] (text ^ "\n");
ignore (
try_lwt
Lwt_io.write_line oc text
with Unix.Unix_error (error, _, _) ->
show_error "cannot send line: %s" (Unix.error_message error);
return ()
)
| None ->
show_error "not connected"
(* +-----------------------------------------------------------------+
| Entry point |
+-----------------------------------------------------------------+ *)
lwt () =
(* Initializes GTK. *)
ignore (GMain.init ~setlocale:false ());
(* Integrate Lwt with Glib. *)
Lwt_glib.install ();
(* Create the UI. *)
let window = GWindow.window ~title:"simple graphical telnet in OCaml with Lwt" ~allow_shrink:true ~width:640 ~height:480 () in
let vbox = GPack.vbox ~packing:window#add () in
(* Create the menu. *)
let menu = GMenu.menu_bar ~packing:(vbox#pack ~expand:false) () in
let menu_file = GMenu.menu ~packing:(GMenu.menu_item ~label:"File" ~packing:menu#add ())#set_submenu () in
let menu_connect = GMenu.image_menu_item ~label:"Connect" ~packing:menu_file#add ~stock:`CONNECT () in
ignore (GMenu.separator_item ~packing:menu_file#add ());
let menu_quit = GMenu.image_menu_item ~label:"Quit" ~packing:menu_file#add ~stock:`QUIT () in
(* The text view displaying inputs and outputs. *)
let view =
GText.view
~editable:false
~packing:(GBin.scrolled_window
~hpolicy:`AUTOMATIC
~vpolicy:`AUTOMATIC
~packing:(GBin.frame
~label:"log"
~packing:vbox#add
())#add
())#add
()
in
ignore (view#buffer#create_tag ~name:"send" [`FOREGROUND "blue"]);
ignore (view#buffer#create_tag ~name:"recv" [`FOREGROUND "#007f00"]);
let hbox = GPack.hbox ~packing:(GBin.frame ~label:"input" ~packing:(vbox#pack ~expand:false) ())#add () in
(* The entry for user input. *)
let entry = GEdit.entry ~packing:hbox#add () in
let send = GButton.button ~label:"send" ~packing:(hbox#pack ~expand:false) () in
(* Try to use a monospace font. *)
(try
view#misc#modify_font_by_name "Monospace";
entry#misc#modify_font_by_name "Monospace"
with _ ->
());
(* Thread waiting for the main window to be closed. *)
let waiter, wakener = wait () in
(* Setup callbacks. *)
ignore (window#connect#destroy (wakeup wakener));
ignore (menu_quit#connect#activate (wakeup wakener));
ignore (menu_connect#connect#activate (fun () -> connect view));
ignore (entry#connect#activate (fun () -> write view entry));
ignore (send#connect#clicked (fun () -> write view entry));
window#show ();
(* Wait for the main window to be closed. *)
waiter
