1# $Id$
2#
3# Obsolete jabberd 1.4 mod_filter (which has been never documented in XEP) support.
4#
5
6
7namespace eval filters {
8    set condtags {unavailable from resource subject body show type}
9    set acttags {settype forward reply offline continue}
10
11
12    set fromtag(unavailable)	[::msgcat::mc "I'm not online"]
13    set fromtag(from)		[::msgcat::mc "the message is from"]
14    set fromtag(resource)	[::msgcat::mc "the message is sent to"]
15    set fromtag(subject)	[::msgcat::mc "the subject is"]
16    set fromtag(body) 		[::msgcat::mc "the body is"]
17    set fromtag(show) 		[::msgcat::mc "my status is"]
18    set fromtag(type) 		[::msgcat::mc "the message type is"]
19    set fromtag(settype)	[::msgcat::mc "change message type to"]
20    set fromtag(forward)	[::msgcat::mc "forward message to"]
21    set fromtag(reply) 		[::msgcat::mc "reply with"]
22    set fromtag(offline)	[::msgcat::mc "store this message offline"]
23    set fromtag(continue)	[::msgcat::mc "continue processing rules"]
24
25    set totag($fromtag(unavailable))	unavailable
26    set totag($fromtag(from))		from
27    set totag($fromtag(resource))	resource
28    set totag($fromtag(subject))	subject
29    set totag($fromtag(body)) 		body
30    set totag($fromtag(show)) 		show
31    set totag($fromtag(type)) 		type
32    set totag($fromtag(settype))	settype
33    set totag($fromtag(forward))	forward
34    set totag($fromtag(reply)) 		reply
35    set totag($fromtag(offline))	offline
36    set totag($fromtag(continue))	continue
37
38    set rulecondmenu [list $fromtag(unavailable) $fromtag(from) \
39			  $fromtag(resource) $fromtag(subject) $fromtag(body) \
40			  $fromtag(show) $fromtag(type)]
41
42    set ruleactmenu [list $fromtag(settype) $fromtag(forward) $fromtag(reply) \
43			 $fromtag(offline) $fromtag(continue)]
44
45    set m [menu .rulecondmenu -tearoff 0]
46    $m add command -label $fromtag(unavailable)
47    $m add command -label $fromtag(from)
48    $m add command -label $fromtag(resource)
49    $m add command -label $fromtag(subject)
50    $m add command -label $fromtag(body)
51    $m add command -label $fromtag(show)
52    $m add command -label $fromtag(type)
53
54    set m [menu .ruleactmenu -tearoff 0]
55    $m add command -label $fromtag(settype)
56    $m add command -label $fromtag(forward)
57    $m add command -label $fromtag(reply)
58    $m add command -label $fromtag(offline)
59    $m add command -label $fromtag(continue)
60
61    custom::defgroup Privacy [::msgcat::mc "Blocking communication options."] -group Tkabber
62
63    custom::defvar options(enable) 0 \
64	[::msgcat::mc "Enable jabberd 1.4 mod_filter support (obsolete)."] \
65	-type boolean -group Privacy \
66	-command [namespace code setup_menu]
67}
68
69proc filters::setup_menu {args} {
70    variable options
71
72    set mlabel [::msgcat::mc "Edit message filters"]
73
74    set m [.mainframe getmenu privacy]
75    catch { set idx [$m index $mlabel] }
76
77    if {$options(enable) && ![info exists idx]} {
78	$m add separator
79	$m add command -label $mlabel -command [namespace code open]
80	return
81    }
82
83    if {!$options(enable) && [info exists idx]} {
84	$m delete [expr {$idx - 1}] $idx
85	return
86    }
87}
88
89hook::add finload_hook [namespace current]::filters::setup_menu
90
91proc filters::open {} {
92    variable rf
93
94    if {[winfo exists .filters]} {
95	.filters draw
96	return
97    }
98
99    set xlib [lindex [connections] 0]
100
101    ::xmpp::sendIQ $xlib get \
102	-query [::xmpp::xml::create item -xmlns jabber:iq:filter] \
103	-command [list filters::recv]
104}
105
106
107proc filters::recv {res child} {
108    variable rf
109    variable rule
110    variable rulelist
111
112    debugmsg filters "$res $child"
113
114    if {![string equal $res ok]} {
115	MessageDlg .filters_err -aspect 50000 -icon error \
116	    -message [::msgcat::mc "Requesting filter rules: %s" \
117			  [error_to_string $child]] \
118	    -type user -buttons ok -default 0 -cancel 0
119	return
120    }
121
122
123    Dialog .filters -title [::msgcat::mc "Filters"] -separator 1 -anchor e \
124	-modal none \
125	-default 0 -cancel 1
126
127    set f [.filters getframe]
128
129    set bf [frame $f.bf]
130    pack $bf -side right -anchor n
131
132    set bb [ButtonBox $bf.bb -orient vertical -spacing 0]
133    $bb add -text [::msgcat::mc "Add"] -command {filters::add}
134    $bb add -text [::msgcat::mc "Edit"] -command {filters::edit}
135    $bb add -text [::msgcat::mc "Remove"] -command {filters::remove}
136    $bb add -text [::msgcat::mc "Move up"] -command {filters::move -1}
137    $bb add -text [::msgcat::mc "Move down"] -command {filters::move 1}
138    pack $bb -side top
139
140    set sw [ScrolledWindow $f.sw]
141    set rf [listbox $sw.rules]
142    pack $sw -expand yes -fill both
143    $sw setwidget $rf
144
145    set ok [.filters add -text [::msgcat::mc "OK"] \
146		-command {filters::commit}]
147    .filters add -text [::msgcat::mc "Cancel"] -command {destroy .filters}
148
149    $rf delete 0 end
150    array unset rule
151    set rulelist {}
152
153    ::xmpp::xml::split $child tag xmlns attrs cdata subels
154
155    if {[string equal $xmlns jabber:iq:filter]} {
156	foreach child $subels {
157	    process_rule $child
158	}
159    }
160    $rf activate 0
161
162    .filters draw
163}
164
165proc filters::process_rule {child} {
166    variable rf
167    variable rulelist
168
169    ::xmpp::xml::split $child tag xmlns attrs cdata subels
170
171    set rname [::xmpp::xml::getAttr $attrs name]
172    $rf insert end $rname
173    lappend rulelist $rname
174
175    foreach data $subels {
176	process_rule_data $rname $data
177    }
178}
179
180proc filters::process_rule_data {name child} {
181    variable rule
182
183    ::xmpp::xml::split $child tag xmlns attrs cdata subels
184
185    lappend rule($name) $tag $cdata
186    debugmsg filters [array get rule]
187}
188
189proc filters::edit {} {
190    variable rf
191
192    set name [$rf get active]
193    debugmsg filters $name
194    if {$name != ""} {
195	open_edit $name
196    }
197}
198
199
200proc filters::open_edit {rname} {
201    variable rule
202    variable tmp
203
204    set w [win_id rule $rname]
205
206    if {[winfo exists $w]} {
207	focus -force $w
208	return
209    }
210
211    Dialog $w -title [::msgcat::mc "Edit rule"] -separator 1 -anchor e -modal none \
212	    -default 0 -cancel 1
213
214    set f [$w getframe]
215
216    label $f.lrname -text [::msgcat::mc "Rule Name:"]
217    entry $f.rname -textvariable filters::tmp($rname,name)
218    set tmp($rname,name) $rname
219
220    grid $f.lrname -row 0 -column 0 -sticky e
221    grid $f.rname  -row 0 -column 1 -sticky ew
222
223    set cond [TitleFrame $f.cond -text [::msgcat::mc "Condition"] -borderwidth 2 -relief groove]
224    set fc [$cond getframe]
225
226    button $fc.add -text [::msgcat::mc "Add"]
227    pack $fc.add -side right -anchor n
228
229    set swc [ScrolledWindow $fc.sw -relief sunken -borderwidth $::tk_borderwidth]
230    pack $swc -expand yes -fill both
231    set sfc [ScrollableFrame $swc.f -height 100]
232    $swc setwidget $sfc
233
234    grid $cond -row 1 -column 0 -sticky news -columnspan 2
235
236    set act [TitleFrame $f.act -text [::msgcat::mc "Action"] -borderwidth 2 -relief groove]
237    set fa [$act getframe]
238
239    button $fa.add -text [::msgcat::mc "Add"]
240    pack $fa.add -side right -anchor n
241
242    set swa [ScrolledWindow $fa.sw -relief sunken -borderwidth $::tk_borderwidth]
243    pack $swa -expand yes -fill both
244    set sfa [ScrollableFrame $swa.f -height 100]
245    $swa setwidget $sfa
246
247    grid $act -row 2 -column 0 -sticky news -columnspan 2
248
249
250    grid columnconfig $f 1 -weight 1 -minsize 0
251    grid rowconfig $f 1 -weight 1
252    grid rowconfig $f 2 -weight 1
253
254    set fcond [$sfc getframe]
255    set fact [$sfa getframe]
256
257    $w add -text [::msgcat::mc "OK"] -command [list filters::accept_rule $w $rname $fcond $fact]
258    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
259
260    variable ruleactmenu
261    variable rulecondmenu
262    $fc.add configure \
263	-command [list filters::insert_item \
264		      $fcond unavailable "" $rulecondmenu]
265    $fa.add configure \
266	-command [list filters::insert_item $fact settype "" $ruleactmenu]
267
268    fill_rule $rname $fcond $fact
269
270    $w draw
271}
272
273
274proc filters::fill_rule {rname fcond fact} {
275    variable rule
276    variable condtags
277    variable acttags
278    variable ruleactmenu
279    variable rulecondmenu
280    variable items
281
282    set items($fcond) {}
283    set items($fact) {}
284    foreach {tag value} $rule($rname) {
285	if {[lcontain $condtags $tag]} {
286	    debugmsg filters "C $tag $value"
287	    insert_item $fcond $tag $value $rulecondmenu
288	} elseif {[lcontain $acttags $tag]} {
289	    debugmsg filters "A $tag $value"
290	    insert_item $fact $tag $value $ruleactmenu
291	}
292    }
293}
294
295
296
297proc filters::insert_item {f tag val menu} {
298    variable items
299    variable fromtag
300
301    if {[llength $items($f)]} {
302	set n [expr {[lindex $items($f) [expr {[llength $items($f)] - 1}]] + 1}]
303    } else {
304	set n 0
305    }
306
307    # TODO: hiding entry for some tags
308    eval [list OptionMenu $f.mb$n $f.mb$n.var] $menu
309    global $f.mb$n.var
310    set $f.mb$n.var $fromtag($tag)
311    entry $f.e$n
312    $f.e$n insert 0 $val
313    Separator $f.sep$n -orient vertical
314    button $f.remove$n -text [::msgcat::mc "Remove"] -command [list filters::remove_item $f $n]
315
316    grid $f.mb$n      -row $n -column 0 -sticky ew
317    grid $f.e$n       -row $n -column 1 -sticky ew
318    grid $f.sep$n     -row $n -column 2 -sticky ew
319    grid $f.remove$n  -row $n -column 3 -sticky ew
320
321
322    lappend items($f) $n
323    debugmsg filters $items($f)
324}
325
326proc filters::remove_item {f n} {
327    variable items
328
329    set idx [lsearch -exact $items($f) $n]
330    set items($f) [lreplace $items($f) $idx $idx]
331
332    eval destroy [grid slaves $f -row $n]
333
334    debugmsg filters $items($f)
335}
336
337proc filters::accept_rule {w rname fcond fact} {
338    variable items
339    variable totag
340    variable rule
341    variable tmp
342    variable rf
343    variable rulelist
344
345    set newname $tmp($rname,name)
346    if {$newname == ""} {
347	MessageDlg .rname_err -aspect 50000 -icon error \
348	    -message [::msgcat::mc "Empty rule name"] -type user \
349	    -buttons ok -default 0 -cancel 0
350	return
351    }
352    if {$rname != $newname && [lcontain $rulelist $newname]} {
353	MessageDlg .rname_err -aspect 50000 -icon error \
354	    -message [::msgcat::mc "Rule name already exists"] -type user \
355	    -buttons ok -default 0 -cancel 0
356	return
357    }
358
359
360    set rule($newname) {}
361    foreach n $items($fcond) {
362	set tag $totag([set ::$fcond.mb$n.var])
363	set val [$fcond.e$n get]
364	debugmsg filters "$tag $val"
365	lappend rule($newname) $tag $val
366    }
367
368    foreach n $items($fact) {
369	set tag $totag([set ::$fact.mb$n.var])
370	set val [$fact.e$n get]
371	debugmsg filters "$tag $val"
372	lappend rule($newname) $tag $val
373    }
374
375    debugmsg filters [array get rule]
376
377    set idx [lsearch -exact $rulelist $rname]
378    set rulelist [lreplace $rulelist $idx $idx $newname]
379
380    $rf delete 0 end
381    foreach r $rulelist {
382	$rf insert end $r
383    }
384
385
386    set items($fcond) {}
387    set items($fact) {}
388    destroy $w
389}
390
391proc filters::add {} {
392    variable rule
393    set rule() {}
394    open_edit ""
395}
396
397proc filters::remove {} {
398    variable rf
399    variable rulelist
400
401    set name [$rf get active]
402    debugmsg filters $name
403    if {$name != ""} {
404	set idx [lsearch -exact $rulelist $name]
405	set rulelist [lreplace $rulelist $idx $idx]
406	$rf delete active
407	debugmsg filters $rulelist
408    }
409}
410
411proc filters::commit {} {
412    variable rulelist
413    variable rule
414
415    set result {}
416    foreach rname $rulelist {
417	set rtags {}
418	foreach {tag val} $rule($rname) {
419	    lappend rtags [::xmpp::xml::create $tag -cdata $val]
420	}
421
422	lappend result [::xmpp::xml::create rule \
423			    -attrs [list name $rname] \
424			    -subelements $rtags]
425    }
426
427    debugmsg filters $result
428
429    set xlib [lindex [connections] 0]
430
431    ::xmpp::sendIQ $xlib set \
432	    -query [::xmpp::xml::create item \
433			    -xmlns jabber:iq:filter \
434			    -subelements $result]
435
436    destroy .filters
437}
438
439proc filters::move {shift} {
440    variable rulelist
441    variable rf
442
443    set name [$rf get active]
444    set idx [lsearch -exact $rulelist $name]
445    set rulelist [lreplace $rulelist $idx $idx]
446    set newidx [expr {$idx + $shift}]
447    set rulelist [linsert $rulelist $newidx $name]
448
449    debugmsg filters $rulelist
450
451    $rf delete 0 end
452    foreach r $rulelist {
453	$rf insert end $r
454    }
455
456    $rf activate $newidx
457    $rf selection set $newidx
458
459    #set newidx [expr [$rf index active] - 1]
460    #$rf move active $newidx
461}
462