[Tkabber-dev] r1395 - branches/tls/tls-sample

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Mon Mar 17 01:09:22 MSK 2008


Author: kostix
Date: 2008-03-17 01:09:21 +0300 (Mon, 17 Mar 2008)
New Revision: 1395

Modified:
   branches/tls/tls-sample/certinfo.tcl
Log:
tls-sample/certinfo.tcl: Implemented working CertInfo frame.


Modified: branches/tls/tls-sample/certinfo.tcl
===================================================================
--- branches/tls/tls-sample/certinfo.tcl	2008-03-15 00:55:33 UTC (rev 1394)
+++ branches/tls/tls-sample/certinfo.tcl	2008-03-16 22:09:21 UTC (rev 1395)
@@ -1,4 +1,12 @@
 #! /usr/bin/env wish
+if 0 {
+In fact DNs returned by OpenSSL should be parsed according to:
+* RFC 2253: http://www.apps.ietf.org/rfc/rfc2253.html
+* RFC 1179: http://www.apps.ietf.org/rfc/rfc1779.html
+The latter seems to be obsoleted by the former, but it appears
+that at least OpenSSL linked to the widely-available Windows
+build of tls package uses 1179.
+}
 
 option add *CertInfo.borderWidth 4 widgetDefault
 
@@ -11,92 +19,362 @@
 option add *CertInfo.Entry.state readonly widgetDefault
 option add *CertInfo.Entry.relief flat widgetDefault
 
-proc CertInfo {w args} {
-    set opts {
+namespace eval CertInfo {
+    variable opts {
 	-reason
 	-issuer
 	-subject
 	-notbefore
 	-notafter
 	-serial
+	-sha1-fingerprint
+	-md5-fingerprint
     }
 
+    variable attrmap; array set attrmap [list \
+	DN            [::msgcat::mc "Distinguished Name (DN)"] \
+	CN            [::msgcat::mc "Canonical Name (CN)"] \
+	L             [::msgcat::mc "Locality (L)"] \
+	ST            [::msgcat::mc "State or province (ST)"] \
+	O             [::msgcat::mc "Organization (O)"] \
+	OU            [::msgcat::mc "Organizational Unit (OU)"] \
+	C             [::msgcat::mc "Country (C)"] \
+	emailAddress  [::msgcat::mc "E-mail address"]
+    ]
+}
+
+interp alias {} CertInfo {} CertInfo::Create
+
+bind CertInfo <Destroy> {CertInfo::Destroy %W}
+
+proc CertInfo::Create {w args} {
+    variable opts
+    variable $w; upvar 0 $w state
+
+    frame $w -class CertInfo
+
+    set validity [list]
     foreach {opt val} $args {
 	set ix [lsearch -exact $opts $opt]
 	if {$ix < 0} {
-	    return -code error "Bad option \"$opt\":\
-		must be one of $opts"
+	    Fail $w "Bad option \"$opt\": must be one of [FlattenOpts $opts]"
 	}
 	set [string trimleft $opt -] $val
     }
 
-    if {![info exists reason]} {
-	set reason [::msgcat::mc "Certificate properties"]
-    }
+    Reason $w [Coalesce reason [::msgcat::mc "Certificate properties"]]
+    Separator $w
+    Subject $w [Coalesce subject ""]
+    Spacer $w
+    Issuer $w [Coalesce issuer ""]
+    Spacer $w
+    Validity $w [Coalesce notbefore ""] [Coalesce notafter ""]
+    Spacer $w
+    Miscellanea $w [Coalesce serial ""] \
+	[Coalesce sha1-fingerprint ""] [Coalesce md5-fingerprint ""]
+    Separator $w
 
-    frame $w -class CertInfo
+    button $w.copy -text [::msgcat::mc "Copy to clipboard"] \
+	-command [list CertInfo::CopyToClipboard $w]
+    grid $w.copy -sticky w
 
-    label $w.reason -text $reason
+    grid columnconfigure $w 1 -weight 1
 
-    frame $w.separator -class Separator
+    FixupLayout $w
+}
 
-    label $w.ititle -text [::msgcat::mc "Issued to"]
-    label $w.iCNcap -text [::msgcat::mc "Common Name (CN):"]
-    label $w.iCNval -text "foo.bar.baz"
-    label $w.iOcap  -text [::msgcat::mc "Organization (O):"]
-    label $w.iOval  -text "yummy"
-    label $w.iOUcap -text [::msgcat::mc "Organizational Unit (OU):"]
-    label $w.iOUval -text "gabba"
-    label $w.iSNcap -text [::msgcat::mc "Serial Number:"]
-    label $w.iSNval -text "1234"
+proc CertInfo::Destroy {w} {
+    variable $w
+    if {[info exists $w]} { unset $w }
+}
 
-    frame $w.spacer1 -class Spacer
+proc CertInfo::Fail {w msg} {
+    Destroy $w
+    return -code error $msg
+}
 
-    label $w.etitle -text [::msgcat::mc "Issued by"]
-    label $w.eCNcap -text [::msgcat::mc "Common Name (CN):"]
-    label $w.eCNval -text "foo.bar.baz"
-    label $w.eOcap  -text [::msgcat::mc "Organization (O):"]
-    label $w.eOval  -text "yummy"
-    label $w.eOUcap -text [::msgcat::mc "Organizational Unit (OU):"]
-    label $w.eOUval -text "gabba"
+proc CertInfo::FlattenOpts {opts} {
+    set last [LPop opts]
+    if {[llength $opts] == 0} { return $last }
 
-    frame $w.spacer2 -class Spacer
+    set next [LPop opts]
+    append next " or " $last
+    if {[llength $opts] == 0} { return $next }
 
-    label $w.vtitle -text [::msgcat::mc "Validity"]
-    label $w.vNBcap -text [::msgcat::mc "Not Defore:"]
-    label $w.vNBval -text "2007-10-12"
-    label $w.vNAcap  -text [::msgcat::mc "Not After:"]
-    label $w.vNAval  -text "2009-12-23"
+    set final [join $opts ", "]
+    append final ", " $next
+    return $final
+}
 
+proc CertInfo::LPop {listVar} {
+    upvar 1 $listVar L
+    set v [lindex $L end]
+    set L [lrange $L 0 end-1]
+    set v
+}
+
+proc CertInfo::Coalesce {varName fallback} {
+    upvar 1 $varName v
+    if {[info exists v]} {
+	return $v
+    } else {
+	return $fallback
+    }
+}
+
+proc CertInfo::Reason {w value} {
+    variable $w; upvar 0 $w state
+
+    label $w.reason -text $value 
     grid $w.reason - -sticky w
-    grid $w.separator - -padx 4 -pady 4 -sticky we
-    grid $w.ititle -sticky w
-    grid $w.iCNcap $w.iCNval
-    grid $w.iOcap  $w.iOval
-    grid $w.iOUcap $w.iOUval
-    grid $w.iSNcap $w.iSNval
-    grid $w.spacer1 - -padx 4 -sticky we
-    grid $w.etitle -sticky w
-    grid $w.eCNcap $w.eCNval
-    grid $w.eOcap  $w.eOval
-    grid $w.eOUcap $w.eOUval
-    grid $w.spacer2 - -padx 4 -sticky we
-    grid $w.vtitle - -sticky w
-    grid $w.vNBcap $w.vNBval
-    grid $w.vNAcap $w.vNAval
 
-    grid configure $w.iCNcap $w.iOcap $w.iOUcap $w.iSNcap \
-	$w.eCNcap $w.eOcap $w.eOUcap \
-	$w.vNBcap $w.vNAcap -sticky e
+    append state(message) [::msgcat::mc "Reason"]\t[::msgcat::mc $value]
+}
 
-    grid configure $w.iCNval $w.iOval $w.iOUval $w.iSNval \
-	$w.eCNval $w.eOval $w.eOUval \
-	$w.vNBval $w.vNAval -sticky w
+proc CertInfo::Heading {w value} {
+    label $w -text $value
+    grid $w - -sticky w -padx {4m 0}
+}
 
-    grid columnconfigure $w 1 -weight 1
+proc CertInfo::Spacer {w} {
+    variable $w; upvar 0 $w state
+    upvar 0 state(spacerno) n
+
+    if {![info exists n]} {
+	set n 0
+    }
+
+    incr n
+
+    frame $w.spacer$n -class Spacer
+    grid $w.spacer$n - -padx 4 -sticky we
 }
 
-CertInfo .certinfo -reason Foo!
+proc CertInfo::Separator {w} {
+    variable $w; upvar 0 $w state
+    upvar 0 state(sepno) n
+
+    if {![info exists n]} {
+	set n 0
+    }
+
+    incr n
+
+    frame $w.separator$n -class Separator
+    grid $w.separator$n - -padx 4 -pady 4 -sticky we
+}
+
+proc CertInfo::Subject {w subject} {
+    PutDN $w subject [::msgcat::mc "Issued to:"] $subject
+}
+
+proc CertInfo::Issuer {w issuer} {
+    PutDN $w issuer [::msgcat::mc "Issued by:"] $issuer
+}
+
+proc CertInfo::PutDN {w type title dn} {
+    variable $w; upvar 0 $w state
+    variable attrmap
+
+    set wtitle $w.${type}_title
+    Heading $wtitle $title
+
+    if {$dn == ""} {
+	$wtitle configure -state disabled
+	return
+    }
+
+    $wtitle configure -state normal
+    append state(message) \n$title
+
+    array set parts {}
+    set nparts [ParseDN $dn parts]
+    if {$nparts == 0} {
+	# Special handling for (probably) unparsable DN:
+	set parts(DN) $dn
+    }
+
+    set fieldno 0
+    foreach part {CN O OU} {
+	if {[info exists parts($part)]} {
+	    set lw $w.${type}_label$fieldno
+	    set vw $w.${type}_value$fieldno
+	    label $lw -text $attrmap($part)
+	    label $vw -text $parts($part)
+	    grid $lw $vw -sticky w
+	    incr fieldno
+	    RegisterCaption $lw
+	    append state(message) \n\t$attrmap($part)\t$parts($part)
+	    unset parts($part)
+	}
+    }
+    foreach part [array names parts] {
+	set lw $w.${type}_label$fieldno
+	set vw $w.${type}_value$fieldno
+	set desc [DescribeX500Attr $part]
+	label $lw -text $desc
+	label $vw -text $parts($part)
+	grid $lw $vw -sticky w
+	incr fieldno
+	RegisterCaption $lw
+	append state(message) \n\t$desc\t$parts($part)
+    }
+}
+
+proc CertInfo::ParseDN {dn partsVar} {
+    upvar 1 $partsVar parts
+
+    set count 0
+
+    foreach part [split [string trim \
+	    [regsub -all {\s*[/,]\s*(\w+)\s*=\s*} $dn \n\\1=]] \n] {
+	# TODO change to [lassign]
+	foreach {key val} [split [regsub = $part \0] \0] {
+	    set parts($key) $val
+	    break
+	}
+	incr count
+    }
+
+    set count
+}
+
+proc CertInfo::DescribeX500Attr {attr} {
+    variable attrmap
+
+    if {[info exists attrmap($attr)]} {
+	return $attrmap($attr)
+    } else {
+	return $attr
+    }
+}
+
+proc CertInfo::Validity {w notbefore notafter} {
+    variable $w; upvar 0 $w state
+
+    set wtitle $w.validity_title
+    set title [::msgcat::mc "Validity:"]
+    Heading $wtitle $title
+    if {$notbefore == "" && $notafter == ""} {
+	$wtitle configure -state disabled
+	return
+    }
+
+    append state(message) \n$title
+
+    set title [::msgcat::mc "Not Before"]
+    label $w.vNBcap -text $title
+    label $w.vNBval -text $notbefore
+    grid $w.vNBcap $w.vNBval -sticky w
+    if {$notbefore == ""} {
+	$w.vNBcap configure -state disabled
+    } else {
+	$w.vNBcap configure -state normal
+    }
+    RegisterCaption $w.vNBcap
+    append state(message) \n\t$title\t$notbefore
+
+    set title [::msgcat::mc "Not After"]
+    label $w.vNAcap -text $title
+    label $w.vNAval -text $notafter
+    grid $w.vNAcap $w.vNAval -sticky w
+    if {$notafter == ""} {
+	$w.vNAcap configure -state disabled
+    } else {
+	$w.vNAcap configure -state normal
+    }
+    RegisterCaption $w.vNAcap
+    append state(message) \n\t$title\t$notafter
+}
+
+proc CertInfo::Miscellanea {w serial sha1fp md5fp} {
+    variable $w; upvar 0 $w state
+
+    set title [::msgcat::mc "Miscellanea:"]
+    set wtitle $w.misc_title
+    Heading $wtitle $title
+    if {$serial == "" && $sha1fp == "" && $md5fp == ""} {
+	$wtitle configure -state disabled
+	return
+    }
+
+    append state(message) \n$title
+
+    set title [::msgcat::mc "Serial Number"]
+    label $w.vSNcap -text $title
+    label $w.vSNval -text $serial
+    grid $w.vSNcap $w.vSNval -sticky w
+    if {$serial == ""} {
+	$w.vSNcap configure -state disabled
+    } else {
+	$w.vSNcap configure -state normal
+    }
+    RegisterCaption $w.vSNcap
+    append state(message) \n\t$title\t$serial
+
+    set title [::msgcat::mc "SHA-1 Fingerprint"]
+    label $w.vSHA1cap -text $title
+    label $w.vSHA1val -text [PrettifyHash $sha1fp]
+    grid $w.vSHA1cap $w.vSHA1val -sticky w
+    if {$sha1fp == ""} {
+	$w.vSHA1cap configure -state disabled
+    } else {
+	$w.vSHA1cap configure -state normal
+    }
+    RegisterCaption $w.vSHA1cap
+    append state(message) \n\t$title\t$sha1fp
+
+    set title [::msgcat::mc "MD5 Fingerprint"]
+    label $w.vMD5cap -text $title
+    label $w.vMD5val -text [PrettifyHash $md5fp]
+    grid $w.vMD5cap $w.vMD5val -sticky w
+    if {$md5fp == ""} {
+	$w.vMD5cap configure -state disabled
+    } else {
+	$w.vMD5cap configure -state normal
+    }
+    RegisterCaption $w.vMD5cap
+    append state(message) \n\t$title\t$md5fp
+}
+
+proc CertInfo::PrettifyHash {hash} {
+    regsub -all {..(?!$)} [string toupper $hash] &:
+}
+
+proc CertInfo::RegisterCaption {widget} {
+    set w [winfo parent $widget]
+    variable $w; upvar 0 $w state
+
+    lappend state(captions) $widget
+}
+
+proc CertInfo::FixupLayout {w} {
+    variable $w; upvar 0 $w state
+
+    foreach widget $state(captions) {
+	grid $widget -padx {0 4m}
+    }
+}
+
+proc CertInfo::CopyToClipboard {w} {
+    variable $w; upvar 0 $w state
+
+    clipboard clear -displayof $w
+    clipboard append -displayof $w $state(message)
+}
+
+package require sha1
+package require md5
+
+CertInfo .certinfo \
+    -reason "Unable to get local issuer certificate" \
+    -subject {/CN=Jabber.RU/OU=Gabba hey!/O=Suckers/ST=Alabama/emailAddress=foo at bar.baz/unknownAttribute = Who's THERE?} \
+    -issuer  {CN=*.007spb.ru , OU = Woohoo!} \
+    -notafter 2009-10-23 \
+    -serial 1234 \
+    -sha1-fingerprint [sha1::sha1 -hex foobarbaz] \
+    -md5-fingerprint  [md5::md5   -hex foobarbaz]
 pack .certinfo -fill both -expand true -anchor nw
+bind . <Escape> {destroy .}
 
 # vim:ts=8:sw=4:sts=4:noet



More information about the Tkabber-dev mailing list