(* Unison file synchronizer: src/linkgtk2.ml *)

(* Copyright 1999-2020, Benjamin C. Pierce

    This program is free software: you can redistribute it and/or modify

    it under the terms of the GNU General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    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 General Public License for more details.

    You should have received a copy of the GNU General Public License

    along with this program.  If not, see <http://www.gnu.org/licenses/>.

*)

module TopLevel = Main.Body(Uigtk2.Body)

(* Unison file synchronizer: src/uigtk2.ml *)

(* Copyright 1999-2020, Benjamin C. Pierce

    This program is free software: you can redistribute it and/or modify

    it under the terms of the GNU General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    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 General Public License for more details.

    You should have received a copy of the GNU General Public License

    along with this program.  If not, see <http://www.gnu.org/licenses/>.

*)

open Common

open Lwt

module Private = struct

let debug = Trace.debug "ui"

let myNameCapitalized = String.capitalize_ascii Uutil.myName

(**********************************************************************

                           LOW-LEVEL STUFF

 **********************************************************************)

(**********************************************************************

 Some message strings (build them here because they look ugly in the

 middle of other code.

 **********************************************************************)

let tryAgainMessage =

  Printf.sprintf

"You can use %s to synchronize a local directory with another local directory,

or with a remote directory.

Please enter the first (local) directory that you want to synchronize."

myNameCapitalized

(* ---- *)

let helpmessage = Printf.sprintf

"%s can synchronize a local directory with another local directory, or with

a directory on a remote machine.

To synchronize with a local directory, just enter the file name.

To synchronize with a remote directory, you must first choose a protocol

that %s will use to connect to the remote machine.  Each protocol has

different requirements:

1) To synchronize using SSH, there must be an SSH client installed on

this machine and an SSH server installed on the remote machine.  You

must enter the host to connect to, a user name (if different from

your user name on this machine), and the directory on the remote machine

(relative to your home directory on that machine).

2) To synchronize using RSH, there must be an RSH client installed on

this machine and an RSH server installed on the remote machine.  You

must enter the host to connect to, a user name (if different from

your user name on this machine), and the directory on the remote machine

(relative to your home directory on that machine).

3) To synchronize using %s's socket protocol, there must be a %s

server running on the remote machine, listening to the port that you

specify here.  (Use \"%s -socket xxx\" on the remote machine to

start the %s server.)  You must enter the host, port, and the directory

on the remote machine (relative to the working directory of the

%s server running on that machine)."

myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized myNameCapitalized

(**********************************************************************

 Font preferences

 **********************************************************************)

let fontMonospace = lazy (Pango.Font.from_string "monospace")

let fontBold = lazy (Pango.Font.from_string "bold")

let fontItalic = lazy (Pango.Font.from_string "italic")

(**********************************************************************

 Unison icon

 **********************************************************************)

(* This does not work with the current version of Lablgtk, due to a bug

let icon =

  GdkPixbuf.from_data ~width:48 ~height:48 ~has_alpha:true

    (Gpointer.region_of_bytes Pixmaps.icon_data)

*)

let icon =

  let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in

  let pxs = GdkPixbuf.get_pixels p in

  (* This little hack is here to support compiling with lablgtk versions both

     < 2.18.6 and >= 2.18.6 *)

  String.iteri (fun i c -> Gpointer.set_byte pxs ~pos:i (Char.code c)) Pixmaps.icon_data;

  p

let leftPtrWatch =

  lazy (Gdk.Cursor.create `WATCH)

let make_busy w =

  if Util.osType <> `Win32 then

    Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch)

let make_interactive w =

  if Util.osType <> `Win32 then

    (* HACK: setting the cursor to NULL restore the default cursor *)

    Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null)

(*********************************************************************

  UI state variables

 *********************************************************************)

type stateItem = { mutable ri : reconItem;

                   mutable bytesTransferred : Uutil.Filesize.t;

                   mutable bytesToTransfer : Uutil.Filesize.t;

                   mutable whatHappened : (Util.confirmation * string option) option}

let theState = ref [||]

let unsynchronizedPaths = ref None

(* ---- *)

let theToplevelWindow = ref None

let setToplevelWindow w = theToplevelWindow := Some w

let toplevelWindow () =

  match !theToplevelWindow with

    Some w -> w

  | None   -> raise (Util.Fatal "Main window not initialized; check your DISPLAY setup")

(*********************************************************************

  Lock management

 *********************************************************************)

let busy = ref false

let getLock f =

  if !busy then

    Trace.status "Synchronizer is busy, please wait.."

  else begin

    busy := true; f (); busy := false

  end

(**********************************************************************

  Miscellaneous

 **********************************************************************)

let sync_action = ref None

let last = ref (0.)

let gtk_sync forced =

  let t = Unix.gettimeofday () in

  if !last = 0. || forced || t -. !last > 0.05 then begin

    last := t;

    begin match !sync_action with

      Some f -> f ()

    | None   -> ()

    end;

    while Glib.Main.iteration false do () done

  end

(**********************************************************************

                      CHARACTER SET TRANSCODING

***********************************************************************)

(* Transcodage from Microsoft Windows Codepage 1252 to Unicode *)

(* Unison currently uses the "ASCII" Windows filesystem API.  With

   this API, filenames are encoded using a proprietary character

   encoding.  This encoding depends on the Windows setup, but in

   Western Europe, the Windows Codepage 1252 is usually used.

   GTK, on the other hand, uses the UTF-8 encoding.  This code perform

   the translation from Codepage 1252 to UTF-8.  A call to [transcode]

   should be wrapped around every string below that might contain

   non-ASCII characters. *)

let code =

  [| 0x0020; 0x0001; 0x0002; 0x0003; 0x0004; 0x0005; 0x0006; 0x0007;

     0x0008; 0x0009; 0x000A; 0x000B; 0x000C; 0x000D; 0x000E; 0x000F;

     0x0010; 0x0011; 0x0012; 0x0013; 0x0014; 0x0015; 0x0016; 0x0017;

     0x0018; 0x0019; 0x001A; 0x001B; 0x001C; 0x001D; 0x001E; 0x001F;

     0x0020; 0x0021; 0x0022; 0x0023; 0x0024; 0x0025; 0x0026; 0x0027;

     0x0028; 0x0029; 0x002A; 0x002B; 0x002C; 0x002D; 0x002E; 0x002F;

     0x0030; 0x0031; 0x0032; 0x0033; 0x0034; 0x0035; 0x0036; 0x0037;

     0x0038; 0x0039; 0x003A; 0x003B; 0x003C; 0x003D; 0x003E; 0x003F;

     0x0040; 0x0041; 0x0042; 0x0043; 0x0044; 0x0045; 0x0046; 0x0047;

     0x0048; 0x0049; 0x004A; 0x004B; 0x004C; 0x004D; 0x004E; 0x004F;

     0x0050; 0x0051; 0x0052; 0x0053; 0x0054; 0x0055; 0x0056; 0x0057;

     0x0058; 0x0059; 0x005A; 0x005B; 0x005C; 0x005D; 0x005E; 0x005F;

     0x0060; 0x0061; 0x0062; 0x0063; 0x0064; 0x0065; 0x0066; 0x0067;

     0x0068; 0x0069; 0x006A; 0x006B; 0x006C; 0x006D; 0x006E; 0x006F;

     0x0070; 0x0071; 0x0072; 0x0073; 0x0074; 0x0075; 0x0076; 0x0077;

     0x0078; 0x0079; 0x007A; 0x007B; 0x007C; 0x007D; 0x007E; 0x007F;

     0x20AC; 0x1234; 0x201A; 0x0192; 0x201E; 0x2026; 0x2020; 0x2021;

     0x02C6; 0x2030; 0x0160; 0x2039; 0x0152; 0x1234; 0x017D; 0x1234;

     0x1234; 0x2018; 0x2019; 0x201C; 0x201D; 0x2022; 0x2013; 0x2014;

     0x02DC; 0x2122; 0x0161; 0x203A; 0x0153; 0x1234; 0x017E; 0x0178;

     0x00A0; 0x00A1; 0x00A2; 0x00A3; 0x00A4; 0x00A5; 0x00A6; 0x00A7;

     0x00A8; 0x00A9; 0x00AA; 0x00AB; 0x00AC; 0x00AD; 0x00AE; 0x00AF;

     0x00B0; 0x00B1; 0x00B2; 0x00B3; 0x00B4; 0x00B5; 0x00B6; 0x00B7;

     0x00B8; 0x00B9; 0x00BA; 0x00BB; 0x00BC; 0x00BD; 0x00BE; 0x00BF;

     0x00C0; 0x00C1; 0x00C2; 0x00C3; 0x00C4; 0x00C5; 0x00C6; 0x00C7;

     0x00C8; 0x00C9; 0x00CA; 0x00CB; 0x00CC; 0x00CD; 0x00CE; 0x00CF;

     0x00D0; 0x00D1; 0x00D2; 0x00D3; 0x00D4; 0x00D5; 0x00D6; 0x00D7;

     0x00D8; 0x00D9; 0x00DA; 0x00DB; 0x00DC; 0x00DD; 0x00DE; 0x00DF;

     0x00E0; 0x00E1; 0x00E2; 0x00E3; 0x00E4; 0x00E5; 0x00E6; 0x00E7;

     0x00E8; 0x00E9; 0x00EA; 0x00EB; 0x00EC; 0x00ED; 0x00EE; 0x00EF;

     0x00F0; 0x00F1; 0x00F2; 0x00F3; 0x00F4; 0x00F5; 0x00F6; 0x00F7;

     0x00F8; 0x00F9; 0x00FA; 0x00FB; 0x00FC; 0x00FD; 0x00FE; 0x00FF |]

let rec transcodeRec buf s i l =

  if i < l then begin

    let c = code.(Char.code s.[i]) in

    if c < 0x80 then

      Buffer.add_char buf (Char.chr c)

    else if c < 0x800 then begin

      Buffer.add_char buf (Char.chr (c lsr 6 + 0xC0));

      Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))

    end else if c < 0x10000 then begin

      Buffer.add_char buf (Char.chr (c lsr 12 + 0xE0));

      Buffer.add_char buf (Char.chr ((c lsr 6) land 0x3f + 0x80));

      Buffer.add_char buf (Char.chr (c land 0x3f + 0x80))

    end;

    transcodeRec buf s (i + 1) l

  end

let transcodeDoc s =

  let buf = Buffer.create 1024 in

  transcodeRec buf s 0 (String.length s);

  Buffer.contents buf

(****)

let escapeMarkup s = Glib.Markup.escape_text s

let transcodeFilename s =

  if Prefs.read Case.unicodeEncoding then

    Unicode.protect s

  else if Util.osType = `Win32 then transcodeDoc s else

  try

    Glib.Convert.filename_to_utf8 s

  with Glib.Convert.Error _ ->

    Unicode.protect s

let transcode s =

  if Prefs.read Case.unicodeEncoding then

    Unicode.protect s

  else

  try

    Glib.Convert.locale_to_utf8 s

  with Glib.Convert.Error _ ->

    Unicode.protect s

(**********************************************************************

                       USEFUL LOW-LEVEL WIDGETS

 **********************************************************************)

class scrolled_text ?editable ?shadow_type ?word_wrap

    ~width ~height ?packing ?show

    () =

  let sw =

    GBin.scrolled_window ?packing ~show:false

      ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()

  in

  let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in

  object

    inherit GObj.widget_full sw#as_widget

    method text = text

    method insert s = text#buffer#set_text s;

    method show () = sw#misc#show ()

    initializer

      text#misc#set_size_chars ~height ~width ();

      if show <> Some false then sw#misc#show ()

  end

(* ------ *)

(* Display a message in a window and wait for the user

   to hit the button. *)

let okBox ~parent ~title ~typ ~message =

  let t =

    GWindow.message_dialog

      ~parent ~title ~message_type:typ ~message ~modal:true

      ~buttons:GWindow.Buttons.ok () in

  ignore (t#run ()); t#destroy ()

(* ------ *)

let primaryText msg =

  Printf.sprintf "<span weight=\"bold\" size=\"larger\">%s</span>"

    (escapeMarkup msg)

(* twoBox: Display a message in a window and wait for the user

   to hit one of two buttons.  Return true if the first button is

   chosen, false if the second button is chosen. *)

let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message =

  let t =

    GWindow.dialog ~parent ~border_width:6 ~modal:true

      ~resizable:false () in

  t#vbox#set_spacing 12;

  let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in

  ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG

            ~yalign:0. ~packing:h1#pack ());

  let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in

  ignore (GMisc.label

            ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message)

            ~selectable:true ~yalign:0. ~packing:v1#add ());

  t#add_button_stock bstock `NO;

  t#add_button_stock astock `YES;

  t#set_default_response `NO;

  t#show();

  let res = t#run () in

  t#destroy ();

  res = `YES

(* ------ *)

(* Avoid recursive invocations of the function below (a window receives

   delete events even when it is not sensitive) *)

let inExit = ref false

let doExit () = Lwt_unix.run (Update.unlockArchives ()); exit 0

let safeExit () =

  if not !inExit then begin

    inExit := true;

    if not !busy then exit 0 else

    if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit"

        ~astock:`YES ~bstock:`NO

        "Unison is working, exit anyway ?"

    then exit 0;

    inExit := false

  end

(* ------ *)

(* warnBox: Display a warning message in a window and wait (unless

   we're in batch mode) for the user to hit "OK" or "Exit". *)

let warnBox ~parent title message =

  let message = transcode message in

  if Prefs.read Globals.batch then begin

    (* In batch mode, just pop up a window and go ahead *)

    let t =

      GWindow.dialog ~parent

        ~border_width:6 ~modal:true ~resizable:false () in

    t#vbox#set_spacing 12;

    let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in

    ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG

              ~yalign:0. ~packing:h1#pack ());

    let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in

    ignore (GMisc.label ~markup:(primaryText title ^ "\n\n" ^

                                 escapeMarkup message)

              ~selectable:true ~yalign:0. ~packing:v1#add ());

    t#add_button_stock `CLOSE `CLOSE;

    t#set_default_response `CLOSE;

    ignore (t#connect#response ~callback:(fun _ -> t#destroy ()));

    t#show ()

  end else begin

    inExit := true;

    let ok =

      twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT

        message in

    if not(ok) then doExit ();

    inExit := false

  end

(****)

let accel_paths = Hashtbl.create 17

let underscore_re = Str.regexp_string "_"

class ['a] gMenuFactory

    ?(accel_group=GtkData.AccelGroup.create ())

    ?(accel_path="<DEFAULT ROOT>/")

    ?(accel_modi=[`CONTROL])

    ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) =

  object (self)

    val menu_shell : #GMenu.menu_shell = menu_shell

    val group = accel_group

    val m = accel_modi

    val flags = (accel_flags:Gtk.Tags.accel_flag list)

    val accel_path = accel_path

    method menu = menu_shell

    method accel_group = group

    method accel_path = accel_path

    method private bind

        ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) =

      menu_shell#append item;

      let accel_path = accel_path ^ name in

      let accel_path = Str.global_replace underscore_re "" accel_path in

      (* Default accel path value *)

      if not (Hashtbl.mem accel_paths accel_path) then begin

        Hashtbl.add accel_paths accel_path ();

        GtkData.AccelMap.add_entry accel_path ?key ~modi

      end;

      (* Register this accel path *)

      GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group;

      Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback)

    method add_item ?key ?modi ?callback ?submenu label =

      let item = GMenu.menu_item  ~use_mnemonic:true ~label () in

      self#bind ?modi ?key ?callback label item;

      Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu;

      item

    method add_image_item ?(image : GObj.widget option)

        ?modi ?key ?callback ?stock ?name label =

      (* GTK 3 does not provide image menu items (there is a way to

         manually create a workaround but that does not work with

         lablgtk. Let's create a regular menu item instead. *)

      let item =

        GMenu.menu_item ~use_mnemonic:true ~label () in

      match stock  with

      | None ->

          self#bind ?modi ?key ?callback label ?name item;

          item

      | Some s ->

          try

            let st = GtkStock.Item.lookup s in

            self#bind

              ?modi ?key:(if st.GtkStock.keyval=0 then key else None)

              ?callback label ?name item;

            item

          with Not_found -> item

    method add_check_item ?active ?modi ?key ?callback label =

      let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in

      self#bind label ?modi ?key

        ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active))

        (item : GMenu.check_menu_item :> GMenu.menu_item);

      item

    method add_separator () = GMenu.separator_item ~packing:menu_shell#append ()

    method add_submenu label =

      let item = GMenu.menu_item ~use_mnemonic:true ~label () in

      self#bind label item;

      (GMenu.menu ~packing:item#set_submenu (), item)

    method replace_submenu (item : GMenu.menu_item) =

      GMenu.menu ~packing:item#set_submenu ()

end

(**********************************************************************

                         HIGHER-LEVEL WIDGETS

***********************************************************************)

(*class stats width height =

  let pixmap = GDraw.pixmap ~width ~height () in

  let area =

    pixmap#set_foreground `WHITE;

    pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();

    GMisc.pixmap pixmap ~width ~height ~xpad:4 ~ypad:8 ()

  in

  object (self)

    inherit GObj.widget_full area#as_widget

    val mutable maxim = ref 0.

    val mutable scale = ref 1.

    val mutable min_scale = 1.

    val values = Array.make width 0.

    val mutable active = false

    method redraw () =

      scale := min_scale;

      while !maxim > !scale do

        scale := !scale *. 1.5

      done;

      pixmap#set_foreground `WHITE;

      pixmap#rectangle ~filled:true ~x:0 ~y:0 ~width ~height ();

      pixmap#set_foreground `BLACK;

      for i = 0 to width - 1 do

        self#rect i values.(max 0 (i - 1)) values.(i)

      done

    method activate a = active <- a; if a then self#redraw ()

    method scale h = truncate ((float height) *. h /. !scale)

    method private rect i v' v =

      let h = self#scale v in

      let h' = self#scale v' in

      let h1 = min h' h in

      let h2 = max h' h in

      pixmap#set_foreground `BLACK;

      pixmap#rectangle

        ~filled:true ~x:i ~y:(height - h1) ~width:1 ~height:h1 ();

      for h = h1 + 1 to h2 do

        let v = truncate (65535. *. (float (h - h1) /. float (h2 - h1))) in

        let v = (v / 4096) * 4096 in (* Only use 16 gray levels *)

        pixmap#set_foreground (`RGB (v, v, v));

        pixmap#rectangle

          ~filled:true ~x:i ~y:(height - h) ~width:1 ~height:1 ();

      done

    method push v =

      let need_max = values.(0) = !maxim in

      for i = 0 to width - 2 do

        values.(i) <- values.(i + 1)

      done;

      values.(width - 1) <- v;

      if need_max then begin

        maxim := 0.;

        for i = 0 to width - 1 do maxim := max !maxim values.(i) done

      end else

        maxim := max !maxim v;

      if active then begin

        let need_resize =

          !maxim > !scale || (!maxim > min_scale && !maxim < !scale /. 1.5) in

        if need_resize then

          self#redraw ()

        else begin

          pixmap#put_pixmap ~x:0 ~y:0 ~xsrc:1 (pixmap#pixmap);

          pixmap#set_foreground `WHITE;

          pixmap#rectangle

            ~filled:true ~x:(width - 1) ~y:0 ~width:1 ~height ();

          self#rect (width - 1) values.(width - 2) values.(width - 1)

        end;

        area#misc#draw None

      end

  end

*)

let clientWritten = ref 0.

let serverWritten = ref 0.

let emitRate2 = ref 0.

let receiveRate2 = ref 0.

let rate2str v =

  if v > 9.9e3 then begin

    if v > 9.9e6 then

      Format.sprintf "%1.0f MiB/s" (v /. 1e6)

    else if v > 999e3 then

      Format.sprintf "%1.1f MiB/s" (v /. 1e6)

    else

      Format.sprintf "%1.0f KiB/s" (v /. 1e3)

  end else begin

    if v > 990. then

      Format.sprintf "%1.1f KiB/s" (v /. 1e3)

    else if v > 99. then

      Format.sprintf "%1.2f KiB/s" (v /. 1e3)

    else

      " "

  end

let mib = 1024. *. 1024.

let kib2str v =

  if v > 100_000_000. then

    Format.sprintf "%.0f MiB" (v /. mib)

  else if v > 1_000_000. then

    Format.sprintf "%.1f MiB" (v /. mib)

  else if v > 1024. then

    Format.sprintf "%.1f KiB" (v /. 1024.)

  else

    Format.sprintf "%.0f B" v

let statistics () =

  let title = "Statistics" in

  let t = GWindow.dialog ~title () in

  let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in

  t_dismiss#grab_default ();

  let dismiss () = t#misc#hide () in

  ignore (t_dismiss#connect#clicked ~callback:dismiss);

  ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));

(*  let emission = new stats 320 50 in

  t#vbox#pack ~expand:false ~padding:4 (emission :> GObj.widget);

  let reception = new stats 320 50 in

  t#vbox#pack ~expand:false ~padding:4 (reception :> GObj.widget);*)

  let cols = new GTree.column_list in

  let c_1 = cols#add Gobject.Data.string in

  let c_client = cols#add Gobject.Data.string in

  let c_server = cols#add Gobject.Data.string in

  let c_total = cols#add Gobject.Data.string in

  let lst = GTree.list_store cols in

  let l = GTree.view ~model:lst ~enable_search:false ~packing:(t#vbox#add) () in

  l#selection#set_mode `NONE;

  ignore (l#append_column (GTree.view_column ~title:""

    ~renderer:(GTree.cell_renderer_text [], ["text", c_1]) ()));

  ignore (l#append_column (GTree.view_column ~title:"Client"

    ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_client]) ()));

  ignore (l#append_column (GTree.view_column ~title:"Server"

    ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_server]) ()));

  ignore (l#append_column (GTree.view_column ~title:"Total"

    ~renderer:(GTree.cell_renderer_text [`XALIGN 1.0], ["text", c_total]) ()));

  let rate_row = lst#append () in

  ignore (lst#set rate_row c_1 "Reception rate");

  let receive_row = lst#append () in

  ignore (lst#set receive_row c_1 "Data received");

  let data_row = lst#append () in

  ignore (lst#set data_row c_1 "File data written");

(*

  ignore (t#event#connect#map ~callback:(fun _ ->

    emission#activate true;

    reception#activate true;

    false));

  ignore (t#event#connect#unmap ~callback:(fun _ ->

    emission#activate false;

    reception#activate false;

    false));*)

  let delay = 0.5 in

  let a = 0.5 in

  let b = 0.8 in

  let emittedBytes = ref 0. in

  let emitRate = ref 0. in

  let receivedBytes = ref 0. in

  let receiveRate = ref 0. in

  let stopCounter = ref 0 in

  let updateTable () =

    let row = rate_row in

    lst#set ~row ~column:c_client (rate2str !receiveRate2);

    lst#set ~row ~column:c_server (rate2str !emitRate2);

    lst#set ~row ~column:c_total (rate2str (!receiveRate2 +. !emitRate2));

    let row = receive_row in

    lst#set ~row ~column:c_client (kib2str !receivedBytes);

    lst#set ~row ~column:c_server (kib2str !emittedBytes);

    lst#set ~row ~column:c_total (kib2str (!receivedBytes +. !emittedBytes));

    let row = data_row in

    lst#set ~row ~column:c_client (kib2str !clientWritten);

    lst#set ~row ~column:c_server (kib2str !serverWritten);

    lst#set ~row ~column:c_total (kib2str (!clientWritten +. !serverWritten))

  in

  let timeout _ =

    emitRate :=

      a *. !emitRate +.

      (1. -. a) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;

    emitRate2 :=

      b *. !emitRate2 +.

      (1. -. b) *. (!Remote.emittedBytes -. !emittedBytes) /. delay;

(*    emission#push !emitRate;*)

    receiveRate :=

      a *. !receiveRate +.

      (1. -. a) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;

    receiveRate2 :=

      b *. !receiveRate2 +.

      (1. -. b) *. (!Remote.receivedBytes -. !receivedBytes) /. delay;

(*    reception#push !receiveRate;*)

    emittedBytes := !Remote.emittedBytes;

    receivedBytes := !Remote.receivedBytes;

    if !stopCounter > 0 then decr stopCounter;

    if !stopCounter = 0 then begin

      emitRate2 := 0.; receiveRate2 := 0.;

    end;

    updateTable ();

    !stopCounter <> 0

  in

  let startStats () =

    if !stopCounter = 0 then begin

      emittedBytes := !Remote.emittedBytes;

      receivedBytes := !Remote.receivedBytes;

      stopCounter := -1;

      ignore (GMain.Timeout.add ~ms:(truncate (delay *. 1000.))

                ~callback:timeout)

    end else

      stopCounter := -1

  in

  let stopStats () = stopCounter := 10 in

  (t, startStats, stopStats)

(* ------ *)

let fatalError message =

  let () =

    try Trace.log (message ^ "\n")

    with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *)

  let title = "Fatal error" in

  let t =

    GWindow.dialog ~parent:(toplevelWindow ())

      ~border_width:6 ~modal:true ~resizable:false () in

  t#vbox#set_spacing 12;

  let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in

  ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG

            ~yalign:0. ~packing:h1#pack ());

  let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in

  ignore (GMisc.label

            ~markup:(primaryText title ^ "\n\n" ^

                     escapeMarkup (transcode message))

            ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ());

  t#add_button_stock `QUIT `QUIT;

  t#set_default_response `QUIT;

  t#show(); ignore (t#run ()); t#destroy ();

  exit 1

(* ------ *)

let tryAgainOrQuit = fatalError

(* ------ *)

let getFirstRoot () =

  let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"

      ~modal:true ~resizable:true () in

  t#misc#grab_focus ();

  let hb = GPack.hbox

      ~packing:(t#vbox#pack ~expand:false ~padding:15) () in

  ignore(GMisc.label ~text:tryAgainMessage

           ~justify:`LEFT

           ~packing:(hb#pack ~expand:false ~padding:15) ());

  let f1 = GPack.hbox ~spacing:4

      ~packing:(t#vbox#pack ~expand:true ~padding:4) () in

  ignore (GMisc.label ~text:"Dir:" ~packing:(f1#pack ~expand:false) ());

  let fileE = GEdit.entry ~packing:f1#add () in

  fileE#misc#grab_focus ();

  let b = GFile.chooser_button ~action:`SELECT_FOLDER

    ~title:"Select a local directory"

    ~packing:(f1#pack ~expand:false) () in

  ignore (b#connect#selection_changed ~callback:(fun () ->

            if not fileE#is_focus then

              fileE#set_text (match b#filename with None -> "" | Some s -> s)));

  ignore (fileE#connect#changed ~callback:(fun () ->

            if fileE#is_focus then ignore (b#set_filename fileE#text)));

  let f3 = t#action_area in

  let result = ref None in

  let contCommand() =

    result := Some(fileE#text);

    t#destroy () in

  let quitButton = GButton.button ~stock:`QUIT ~packing:f3#add () in

  ignore (quitButton#connect#clicked

            ~callback:(fun () -> result := None; t#destroy()));

  let contButton = GButton.button ~stock:`OK ~packing:f3#add () in

  ignore (contButton#connect#clicked ~callback:contCommand);

  ignore (fileE#connect#activate ~callback:contCommand);

  contButton#grab_default ();

  t#show ();

  ignore (t#connect#destroy ~callback:GMain.Main.quit);

  GMain.Main.main ();

  match !result with None -> None

  | Some file ->

      Some(Clroot.clroot2string(Clroot.ConnectLocal(Some file)))

(* ------ *)

let getSecondRoot () =

  let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection"

      ~modal:true ~resizable:true () in

  t#misc#grab_focus ();

  let message = "Please enter the second directory you want to synchronize." in

  let vb = t#vbox in

  let hb = GPack.hbox ~packing:(vb#pack ~expand:false ~padding:15) () in

  ignore(GMisc.label ~text:message

           ~justify:`LEFT

           ~packing:(hb#pack ~expand:false ~padding:15) ());

  let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in

  ignore (helpB#connect#clicked

            ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO

                ~message:helpmessage));

  let result = ref None in

  let f = GPack.vbox ~packing:(vb#pack ~expand:false) () in

  let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in

  ignore (GMisc.label ~text:"Directory:" ~packing:(f1#pack ~expand:false) ());

  let fileE = GEdit.entry ~packing:f1#add () in

  fileE#misc#grab_focus ();

  let b = GFile.chooser_button ~action:`SELECT_FOLDER

    ~title:"Select a local directory"

    ~packing:(f1#pack ~expand:false) () in

  ignore (b#connect#selection_changed ~callback:(fun () ->

            if not fileE#is_focus then

              fileE#set_text (match b#filename with None -> "" | Some s -> s)));

  ignore (fileE#connect#changed ~callback:(fun () ->

            if fileE#is_focus then ignore (b#set_filename fileE#text)));

  let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in

  let localB = GButton.radio_button ~packing:(f0#pack ~expand:false)

      ~label:"Local" () in

  let sshB = GButton.radio_button ~group:localB#group

      ~packing:(f0#pack ~expand:false)

      ~label:"SSH" () in

  let rshB = GButton.radio_button ~group:localB#group

      ~packing:(f0#pack ~expand:false) ~label:"RSH" () in

  let socketB = GButton.radio_button ~group:sshB#group

      ~packing:(f0#pack ~expand:false) ~label:"Socket" () in

  let f2 = GPack.hbox ~spacing:4 ~packing:f#add () in

  ignore (GMisc.label ~text:"Host:" ~packing:(f2#pack ~expand:false) ());

  let hostE = GEdit.entry ~packing:f2#add () in

  ignore (GMisc.label ~text:"(Optional) User:"

            ~packing:(f2#pack ~expand:false) ());

  let userE = GEdit.entry ~packing:f2#add () in

  ignore (GMisc.label ~text:"Port:"

            ~packing:(f2#pack ~expand:false) ());

  let portE = GEdit.entry ~packing:f2#add () in

  let varLocalRemote = ref (`Local : [`Local|`SSH|`RSH|`SOCKET]) in

  let localState() =

    varLocalRemote := `Local;

    hostE#misc#set_sensitive false;

    userE#misc#set_sensitive false;

    portE#misc#set_sensitive false;

    b#misc#set_sensitive true in

  let remoteState() =

    hostE#misc#set_sensitive true;

    b#misc#set_sensitive false;

    match !varLocalRemote with

      `SOCKET ->

        (portE#misc#set_sensitive true; userE#misc#set_sensitive false)

    | _ ->

        (portE#misc#set_sensitive false; userE#misc#set_sensitive true) in

  let protoState x =

    varLocalRemote := x;

    remoteState() in

  ignore (localB#connect#clicked ~callback:localState);

  ignore (sshB#connect#clicked ~callback:(fun () -> protoState(`SSH)));

  ignore (rshB#connect#clicked ~callback:(fun () -> protoState(`RSH)));

  ignore (socketB#connect#clicked ~callback:(fun () -> protoState(`SOCKET)));

  localState();

  let getRoot() =

    let file = fileE#text in

    let user = userE#text in

    let host = hostE#text in

    let port = portE#text in

    match !varLocalRemote with

      `Local ->

        Clroot.clroot2string(Clroot.ConnectLocal(Some file))

    | `SSH | `RSH ->

        Clroot.clroot2string(

        Clroot.ConnectByShell((if !varLocalRemote=`SSH then "ssh" else "rsh"),

                              host,

                              (if user="" then None else Some user),

                              (if port="" then None else Some port),

                              Some file))

    | `SOCKET ->

        Clroot.clroot2string(

        (* FIX: report an error if the port entry is not well formed *)

        Clroot.ConnectBySocket(host,

                               portE#text,

                               Some file)) in

  let contCommand() =

    try

      let root = getRoot() in

      result := Some root;

      t#destroy ()

    with Failure _ ->

      if portE#text="" then

        okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port"

      else okBox ~parent:t ~title:"Error" ~typ:`ERROR

          ~message:"The port you specify must be an integer"

    | _ ->

      okBox ~parent:t ~title:"Error" ~typ:`ERROR

        ~message:"Something's wrong with the values you entered, try again" in

  let f3 = t#action_area in

  let quitButton =

    GButton.button ~stock:`QUIT ~packing:f3#add () in

  ignore (quitButton#connect#clicked ~callback:safeExit);

  let contButton =

    GButton.button ~stock:`OK ~packing:f3#add () in

  ignore (contButton#connect#clicked ~callback:contCommand);

  contButton#grab_default ();

  ignore (fileE#connect#activate ~callback:contCommand);

  t#show ();

  ignore (t#connect#destroy ~callback:GMain.Main.quit);

  GMain.Main.main ();

  !result

(* ------ *)

let getPassword rootName msg =

  let t =

    GWindow.dialog ~parent:(toplevelWindow ())

      ~title:"Unison: SSH connection" ~position:`CENTER

      ~modal:true ~resizable:false ~border_width:6 () in

  t#misc#grab_focus ();

  t#vbox#set_spacing 12;

  let header =

    primaryText

      (Format.sprintf "Connecting to '%s'..." (Unicode.protect rootName)) in

  let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in

  ignore (GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG

            ~yalign:0. ~packing:h1#pack ());

  let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in

  ignore(GMisc.label ~markup:(header ^ "\n\n" ^

                              escapeMarkup (Unicode.protect msg))

           ~selectable:true ~yalign:0. ~packing:v1#pack ());

  let passwordE = GEdit.entry ~packing:v1#pack ~visibility:false () in

  passwordE#misc#grab_focus ();

  t#add_button_stock `QUIT `QUIT;

  t#add_button_stock `OK `OK;

  t#set_default_response `OK;

  ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK));

  t#show();

  let res = t#run () in

  let pwd = passwordE#text in

  t#destroy ();

  gtk_sync true;

  begin match res with

    `DELETE_EVENT | `QUIT -> safeExit (); ""

  | `OK                   -> pwd

  end

let termInteract = Some getPassword

(* ------ *)

module React = struct

  type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list }

  let make v =

    let res = { state = v; observers = [] } in

    let update v =

      if res.state <> v then begin

        res.state <- v; List.iter (fun f -> f v) res.observers

      end

    in

    (res, update)

  let const v = fst (make v)

  let add_observer x f = x.observers <- f :: x.observers

  let state x = x.state

  let lift f x =

    let (res, update) = make (f (state x)) in

    add_observer x (fun v -> update (f v));

    res

  let lift2 f x y =

    let (res, update) = make (f (state x) (state y)) in

    add_observer x (fun v -> update (f v (state y)));

    add_observer y (fun v -> update (f (state x) v));

    res

  let lift3 f x y z =

    let (res, update) = make (f (state x) (state y) (state z)) in

    add_observer x (fun v -> update (f v (state y) (state z)));

    add_observer y (fun v -> update (f (state x) v (state z)));

    add_observer z (fun v -> update (f (state x) (state y) v));

    res

  let iter f x = f (state x); add_observer x f

  type 'a event = { mutable ev_observers : ('a -> unit) list }

  let make_event () =

    let res = { ev_observers = [] } in

    let trigger v = List.iter (fun f -> f v) res.ev_observers in

    (res, trigger)

  let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers

  let hold v e =

    let (res, update) = make v in

    add_ev_observer e update;

    res

  let iter_ev f e = add_ev_observer e f

  let lift_ev f e =

    let (res, trigger) = make_event () in

    add_ev_observer e (fun x -> trigger (f x));

    res

  module Ops = struct

    let (>>) x f = lift f x

    let (>|) x f = iter f x

    let (>>>) x f = lift_ev f x

    let (>>|) x f = iter_ev f x

  end

end

module GtkReact = struct

  let entry (e : #GEdit.entry) =

    let (res, update) = React.make e#text in

    ignore (e#connect#changed ~callback:(fun () -> update (e#text)));

    res

  let text_combo ((c, _) : _ GEdit.text_combo) =

    let (res, update) = React.make c#active in

    ignore (c#connect#changed ~callback:(fun () -> update (c#active)));

    res

  let toggle_button (b : #GButton.toggle_button) =

    let (res, update) = React.make b#active in

    ignore (b#connect#toggled ~callback:(fun () -> update (b#active)));

    res

  let file_chooser (c : #GFile.chooser) =

    let (res, update) = React.make c#filename in

    ignore (c#connect#selection_changed

              ~callback:(fun () -> update (c#filename)));

    res

  let current_tree_view_selection (t : #GTree.view) =

    let m =t#model in

    Safelist.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows

  let tree_view_selection_changed t =

    let (res, trigger) = React.make_event () in

    ignore (t#selection#connect#changed

              ~callback:(fun () -> trigger (current_tree_view_selection t)));

    res

  let tree_view_selection t =

    React.hold (current_tree_view_selection t) (tree_view_selection_changed t)

  let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x

  let label_underlined (l : #GMisc.label) x =

    React.iter (fun v -> l#set_text v; l#set_use_underline true) x

  let label_markup (l : #GMisc.label) x =

    React.iter (fun v -> l#set_text v; l#set_use_markup true) x

  let show w x =

    React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x

  let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x

end

open React.Ops

(* ------ *)

(* Resize an object (typically, a label with line wrapping) so that it

   use all its available space *)

let adjustSize (w : #GObj.widget) =

  let notYet = ref true in

  ignore

    (w#misc#connect#size_allocate ~callback:(fun r ->

       if !notYet then begin

         notYet := false;

         (* JV: I have no idea where the 12 comes from.  Without it,

            a window resize may happen. *)

         w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) ()

       end))

let createProfile parent =

  let assistant = GAssistant.assistant ~modal:true () in

  assistant#set_transient_for parent#as_window;

  assistant#set_modal true;

  assistant#set_title "Profile Creation";

  let nonEmpty s = s <> "" in

(*

  let integerRe =

    Str.regexp "\\([+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\\)" in

*)

  let integerRe = Str.regexp "[0-9]+" in

  let isInteger s =

    Str.string_match integerRe s 0 && Str.matched_string s = s in

  (* Introduction *)

  let intro =

    GMisc.label

      ~xpad:12 ~ypad:12

      ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\

             Click \"Next\" to begin."

    () in

  ignore

    (assistant#append_page

       ~title:"Profile Creation"

       ~page_type:`INTRO

       ~complete:true

      intro#as_widget);

  (* Profile name and description *)

  let description = GPack.vbox ~border_width:12 ~spacing:6 () in

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

       ~text:"Please enter the name of the profile and \

              possibly a short description."

       ~packing:(description#pack ~expand:false) ());

  let tbl =

    let al = GBin.alignment ~packing:(description#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6

      ~packing:(al#add) () in

  let nameEntry =

    GEdit.entry ~activates_default:true

      ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in

  let name = GtkReact.entry nameEntry in

  ignore (GMisc.label ~text:"Profile _name:" ~xalign:0.

            ~use_underline:true ~mnemonic_widget:nameEntry

            ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());

  let labelEntry =

    GEdit.entry ~activates_default:true

       ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in

  let label = GtkReact.entry labelEntry in

  ignore (GMisc.label ~text:"_Description:" ~xalign:0.

            ~use_underline:true ~mnemonic_widget:labelEntry

            ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());

  let existingProfileLabel =

    GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) ()

  in

  adjustSize existingProfileLabel;

  GtkReact.label_markup existingProfileLabel

    (name >> fun s -> Format.sprintf " <i>Profile %s already exists.</i>"

                        (escapeMarkup s));

  let profileExists =

    name >> fun s -> s <> "" && System.file_exists (Prefs.profilePathname s)

  in

  GtkReact.show existingProfileLabel profileExists;

  ignore

    (assistant#append_page

       ~title:"Profile Description"

       ~page_type:`CONTENT

       description#as_widget);

  let setPageComplete page b = assistant#set_page_complete page#as_widget b in

  React.lift2 (&&) (name >> nonEmpty) (profileExists >> not)

    >| setPageComplete description;

  let connection = GPack.vbox ~border_width:12 ~spacing:18 () in

  let al = GBin.alignment ~packing:(connection#pack ~expand:false) () in

  al#set_left_padding 12;

  let vb =

    GPack.vbox ~spacing:6 ~packing:(al#add) () in

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

       ~text:"You can use Unison to synchronize a local directory \

              with another local directory, or with a remote directory."

       ~packing:(vb#pack ~expand:false) ());

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

       ~text:"Please select the kind of synchronization \

              you want to perform."

       ~packing:(vb#pack ~expand:false) ());

  let tbl =

    let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6

      ~packing:(al#add) () in

  ignore (GMisc.label ~text:"Description:" ~xalign:0. ~yalign:0.

            ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());

  let kindCombo =

    let al =

      GBin.alignment ~xscale:0. ~xalign:0.

        ~packing:(tbl#attach ~left:1 ~top:0) () in

    GEdit.combo_box_text

      ~strings:["Local"; "Using SSH"; "Using RSH";

                "Through a plain TCP connection"]

      ~active:0 ~packing:(al#add) ()

  in

  ignore (GMisc.label ~text:"Synchronization _kind:" ~xalign:0.

            ~use_underline:true ~mnemonic_widget:(fst kindCombo)

            ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());

  let kind =

    GtkReact.text_combo kindCombo

      >> fun i -> List.nth [`Local; `SSH; `RSH; `SOCKET] i

  in

  let isLocal = kind >> fun k -> k = `Local in

  let isSSH = kind >> fun k -> k = `SSH in

  let isSocket = kind >> fun k -> k = `SOCKET in

  let descrLabel =

    GMisc.label ~xalign:0. ~line_wrap:true

       ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()

  in

  adjustSize descrLabel;

  GtkReact.label descrLabel

    (kind >> fun k ->

     match k with

       `Local ->

          "Local synchronization."

     | `SSH ->

          "This is the recommended way to synchronize \

           with a remote machine.  A\xc2\xa0remote instance of Unison is \

           automatically started via SSH."

     | `RSH ->

          "Synchronization with a remote machine by starting \

           automatically a remote instance of Unison via RSH."

     | `SOCKET ->

          "Synchronization with a remote machine by connecting \

           to an instance of Unison already listening \

           on a specific TCP port.");

  let vb = GPack.vbox ~spacing:6 ~packing:(connection#add) () in

  GtkReact.show vb (isLocal >> not);

  ignore (GMisc.label ~markup:"<b>Configuration</b>" ~xalign:0.

            ~packing:(vb#pack ~expand:false) ());

  let al = GBin.alignment ~packing:(vb#add) () in

  al#set_left_padding 12;

  let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in

  let requirementLabel =

    GMisc.label ~xalign:0. ~line_wrap:true

       ~packing:(vb#pack ~expand:false) ()

  in

  adjustSize requirementLabel;

  GtkReact.label requirementLabel

    (kind >> fun k ->

     match k with

       `Local ->

          ""

     | `SSH ->

          "There must be an SSH client installed on this machine, \

           and Unison and an SSH server installed on the remote machine."

     | `RSH ->

          "There must be an RSH client installed on this machine, \

           and Unison and an RSH server installed on the remote machine."

     | `SOCKET ->

          "There must be a Unison server running on the remote machine, \

           listening on the port that you specify here.  \

           (Use \"Unison -socket xxx\" on the remote machine to start \

           the Unison server.)");

  let connDescLabel =

    GMisc.label ~xalign:0. ~line_wrap:true

       ~packing:(vb#pack ~expand:false) ()

  in

  adjustSize connDescLabel;

  GtkReact.label connDescLabel

    (kind >> fun k ->

     match k with

       `Local  -> ""

     | `SSH    -> "Please enter the host to connect to and a user name, \

                   if different from your user name on this machine."

     | `RSH    -> "Please enter the host to connect to and a user name, \

                   if different from your user name on this machine."

     | `SOCKET -> "Please enter the host and port to connect to.");

  let tbl =

    let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6

      ~packing:(al#add) () in

  let hostEntry =

    GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in

  let host = GtkReact.entry hostEntry in

  ignore (GMisc.label ~text:"_Host:" ~xalign:0.

            ~use_underline:true ~mnemonic_widget:hostEntry

            ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());

  let userEntry =

    GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()

  in

  GtkReact.show userEntry (isSocket >> not);

  let user = GtkReact.entry userEntry in

  GtkReact.show

    (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0.

       ~use_underline:true ~mnemonic_widget:userEntry

       ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())

    (isSocket >> not);

  let portEntry =

    GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()

  in

  GtkReact.show portEntry isSocket;

  let port = GtkReact.entry portEntry in

  GtkReact.show

    (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0.

       ~use_underline:true ~mnemonic_widget:portEntry

       ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ())

    isSocket;

  let compressLabel =

    GMisc.label ~xalign:0. ~line_wrap:true

      ~text:"Data compression can greatly improve performance \

             on slow connections.  However, it may slow down \

             things on (fast) local networks."

      ~packing:(vb#pack ~expand:false) ()

  in

  adjustSize compressLabel;

  GtkReact.show compressLabel isSSH;

  let compressButton =

    let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true

       ~active:true ~packing:(al#add) ())

  in

  GtkReact.show compressButton isSSH;

  let compress = GtkReact.toggle_button compressButton in

(*XXX Disabled for now... *)

(*

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true

       ~text:"If this is possible, it is recommended that Unison \

              attempts to connect immediately to the remote machine, \

              so that it can perform some auto-detections."

       ~packing:(vb#pack ~expand:false) ());

  let connectImmediately =

    let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    GtkReact.toggle_button

      (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true

         ~active:true ~packing:(al#add) ())

  in

  let connectImmediately =

    React.lift2 (&&) connectImmediately (isLocal >> not) in

*)

  let pageComplete =

    React.lift2 (||) isLocal

      (React.lift2 (&&) (host >> nonEmpty)

          (React.lift2 (||) (isSocket >> not) (port >> isInteger)))

  in

  ignore

    (assistant#append_page

       ~title:"Connection Setup"

       ~page_type:`CONTENT

       connection#as_widget);

  pageComplete >| setPageComplete connection;

  (* Connection to server *)

(*XXX Disabled for now... Fill in this page

  let connectionInProgress = GMisc.label ~text:"..." () in

  let p =

    assistant#append_page

      ~title:"Connecting to Server..."

      ~page_type:`PROGRESS

      connectionInProgress#as_widget

  in

  ignore

    (assistant#connect#prepare (fun () ->

       if assistant#current_page = p then begin

         if React.state connectImmediately then begin

           (* XXXX start connection... *)

           assistant#set_page_complete connectionInProgress#as_widget true

         end else

           assistant#set_current_page (p + 1)

       end));

*)

  (* Directory selection *)

  let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

       ~text:"Please select the two directories that you want to synchronize."

       ~packing:(directorySelection#pack ~expand:false) ());

  let secondDirLabel1 =

    GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

      ~text:"The second directory is relative to your home \

             directory on the remote machine."

      ~packing:(directorySelection#pack ~expand:false) ()

  in

  adjustSize secondDirLabel1;

  GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not);

  let secondDirLabel2 =

    GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

      ~text:"The second directory is relative to \

             the working directory of the Unison server \

             running on the remote machine."

      ~packing:(directorySelection#pack ~expand:false) ()

  in

  adjustSize secondDirLabel2;

  GtkReact.show secondDirLabel2 isSocket;

  let tbl =

    let al =

      GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6

      ~packing:(al#add) () in

(*XXX Should focus on this button when becomes visible... *)

  let firstDirButton =

    GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory"

       ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) ()

  in

  isLocal >| (fun b -> firstDirButton#set_title

                         (if b then "First Directory" else "Local Directory"));

  GtkReact.label_underlined

    (GMisc.label ~xalign:0.

       ~mnemonic_widget:firstDirButton

       ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ())

    (isLocal >> fun b ->

       if b then "_First directory:" else "_Local directory:");

  let noneToEmpty o = match o with None -> "" | Some s -> s in

  let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in

  let secondDirButton =

    GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory"

       ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in

  let secondDirLabel =

    GMisc.label ~xalign:0.

      ~text:"Se_cond directory:"

      ~use_underline:true ~mnemonic_widget:secondDirButton

      ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in

  GtkReact.show secondDirButton isLocal;

  GtkReact.show secondDirLabel isLocal;

  let remoteDirEdit =

    GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) ()

  in

  let remoteDirLabel =

    GMisc.label ~xalign:0.

      ~text:"_Remote directory:"

      ~use_underline:true ~mnemonic_widget:remoteDirEdit

      ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()

  in

  GtkReact.show remoteDirEdit (isLocal >> not);

  GtkReact.show remoteDirLabel (isLocal >> not);

  let secondDir =

    React.lift3 (fun b l r -> if b then l else r) isLocal

      (GtkReact.file_chooser secondDirButton >> noneToEmpty)

      (GtkReact.entry remoteDirEdit)

  in

  ignore

    (assistant#append_page

       ~title:"Directory Selection"

       ~page_type:`CONTENT

       directorySelection#as_widget);

  React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir)

    >| setPageComplete directorySelection;

  (* Specific options *)

  let options = GPack.vbox ~border_width:18 ~spacing:12 () in

  (* Do we need to set specific options for FAT partitions?

     If under Windows, then all the options are set properly, except for

     ignoreinodenumbers in case one replica is on a FAT partition on a

     remote non-Windows machine.  As this is unlikely, we do not

     handle this case. *)

  let fat =

    if Util.osType = `Win32 then

      React.const false

    else begin

      let vb =

        GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in

      let fatLabel =

        GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

          ~text:"Select the following option if one of your \

                 directory is on a FAT partition.  This is typically \

                 the case for a USB stick."

          ~packing:(vb#pack ~expand:false) ()

      in

      adjustSize fatLabel;

      let fatButton =

        let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in

        al#set_left_padding 12;

        (GButton.check_button

           ~label:"Synchronization involving a _FAT partition"

           ~use_mnemonic:true ~active:false ~packing:(al#add) ())

      in

      GtkReact.toggle_button fatButton

    end

  in

  (* Fastcheck is safe except on FAT partitions and on Windows when

     not in Unicode mode where there is a very slight chance of

     missing an update when a file is moved onto another with the same

     modification time.  Nowadays, FAT is rarely used on working

     partitions.  In most cases, we should be in Unicode mode.

     Thus, it seems sensible to always enable fastcheck. *)

(*

  let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in

*)

  (* Unicode mode can be problematic when the source machine is under

     Windows and the remote machine is not, as Unison may have already

     been used using the legacy Latin 1 encoding.  Cygwin also did not

     handle Unicode before version 1.7. *)

  let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in

  let askUnicode = React.const false in

(* isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in*)

  GtkReact.show vb askUnicode;

  adjustSize

    (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT

       ~text:"When synchronizing in case insensitive mode, \

              Unison has to make some assumptions regarding \

              filename encoding.  If ensure, use Unicode."

       ~packing:(vb#pack ~expand:false) ());

  let vb =

    let al = GBin.alignment

      ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.vbox ~spacing:0 ~packing:(al#add) ()

  in

  ignore

    (GMisc.label ~xalign:0. ~text:"Filename encoding:"

       ~packing:(vb#pack ~expand:false) ());

  let hb =

    let al = GBin.alignment

      ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in

    al#set_left_padding 12;

    GPack.button_box `VERTICAL ~layout:`START

      ~spacing:0 ~packing:(al#add) ()

  in

  let unicodeButton =

    GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true

      ~packing:(hb#add) ()

  in

  ignore

    (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true

       ~group:unicodeButton#group ~packing:(hb#add) ());

(*

  let unicode =

    React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton)

  in

*)

  let p =

    assistant#append_page

      ~title:"Specific Options" ~complete:true

      ~page_type:`CONTENT

      options#as_widget

  in

  ignore

    (assistant#connect#prepare ~callback:(fun () ->

       if assistant#current_page = p &&

          not (Util.osType <> `Win32 || React.state askUnicode)

       then

         assistant#set_current_page (p + 1)));

  let conclusion =

    GMisc.label

      ~xpad:12 ~ypad:12

      ~text:"You have now finished filling in the profile.\n\n\

             Click \"Apply\" to create it."

    () in

  ignore

    (assistant#append_page

       ~title:"Done" ~complete:true

       ~page_type:`CONFIRM

       conclusion#as_widget);

  let profileName = ref None in

  let saveProfile () =

    let filename = Prefs.profilePathname (React.state name) in

    begin try

      let ch =

        System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename

      in

      Printf.fprintf ch "# Unison preferences\n";

      let label = React.state label in

      if label <> "" then Printf.fprintf ch "label = %s\n" label;

      Printf.fprintf ch "root = %s\n" (React.state firstDir);

      let secondDir = React.state secondDir in

      let host = React.state host in

      let user = match React.state user with "" -> None | u -> Some u in

      let secondRoot =

        match React.state kind with

          `Local  -> Clroot.ConnectLocal (Some secondDir)

        | `SSH    -> Clroot.ConnectByShell

                       ("ssh", host, user, None, Some secondDir)

        | `RSH    -> Clroot.ConnectByShell

                       ("rsh", host, user, None, Some secondDir)

        | `SOCKET -> Clroot.ConnectBySocket

                       (host, React.state port, Some secondDir)

      in

      Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot);

      if React.state compress && React.state kind = `SSH then

        Printf.fprintf ch "sshargs = -C\n";

(*

      if React.state fastcheck then

        Printf.fprintf ch "fastcheck = true\n";

      if React.state unicode then

        Printf.fprintf ch "unicode = true\n";

*)

      if React.state fat then Printf.fprintf ch "fat = true\n";

      close_out ch;

      profileName := Some (React.state name)

    with Sys_error _ as e ->

      okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile"

        ~message:(Uicommon.exn2string e)

    end;

    assistant#destroy ();

  in

  ignore (assistant#connect#close ~callback:saveProfile);

  ignore (assistant#connect#destroy ~callback:GMain.Main.quit);

  ignore (assistant#connect#cancel ~callback:assistant#destroy);

  assistant#show ();

  GMain.Main.main ();

  !profileName

(* ------ *)

let nameOfType t =

  match t with

    `BOOL        -> "boolean"

  | `BOOLDEF     -> "boolean"

  | `INT         -> "integer"

  | `STRING      -> "text"

  | `STRING_LIST -> "text list"

  | `CUSTOM      -> "custom"

  | `UNKNOWN     -> "unknown"

let defaultValue t =

  match t with

    `BOOL        -> ["true"]

  | `BOOLDEF     -> ["true"]

  | `INT         -> ["0"]

  | `STRING      -> [""]

  | `STRING_LIST -> []

  | `CUSTOM      -> []

  | `UNKNOWN     -> []

let editPreference parent nm ty vl =

  let t =

    GWindow.dialog ~parent ~border_width:12

      ~title:"Edit the Preference"

      ~modal:true () in

  let vb = t#vbox in

  vb#set_spacing 6;

  let isList =

    match ty with

      `STRING_LIST | `CUSTOM | `UNKNOWN -> true

    | _ -> false

  in

  let columns = if isList then 5 else 4 in

  let rows = if isList then 3 else 2 in

  let tbl =

    GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6

      ~packing:(vb#pack ~expand:false) () in

  ignore (GMisc.label ~text:"Preference:" ~xalign:0.

            ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());

  ignore (GMisc.label ~text:"Description:" ~xalign:0.

            ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());

  ignore (GMisc.label ~text:"Type:" ~xalign:0.

            ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ());

  ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true ()

            ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X));

  let (doc, _, _) = Prefs.documentation nm in

  ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true ()

            ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X));

  ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true ()

            ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X));

  let newValue =

    if isList then begin

      let valueLabel =

        GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0.

          ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()

      in

      let cols = new GTree.column_list in

      let c_value = cols#add Gobject.Data.string in

      let c_ml = cols#add Gobject.Data.caml in

      let lst_store = GTree.list_store cols in

      let lst =

        let sw =

          GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X)

            ~shadow_type:`IN ~height:200 ~width:400

            ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in

        GTree.view ~model:lst_store ~headers_visible:false

          ~reorderable:true ~packing:sw#add () in

      valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget));

      let column =

        GTree.view_column

          ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ()

      in

      ignore (lst#append_column column);

      let vb =

        GPack.button_box

          `VERTICAL ~layout:`START ~spacing:6

          ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) ()

      in

      let selection = GtkReact.tree_view_selection lst in

      let hasSel = selection >> fun l -> l <> [] in

      let addB =

        GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in

      let removeB =

        GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in

      let editB =

        GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in

      let upB =

        GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in

      let downB =

        GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in

      List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB];

      GtkReact.set_sensitive removeB hasSel;

      let editLabel =

        GMisc.label ~text:"Edited _item:"

          ~use_underline:true ~xalign:0.

          ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) ()

      in

      let editEntry =

        GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in

      editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget));

      let edit = GtkReact.entry editEntry in

      let edited =

        React.lift2

          (fun l txt ->

             match l with

               [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt

             | _    -> false)

          selection edit

      in

      GtkReact.set_sensitive editB edited;

      let selectionChange = GtkReact.tree_view_selection_changed lst in

      selectionChange >>| (fun s ->

        match s with

          [rf] -> editEntry#set_text

                    (lst_store#get ~row:rf#iter ~column:c_value)

        | _    -> ());

      let add () =

        let txt = editEntry#text in

        let row = lst_store#append () in

        lst_store#set ~row ~column:c_value txt;

        lst_store#set ~row ~column:c_ml txt;

        lst#selection#select_iter row;

        lst#scroll_to_cell (lst_store#get_path row) column

      in

      ignore (addB#connect#clicked ~callback:add);

      ignore (editEntry#connect#activate ~callback:add);

      let remove () =

        match React.state selection with

          [rf] -> let i = rf#iter in

                  if lst_store#iter_next i then

                    lst#selection#select_iter i

                  else begin

                    let p = rf#path in

                    if GTree.Path.prev p then

                      lst#selection#select_path p

                  end;

                  ignore (lst_store#remove rf#iter)

        | _    -> ()

      in

      ignore (removeB#connect#clicked ~callback:remove);

      let edit () =

        match React.state selection with

          [rf] -> let row = rf#iter in

                  let txt = editEntry#text in

                  lst_store#set ~row ~column:c_value txt;

                  lst_store#set ~row ~column:c_ml txt

        | _    -> ()

      in

      ignore (editB#connect#clicked ~callback:edit);

      let updateUpDown l =

        let (upS, downS) =

          match l with

              [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter)

          | _      -> (false, false)

        in

        upB#misc#set_sensitive upS;

        downB#misc#set_sensitive downS

      in

      selectionChange >>| updateUpDown;

      ignore (lst_store#connect#after#row_deleted

                ~callback:(fun _ -> updateUpDown (React.state selection)));

      let go_up () =

        match React.state selection with

          [rf] -> let p = rf#path in

                  if GTree.Path.prev p then begin

                    let i = rf#iter in

                    let i' = lst_store#get_iter p in

                    ignore (lst_store#swap i i');

                    lst#scroll_to_cell (lst_store#get_path i) column