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

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Tue Jan 21 22:36:17 MSK 2014


Author: sergei
Date: 2014-01-21 22:36:17 +0400 (Tue, 21 Jan 2014)
New Revision: 2076

Added:
   trunk/tkabber-plugins/otr/auth.tcl
Modified:
   trunk/tkabber-plugins/ChangeLog
   trunk/tkabber-plugins/otr/tclotr/key.tcl
Log:
	* otr/auth.tcl: Implemented authentication storing and restoring
	  infrastructure for future use (untested yet).


Modified: trunk/tkabber-plugins/ChangeLog
===================================================================
--- trunk/tkabber-plugins/ChangeLog	2014-01-21 16:24:29 UTC (rev 2075)
+++ trunk/tkabber-plugins/ChangeLog	2014-01-21 18:36:17 UTC (rev 2076)
@@ -15,6 +15,9 @@
 	* otr/tclotr/otr.tcl: Attach the OTR whitespace tag only if there
 	  weren't received plaintext messages from the peer before.
 
+	* otr/auth.tcl: Implemented authentication storing and restoring
+	  infrastructure for future use (untested yet).
+
 2014-01-20  Sergei Golovan <sgolovan at nes.ru>
 
 	* otr/tclotr/otr.tcl: Do not send the OTR query message after an OTR

Added: trunk/tkabber-plugins/otr/auth.tcl
===================================================================
--- trunk/tkabber-plugins/otr/auth.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/otr/auth.tcl	2014-01-21 18:36:17 UTC (rev 2076)
@@ -0,0 +1,123 @@
+# $Id$
+
+namespace eval auth {
+    set ns http://tkabber.jabber.ru/otr
+    set otrdir [file join $::configdir otr]
+    if {![file exists $otrdir]} {
+	file mkdir $otrdir
+	catch {file attributes -permissions 0700 $otrdir}
+    }
+}
+
+proc auth::store {auth} {
+    variable otrdir
+
+    if {![catch {
+	    set fd [open [file join $otrdir auth.xml.new] w]
+	    fconfigure $fd -encoding utf-8
+
+	    puts $fd {<?xml version="1.0" encoding="UTF-8"?>}
+	    puts $fd [serialize_auth $auth]
+
+	    close $fd
+	}]} {
+	file rename [file join $otrdir auth.xml.new] [file join $otrdir auth.xml]
+    }
+}
+
+proc auth::serialize_auth {auth} {
+    variable ns
+
+    set subtags {}
+    dict for {jid val} $auth {
+	lappend subtags [serialize_auth_items $jid $val]
+    }
+
+    ::xmpp::xml::toTabbedText [::xmpp::xml::create authentication \
+					-xmlns $ns \
+					-subelements $subtags]
+}
+
+proc auth::serialize_auth_items {jid items} {
+    variable ns
+
+    set subtags {}
+    dict for {item val} $items {
+	lappend subtags [serialize_auth_item $item $val]
+    }
+
+    ::xmpp::xml::toTabbedText [::xmpp::xml::create profile \
+					-xmlns $ns \
+					-attrs [list jid $jid]
+					-subelements $subtags]
+}
+
+proc auth::serialize_auth_item {item val} {
+    variable ns
+
+    lassign $item jid fingerprint
+
+    ::xmpp::xml::toTabbedText [::xmpp::xml::create item \
+					-xmlns $ns \
+					-attrs [list jid $jid \
+						     fingerprint $fingerprint \
+						     auth $val]]
+}
+
+proc auth::restore {} {
+    variable otrdir
+
+    if {[catch {set fd [open [file join $otrdir auth.xml]]}]} {
+	return [dict create]
+    }
+
+    set data [read $fd]
+    close $fd
+
+    deserialize_auth [lindex $data 0]
+}
+
+proc auth::deserialize_auth {xmlel} {
+    variable ns
+
+    ::xmpp::xml::split $xmlel tag xmlns attrs cdata subels
+
+    if {$tag ne "authentication"} {
+	return -code error "The root element must be 'authentication'"
+    }
+    if {$xmlns ne $ns} {
+	return -code error "The namespace must be '$ns'"
+    }
+    set auth [dict create]
+    foreach subel $subels {
+	::xmpp::xml::split $subel tag1 xmlns1 attrs1 cdata1 subels1
+	dict set auth [::xmpp::xml::getAttr $attrs1 jid] [deserialize_items $subels1]
+    }
+    set auth
+}
+
+proc auth::deserialize_items {xmlels} {
+    set items [dict create]
+    foreach xmlel $xmlels {
+	::xmpp::xml::split $xmlel tag xmlns attrs cdata subels
+	dict set items [list [::xmpp::xml::getAttr $attrs jid] \
+			     [::xmpp::xml::getAttr $attrs fingerprint] \
+		       [::xmpp::xml::getAttr $attrs $auth]]
+    }
+    set items
+}
+
+proc auth::set_auth {auth myjid jid fingerprint value} {
+    if {!$value} {
+	if {[dict exists $auth $myjid]} {
+	    dict unset auth $myjid [list $jid $fingerprint]
+	}
+    } else {
+	if {![dict exists $auth $myjid]} {
+	    dict set auth $myjid [dict create]
+	}
+	dict set auth $myjid [list $jid $fingerprint] 1
+    }
+    set auth
+}
+


Property changes on: trunk/tkabber-plugins/otr/auth.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
Index: trunk/tkabber-plugins/otr/tclotr/key.tcl
===================================================================
--- trunk/tkabber-plugins/otr/tclotr/key.tcl	2014-01-21 16:24:29 UTC (rev 2075)
+++ trunk/tkabber-plugins/otr/tclotr/key.tcl	2014-01-21 18:36:17 UTC (rev 2076)

Property changes on: trunk/tkabber-plugins/otr/tclotr/key.tcl
___________________________________________________________________
Added: svn:keywords
## -0,0 +1 ##
+Author Date Id Revision
\ No newline at end of property
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property


More information about the Tkabber-dev mailing list