[Tkabber-dev] r2085 - in trunk/tkabber-plugins: . otr otr/tclotr

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Jan 24 00:00:16 MSK 2014


Author: sergei
Date: 2014-01-24 00:00:16 +0400 (Fri, 24 Jan 2014)
New Revision: 2085

Added:
   trunk/tkabber-plugins/otr/key.tcl
Modified:
   trunk/tkabber-plugins/ChangeLog
   trunk/tkabber-plugins/otr/otr.tcl
   trunk/tkabber-plugins/otr/tclotr/key.tcl
Log:
	* otr/key.tcl, otr/tclotr/key.tcl, otr/otr.tcl: Implemented simple GUI
	  for managing OTR private DSA keys (currently importing, exporting,
	  deleting keys are supported).


Modified: trunk/tkabber-plugins/ChangeLog
===================================================================
--- trunk/tkabber-plugins/ChangeLog	2014-01-23 16:09:01 UTC (rev 2084)
+++ trunk/tkabber-plugins/ChangeLog	2014-01-23 20:00:16 UTC (rev 2085)
@@ -15,6 +15,10 @@
 
 	* otr/pixmaps/otr/notprivate.gif: Fixed the right edge.
 
+	* otr/key.tcl, otr/tclotr/key.tcl, otr/otr.tcl: Implemented simple GUI
+	  for managing OTR private DSA keys (currently importing, exporting,
+	  deleting keys are supported).
+
 2014-01-22  Sergei Golovan <sgolovan at nes.ru>
 
 	* otr/auth.tcl, otr/otr.tcl, otr/tclotr/otr.tcl: Store the

Added: trunk/tkabber-plugins/otr/key.tcl
===================================================================
--- trunk/tkabber-plugins/otr/key.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/otr/key.tcl	2014-01-23 20:00:16 UTC (rev 2085)
@@ -0,0 +1,315 @@
+# $Id$
+
+namespace eval key {
+    set ns http://tkabber.jabber.ru/otr
+    set otrdir [file join $::configdir otr]
+    if {![file exists $otrdir]} {
+	file mkdir $otrdir
+	catch {file attributes $otrdir -permissions 0700}
+    }
+    # State variable with all key data
+    set Keys [dict create]
+
+    hook::add finload_hook [namespace current]::restore
+}
+
+proc key::store {keys} {
+    variable otrdir
+
+    if {![catch {
+	    set fd [open [file join $otrdir keys.xml.new] w]
+	    fconfigure $fd -encoding utf-8
+
+	    puts $fd {<?xml version="1.0" encoding="UTF-8"?>}
+	    puts $fd [serialize_keys $keys]
+
+	    close $fd
+	} res]} {
+	file rename -force -- [file join $otrdir keys.xml.new] \
+			      [file join $otrdir keys.xml]
+    }
+}
+
+proc key::serialize_keys {keys} {
+    variable ns
+
+    set subtags {}
+    dict for {jid val} $keys {
+	lappend subtags [serialize_key $jid $val]
+    }
+
+    ::xmpp::xml::toTabbedText [::xmpp::xml::create privkeys \
+					-xmlns $ns \
+					-subelements $subtags]
+}
+
+proc key::serialize_key {jid key} {
+    variable ns
+
+    set attrs [list jid	 $jid \
+		    type DSA \
+		    p	 [format %llx [lindex $key 0]] \
+		    q	 [format %llx [lindex $key 1]] \
+		    g	 [format %llx [lindex $key 2]] \
+		    y	 [format %llx [lindex $key 3]] \
+		    x	 [format %llx [lindex $key 4]]]
+
+    ::xmpp::xml::create key -xmlns $ns \
+			    -attrs $attrs
+}
+
+proc key::restore {} {
+    variable otrdir
+    variable Keys
+
+    if {[catch {set fd [open [file join $otrdir keys.xml]]}]} {
+	return [dict create]
+    }
+
+    set data [read $fd]
+    close $fd
+
+    set Keys [deserialize_keys [lindex [::xmpp::xml::parseData $data] 0]]
+}
+
+proc key::deserialize_keys {xmlel} {
+    variable ns
+
+    ::xmpp::xml::split $xmlel tag xmlns attrs cdata subels
+
+    if {$tag ne "privkeys"} {
+	return -code error "The root element must be 'privkeys'"
+    }
+    if {$xmlns ne $ns} {
+	return -code error "The namespace must be '$ns'"
+    }
+    set keys [dict create]
+    foreach subel $subels {
+	::xmpp::xml::split $subel tag1 xmlns1 attrs1 cdata1 subels1
+	if {[::xmpp::xml::getAttr $attrs1 type] eq "DSA"} {
+	    scan [::xmpp::xml::getAttr $attrs1 p] %llx p
+	    scan [::xmpp::xml::getAttr $attrs1 q] %llx q
+	    scan [::xmpp::xml::getAttr $attrs1 g] %llx g
+	    scan [::xmpp::xml::getAttr $attrs1 y] %llx y
+	    scan [::xmpp::xml::getAttr $attrs1 x] %llx x
+	    dict set keys [::xmpp::xml::getAttr $attrs1 jid] \
+			  [list $p $q $g $y $x]
+	}
+    }
+    set keys
+}
+
+proc key::set_key {vkeys jid key} {
+    upvar $vkeys keys
+
+    set jid [::xmpp::jid::normalize $jid]
+    dict set keys $jid $key
+    set keys
+}
+
+proc key::del_key {vkeys jid} {
+    upvar $vkeys keys
+
+    set jid [::xmpp::jid::normalize $jid]
+    if {[dict exists $keys $jid]} {
+	dict unset keys $myjid
+    }
+    set keys
+}
+
+proc key::get_key {keys jid} {
+    set jid [::xmpp::jid::normalize $jid]
+    if {[catch {dict get $keys $jid} res]} {
+	return {}
+    } else {
+	return $res
+    }
+}
+
+proc key::manage_keys_dialog {} {
+    variable Keys
+    variable keyjid
+    variable progress
+    variable help
+    variable fingerprint
+
+    set w .otreditkeys
+
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    Dialog $w -title [::msgcat::mc "Manage OTR private keys"] \
+	      -separator 1 -anchor e -default 0 -cancel 0
+
+    set f [$w getframe]
+
+    $w add -text [::msgcat::mc "Close"] \
+	   -command [list destroy $w]
+
+    # Start with the existing keys
+    set jids [lsort [dict keys $Keys]]
+    # Next, the existing connections
+    foreach connid [connections] {
+	lappend jids \
+	       [::xmpp::jid::normalize [::xmpp::jid::removeResource $connid]]
+    }
+    # Next the existing profiles
+    for {set i 1} {[info exists ::loginconf$i]} {incr i} {
+	upvar #0 ::loginconf$i loginconf
+	if {$loginconf(user) ne "" && $loginconf(server) ne ""} {
+	    lappend jids [::xmpp::jid::normalize \
+			[::xmpp::jid::jid $loginconf(user) $loginconf(server)]]
+	}
+    }
+    # Finally, the ::loginconf
+    if {$::loginconf(user) ne "" && $::loginconf(server) ne ""} {
+	lappend jids [::xmpp::jid::normalize \
+			[::xmpp::jid::jid $::loginconf(user) $::loginconf(server)]]
+    }
+    set jids [lsort -unique -dictionary $jids]
+
+    if {[llength [connections]] > 0} {
+	set keyjid [::xmpp::jid::normalize \
+	    [::xmpp::jid::removeResource [connection_jid [lindex [connections] 0]]]]
+    } else {
+	set keyjid [lindex $jids 0]
+    }
+
+    trace add variable [namespace current]::keyjid write \
+	  [namespace code [list fill_dialog $w $f]]
+
+    bind $w <Destroy> [list unset -nocomplain [namespace current]::keyjid]
+    bind $w <Destroy> +[list unset -nocomplain [namespace current]::progress]
+    bind $w <Destroy> +[list unset -nocomplain [namespace current]::help]
+    bind $w <Destroy> +[list unset -nocomplain [namespace current]::fingerprint]
+
+    message $f.header -text [::msgcat::mc "Manage OTR long term DSA private key for your JID"] \
+		      -width 12c
+    grid $f.header -row 0 -column 0 -columnspan 2 -sticky nsew
+
+    tk_optionMenu $f.jid [namespace current]::keyjid {*}$jids
+    grid $f.jid -row 1 -column 0 -columnspan 2 -sticky ew
+
+    message $f.help -textvariable [namespace current]::help -width 12c
+    grid $f.help -row 2 -column 0 -columnspan 2 -sticky nsew
+
+    message $f.fingerprint -textvariable [namespace current]::fingerprint -width 12c
+    grid $f.fingerprint -row 3 -column 0 -columnspan 2 -sticky nsew
+
+    button $f.import -text [::msgcat::mc "Import key..."] \
+		-command [namespace code [list import_key $w]]
+    grid $f.import -row 4 -column 0 -sticky nsew
+
+    button $f.export -text [::msgcat::mc "Export key..."] \
+		-command [namespace code [list export_key $w]]
+    grid $f.export -row 4 -column 1 -sticky nsew
+
+    button $f.gen -text [::msgcat::mc "Generate new key"] -state disabled \
+		-command [namespace code [list generate_key $w]]
+    grid $f.gen -row 5 -column 0 -sticky nsew
+
+    button $f.delete -text [::msgcat::mc "Delete key"] \
+		-command [namespace code [list delete_key $w]]
+    grid $f.delete -row 5 -column 1 -sticky nsew
+
+    ProgressBar $f.pb -variable [namespace current]::progress \
+		      -maximum 50 \
+		      -type infinite
+    grid $f.pb -row 6 -column 0 -columnspan 2 -sticky ew
+
+    frame $f.f -width 12c -height 0m
+    grid $f.f -row 7 -column 0 -columnspan 2 -sticky ew
+
+    fill_dialog $w
+
+    $w draw
+}
+
+proc key::fill_dialog {w args} {
+    variable Keys
+    variable keyjid
+    variable help
+    variable fingerprint
+
+    if {![winfo exists $w]} return
+
+    set f [$w getframe]
+
+    if {[dict exists $Keys $keyjid]} {
+	set help [::msgcat::mc "The fingerprint of your long term OTR DSA private\
+			key for this JID is the following:"]
+	set key [dict get $Keys $keyjid]
+	binary scan [::otr::crypto::DSAFingerprint $key] Iu* nums
+	set res {}
+	foreach n $nums {
+	    lappend res [format %X $n]
+	}
+	set fingerprint $res
+	$f.import configure -state normal
+	$f.export configure -state normal
+	# TODO: generate new key
+	#$f.gen configure -state normal
+	$f.delete configure -state normal
+    join $res
+    } else {
+	set help [::msgcat::mc "You don't have a private DSA key for this JID.\
+		    Either import a 1024 bit DSA private key, or generate one."]
+	set fingerprint ""
+	$f.import configure -state normal
+	$f.export configure -state disabled
+	# TODO: generate new key
+	#$f.gen configure -state normal
+	$f.delete configure -state disabled
+    }
+}
+
+proc key::import_key {w} {
+    variable Keys
+    variable keyjid
+
+    set filename [tk_getOpenFile \
+		      -initialdir $::configdir \
+		      -filetypes [list [list [::msgcat::mc "Key files"] *.key] \
+				      [list [::msgcat::mc "All files"] *]]]
+    if {$filename == ""} return
+
+    if {![file readable $filename]} return
+
+    if {[catch {::otr::key::readPEM $filename} key]} return
+
+    dict set Keys $keyjid $key
+    store $Keys
+
+    # TODO: Drop all OTR sessions for the old key
+
+    fill_dialog $w
+}
+
+proc key::export_key {w} {
+    variable Keys
+    variable keyjid
+
+    set filename [tk_getSaveFile \
+		      -initialdir $::configdir \
+		      -initialfile otr-$keyjid.key \
+		      -filetypes [list [list [::msgcat::mc "Key files"] *.key] \
+				      [list [::msgcat::mc "All files"] *]]]
+    if {$filename == ""} return
+
+    set key [dict get $Keys $keyjid]
+
+    ::otr::key::writePEM $key $filename
+}
+
+proc key::delete_key {w} {
+    variable Keys
+    variable keyjid
+
+    dict unset Keys $keyjid
+    store $Keys
+
+    # TODO: Drop all OTR sessions for this key
+
+    fill_dialog $w
+}


Property changes on: trunk/tkabber-plugins/otr/key.tcl
___________________________________________________________________
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+Author Date Id Revision
\ No newline at end of property
Modified: trunk/tkabber-plugins/otr/otr.tcl
===================================================================
--- trunk/tkabber-plugins/otr/otr.tcl	2014-01-23 16:09:01 UTC (rev 2084)
+++ trunk/tkabber-plugins/otr/otr.tcl	2014-01-23 20:00:16 UTC (rev 2085)
@@ -30,17 +30,8 @@
     }
 
     source [file join $scriptdir auth.tcl]
+    source [file join $scriptdir key.tcl]
 
-    # TODO: DSA private key management
-    set keyfile [file join $::configdir otr.private.key.pem]
-    if {![file readable $keyfile]} {
-	puts stderr "To use the OTR plugin, generate your DSA private key\
-		     and save it into $keyfile file."
-	return
-    }
-
-    set ::OTRPrivateKey [::otr::key::readPEM $keyfile]
-
     # Auxiliary namespace. Rewrite_message_hook will use it to add some
     # supplemetary info.
     set ns tkabber:otr
@@ -179,10 +170,18 @@
 
     debugmsg otr "ONCE_ONLY $xlib $jid"
 
-    if {[info exists ctx($xlib,$jid)]} return
+    if {[info exists ctx($xlib,$jid)]} {
+	return 1
+    }
 
+    set myjid [::xmpp::jid::removeResource [connection_jid $xlib]]
+    set privkey [key::get_key $key::Keys $myjid]
+    if {[llength $privkey] == 0} {
+	return 0
+    }
+
     set ctx($xlib,$jid) \
-	[::otr::new $::OTRPrivateKey \
+	[::otr::new $privkey \
 		-policy [get_policy $xlib $jid] \
 		-authstatecommand [namespace code [list on_authstate_change $xlib $jid]] \
 		-msgstatecommand [namespace code [list on_msgstate_change $xlib $jid]] \
@@ -191,6 +190,7 @@
 		-infocommand [namespace code [list show_info $xlib $jid]] \
 		-errorcommand [namespace code [list show_error $xlib $jid]] \
 		-sendcommand [namespace code [list send $xlib $jid]]]
+    return 1
 }
 
 #############################################################################
@@ -832,7 +832,7 @@
     # body, so be it
     if {$body eq ""} return
 
-    once_only $xlib $from
+    if {![once_only $xlib $from]} return
 
     set result [::otr::incomingMessage $ctx($xlib,$from) $body] 
 
@@ -915,7 +915,7 @@
     # Only messages with body are subject to OTR
     if {![info exists body]} return
 
-    once_only $xlib $to
+    if {![once_only $xlib $to]} return
 
     # Only the message body is encrypted if appropriate
     set result [::otr::outgoingMessage $ctx($xlib,$to) $body]
@@ -1002,8 +1002,6 @@
     set jid [chat::get_jid $chatid]
     set cw [chat::winid $chatid]
 
-    once_only $xlib $jid
-
     Button $cw.status.otrmsgstate \
 	   -relief flat \
            -image [msgstate:icon $xlib $jid] \
@@ -1134,6 +1132,8 @@
 
 	set mm .otr_menu
 	menu $mm -tearoff $::ifacetk::options(show_tearoffs)
+	$mm add command -label [::msgcat::mc "Manage private keys"] \
+	    -command [namespace code key::manage_keys_dialog]
 	$mm add command -label [::msgcat::mc "Edit authentication"] \
 	    -command [namespace code auth::edit_auth_dialog]
 	$mm add separator
@@ -1175,27 +1175,33 @@
 	}
     }
 
-    once_only $xlib $jid
-
-    switch -- $ctx(msgstate,$xlib,$jid) {
-	MSGSTATE_PLAINTEXT {
-	    set qstate normal
-	    set rstate disabled
-	    set fstate disabled
-	    set astate disabled
+    if {![once_only $xlib $jid]} {
+	set state disabled
+	set qstate disabled
+	set rstate disabled
+	set fstate disabled
+	set astate disabled
+    } else {
+	switch -- $ctx(msgstate,$xlib,$jid) {
+	    MSGSTATE_PLAINTEXT {
+		set qstate normal
+		set rstate disabled
+		set fstate disabled
+		set astate disabled
+	    }
+	    MSGSTATE_ENCRYPTED {
+		set qstate disabled
+		set rstate normal
+		set fstate normal
+		set astate normal
+	    }
+	    MSGSTATE_FINISHED {
+		set qstate disabled
+		set rstate normal
+		set fstate normal
+		set astate disabled
+	    }
 	}
-	MSGSTATE_ENCRYPTED {
-	    set qstate disabled
-	    set rstate normal
-	    set fstate normal
-	    set astate normal
-	}
-	MSGSTATE_FINISHED {
-	    set qstate disabled
-	    set rstate normal
-	    set fstate normal
-	    set astate disabled
-	}
     }
 
     set mm $m.otr_menu
@@ -1235,11 +1241,10 @@
     $m add cascade -label [::msgcat::mc "OTR"] -menu $mm -state $state
 }
 
-hook::add chat_create_user_menu_hook [list [namespace current]::otr::user_menu chat] 78.5
-hook::add roster_conference_popup_menu_hook [list [namespace current]::otr::user_menu ""] 78.5
-hook::add roster_service_popup_menu_hook [list [namespace current]::otr::user_menu ""] 78.5
-hook::add roster_jid_popup_menu_hook [list [namespace current]::otr::user_menu ""] 78.5
-hook::add message_dialog_menu_hook [list [namespace current]::otr::user_menu ""] 78.5
+hook::add chat_create_user_menu_hook [list [namespace current]::otr::user_menu chat] 43.8
+hook::add roster_jid_popup_menu_hook [list [namespace current]::otr::user_menu ""] 43.8
+hook::add message_dialog_menu_hook [list [namespace current]::otr::user_menu ""] 43.8
+hook::add roster_create_groupchat_user_menu_hook [list [namespace current]::otr::user_menu ""] 43.8
 
 ###############################################################################
 

Modified: trunk/tkabber-plugins/otr/tclotr/key.tcl
===================================================================
--- trunk/tkabber-plugins/otr/tclotr/key.tcl	2014-01-23 16:09:01 UTC (rev 2084)
+++ trunk/tkabber-plugins/otr/tclotr/key.tcl	2014-01-23 20:00:16 UTC (rev 2085)
@@ -66,4 +66,11 @@
     decodePEM $data
 }
 
+proc ::otr::key::writePEM {key file} {
+    set fd [open $file w]
+    set data [encodePEM $key]
+    puts $fd $data
+    close $fd
+}
+
 # vim:ts=8:sw=4:sts=4:et



More information about the Tkabber-dev mailing list