1# $Id$
2
3namespace eval ::ssj {}
4
5#############################################################################
6# Draw icons aside encrypted messages even if no GPG support
7
8proc ::ssj::draw_encrypted {chatid from type body x} {
9    # we already deciphered it in rewrite_message_hook
10
11    set chatw [chat::chat_win $chatid]
12
13    foreach xe $x {
14	::xmpp::xml::split $xe tag xmlns attrs cdata subels
15
16	if {![string equal $xmlns $::NS(encrypted)]} {
17	    continue
18	}
19
20	if {[string equal $cdata ""] || \
21	    [string equal [info commands ::ssj::encrypted:input] ""]} {
22	    $chatw image create end -image gpg/badencrypted
23	} else {
24	    $chatw image create end -image gpg/encrypted
25	}
26	break
27    }
28}
29
30hook::add draw_message_hook ::ssj::draw_encrypted 6
31
32#############################################################################
33
34proc ::ssj::process_x_encrypted {rowvar bodyvar f x xlib from id type replyP} {
35    upvar 2 $rowvar row
36    upvar 2 $bodyvar body
37
38    if {!$replyP || [string equal $type error]} {
39	return
40    }
41
42    foreach xa $x {
43	::xmpp::xml::split $xa tag xmlns attrs cdata subels
44
45	if {$xmlns != $::NS(encrypted)} continue
46
47	# we already deciphered it in rewrite_message_hook
48	set lb [join [lrange [split $f .] 0 end-1] .].title.encrypted
49	if {[winfo exists $lb]} {
50	    destroy $lb
51	}
52
53	if {[string equal $cdata ""] || \
54	    [string equal [info commands ::ssj::encrypted:input] ""]} {
55	    Label $lb -image gpg/badencrypted
56	} else {
57	    Label $lb -image gpg/encrypted
58	}
59	grid $lb -row 1 -column 3 -sticky e
60    }
61
62    return
63}
64
65hook::add message_process_x_hook ::ssj::process_x_encrypted 21
66
67#############################################################################
68
69if {[catch {package require gpg}]} {
70    debugmsg ssj "unable to load the GPG package, so no crypto!"
71    return
72}
73
74namespace eval ::ssj {
75    variable options
76
77    custom::defgroup GPG [::msgcat::mc "GPG options (signing and encryption)."] \
78	-group Tkabber
79
80    custom::defvar options(one-passphrase) 1 \
81	[::msgcat::mc "Use the same passphrase for signing and decrypting messages."] \
82	-group GPG -type boolean
83
84    custom::defvar options(sign-traffic) 0 \
85	[::msgcat::mc "GPG-sign outgoing presence updates."] \
86	-group GPG -type boolean
87
88    custom::defvar options(sign-personal-messages) 0 \
89	[::msgcat::mc "GPG-sign outgoing personal messages."] \
90	-group GPG -type boolean
91
92    custom::defvar options(sign-groupchat-messages) 0 \
93	[::msgcat::mc "GPG-sign outgoing groupchat messages."] \
94	-group GPG -type boolean
95
96    custom::defvar options(encrypt-traffic) 0 \
97	[::msgcat::mc "GPG-encrypt outgoing messages where possible."] \
98	-group GPG -type boolean
99
100    custom::defvar options(prevent-replay-attack) 1 \
101	[::msgcat::mc "Add your JID and timestamp to the GPG-signed outgoing messages\
102		       or presence updates. This prevents replay attacks, but shows\
103		       your JID in every message or presence status."] \
104	-group GPG -type boolean
105
106    custom::defvar options(key) "" \
107	[::msgcat::mc "Use specified key ID for signing and decrypting messages."] \
108	-group GPG -type string
109
110    custom::defvar options(display_sig_warnings) 1 \
111	[::msgcat::mc "Display warning dialogs when signature verification fails."] \
112	-group GPG -type boolean
113}
114
115
116package require base64
117
118
119namespace eval ::ssj {
120    variable ctx
121    variable e4me
122    variable j2k
123    variable options
124    variable passphrase
125    variable s2e
126    variable signers
127    variable warnings
128    variable gpg_error_id 0
129
130    array set ctx {}
131
132    array set j2k {}
133
134    array set options {}
135
136    array set passphrase {}
137
138    array set s2e \
139          [list none       [::msgcat::mc "No information available"] \
140                bad        [::msgcat::mc "Invalid signature"] \
141                nokey      [::msgcat::mc "Signature not processed due to missing key"] \
142                nosig      [::msgcat::mc "Malformed signature block"] \
143                error      [::msgcat::mc "Error in signature processing"] \
144                diff       [::msgcat::mc "Multiple signatures having different authenticity"] \
145                expired    [::msgcat::mc "The signature is good but has expired"] \
146                expiredkey [::msgcat::mc "The signature is good but the key has expired"]]
147
148    catch {unset warnings}
149    array set warnings {}
150
151    variable signedid 0
152}
153
154
155proc ::ssj::once_only {xlib} {
156    global env
157    variable options
158    variable ctx
159
160    debugmsg ssj "ONCE_ONLY $xlib"
161
162    if {[info exists ctx($xlib)] && ![string equal $ctx($xlib) ""]} {
163        return
164    }
165
166    set ctx($xlib) [gpg::new]
167    $ctx($xlib) set -property armor \
168		    -value    true
169    $ctx($xlib) set -property encoding \
170		    -value    utf-8
171
172    if {![info exists env(GPG_AGENT_INFO)]} {
173        $ctx($xlib) set -property passphrase-callback \
174			-value    [list ::ssj::passphrase $xlib]
175    }
176
177    set pattern [connection_bare_jid $xlib]
178
179    set firstP 1
180    if {$options(key) != ""} {
181	set patterns [list $options(key)]
182    } else {
183	set patterns {}
184    }
185    lappend patterns $pattern ""
186    foreach p $patterns {
187        set command [list $ctx($xlib) list-keys -secretonly true]
188        if {![string equal $p ""]} {
189            lappend command -patterns [list $p]
190        }
191        set keys [eval $command]
192
193        if {[llength $keys] > 0} {
194            break
195        }
196        if {[string equal $p ""]} {
197            return
198        }
199        set firstP 0
200    }
201
202    switch -- [llength $keys] {
203        0 {
204            return
205        }
206
207        1 {
208            if {$firstP} {
209                e4meP $xlib $keys
210                return
211            }
212        }
213
214        default {
215        }
216    }
217
218    set dw .selectkey[psuffix $xlib]
219    catch {destroy $dw}
220
221    set titles {}
222    set balloons {}
223    foreach key $keys {
224	set key_info [$ctx($xlib) info-key -key $key]
225        foreach {k v} $key_info {
226	    if {[string equal $k email]} {
227		lappend titles $key $v
228		lappend balloons $key [key_balloon_text $key_info]
229		break
230	    }
231	}
232        foreach {k v} [$ctx($xlib) info-key -key $key] {
233	    if {![string equal $k subkeys]} {
234		continue
235	    }
236
237	    foreach subkey $v {
238		foreach {k1 v1} $subkey {
239		    if {[string equal $k1 email]} {
240			lappend titles $key $v1
241			lappend balloons $key [key_balloon_text $subkey]
242			break
243		    }
244		}
245	    }
246	}
247    }
248
249    CbDialog $dw [::msgcat::mc "Select Key for Signing %s Traffic" $pattern] \
250        [list [::msgcat::mc "Select"] "::ssj::once_only_aux $dw $xlib" \
251	      [::msgcat::mc "Cancel"] "destroy $dw"] \
252	::ssj::selectkey[psuffix $xlib] $titles $balloons \
253	-modal local
254}
255
256proc ::ssj::key_balloon_text {key} {
257    array set params $key
258    if {[catch {format "%d%s/%s %s" $params(length)          \
259                       [string range $params(algorithm) 0 0]   \
260                       [string range $params(keyid) end-7 end] \
261                       [clock format $params(created)          \
262                                     -format "%Y-%m-%d"]} text]} {
263	return ""
264    }
265
266    foreach {k v} $key {
267	switch -- $k {
268	    userid {
269		append text [format "\n\t%s" $v]
270	    }
271	}
272    }
273    return $text
274}
275
276proc ::ssj::once_only_aux {dw xlib} {
277    variable selectkey[psuffix $xlib]
278
279    set keys {}
280    foreach key [array names selectkey[psuffix $xlib]] {
281        if {[set selectkey[psuffix $xlib]($key)]} {
282            lappend keys $key
283        }
284    }
285
286    destroy $dw
287
288    if {[llength $keys] > 0} {
289        e4meP $xlib $keys
290    }
291}
292
293
294proc ::ssj::passphrase {xlib data} {
295    variable passphrase
296    variable options
297
298    array set params $data
299
300    if {!$options(one-passphrase)} {
301        set params(keyid) $params(subkeyid)
302    }
303    set keyid $params(keyid)
304
305    if {([string equal $params(hint) enter]) && \
306            [info exists passphrase($keyid)] && \
307            ![string equal $passphrase($keyid) ""]} {
308        return $passphrase($keyid)
309    }
310
311    set pw .passphrase[psuffix $xlib]
312    if {[winfo exists $pw]} {
313        destroy $pw
314    }
315
316    set title [::msgcat::mc "Please enter passphrase"]
317    switch -- $params(hint) {
318        enter {
319        }
320
321        try_again {
322            set title [::msgcat::mc "Please try again"]
323        }
324
325        default {
326            append title ": " $params(hint)
327        }
328    }
329    Dialog $pw -title $title -separator 1 -anchor e -default 0 -cancel 1
330
331    set pf [$pw getframe]
332    grid columnconfigure $pf 1 -weight 1
333
334    foreach {k v} [list keyid  [::msgcat::mc "Key ID"] \
335			userid [::msgcat::mc "User ID"]] {
336        label $pf.l$k -text ${v}:
337        entry $pf.$k
338        $pf.$k insert 0 $params($k)
339        if {[string length $params($k)] <= 72} {
340            $pf.$k configure -width 0
341        }
342        if {[info tclversion] >= 8.4} {
343            set bgcolor [lindex [$pf.$k configure -background] 4]
344            $pf.$k configure -state readonly -readonlybackground $bgcolor
345        } else {
346            $pf.$k configure -state disabled
347        }
348    }
349
350    label $pf.lpassword -text [::msgcat::mc "Passphrase:"]
351    entry $pf.password  \
352	  -textvariable ::ssj::passphrase($xlib,$keyid) \
353          -show *
354    set passphrase($xlib,$keyid) ""
355
356    grid $pf.lkeyid    -row 0 -column 0 -sticky e
357    grid $pf.keyid     -row 0 -column 1 -sticky ew
358    grid $pf.luserid   -row 1 -column 0 -sticky e
359    grid $pf.userid    -row 1 -column 1 -sticky ew
360    grid $pf.lpassword -row 2 -column 0 -sticky e
361    grid $pf.password  -row 2 -column 1 -sticky ew
362
363    $pw add -text [::msgcat::mc "OK"] -command "$pw enddialog 0"
364    $pw add -text [::msgcat::mc "Cancel"] -command "$pw enddialog 1"
365
366    set abort [$pw draw $pf.password]
367
368    destroy $pw
369
370    if {!$abort} {
371	set passphrase($keyid) $passphrase($xlib,$keyid)
372	unset passphrase($xlib,$keyid)
373        return $passphrase($keyid)
374    } else {
375	return -code break
376    }
377}
378
379
380proc ::ssj::armor:encode {text} {
381    if {[set x [string first "\n\n" $text]] >= 0} {
382        set text [string range $text [expr {$x + 2}] end]
383    }
384    if {[set x [string first "\n-----" $text]] > 0} {
385        set text [string range $text 0 [expr {$x - 1}]]
386    }
387
388    return $text
389}
390
391proc ::ssj::armor:decode {text} {
392    return "-----BEGIN PGP MESSAGE-----\n\n$text\n-----END PGP MESSAGE-----"
393}
394
395proc ::ssj::signed:input {xlib from signature data what} {
396    variable ctx
397    variable j2k
398    variable s2e
399    variable warnings
400    variable options
401
402    once_only $xlib
403
404    if {[catch {$ctx($xlib) verify \
405			    -input     $data  \
406			    -signature [armor:decode $signature]} result]} {
407        debugmsg ssj "verify processing error ($xlib): $result ($from)"
408
409        if {![info exists warnings(verify-traffic,$xlib)]} {
410            set warnings(verify-traffic,$xlib) 1
411	    hook::run gpg_input_error_hook $xlib $from software \
412		[::msgcat::mc "Error in signature verification software: %s." \
413		    $result]
414        }
415
416        set params(reason) $result
417
418        return [array get params]
419    }
420
421    debugmsg ssj "VERIFY: $xlib $from ($data); $result"
422
423    array set params $result
424    set result $params(status)
425
426    set signatures {}
427    foreach signature $params(signatures) {
428        catch {unset sparams}
429        array set sparams $signature
430
431        if {[info exists sparams(key)]} {
432            set sparams(key) [$ctx($xlib) info-key -key $sparams(key)]
433            foreach {k v} $sparams(key) {
434		switch -- $k {
435		    keyid {
436			set j2k($from) $v
437			break
438		    }
439		    subkeys {
440			foreach subkey $v {
441			    catch {unset kparams}
442			    array set kparams $subkey
443			    if {[info exists kparams(keyid)]} {
444				set j2k($from) $kparams(keyid)
445				break
446			    }
447			}
448		    }
449		}
450            }
451        }
452
453        lappend signatures [array get sparams]
454    }
455    catch {unset params}
456    array set params [list signatures $signatures]
457
458    if {![string equal $result good]} {
459        if {[info exists s2e($result)]} {
460            set result $s2e($result)
461        }
462        set params(reason) $result
463
464        if {![info exists warnings(verify,$from)] && $options(display_sig_warnings)} {
465            set warnings(verify,$from) 1
466	    hook::run gpg_input_error_hook $xlib $from $what \
467                [::msgcat::mc "%s purportedly signed by %s can't be verified: %s." \
468				       $what $from $result]
469        }
470    }
471
472    return [array get params]
473}
474
475
476proc ::ssj::signed:output {xlib data args} {
477    variable ctx
478    variable options
479    variable warnings
480    variable gpg_error_id
481
482    if {[llength $args] == 0} {
483	# Presence
484	if {!$options(sign-traffic)} return
485    } else {
486	# Message
487	set to [lindex $args 0]
488	set chatid [chat::chatid $xlib $to]
489	if {[chat::is_groupchat $chatid]} {
490	    if {!$options(sign-groupchat-messages)} return
491	} else {
492	    if {!$options(sign-personal-messages)} return
493	}
494    }
495
496    once_only $xlib
497
498    if {[catch {$ctx($xlib) sign -input $data \
499				 -mode  detach} result]} {
500        set options(sign-traffic) 0
501        set options(sign-personal-messages) 0
502        set options(sign-groupchat-messages) 0
503
504        debugmsg ssj "signature processing error ($xlib): $result ($data)"
505
506        if {[llength $args] == 0} {
507            set buttons ok
508            set cancel 0
509            set message [::msgcat::mc "Unable to sign presence information:\
510				       %s.\n\nPresence will be sent, but\
511				       signing traffic is now disabled." $result]
512        } else {
513            set buttons {ok cancel}
514            set cancel 1
515            set message [::msgcat::mc "Unable to sign message body:\
516				       %s.\n\nSigning traffic is now\
517				       disabled.\n\nSend it WITHOUT a signature?"\
518				      $result]
519        }
520
521        incr gpg_error_id
522        if {[MessageDlg .sign_error$gpg_error_id -aspect 50000 -icon error -type user \
523                        -buttons $buttons -default 0 -cancel $cancel \
524                        -message $message]} {
525            error ""
526        }
527
528        return
529    }
530    set result [armor:encode $result]
531
532    debugmsg ssj "SIGN: $data; $result"
533    whichkeys $xlib sign
534
535    return $result
536}
537
538proc ::ssj::signed:info {pinfo} {
539
540    set text ""
541    array set params $pinfo
542
543    foreach {k v} $pinfo {
544	if {![string equal $k signatures]} {
545	    if {![string equal $v ""]} {
546		append text [format "%s: %s\n" $k $v]
547	    }
548	}
549    }
550
551    foreach signature $params(signatures) {
552	set info ""
553	set addrs ""
554	set s ""
555	foreach {k v} $signature {
556	    switch -- $k {
557		key {
558		    foreach {k v} $v {
559			if {![string equal $k subkeys]} {
560			    continue
561			}
562			foreach subkey $v {
563			    catch {unset sparams}
564			    array set sparams $subkey
565			    if {[info exists sparams(email)]} {
566				append addrs $s $sparams(email)
567                                set s "\n     "
568			    }
569			}
570		    }
571		}
572		created {
573		    append info "created: [clock format $v]\n"
574		}
575		expires {
576		    append info "expires: [clock format $v]\n"
577		}
578		fingerprint {
579		    append info [format "keyid: 0x%s\n" [string range $v end-7 end]]
580		    append info [format "%s: %s\n" $k $v]
581		}
582		default {
583		    if {![string equal $v ""]} {
584			append info [format "%s: %s\n" $k $v]
585		    }
586		}
587	    }
588	}
589
590	if {![string equal $addrs ""]} {
591	    set info "email: $addrs\n$info"
592	}
593	if {![string equal $info ""]} {
594	    append text "\n" [string trimright $info]
595	}
596    }
597
598    return [string trimleft $text]
599}
600
601proc ::ssj::signed:Label {lb xlib jid pinfo} {
602    if {[set rjid [muc::get_real_jid $xlib $jid]] == ""} {
603	set rjid [::xmpp::jid::stripResource $jid]
604    } else {
605	set rjid [::xmpp::jid::stripResource $rjid]
606    }
607
608    array set params $pinfo
609
610    set checks {}
611    set trust 0
612    foreach signature $params(signatures) {
613	set emails {}
614	set valid 0
615	foreach {k v} $signature {
616	    switch -- $k {
617		key {
618		    foreach {k v} $v {
619			if {![string equal $k subkeys]} {
620			    continue
621			}
622			foreach subkey $v {
623			    catch {unset sparams}
624			    array set sparams $subkey
625			    if {[info exists sparams(email)]} {
626				lappend emails $sparams(email)
627			    }
628			}
629		    }
630		}
631		validity {
632		    switch -- $v {
633			ultimate -
634			full -
635			marginal {
636			    set valid 1
637			}
638			never -
639			undefined -
640			unknown -
641			default {
642			    set valid 0
643			}
644		    }
645		}
646	    }
647	}
648	if {$valid && ([lsearch -exact $emails $rjid] >= 0)} {
649	    set trust 1
650	    break
651	}
652    }
653
654    if {[info exists params(reason)]} {
655	set args [list -image gpg/badsigned]
656    } elseif {$trust} {
657	set args [list -image gpg/signed]
658    } else {
659	set args [list -image gpg/vsigned]
660    }
661
662    if {![string equal [set info [signed:info $pinfo]] ""]} {
663	lappend args -helptext $info -helptype balloon
664    }
665
666    eval [list Label $lb] $args -cursor arrow \
667	 -padx 0 -pady 0 -borderwidth 0 -highlightthickness 0
668
669    if {[info exists params(reason)] && [string equal $params(reason) nokey]} {
670	bind $lb <<ContextMenu>> [list ::ssj::signed:popup [double% $pinfo]]
671    }
672    return $lb
673}
674
675###############################################################################
676
677proc ::ssj::signed:popup {pinfo} {
678    set m .signed_label_popupmenu
679    if {[winfo exists $m]} {
680	destroy $m
681    }
682    menu $m -tearoff 0
683    $m add command -label [::msgcat::mc "Fetch GPG key"] \
684	-command [list ::ssj::fetchkeys $pinfo]
685    tk_popup $m [winfo pointerx .] [winfo pointery .]
686}
687
688proc ::ssj::signed:user_menu {m xlib jid} {
689    variable signed
690
691    if {[info exists signed($xlib,$jid)]} {
692	array set params $signed($xlib,$jid)
693	if {[info exists params(status)] && [string equal $params(status) nokey]} {
694	    $m add command -label [::msgcat::mc "Fetch GPG key"] \
695		-command [list ::ssj::fetchkeys \
696			       $signed($xlib,$jid)]
697	}
698    }
699}
700
701hook::add chat_create_user_menu_hook ::ssj::signed:user_menu 78
702
703###############################################################################
704
705proc ::ssj::fetchkeys {pinfo} {
706    variable gpg_error_id
707
708    array set params $pinfo
709
710    set keyids {}
711    foreach signature $params(signatures) {
712	catch {unset sparams}
713	array set sparams $signature
714
715	if {[info exists sparams(fingerprint)]} {
716	    lappend keyids [string range $sparams(fingerprint) end-7 end]
717	}
718    }
719    set res [catch {set output [eval [list exec gpg --recv-keys] $keyids]} errMsg]
720    incr gpg_error_id
721    if {$res} {
722        NonmodalMessageDlg .keyfetch_ok$gpg_error_id -aspect 50000 -icon error \
723            -message "Key fetch error\n\n$errMsg"
724    } else {
725        NonmodalMessageDlg .keyfetch_error$gpg_error_id -aspect 50000 -icon info \
726            -message "Key fetch result\n\n$output"
727    }
728}
729
730###############################################################################
731
732proc ::ssj::rewrite_message_body \
733     {vxlib vfrom vid vtype vis_subject vsubject vbody verr vthread vpriority vx} {
734    upvar 2 $vxlib xlib
735    upvar 2 $vfrom from
736    upvar 2 $vbody body
737    upvar 2 $vx x
738
739    set badenc 0
740    set xs {}
741    foreach xe $x {
742	::xmpp::xml::split $xe tag xmlns attrs cdata subels
743
744	if {![string equal $xmlns $::NS(encrypted)]} {
745	    lappend xs $xe
746	} elseif {[string equal $cdata ""]} {
747	    # in case the sender didn't check the exit code from gpg we ignore
748	    # jabber:x:encrypted
749	} elseif {[catch {ssj::encrypted:input $xlib $from $cdata} msg]} {
750	    set body [::msgcat::mc ">>> Unable to decipher data: %s <<<" $msg]
751	    # Add empty x tag to show problems with gpg
752	    lappend xs [::xmpp::xml::create x -xmlns $::NS(encrypted)]
753	    set badenc 1
754	} else {
755	    set body $msg
756	    lappend xs $xe
757	}
758    }
759
760    set x $xs
761
762    if {$badenc} {
763	# if decryption failed, then remove signature. It can't be correct.
764
765	set xs {}
766	foreach xe $x {
767	    ::xmpp::xml::split $xe tag xmlns attrs cdata subels
768
769	    if {![string equal $xmlns $::NS(signed)]} {
770		lappend xs $xe
771	    }
772	}
773	set x $xs
774    } else {
775	# Check the signature before some other plugin rewrites the message body
776
777	set xs {}
778	foreach xe $x {
779	    ::xmpp::xml::split $xe tag xmlns attrs cdata subels
780
781	    if {![string equal $xmlns $::NS(signed)]} {
782		lappend xs $xe
783	    } else {
784		# in case the sender didn't check the exit code from gpg...
785		if {![string equal $cdata ""]} {
786		    # Create special tag with signature info
787		    lappend xs [::xmpp::xml::create "" -xmlns $::NS(signed) \
788				    -attrs [signed:input $xlib $from $cdata $body \
789						[::msgcat::mc "Message body"]]]
790		}
791	    }
792	}
793	set x $xs
794    }
795    return
796}
797
798hook::add rewrite_message_hook ::ssj::rewrite_message_body 70
799
800###############################################################################
801
802proc ::ssj::encrypted:input {xlib from data} {
803    variable ctx
804    variable warnings
805    variable gpg_error_id
806
807    once_only $xlib
808
809    if {[catch {$ctx($xlib) decrypt -input [armor:decode $data]} result]} {
810        debugmsg ssj "decryption processing error ($xlib): $result ($from)"
811
812        if {![info exists warnings(decrypt,$from)]} {
813            set warnings(decrypt,$from) 1
814            incr gpg_error_id
815            after idle [list NonmodalMessageDlg .decrypt_error$gpg_error_id -aspect 50000 -icon error \
816                -message [::msgcat::mc "Data purported sent by %s can't be deciphered.\n\n%s." \
817				       $from $result]]
818        }
819
820        error $result
821    }
822
823    debugmsg ssj "DECRYPT: $xlib; $from; $result"
824
825    array set params $result
826    return $params(plaintext)
827}
828
829
830proc ::ssj::encrypted:output {xlib data to} {
831    variable ctx
832    variable e4me
833    variable j2k
834    variable options
835    variable gpg_error_id
836
837    if {[string equal $data ""]} {
838        return
839    }
840
841    if {![encryptP $xlib $to]} {
842        return
843    }
844
845    set bto [::xmpp::jid::stripResource $to]
846
847    if {[info exists j2k($to)]} {
848        set name $j2k($to)
849    } elseif {[llength [set k [array names j2k $to/*]]] > 0} {
850        set name $j2k([lindex $k 0])
851    } else {
852        set name $bto
853    }
854
855    set recipient [gpg::recipient]
856    $recipient add -name     $name \
857		   -validity full
858    foreach signer $e4me($xlib) {
859        $recipient add -name     $signer \
860		       -validity full
861    }
862
863    once_only $xlib
864
865    set code \
866	[catch {
867	    $ctx($xlib) encrypt -input      $data \
868				-recipients $recipient
869	 } result]
870
871    $recipient free
872
873    if {$code} {
874        debugmsg ssj "encryption processing error ($xlib): $result ($data)"
875
876        set options(encrypt,$xlib,$to) 0
877        incr gpg_error_id
878        if {[MessageDlg .encrypt_error$gpg_error_id \
879		-aspect 50000 \
880		-icon error \
881		-type user \
882                -buttons {ok cancel} \
883		-default 0 \
884		-cancel 1 \
885                -message [::msgcat::mc \
886			      "Unable to encipher data for %s:\
887			       %s.\n\nEncrypting traffic to this user is\
888			       now disabled.\n\nSend it as PLAINTEXT?" \
889			      $to $result]]} {
890            error ""
891        }
892
893        return
894    }
895    set result [armor:encode $result]
896
897    debugmsg ssj "ENCRYPT: $xlib; $data; $result"
898
899    return $result
900}
901
902proc ::ssj::whichkeys {xlib what} {
903    variable ctx
904    variable warnings
905
906    if {[catch {$ctx($xlib) set -property last-op-info} s]} {
907        return
908    }
909
910    set keys {}
911    while {([set x [string first <fpr> $s]] > 0) \
912                && ([set y [string first </fpr> $s]] > $x) \
913                && ($x+45 == $y)} {
914        lappend keys [string range $s [expr {$x + 20}] [expr {$y - 1}]]
915        set s [string range $s $y end]
916    }
917
918    if {![info exists warnings($what)]} {
919        set warnings($what) ""
920    } elseif {[string equal $warnings($what) $keys]} {
921        return
922    }
923
924    set warnings($what) $keys
925    debugmsg ssj "${what}ing with $keys"
926}
927
928#############################################################################
929
930proc ::ssj::prefs {xlib jid} {
931    variable ctx
932    variable options
933    variable optionsX
934
935    set w [win_id security_preferences [list $xlib $jid]]
936
937    if {[winfo exists $w]} {
938        focus -force $w
939        return
940    }
941
942    Dialog $w \
943	   -title [::msgcat::mc "Change security preferences for %s" $jid] \
944	   -separator 1 -anchor e -default 0 -cancel 1
945
946    $w add -text [::msgcat::mc "OK"] \
947	   -command [list ::ssj::prefs_ok $w $xlib $jid]
948    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
949
950    set f [$w getframe]
951
952    if {![info exists options(encrypt,$xlib,$jid)]} {
953        set options(encrypt,$xlib,$jid) [encryptP $xlib $jid]
954    }
955
956    set optionsX(encrypt,$xlib,$jid) $options(encrypt,$xlib,$jid)
957    checkbutton $f.encrypt \
958        -text     [::msgcat::mc "Encrypt traffic"] \
959        -variable ::ssj::optionsX(encrypt,$xlib,$jid)
960
961    pack $f.encrypt -side left
962    pack [frame $f.f -width 9c -height 2c]
963
964    $w draw $f.name
965}
966
967proc ::ssj::prefs_ok {w xlib jid} {
968    variable options
969    variable optionsX
970
971    set options(encrypt,$xlib,$jid) $optionsX(encrypt,$xlib,$jid)
972
973    destroy $w
974}
975
976proc ::ssj::prefs_user_menu {m xlib jid} {
977    $m add command -label [::msgcat::mc "Edit security..."] \
978	-command [list ::ssj::prefs $xlib $jid]
979}
980
981hook::add chat_create_user_menu_hook ::ssj::prefs_user_menu 78
982hook::add roster_conference_popup_menu_hook ::ssj::prefs_user_menu 78
983hook::add roster_service_popup_menu_hook ::ssj::prefs_user_menu 78
984hook::add roster_jid_popup_menu_hook ::ssj::prefs_user_menu 78
985
986#############################################################################
987
988proc ::ssj::signP {} {
989    variable options
990
991    return $options(sign-traffic)
992}
993
994proc ::ssj::encryptP {xlib jid} {
995    variable ctx
996    variable j2k
997    variable options
998
999    if {[string equal $jid ""]} {
1000	return $options(encrypt-traffic)
1001    }
1002
1003    lassign [roster::get_category_and_subtype $xlib $jid] \
1004            category subtype
1005    switch -- $category {
1006	conference -
1007	server     -
1008	gateway    -
1009	service {
1010	    set resP 0
1011	}
1012
1013	default {
1014	    set resP 1
1015	}
1016    }
1017
1018    set bjid [::xmpp::jid::stripResource $jid]
1019
1020    if {[info exists options(encrypt,$xlib,$jid)]} {
1021        return $options(encrypt,$xlib,$jid)
1022    } elseif {[info exists options(encrypt,$xlib,$bjid)]} {
1023        return $options(encrypt,$xlib,$bjid)
1024    } elseif {[info exists options(encrypt,$jid)]} {
1025	return $options(encrypt,$jid)
1026    } elseif {[info exists options(encrypt,$bjid)]} {
1027	return $options(encrypt,$jid)
1028    }
1029
1030    if {!$options(encrypt-traffic)} {
1031        return 0
1032    }
1033
1034    if {[info exists options(encrypt-tried,$xlib,$jid)]} {
1035        return $options(encrypt-tried,$xlib,$jid)
1036    }
1037
1038    once_only $xlib
1039
1040    if {[info exists j2k($jid)]} {
1041        set name $j2k($jid)
1042    } elseif {($resP) && ([llength [set k [array names j2k $jid/*]]] > 0)} {
1043        set name $j2k([lindex $k 0])
1044    } else {
1045        set name $bjid
1046    }
1047
1048    [set recipient [gpg::recipient]] add \
1049				     -name     $name \
1050				     -validity full
1051
1052    if {[catch {$ctx($xlib) encrypt -input      "Hello world." \
1053				    -recipients $recipient}]} {
1054        set options(encrypt-tried,$xlib,$jid) 0
1055    } else {
1056        set options(encrypt-tried,$xlib,$jid) 1
1057    }
1058
1059    $recipient free
1060
1061    return $options(encrypt-tried,$xlib,$jid)
1062}
1063
1064#############################################################################
1065
1066proc ::ssj::e4meP {xlib keys} {
1067    variable ctx
1068    variable e4me
1069    variable signers
1070
1071    $ctx($xlib) set -property signers \
1072		    -value    [set signers($xlib) $keys]
1073
1074    set e4me($xlib) {}
1075    foreach signer $signers($xlib) {
1076        [set recipient [gpg::recipient]] add \
1077					 -name     $signer \
1078					 -validity full
1079
1080        if {![catch {$ctx($xlib) encrypt -input      "Hello world." \
1081					 -recipients $recipient} result]} {
1082            lappend e4me($xlib) $signer
1083        }
1084
1085        $recipient free
1086    }
1087}
1088
1089#############################################################################
1090
1091proc ::ssj::sign:toggleP {} {
1092    variable options
1093
1094    set options(sign-traffic) [expr {!$options(sign-traffic)}]
1095}
1096
1097proc ::ssj::encrypt:toggleP {{xlib ""} {jid ""}} {
1098    variable options
1099
1100    if {[string equal $jid ""]} {
1101	set options(encrypt-traffic) [expr {!$options(encrypt-traffic)}]
1102        return
1103    }
1104
1105    if {![string equal $xlib ""]} {
1106	if {![info exists options(encrypt,$xlib,$jid)]} {
1107	    set options(encrypt,$xlib,$jid) [encryptP $xlib $jid]
1108	}
1109	set options(encrypt,$xlib,$jid) \
1110	    [expr {!$options(encrypt,$xlib,$jid)}]
1111    } else {
1112	return -code error \
1113	    "::ssj::encrypt:toggleP: xlib is empty and jid is not"
1114    }
1115}
1116
1117#############################################################################
1118
1119proc ::ssj::signed:trace {script} {
1120    variable options
1121    variable trace
1122
1123    if {![info exists trace(sign-traffic)]} {
1124        set trace(sign-traffic) {}
1125
1126        ::trace variable ::ssj::options(sign-traffic) w ::ssj::trace
1127    }
1128
1129    lappend trace(sign-traffic) $script
1130}
1131
1132proc ::ssj::encrypted:trace {script {xlib ""} {jid ""}} {
1133    variable options
1134    variable trace
1135
1136    if {[string equal $jid ""]} {
1137	set k encrypt-traffic
1138    } else {
1139	if {![string equal $xlib ""]} {
1140	    set k encrypt,$xlib,$jid
1141	} else {
1142	    return -code error \
1143		"::ssj::encrypted:trace: xlib is empty and jid is not"
1144	}
1145    }
1146    if {![info exists trace($k)]} {
1147        set trace($k) {}
1148
1149        ::trace variable ::ssj::options($k) w ::ssj::trace
1150    }
1151
1152    lappend trace($k) $script
1153}
1154
1155proc ::ssj::trace {name1 name2 op} {
1156    variable trace
1157
1158    set new {}
1159    foreach script $trace($name2) {
1160        if {[catch {eval $script} result]} {
1161            debugmsg ssj "$result -- $script"
1162        } else {
1163            lappend new $script
1164        }
1165    }
1166    set trace($name2) $new
1167}
1168
1169#############################################################################
1170
1171proc ::ssj::clear_signatures {xlib} {
1172    variable signed
1173
1174    array unset signed $xlib,*
1175}
1176
1177hook::add disconnected_hook ::ssj::clear_signatures
1178
1179#############################################################################
1180
1181proc ::ssj::check_signature {xlib from type x args} {
1182    variable signed
1183
1184    switch -- $type {
1185	unavailable -
1186	available {
1187	    catch {unset signed($xlib,$from)}
1188
1189	    set signature ""
1190	    foreach xs $x {
1191		::xmpp::xml::split $xs tag xmlns attrs cdata subels
1192		if {$xmlns == $::NS(signed)} {
1193		    set signature $cdata
1194		    break
1195		}
1196	    }
1197
1198	    # in case the sender didn't check the exit code from gpg...
1199	    if {[string equal $signature ""]} return
1200
1201	    set status ""
1202	    foreach {key val} $args {
1203		switch -- $key {
1204		    -status { set status $val }
1205		}
1206	    }
1207
1208	    set signed($xlib,$from) \
1209		[signed:input $xlib $from $signature $status \
1210		     [::msgcat::mc "Presence information"]]
1211	}
1212    }
1213}
1214
1215hook::add client_presence_hook ::ssj::check_signature
1216
1217#############################################################################
1218
1219proc ::ssj::add_timestamp_to_signature {varname xlib} {
1220    variable options
1221    upvar 2 $varname var
1222
1223    if {!$options(prevent-replay-attack)} return
1224
1225    if {![catch {signed:output $xlib $var} cdata] &&
1226	    ![string equal $cdata ""]} {
1227	set timestamp [clock format [clock seconds] \
1228				    -format "%Y%m%dT%TZ" -gmt true]
1229	if {![string equal $var ""]} {
1230	    set var " $var"
1231	}
1232	set var "\[[::xmpp::jid::removeResource [connection_jid $xlib]],\
1233		 $timestamp\]$var"
1234    }
1235    return
1236}
1237
1238hook::add rewrite_presence_status_hook ::ssj::add_timestamp_to_signature
1239
1240proc ::ssj::make_signature {varname xlib status} {
1241    upvar 2 $varname var
1242
1243    if {![catch {signed:output $xlib $status} cdata] && \
1244	    ![string equal $cdata ""]} {
1245	lappend var [::xmpp::xml::create x -xmlns $::NS(signed) \
1246					   -cdata $cdata]
1247    }
1248    return
1249}
1250
1251hook::add presence_xlist_hook ::ssj::make_signature
1252
1253#############################################################################
1254
1255proc ::ssj::add_timestamp {vxlib vto vid vtype vsubject vbody verr vthread vx} {
1256    variable options
1257    upvar 2 $vxlib xlib
1258    upvar 2 $vto to
1259    upvar 2 $vbody body
1260    upvar 2 $vx x
1261
1262    if {!$options(prevent-replay-attack)} return
1263
1264    if {![info exists body]} return
1265
1266    if {![catch { ssj::signed:output $xlib $body $to } cdata] &&
1267	    ![string equal $cdata ""]} {
1268	set timestamp [clock format [clock seconds] \
1269				    -format "%Y%m%dT%TZ" -gmt true]
1270	if {![string equal $body ""]} {
1271	    set body " $body"
1272	}
1273	set body "\[[::xmpp::jid::removeResource [connection_jid $xlib]],\
1274		  $timestamp\] $body"
1275    }
1276    return
1277}
1278
1279hook::add rewrite_outgoing_message_hook ::ssj::add_timestamp 5
1280
1281proc ::ssj::sign_encrypt_body {vxlib vto vid vtype vsubject vbody verr vthread vx} {
1282    upvar 2 $vxlib xlib
1283    upvar 2 $vto to
1284    upvar 2 $vbody body
1285    upvar 2 $vx x
1286
1287    if {![info exists body]} return
1288
1289    foreach tag [list signed encrypted] {
1290        if {[catch { ssj::${tag}:output $xlib $body $to } cdata]} {
1291            debugmsg message "ssj::${tag}:output: $cdata"
1292
1293	    # Disable sending the message
1294	    hook::unset_flag rewrite_outgoing_message_hook send
1295
1296            return
1297        }
1298
1299        if {![string equal $cdata ""]} {
1300            lappend x [::xmpp::xml::create x -xmlns $::NS($tag) -cdata $cdata]
1301            if {[string equal $tag encrypted]} {
1302                set body [::msgcat::mc "This message is encrypted."]
1303            }
1304        }
1305    }
1306    return
1307}
1308
1309hook::add rewrite_outgoing_message_hook ::ssj::sign_encrypt_body
1310
1311#############################################################################
1312
1313proc ::ssj::userinfo {tab xlib jid editable} {
1314    variable signed
1315
1316    if {$editable} return
1317
1318    set bare_jid [::xmpp::jid::stripResource $jid]
1319    set chatid [chat::chatid $xlib $bare_jid]
1320    if {[chat::is_groupchat $chatid]} {
1321	if {[info exists signed($xlib,$jid)]} {
1322	    set jids [list $xlib,$jid]
1323	} else {
1324	    set jids [list]
1325	}
1326    } else {
1327	set jids [array names signed $xlib,$bare_jid/*]
1328    }
1329    if {[llength $jids] > 0} {
1330	set presenceinfo [$tab insert end presenceinfo \
1331			      -text [::msgcat::mc "Presence"]]
1332	set i 0
1333	foreach j $jids {
1334	    regexp {[^,]*,(.*)} $j -> fjid
1335	    set x [userinfo::pack_frame $presenceinfo.presence_$i $fjid]
1336	    catch {array unset params}
1337	    array set params $signed($j)
1338
1339	    set kv {}
1340	    set addrs ""
1341	    set s ""
1342	    foreach signature $params(signatures) {
1343		foreach {k v} $signature {
1344		    switch -- $k {
1345			key {
1346			    foreach {k v} $v {
1347				if {![string equal $k subkeys]} continue
1348
1349				foreach subkey $v {
1350				    catch {unset sparams}
1351				    array set sparams $subkey
1352				    if {[info exists sparams(email)]} {
1353					append addrs $s $sparams(email)
1354					set s ", "
1355				    }
1356				}
1357			    }
1358			    continue
1359			}
1360			status { continue }
1361			created -
1362			expires { set v [clock format $v] }
1363			fingerprint {
1364			    lappend kv keyid \
1365				[format "0x%s" [string range $v end-7 end]]
1366			}
1367			default {
1368			    if {[string equal $v ""]} { continue }
1369			}
1370		    }
1371
1372		    lappend kv $k $v
1373		}
1374	    }
1375
1376
1377	    userinfo::pack_entry $jid $x $i presence_$i [::msgcat::mc "Reason:"]
1378	    if {![info exists params(reason)]} {
1379		set params(reason) [::msgcat::mc "Presence is signed"]
1380		if {![string equal $addrs ""]} {
1381		    append params(reason) [::msgcat::mc " by "] $addrs
1382		}
1383	    }
1384	    set userinfo::userinfo(presence_$i,$jid) $params(reason)
1385	    incr i
1386
1387	    foreach {k v} $kv {
1388		userinfo::pack_entry $jid $x $i presence_$i \
1389		    [::msgcat::mc [string totitle ${k}:]]
1390		set userinfo::userinfo(presence_$i,$jid) $v
1391		incr i
1392	    }
1393	}
1394    }
1395}
1396
1397hook::add userinfo_hook ::ssj::userinfo 90
1398
1399#############################################################################
1400
1401proc ::ssj::message_buttons {mw xlib jid} {
1402    set bbox1 [ButtonBox $mw.bottom.buttons1 -spacing 0]
1403
1404    # TODO reflect changes of xlib
1405    set b [$bbox1 add \
1406		  -image [encrypted:icon $xlib $jid] \
1407		  -helptype balloon \
1408		  -helptext [::msgcat::mc "Toggle encryption"] \
1409		  -height 24 \
1410		  -width 24 \
1411		  -relief link \
1412		  -bd $::tk_borderwidth \
1413		  -command [list ::ssj::encrypt:toggleP $xlib $jid]]
1414    encrypted:trace \
1415	"$b configure -image \[::ssj::encrypted:icon [list $xlib] [list $jid]\]" \
1416	$xlib $jid
1417
1418    pack $bbox1 -side left -fill x -padx 2m -pady 2m
1419}
1420
1421hook::add open_message_post_hook ::ssj::message_buttons
1422
1423#############################################################################
1424
1425proc ::ssj::process_x_signed {rowvar bodyvar f x xlib from id type replyP} {
1426    upvar 2 $rowvar row
1427    upvar 2 $bodyvar body
1428
1429    if {!$replyP || [string equal $type error]} {
1430	return
1431    }
1432
1433    foreach xa $x {
1434	::xmpp::xml::split $xa tag xmlns attrs cdata subels
1435
1436	if {$tag != "" || $xmlns != $::NS(signed)} {
1437	    continue
1438	}
1439
1440	set lb [join [lrange [split $f .] 0 end-1] .].title.signed
1441	if {[winfo exists $lb]} {
1442	    destroy $lb
1443	}
1444
1445	grid [signed:Label $lb $xlib $from $attrs] -row 1 -column 2 -sticky e
1446    }
1447
1448    return
1449}
1450
1451hook::add message_process_x_hook ::ssj::process_x_signed 20
1452
1453#############################################################################
1454
1455proc ::ssj::signed:icon {} {
1456    return [lindex [list toolbar/gpg-unsigned toolbar/gpg-signed] \
1457                   [signP]]
1458}
1459
1460proc ::ssj::encrypted:icon {{xlib ""} {jid ""}} {
1461    return [lindex [list toolbar/gpg-unencrypted toolbar/gpg-encrypted] \
1462                   [encryptP $xlib $jid]]
1463}
1464
1465#############################################################################
1466
1467proc ::ssj::draw_signed {chatid from type body x} {
1468    variable signedid
1469
1470    set chatw [chat::chat_win $chatid]
1471
1472    foreach xe $x {
1473        ::xmpp::xml::split $xe tag xmlns attrs cdata subels
1474
1475        if {$tag != "" || ![string equal $xmlns $::NS(signed)]} {
1476            continue
1477        }
1478
1479        incr signedid
1480	set xlib [chat::get_xlib $chatid]
1481        catch {
1482	    set lb $chatw.signed$signedid
1483            $chatw window create end \
1484                  -window [signed:Label $lb $xlib $from $attrs]
1485	    $lb configure -bg [get_conf $chatw -bg]
1486        }
1487    }
1488}
1489
1490hook::add draw_message_hook ::ssj::draw_signed 7
1491
1492###############################################################################
1493
1494proc ::ssj::chat_window_button {chatid type} {
1495    set xlib [chat::get_xlib $chatid]
1496    set jid [chat::get_jid $chatid]
1497    set cw [chat::winid $chatid]
1498
1499    Button $cw.status.encrypted \
1500	   -relief flat \
1501           -image [encrypted:icon $xlib $jid] \
1502           -helptype balloon \
1503           -helptext [::msgcat::mc "Toggle encryption"] \
1504           -command [list ::ssj::encrypt:toggleP $xlib $jid]
1505
1506    encrypted:trace "$cw.status.encrypted configure \
1507		-image \[::ssj::encrypted:icon $xlib $jid\]" \
1508        $xlib $jid
1509    pack $cw.status.encrypted -side left -before $cw.status.mb
1510}
1511
1512hook::add open_chat_post_hook ::ssj::chat_window_button
1513
1514###############################################################################
1515
1516proc ::ssj::toolbar {} {
1517    set idx [ifacetk::add_toolbar_button \
1518		 [signed:icon] \
1519		 ::ssj::sign:toggleP \
1520		 [::msgcat::mc "Toggle signing presence updates"]]
1521    signed:trace \
1522	[list ifacetk::set_toolbar_icon $idx ::ssj::signed:icon]
1523
1524    set idx [ifacetk::add_toolbar_button \
1525		 [encrypted:icon] \
1526		 ::ssj::encrypt:toggleP \
1527		 [::msgcat::mc "Toggle encryption (when possible)"]]
1528    encrypted:trace \
1529	[list ifacetk::set_toolbar_icon $idx ::ssj::encrypted:icon]
1530}
1531
1532hook::add finload_hook ::ssj::toolbar
1533
1534###############################################################################
1535
1536proc ::ssj::setup_menu {} {
1537    variable options
1538
1539    catch {
1540	set m [.mainframe getmenu tkabber]
1541	set ind [$m index [::msgcat::mc "View"]]
1542	incr ind -1
1543
1544	set mm .ssj_menu
1545	menu $mm -tearoff $::ifacetk::options(show_tearoffs)
1546	$mm add checkbutton -label [::msgcat::mc "Sign presence updates"] \
1547	    -variable ::ssj::options(sign-traffic)
1548	$mm add checkbutton -label [::msgcat::mc "Encrypt messages (when possible)"] \
1549	    -variable ::ssj::options(encrypt-traffic)
1550
1551	$m insert $ind cascade -label [::msgcat::mc "Encryption"] \
1552	    -menu $mm
1553    }
1554}
1555
1556
1557hook::add finload_hook ::ssj::setup_menu
1558
1559###############################################################################
1560
1561proc ::ssj::add_user_popup_info {infovar xlib jid} {
1562    variable signed
1563
1564    upvar 0 $infovar info
1565
1566    if {[info exists signed($xlib,$jid)]} {
1567	set signed_info [signed:info $signed($xlib,$jid)]
1568	append info [::msgcat::mc "\n\tPresence is signed:"]
1569	regsub -all {(\n)} "\n$signed_info" "\\1\t    " extra
1570	append info $extra
1571    }
1572}
1573
1574hook::add roster_user_popup_info_hook ::ssj::add_user_popup_info 99
1575
1576###############################################################################
1577
1578proc ::ssj::process_gpg_input_error {xlib from what message} {
1579    show_error $message
1580}
1581
1582hook::add gpg_input_error_hook ::ssj::process_gpg_input_error 99
1583
1584proc ::ssj::show_error {message} {
1585  set w .gpg_error
1586
1587  if {![winfo exists $w]} {
1588    Dialog $w -title [::msgcat::mc "GPG error"] \
1589      -modal none -transient no \
1590      -separator 1 -anchor e -default 0
1591    $w add -text [::msgcat::mc "Close"] -command [list destroy $w]
1592
1593    set f [$w getframe]
1594    text $f.text -wrap word -yscrollcommand [list $f.vsb set]
1595    scrollbar $f.vsb -orient vertical -command [list $f.text yview]
1596    grid $f.text $f.vsb -sticky ns
1597    grid $f.text -sticky news
1598    grid rowconfigure    $f 0 -weight 1
1599    grid columnconfigure $f 0 -weight 1
1600
1601    $w draw
1602  }
1603
1604  set t [$w getframe].text
1605  $t configure -state normal
1606  $t insert end [format {[%s]: %s} \
1607    [clock format [clock seconds]] $message\n\n]
1608  $t configure -state disabled
1609}
1610
1611# vim:ts=8:sw=4:sts=4:noet
1612