219 lines
8.2 KiB
OCaml
219 lines
8.2 KiB
OCaml
(* 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
|