diff options
| -rw-r--r-- | gui.ml | 91 | ||||
| -rw-r--r-- | main.ml | 112 | ||||
| -rw-r--r-- | vndbApi.ml | 2 |
3 files changed, 174 insertions, 31 deletions
@@ -14,18 +14,32 @@ class loginwin mainwin = let g_vbox = GPack.vbox ~packing:g_hbox#add () in (* input fields *) - let g_frm = GPack.table ~rows:3 ~columns:2 ~col_spacings:3 ~packing:g_vbox#add () in + 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 = GEdit.entry ~activates_default:true ~packing:(g_frm#attach ~left:1 ~top:1 ~expand:`NONE) () in - let g_frm_ulb = GMisc.label ~text:"Username:" ~xalign:1.0 ~mnemonic_widget:g_frm_usr ~packing:(g_frm#attach ~left:0 ~top:1 ~expand:`NONE) () in - let g_frm_pas = GEdit.entry ~activates_default:true ~packing:(g_frm#attach ~left:1 ~top:2 ~expand:`NONE) () in - let g_frm_plb = GMisc.label ~text:"Password:" ~xalign:1.0 ~mnemonic_widget:g_frm_pas ~packing:(g_frm#attach ~left:0 ~top:2 ~expand:`NONE) () 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 ~xalign:0.0 ~packing:(g_nfo#pack ~expand:true) () 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 @@ -43,26 +57,87 @@ class loginwin mainwin = 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_frm_usr#misc#grab_focus (); + 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 + 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; @@ -1,35 +1,82 @@ -(* blocking pollfunc, useful for testing the vndbApi outside of GTK * -let pollfunc sock read cb = - let _,_,_ = Unix.select - (if read then [sock] else []) - (if read then [] else [sock]) - [] (-.1.0) in - cb ();; -*) +(* global useful functions *) +let config_dir create = + let confdir = Filename.concat (Glib.get_user_config_dir ()) "Serika" in + if create then ( + try + Unix.mkdir confdir 0o700 + with Unix.Unix_error (Unix.EEXIST, _, _) -> () + ); + confdir -let _ = - ignore (GtkMain.Main.init ()); - let win = new Gui.mainwin () in - let api = new VndbApi.connection - (fun sock read cb -> - ignore (GMain.Io.add_watch ~cond:[if read then `IN else `OUT] - ~callback:(fun _ -> cb (); false) (Glib.Io.channel_of_descr sock))) - (fun sec cb -> win#set_throttled (sec+5) cb) - in +(* init GTK and create objects *) +let _ = GtkMain.Main.init () +let win = new Gui.mainwin () +let _ = win#show +let api = new VndbApi.connection + (fun sock read cb -> + ignore (GMain.Io.add_watch ~cond:[if read then `IN else `OUT] + ~callback:(fun _ -> cb (); false) (Glib.Io.channel_of_descr sock))) + (fun sec cb -> win#set_throttled (sec+5) cb) + +(* global API callbacks *) +let _ = api#set_linefunc (Some (fun sent str -> win#add_debuglog (if sent then `write else `read) (Str.replace_first (Str.regexp "\\(\"password\"[\r\n\t ]*:[\r\n\t ]*\"\\)[^\"]+\"") "\\1<secret>\"" str); win#add_bandwidth ((String.length str)+1); if not sent then win#incr_cmd_count )); + api#set_disconnectfunc (Some win#set_loggedout) + + + +(* login functions and callbacks *) - api#set_disconnectfunc (Some win#set_loggedout); +let login_read () = + let fn = Filename.concat (config_dir false) "login.json" in + let fd = open_in fn in + let obj = Json.json_of_channel fd in + close_in_noerr fd; + win#login#set_defaults ( + Json.get_bool (Json.get_value obj "anonymous"), + Json.get_string (Json.get_value obj "username"), + Json.get_string (Json.get_value obj "password"), + Json.get_string (Json.get_value obj "server"), + int_of_string (Json.get_int (Json.get_value obj "port")), + Json.get_bool (Json.get_value obj "remember"), + Json.get_bool (Json.get_value obj "autoconnect") + ) - win#login#set_on_connect (fun anon user pass -> +let login_write anon user pass serv port remem auto = + let fn = Filename.concat (config_dir true) "login.json" in + if remem then ( + let obj = Json.Object [ + ("anonymous", Json.Bool anon); + ("username", Json.String user); + ("password", Json.String (if anon || not auto then "" else pass)); + ("server", Json.String serv); + ("port", Json.Int (string_of_int port)); + ("remember", Json.Bool remem); + ("autoconnect", Json.Bool auto) + ] in + let fd = open_out fn in + output_string fd (Json.string_of_json obj); + close_out_noerr fd; + Unix.chmod fn 0o600 + ) else + Unix.unlink fn + +let _ = + (try login_read () with _ -> ()); + win#login#apply_defaults; + win#login#set_on_connect (fun (anon, user, pass, serv, port, remem, auto) -> + (try login_write anon user pass serv port remem auto with _ -> ()); + api#set_host serv; + api#set_port port; api#connect (fun ip port -> win#add_debuglog `status ("Connected to " ^ (Unix.string_of_inet_addr ip) ^ ":" ^ (string_of_int port)); win#login#set_connected; @@ -47,7 +94,12 @@ let _ = ) ) (fun _ _ msg -> win#login#failed ("Connection failed: "^msg)) ); + win#login#do_connect + + +(* running custom commands *) +let _ = win#set_on_debug_cmd (fun str -> win#statusmsg "Executing custom command..."; api#addcmd str (fun r -> @@ -59,8 +111,24 @@ let _ = "and error messages.") | _ -> () ) - ); + ) + + + +(* enter the mainloop *) +let _ = GMain.Main.main () + + + + - win#show; - GMain.Main.main () + +(* blocking pollfunc, useful for testing the vndbApi outside of GTK * +let pollfunc sock read cb = + let _,_,_ = Unix.select + (if read then [sock] else []) + (if read then [] else [sock]) + [] (-.1.0) in + cb ();; +*) @@ -29,7 +29,7 @@ class connection method get_host = s_host - method set_host h = s_host <- h + method set_host h = s_host <- h; s_addr <- None method get_port = s_port method set_port p = s_port <- p method get_addr = s_addr |