path: root/gui.ml

type debuglog_type = [`read | `write | `status]



class loginwin mainwin =
  (* window & layout *)
  let g_win = GWindow.window ~modal:true ~type_hint:`DIALOG ~position:`CENTER
    ~title:"Serika Login" ~border_width:5 ~width:400 ~resizable:false () in
  let _ = g_win#set_transient_for mainwin in
  let _ = g_win#set_destroy_with_parent true in
  let g_hbox = GPack.hbox ~packing:g_win#add () in
  let _ = GMisc.image ~stock:`DIALOG_AUTHENTICATION ~icon_size:`DIALOG ~yalign:0.2 ~packing:(g_hbox#pack ~expand:false) () in
  let g_vbox = GPack.vbox ~packing:g_hbox#add () in

  (* input fields *)
  let inputfield (tbl:GPack.table) top label entry =
    let align = GBin.alignment ~xscale:0.0 ~xalign:0.0 ~packing:(tbl#attach ~left:1 ~top:top ~expand:`X ~fill:`X) () in
    let lbl = GMisc.label ~width:80 ~text:label ~xalign:1.0 ~mnemonic_widget:entry ~packing:(tbl#attach ~left:0 ~top:top ~expand:`NONE) () in
    align#add entry#coerce;
    (entry, lbl)
  in
  let g_frm = GPack.table ~rows:4 ~columns:2 ~col_spacings:3 ~packing:g_vbox#add () in
  let g_frm_ano = GButton.check_button ~label:"Connect anonymously" ~packing:(g_frm#attach ~left:0 ~top:0 ~right:2) () in
  let (g_frm_usr, g_frm_ulb) = inputfield g_frm 1 "Username:" (GEdit.entry ~activates_default:true ()) in
  let (g_frm_pas, g_frm_plb) = inputfield g_frm 2 "Password:" (GEdit.entry ~activates_default:true ~visibility:false ()) in
  (* advanced *)
  let g_frm_exp = GBin.expander ~expanded:false ~label:"Advanced" ~packing:(g_frm#attach ~left:0 ~top:3 ~right:2 ~ypadding:5) () in
  let g_frm_atb = GPack.table ~rows:4 ~columns:2 ~col_spacings:3 ~packing:g_frm_exp#add () in
  let (g_frm_ser, _) = inputfield g_frm_atb 0 "Server:" (GEdit.entry ~activates_default:true ()) in
  let (g_frm_por, _) = inputfield g_frm_atb 1 "Port:" (GEdit.spin_button ~snap_to_ticks:true ()) in
  let g_frm_rem = GButton.check_button ~label:"Remember login settings (except password)" ~packing:(g_frm_atb#attach ~left:0 ~top:2 ~right:2) () in
  let g_frm_aut = GButton.check_button ~label:"Automatically login on startup" ~packing:(g_frm_atb#attach ~left:0 ~top:3 ~right:2) () in
  (* some input settings *)
  let _ = g_frm_pas#set_visibility false in
  let g_frm_port = g_frm_por#adjustment in
  let _ = g_frm_port#set_bounds ~lower:1.0 ~upper:65535.0 ~step_incr:1.0 () in

  (* info part *)
  let g_nfo     = GPack.hbox ~spacing:5 ~packing:(g_vbox#pack ~expand:false ~padding:5) () in
  let g_nfo_img = GMisc.image ~stock:`DIALOG_WARNING ~packing:(g_nfo#pack ~expand:false) () in
  let g_nfo_lbl = GMisc.label ~line_wrap:true ~selectable:true ~xalign:0.0 ~packing:(g_nfo#pack ~expand:true ~fill:true) () in

  (* buttons *)
  let g_but     = GPack.button_box `HORIZONTAL ~spacing:10 ~layout:`END ~packing:(g_vbox#pack ~expand:false) () in
  let g_but_con = GButton.button ~stock:`CONNECT ~packing:g_but#add () in
  let g_but_can = GButton.button ~stock:`CANCEL  ~packing:g_but#add () in
  let _ = g_but_can#connect#clicked g_win#misc#hide in
  let _ = g_but_con#misc#set_can_default true in
  let _ = g_but_con#misc#grab_default () in

  (* set user/pass sensitivity *)
  let _ = g_frm_ano#connect#toggled (fun () ->
    g_frm_usr#misc#set_sensitive (not g_frm_ano#active);
    g_frm_ulb#misc#set_sensitive (not g_frm_ano#active);
    g_frm_pas#misc#set_sensitive (not g_frm_ano#active);
    g_frm_plb#misc#set_sensitive (not g_frm_ano#active)
  ) in

  (* set autologin sensitivity *)
  let _ = g_frm_aut#misc#set_sensitive false in
  let _ = g_frm_rem#connect#toggled (fun () ->
    g_frm_aut#misc#set_sensitive g_frm_rem#active;
    if not g_frm_rem#active then g_frm_aut#set_active false
  ) in

  (* warn about saving password *)
  let g_warnpass_d = GWindow.message_dialog ~message:("Your password will be"
    ^" saved without encryption and could possibly be read by other users on"
    ^" this computer. Are you sure you want to enable auto-connect?")
    ~title:"Confirm saving your password" ~buttons:GWindow.Buttons.yes_no
    ~parent:g_win ~message_type:`WARNING () in
  let g_warnpass_block = ref false in
  let g_warnpass () =
    if not !g_warnpass_block && g_frm_aut#active && not g_frm_ano#active then (
      g_warnpass_block := true;
      g_frm_aut#set_active ((g_warnpass_d#run ()) = `YES);
      g_warnpass_block := false;
      g_warnpass_d#misc#hide ()
    )
  in
  let _ = g_frm_aut#connect#toggled g_warnpass in
  let _ = g_frm_ano#connect#toggled g_warnpass in

  (* the object *)
  object (self)
    val mutable defaults = (false, "", "", "api.vndb.org", 19534, false, false)

    method private statusmsg img msg =
      g_nfo_img#set_stock img;
      g_nfo_lbl#set_text msg

    method set_defaults d = defaults <- d

    method apply_defaults =
      match defaults with
      | (anon, user, pass, serv, port, remem, auto) ->
        g_warnpass_block := true;
        g_frm_ano#set_active anon;
        g_frm_usr#set_text user;
        g_frm_pas#set_text pass;
        g_frm_ser#set_text serv;
        g_frm_port#set_value (float port);
        g_frm_rem#set_active remem;
        g_frm_aut#set_active auto;
        g_warnpass_block := false

    method show =
      if not g_win#misc#visible then (
        self#statusmsg `DIALOG_WARNING "Note: The application might hang while connecting. Feel free to kill it when it takes too long.";
        g_but_con#misc#set_sensitive true;
        g_frm#misc#set_sensitive true;
        if String.length g_frm_usr#text = 0 then
          g_frm_usr#misc#grab_focus ()
        else
          g_frm_pas#misc#grab_focus ();
        g_win#show ()
      )

    method hide = g_win#misc#hide ()

    method do_connect =
      match defaults with
      | (_,_,_,_,_,_,true) -> g_but_con#clicked ()
      | _ -> ()

    method set_on_connect f =
      ignore (g_but_con#connect#clicked (fun () ->
        g_but_con#misc#set_sensitive false;
        g_frm#misc#set_sensitive false;
        ignore (self#statusmsg `DIALOG_INFO "Connecting...");
        f (g_frm_ano#active,
           g_frm_usr#text,
           g_frm_pas#text,
           g_frm_ser#text,
           (int_of_float g_frm_port#value),
           g_frm_rem#active,
           g_frm_aut#active)
      ))

    method set_connected = self#statusmsg `DIALOG_INFO "Connected, logging in..."

    method failed msg =
      self#statusmsg `DIALOG_ERROR msg;
      g_but_con#misc#set_sensitive true;
      g_frm#misc#set_sensitive true;
      g_frm_usr#misc#grab_focus ()
  end



class mainwin () =
  (* main window layout *)
  let g_win = GWindow.window ~title:"Serika" ~position:`CENTER () in
  let _ = g_win#set_default_width 640 and _ = g_win#set_default_height 480 in
  let g_vbox = GPack.vbox ~packing:g_win#add () in
  let g_menu = GMenu.menu_bar ~packing:(g_vbox#pack ~expand:false) () in
  let g_tabs = GPack.notebook ~packing:g_vbox#add () in
  let g_status = GMisc.statusbar ~packing:(g_vbox#pack ~expand:false) () in

  (* menu bar *)
  let g_menu_file = GMenu.menu_item ~label:"_File" ~use_mnemonic:true ~packing:g_menu#append () in
  let g_menu_file_m = GMenu.menu ~packing:g_menu_file#set_submenu () in
  let g_menu_file_con    = GMenu.image_menu_item ~stock:`CONNECT ~label:"Co_nnect" ~use_mnemonic:true ~packing:g_menu_file_m#append () in
  let g_menu_file_discon = GMenu.image_menu_item ~stock:`DISCONNECT ~label:"_Disconnect" ~use_mnemonic:true ~packing:g_menu_file_m#append () in
  let _ = GMenu.separator_item ~packing:g_menu_file_m#append () in
  let g_menu_file_quit   = GMenu.image_menu_item ~stock:`QUIT       ~label:"_Close" ~use_mnemonic:true ~packing:g_menu_file_m#append () in

  (* debug tab *)
  let g_debug_tbl = GPack.table ~rows:2 ~columns:2 () in
  let g_debug_scroll = GBin.scrolled_window ~vpolicy:`ALWAYS ~hpolicy:`AUTOMATIC ~packing:(g_debug_tbl#attach ~left:0 ~top:0 ~right:2 ~expand:`BOTH) () in
  let g_debug = GText.view ~editable:false ~wrap_mode:`CHAR ~packing:g_debug_scroll#add () in
  let g_debug_cmd = GEdit.entry ~activates_default:true ~packing:(g_debug_tbl#attach ~left:0 ~top:1 ~expand:`X) () in
  let g_debug_send = GButton.button ~label:"_Send command" ~use_mnemonic:true ~packing:(g_debug_tbl#attach ~left:1 ~top:1 ~expand:`NONE) () in
  let _ = g_tabs#append_page ~tab_label:((GMisc.label ~text:"Debug" ())#coerce) g_debug_tbl#coerce in
  let _ = g_debug_cmd#connect#activate (fun () -> ignore (g_debug_send#misc#activate ())) in

  (* status bar *)
  let g_statuscontext = g_status#new_context ~name:"Meh" in
  let g_bandwidth   = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~xalign:1.0 ~width:80 ~text:"0.0 kB" () in
  let g_cmd_count   = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~xalign:1.0 ~width:30 ~text:"0" () in
  let g_loggedinusr = GMisc.label ~packing:(g_status#pack ~from:`END ~expand:false) ~xalign:1.0 ~text:"-" () in

  (* coloring and marking for the debug textview *)
  let _ = g_debug#buffer#create_tag  ~name:"read"   [`FOREGROUND "#cc6666"] in
  let _ = g_debug#buffer#create_tag  ~name:"write"  [`FOREGROUND "#6666cc"] in
  let _ = g_debug#buffer#create_tag  ~name:"prefix" [`WEIGHT `LIGHT] in
  let _ = g_debug#buffer#create_mark ~name:"end" ~left_gravity:false g_debug#buffer#end_iter in

  (* login window *)
  let login = new loginwin g_win#as_window in

  (* connect events *)
  let _ = g_win#connect#destroy GMain.Main.quit in
  let _ = g_menu_file_quit#connect#activate GMain.Main.quit in

  (* the object *)
  object (self)
    val mutable bandwidth = 0
    val mutable cmd_count = 0
    val mutable laststatusmsg = g_statuscontext#push "Not connected."

    val ugly_init =
      g_menu_file_con#connect#activate (fun () -> login#show)

    method show =
      self#set_sensitive false;
      g_win#show ();
      login#show

    method set_on_disconnect f = ignore (g_menu_file_discon#connect#activate f)

    method set_on_debug_cmd f =
      ignore (g_debug_send#connect#clicked (fun () ->
        f (g_debug_cmd#text)
      ))

    method login = login

    (* updates widget sensitivity according to whether we're connected or not *)
    method set_sensitive b =
      g_debug_send#misc#set_sensitive b;
      g_menu_file_discon#misc#set_sensitive b;
      g_menu_file_con#misc#set_sensitive (not b)

    method set_loggedin user =
      login#hide;
      self#statusmsg "Login successful.";
      g_loggedinusr#set_text user;
      self#set_sensitive true

    method set_loggedout () =
      login#show;
      self#statusmsg "Not connected.";
      g_loggedinusr#set_text "-";
      self#set_sensitive false

    method statusmsg str =
      let msg = g_statuscontext#push str in
      g_statuscontext#remove laststatusmsg;
      laststatusmsg <- msg;
      self#add_debuglog `status str

    method add_bandwidth s =
      bandwidth <- bandwidth+s;
      g_bandwidth#set_text (Printf.sprintf "%.1f kB" ((float bandwidth) /. 1024.0))

    method incr_cmd_count =
      cmd_count <- cmd_count+1;
      g_cmd_count#set_text (string_of_int cmd_count)

    method add_debuglog (t : debuglog_type) str =
      let tm = Unix.localtime (Unix.time ()) in
      let time = Printf.sprintf "[%02d:%02d:%02d] " tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
      let tags, prefix = match t with
      | `read   -> (["read"],   "< ")
      | `write  -> (["write"],  "> ")
      | `status -> ([],         "= ") in
      let buf = g_debug#buffer in
      buf#insert ~iter:buf#end_iter ~tag_names:["prefix"] (time ^ prefix);
      buf#insert ~iter:buf#end_iter ~tag_names:tags str;
      buf#insert ~iter:buf#end_iter "\n";
      g_debug#scroll_mark_onscreen (`NAME "end")

    method set_throttled sec (cb : (unit -> unit)) =
      let togo = ref sec in
      self#set_sensitive false;
      let secfunc () =
        togo := !togo - 1;
        if !togo < 1 then (
          self#set_sensitive true;
          cb ();
          false
        ) else (
          g_statuscontext#flash ~delay:1000 ("Throttled. Waiting "
            ^(string_of_int !togo)^" seconds before continuing...");
          true
        )
      in
      ignore (GMain.Timeout.add ~ms:1000 ~callback:secfunc)

  end