# pgpMatch.tcl -- 
# created by monnier@didec26.epfl.ch on Sat Nov 19 14:43:42 1994

# 
# for matching between email addresses and pgp key ids
# 

# todo:
# - better control of the quality of the match

# $Log: pgpMatch.tcl,v $
# Revision 1.3  1995/04/07  21:43:00  welch
# Updated listbox to handle Tk 4.0
#
# Revision 1.2  1995/03/24  02:14:58  welch
# Added FontWidget to listbox creation
#
# Revision 1.1  1994/12/30  21:49:00  welch
# Initial revision
#
# Revision 1.1  1994/12/30  21:49:00  welch
# Initial revision
#
# Revision 1.1  1994/12/17  20:19:08  monnier
# Initial revision
#

# returns the list of keys of the recipients of the draft
proc PgpMatch_Whom { draft {hasfcc 0} } {
    global pgp

    set ids {}

    # get the list of recipients with "whom" (does alias expansion)
    catch {exec whom -nocheck $draft} recipients
    foreach id [split $recipients "\n"] {
	if [regexp "^ *-" $id] {
	    continue
	}
	set id [string trim $id]
	regsub { at } $id {@} id
	set ids [concat $ids [PgpMatch_Email $id $pgp(pubring)]]
    }
    if $hasfcc {
	lappend ids $pgp(myname)
    }

    return $ids
}

# like a "grep id keyring". Returns the unique element of
# the keyring that matches $email. The returned value is actually a list
# of keys, in case someone needs the feature (?)
proc PgpMatch_Email { email keyring } {
    global pgp env pgpMatch pgpSimpleMatch

    set email [string tolower [string trim $email]]

    if {$pgp(cacheids) && [info exists pgpMatch($email)]} {
	return $pgpMatch($email)
    }

    if {![regexp "@" $email]} {
	set id "$email@$env(LOCALHOST)"
    } else {
	set id $email
    }

    set sep {][{}<>()@"|,;!' }

    # split into login, domain and comment
    if {![regexp "^(.*\[$sep])?(\[^$sep]+)@(\[^$sep]+)(.*)\$" $id {} comment1 login domain comment2]} {
	error "<PGP> meaningless recipient: <$email>"
    }
    set commentids [Misc_Filter x {$x != {}} [split [string tolower "$comment1 $comment2"] ".$sep"]]
    set loginids [Misc_Filter x {$x != {}} [split [string tolower "$login"] "."]]
    set domainids [Misc_Filter x {$x != {}} [split [string tolower "$domain"] "."]]

    set pgpkeys(0) [PgpMatch_InitialKeyList $loginids $domainids $commentids $keyring]
    set subids [concat \
	    [Misc_Map x {format "(^|\[$sep.])${x}(\\.\[^$sep]*)*@"} $loginids] \
	    [Misc_Map x {format "@(\[^$sep]*\\.)*${x}(\$|\[$sep.])"} [Misc_Reverse $domainids]] \
	    [Misc_Map x {format "(^|\[$sep.])${x}(\$|\[$sep.])"} $commentids]]

    foreach subidindex [Misc_IntList 0 [llength $subids]] {
	set subid [lindex $subids $subidindex]
	set pgpkeys([expr $subidindex + 1]) {}

	foreach class [Misc_Reverse [Misc_IntList 0 [expr $subidindex + 1]]] {
	    set tmp [Misc_Segregate key {[regexp -nocase $subid $key]} $pgpkeys($class)]
	    set pgpkeys([expr $class + 1]) [concat $pgpkeys([expr $class + 1]) [lindex $tmp 0]]
	    set pgpkeys($class) [lindex $tmp 1]
	}
    }

    set maxmatches [llength $subids]
    while {$pgpkeys($maxmatches) == {}} {
	set maxmatches [expr $maxmatches - 1]
    }

    # check the match's quality
    if {[llength $pgpkeys($maxmatches)] > 1} {
	ExmhLog "<PgpMatch_Email> $id is ambiguous: [join $pgpkeys($maxmatches) ", "]"
	set filter {}
	set result [Pgp_KeyBox "Please select the key of $id" $keyring $pgpkeys($maxmatches)]
    } else {
	set result $pgpkeys($maxmatches)
    }
    while {$result == {}} {
	set result [Pgp_KeyBox "You didn't select a key for $id" $keyring $pgpkeys($maxmatches)]
    }
    set pgpMatch($email) $result
    foreach key $result {
	set pgpSimpleMatch([string tolower [string trim [lindex $key 1]]]) $key
    }
    return $pgpMatch($email)
}

# returns the only key matching $name.
proc PgpMatch_Simple { name keyring } {
    global pgp pgpSimpleMatch

    set name [string tolower [string trim $name]]

    if {!$pgp(cacheids) || ![info exists pgpSimpleMatch($name)]} {
	set keylist [PgpExec_KeyList $name $keyring]

	if {[llength $keylist] == 1} {
	    set pgpSimpleMatch($name) [lindex $keylist 0]
	} elseif {[llength $keylist] == 0} {
	    error "<PGP> no keys matching $name"
	} else {
	    error "<PGP> several keys matching $name"
	}
    }
    return $pgpSimpleMatch($name)
}

#
proc Pgp_FlatKeyList { pattern keyring } {
    global pgp

    set keys [PgpExec_KeyList $pattern $keyring]
    set userids {}
    foreach key $keys {
	if {[llength $key] > 2} {
	    set keyid [lindex $key 0]
	    foreach userid [lrange $key 1 end] {
		lappend userids [list $keyid $userid]
	    }
	} else {
	    lappend userids $key
	}
    }
    return $userids
}

# returns a list of pgpkeys that should be as small as possible,
# while (hopefully) still containing the key matching the guy specified by
# $loginids $domainids and $commentids
proc PgpMatch_InitialKeyList { loginids domainids commentids keyring } {
#    puts "<PgpMatch_InitialKeyList> $loginids $domainids $commentids"

    if {[llength $domainids] > 2} {
	set pattern [join [lrange $domainids 1 end] "."]
    } elseif {[llength $domainids] > 1} {
	set pattern [join $domainids "."]
    } elseif {[llength $loginids] > 0} {
	set pattern [lindex $loginids 0]
    } elseif {[llength $commentids] > 0} {
	set pattern [lindex $commentids 0]
    } else {
	set pattern [join $domainids "."]
    }

    # get the list of pgp userids of the public ring and
    # remove all the uninteresting part of the listing displayed by pgp -kv
    # and change the long string into a list of userids
    set keylist [Pgp_FlatKeyList $pattern $keyring]
    if {$keylist == {}} {
	ExmhLog "<PgpMatch_InitialKeyList> no match on $pattern, trying full keyring"
	set keylist [Pgp_FlatKeyList "" $keyring]
	if {$keylist == {}} {
	    ExmhLog "<PgpMatch_InitialKeyList> can't find keys in pgp's output"
	    error "<PGP> can't get the pubring list, probable install problem"
	}
    }
    return $keylist
}

# based on fileselect.tcl
# asks the user for selection of keys.
proc Pgp_KeyBox { label keyring keylist } {
    global keybox
    set w .keybox

    if [Exwin_Toplevel $w "Choose key" Dialog no] {
	# path independent names for the widgets
	
	set keybox(list) $w.key.sframe.list
	set keybox(scroll) $w.key.sframe.scroll
	set keybox(ok) $w.but.ok
	set keybox(listbut) $w.but.list
	set keybox(cancel) $w.but.cancel
	set keybox(msg) $w.label
	set keybox(sel) $w.key.sel
	
	# widgets
	Widget_Frame $w but Menubar {top fillx}
	Widget_Label $w label {top fillx pady 10 padx 20}
	Widget_Frame $w key Dialog {bottom expand fill} -bd 10
	Widget_Entry $w.key sel {bottom fillx pady 10}

	Widget_AddBut $w.but ok OK \
		[list keybox.ok.cmd $w ] {left padx 1}
	Widget_AddBut $w.but cancel Cancel \
		[list keybox.cancel.cmd $w ] {right padx 1}
	Widget_AddBut $w.but list List \
		[list keybox.list.cmd $w $keyring] {right padx 1}

	Widget_Frame $w.key sframe

	scrollbar $w.key.sframe.yscroll -relief sunken \
		-command [list $w.key.sframe.list yview]
	FontWidget listbox $w.key.sframe.list -relief sunken \
		-yscroll [list $w.key.sframe.yscroll set] -setgrid 1
	global tk_version
	if {$tk_version >= 4.0} {
	    $w.key.sframe.list config -width 48 -height 16
	} else {
	    $w.key.sframe.list config -geometry 48x16
	}
	pack append $w.key.sframe \
		$w.key.sframe.yscroll {right filly} \
		$w.key.sframe.list {left expand fill}
    }
    $keybox(sel) configure -textvariable keybox(filter)
    set keybox(state) ""
    set keybox(filter) {}
    set keybox(keylist) $keylist
    set keybox(result) {}
    $keybox(msg) configure -text $label
    $keybox(list) delete 0 end
    foreach i $keybox(keylist) {
	$keybox(list) insert end [lindex $i 1]
    }
    bind $keybox(list) <Double-ButtonPress-1> {
	%W select from [%W nearest %y]
	$keybox(ok) invoke
    }
    bind $keybox(sel) <Key-Return> [list $keybox(listbut) invoke]

    Exwin_ToplevelFocus $w $keybox(sel)
    update idletask
    grab $w
    tkwait variable keybox(result)
    grab release $w

    if {$keybox(state) == "cancel"} {
	error "cancel"
    }
    return $keybox(result)
}

proc keybox.ok.cmd {w} {
    global keybox

    #    if {[selection own] == $keybox(list)}
    
    set keybox(result) [Misc_Map i {lindex $keybox(keylist) $i} [$keybox(list) curselection]]
    if {$keybox(result) == {} && [llength $keybox(keylist)] == 1} {
	set keybox(result) $keybox(keylist)
    }
    Exwin_Dismiss $w
}

proc keybox.cancel.cmd {w} {
    global keybox
    set keybox(state) "cancel"
    set keybox(result) {}
    Exwin_Dismiss $w
}

proc keybox.list.cmd { w keyring } {
    global keybox

    $keybox(list) delete 0 end
    set keybox(keylist) [Pgp_FlatKeyList [$keybox(sel) get] $keyring]
    foreach x $keybox(keylist) {
	$keybox(list) insert end [lindex $x 1]
    }
}

#
proc PgpMatch_CheckPoint {  } {
    global pgp pgpMatch pgpSimpleMatch
    if {$pgp(cacheids) && ![catch {open $pgp(pgppath)/.matchcache w 0600} out]} {
	foreach email [array names pgpMatch] {
	    puts $out [linsert $pgpMatch($email) 0 $email]
	}
	puts $out ""
	foreach email [array names pgpSimpleMatch] {
	    puts $out [linsert $pgpSimpleMatch($email) 0 $email]
	}
	close $out
    }
}


# proc PgpMatch_Init {  }
if {$pgp(cacheids) && ![catch {open $pgp(pgppath)/.matchcache r} in]} {
    for {set len [gets $in line]} {$len > 0} {set len [gets $in line]} {
	set pgpMatch([lindex $line 0]) [lrange $line 1 end]
    }
    for {set len [gets $in line]} {$len >= 0} {set len [gets $in line]} {
	set pgpSimpleMatch([lindex $line 0]) [lrange $line 1 end]
    }
    close $in
}
