1#!%TCLSH%
2
3#
4# Search informations (host name, IP address, MAC address, groups, etc.)
5#
6# Parameters (form or url):
7#	- q: search query (ip, cidr, or fqdn, or _ for "here")
8#
9# History
10#   2002/07/25 : pda      : design
11#   2003/05/13 : pda/jean : use auth base
12#   2004/01/14 : pda/jean : add IPv6
13#   2004/08/06 : pda/jean : extend network access rights
14#   2005/02/24 : pda      : add case role mail without IP address
15#   2010/10/17 : pda      : add search case for "here"
16#   2010/12/10 : pda      : i18n
17#   2010/12/25 : pda      : use cgi-dispatch
18#   2013/03/06 : pda/jean : multi-views
19#   2013/03/13 : pda/jean : generalization to different object types
20#   2013/20/06 : schplurtz: fix bug
21#
22
23#
24# Template pages used by this script
25#
26
27set conf(page)		search.html
28
29#
30# Next actions
31#
32
33set conf(next)		"search"
34
35#
36# Script parameters
37#
38
39set conf(form)	{
40	{q	0 1 {}}
41}
42
43#
44# Netmagis general library
45#
46
47source %LIBNETMAGIS%
48
49# ::webapp::cgidebug ; exit
50
51##############################################################################
52# Utilities
53##############################################################################
54
55proc display-message {q msg} {
56    global conf
57
58    set qmsg [::webapp::html-string $msg]
59    set qq   [::webapp::html-string $q]
60    set result [::webapp::helem "font" $qmsg "color" "#FF0000"]
61    d urlset "%URLFORM%" $conf(next) {}
62    d result $conf(page) [list \
63				[list %CRITERE% $qq] \
64				[list %RESULTAT% $result] \
65			    ]
66    exit 0
67}
68
69#
70# Parse a search query, which has the form
71#	[<sel>:]<val>
72# Examples:
73#	192.168.1.2 01
74#	01:02:03:04:05:06
75#	www.example.com
76#	host: www
77#	net: lab
78#
79# Input:
80#   - dbfd: database access
81#   - q: user query
82#   - _sel, _val, _type: see below
83# Output:
84#   - return value: empty string or error message
85#   - sel: list of selector procedures (see cgi-search-* procedures)
86#   - val: value to search
87#   - type: detected value type (mac, inet, cidr or string)
88#
89# History:
90#   2013/02/27: pda/jean : attempt to spec
91#   2013/03/06: pda/jean : design
92#   2013/06/20: schplurtz : return more accurate search func list
93#
94
95proc parse-query {dbfd q _sel _val _type} {
96    global conf
97
98    upvar $_sel sel
99    upvar $_val val
100    upvar $_type type
101
102    set sel ""
103    set val ""
104    set type ""
105
106    set matchproc *
107    set q [string trim $q]
108    #
109    # Avoid case where the beginning of a MAC address is confused with
110    # an operator
111    #
112    if {$q eq "_"} then {
113	set sel "myaddr"
114	set val "_"
115	set type ""
116	set matchproc myaddr
117    } elseif {[check-mac-syntax $dbfd $q] eq ""} then {
118	set sel ""
119	set val $q
120	set type "mac"
121	set matchproc host
122    } elseif {[check-ip-syntax $dbfd $q "inet"] eq ""} then {
123	set sel ""
124	set val $q
125	set type "inet"
126	set matchproc host
127	set r ""
128    } elseif {[check-ip-syntax $dbfd $q "cidr"] eq ""} then {
129	set sel ""
130	set val $q
131	set type "cidr"
132	set r ""
133	set matchproc cidr ; # cgi-search*cidr not yet implemented
134    } else {
135	#
136	# Check operator and value
137	#
138
139	if {[regexp {^(([a-z]+):\s*)?(\S+)$} $q dum1 dum2 sel val]} then {
140	    # nothing
141	} elseif {[regexp {^\S+$} $q val]} then {
142	    set sel ""
143	} else {
144	    return [mc "Invalid search query '%s'" $q]
145	}
146
147	#
148	# Recognize type
149	#
150
151	if {[check-ip-syntax $dbfd $val "inet"] eq ""} then {
152	    set type "inet"
153	    set matchproc host
154	} elseif {[check-ip-syntax $dbfd $val "cidr"] eq ""} then {
155	    set matchproc [set type "cidr"]
156	} else {
157	    set type "string"
158	}
159    }
160
161    #
162    # Verify operator/type compatibility
163    #
164
165    if {$sel eq ""} then {
166	set sel [lsort [info procs "cgi-search-*-$matchproc"]]
167    } else {
168	set proc [info procs "cgi-search-*-$sel"]
169	if {$proc eq ""} then {
170	    return [mc "Invalid search operator '%s'" $sel]
171	}
172	set sel [list $proc]
173    }
174
175    return ""
176}
177
178proc display-host {dbfd _trr idview q} {
179    upvar $_trr trr
180
181    set rrtmpl {
182	allowed-groups {search {q group:%s}}
183	ip {edit {addr %1$s} {idview %2$s}}
184    }
185
186    array set t $rrtmpl
187    lappend t(ip) {nextprog search}
188    lappend t(ip) [list "nextargs" "q=$q"]
189    set rrtmpl [array get t]
190
191    lassign [display-rr-masked $dbfd trr $idview $rrtmpl] link desc
192    set title [mc {%1$s is a host in view %2$s} $link [u viewname $idview]]
193    return "$title $desc"
194}
195
196
197proc display-alias {dbfd _trr idview q} {
198    upvar $_trr trr
199
200    h mask-next
201    set fqdn "$trr(name).$trr(domain)"
202    set idalias [rr-cname-by-view trr $idview]
203    if {! [read-rr-by-id $dbfd $idalias trra]} then {
204	d error [mc {Cannot read host-id %s} $idalias]
205    }
206
207    set rrtmpl {
208	allowed-groups {search {q group:%s}}
209	ip {edit {addr %1$s} {idview %2$s}}
210    }
211
212    # Display aliased host
213    lassign [display-rr-masked $dbfd trra $idview $rrtmpl] link desc
214    set title [mc {%1$s is an alias of host %2$s in view %3$s} $fqdn $link [u viewname $idview]]
215
216    return "$title $desc"
217}
218
219proc display-all-mx {dbfd _trr idview q} {
220    upvar $_trr trr
221
222    h mask-next
223    set fqdn "$trr(name).$trr(domain)"
224    set lmx [rr-mx-by-view trr $idview]
225
226    set rrtmpl {
227	allowed-groups {search {q group:%s}}
228	ip {edit {addr %1$s} {idview %2$s}}
229    }
230
231    set lfound {}
232    foreach mx $lmx {
233	lassign $mx prio idtarget
234	if {! [read-rr-by-id $dbfd $idtarget trrt]} then {
235	    d error [mc {Cannot read MX with id %s} $idtarget]
236	}
237
238	# Display MX target host
239	lassign [display-rr-masked $dbfd trrt $idview $rrtmpl] link desc
240	set title [mc {%1$s is a MX (priority %2$s) to host %3$s in view %4$s} $fqdn $prio $link [u viewname $idview]]
241
242	lappend lfound "$title $desc"
243    }
244
245    return $lfound
246}
247
248proc display-mailrole {dbfd _trr idview q} {
249    upvar $_trr trr
250
251    h mask-next
252    set fqdn "$trr(name).$trr(domain)"
253    lassign [rr-mailrole-by-view trr $idview] idheb idviewheb
254    if {! [read-rr-by-id $dbfd $idheb trrh]} then {
255	d error [mc {Cannot read host-id %s} $idheb]
256    }
257
258    set rrtmpl {
259	allowed-groups {search {q group:%s}}
260	ip {edit {addr %1$s} {idview %2$s}}
261    }
262
263    # Display aliased host
264    lassign [display-rr-masked $dbfd trrh $idviewheb $rrtmpl] link desc
265    set title [mc {%1$s in view %2$s is a mail address hosted by %3$s in view %4$s} $fqdn [u viewname $idview] $link [u viewname $idviewheb]]
266
267    return "$title $desc"
268}
269
270
271##############################################################################
272# Search cases
273##############################################################################
274
275proc cgi-search-100-myaddr {dbfd q val type} {
276    global env
277
278    set lfound {}
279    if {[info exists env(REMOTE_ADDR)] && $val eq "_"} then {
280	set val $env(REMOTE_ADDR)
281	foreach idview [u myviewids] {
282	    if {[read-rr-by-ip $dbfd $val $idview trr]} then {
283		lappend lfound [display-host $dbfd trr $idview $q]
284	    }
285	}
286	if {[llength $lfound] == 0} then {
287	    lappend lfound [mc "Searched address: %s" $val]
288	}
289    }
290    return $lfound
291}
292
293proc cgi-search-150-host {dbfd q val type} {
294    set lfound {}
295
296    switch $type {
297	mac {
298	    #
299	    # Attempt to search for the host. It if exists, trr will
300	    # be filled. If it does not exists, trr will not be created.
301	    # We don't test result, since existence of trr(idrr) will
302	    # suffice for next steps.
303	    #
304	    if {[read-rr-by-mac $dbfd $val trr]} then {
305		set lhost {}
306		foreach idview [u myviewids] {
307		    if {[llength [rr-ip-by-view trr $idview]] > 0} then {
308			lappend lhost $idview
309			break
310		    }
311		}
312		foreach idview $lhost {
313		    lappend lfound [display-host $dbfd trr $idview $q]
314		}
315	    }
316	}
317	inet {
318	    #
319	    # Attempt to search for the host. It if exists, trr will
320	    # be filled. If it does not exists, trr will not be created.
321	    # We don't test result, since existence of trr(idrr) will
322	    # suffice for next steps.
323	    #
324	    foreach idview [u myviewids] {
325		if {[read-rr-by-ip $dbfd $val $idview trr]} then {
326		    lappend lfound [display-host $dbfd trr $idview $q]
327		}
328	    }
329	}
330	cidr {
331	}
332	string {
333	    if {[regexp {^[^.]+\..+$} $val]} then {
334		#
335		# Name and domain
336		#
337		set msg [check-fqdn-syntax $dbfd $val name domain iddom]
338		if {$msg ne ""} then {
339		    display-message $val $msg
340		}
341		set ldom [list $iddom]
342	    } else {
343		set msg [check-name-syntax $val]
344		if {$msg ne ""} then {
345		    display-message $val $msg
346		}
347		set ldom [u myiddom]
348		set name $val
349	    }
350
351	    foreach iddom $ldom {
352		foreach idview [u myviewids] {
353		    if {[read-rr-by-name $dbfd $name $iddom $idview trr]} then {
354			if {[llength [rr-ip-by-view trr $idview]] > 0} then {
355			    lappend lfound [display-host $dbfd trr $idview $q]
356			}
357			if {[rr-cname-by-view trr $idview] ne ""} then {
358			    lappend lfound [display-alias $dbfd trr $idview $q]
359			}
360			if {[rr-mx-by-view trr $idview] ne ""} then {
361			    foreach l [display-all-mx $dbfd trr $idview $q] {
362				lappend lfound $l
363			    }
364			}
365		    }
366		}
367	    }
368	}
369	default {
370	    d error [mc "Internal error: unknown type"]
371	}
372    }
373
374    return $lfound
375}
376
377proc cgi-search-160-mailrole {dbfd q val type} {
378    set lfound {}
379
380    switch $type {
381	string {
382	    if {[regexp {^[^.]+\..+$} $val]} then {
383		#
384		# Name and domain
385		#
386		set msg [check-fqdn-syntax $dbfd $val name domain iddom]
387		if {$msg ne ""} then {
388		    display-message $val $msg
389		}
390		set ldom [list $iddom]
391	    } else {
392		set msg [check-name-syntax $val]
393		if {$msg ne ""} then {
394		    display-message $val $msg
395		}
396		set ldom [u myiddom]
397		set name $val
398	    }
399
400	    foreach iddom $ldom {
401		foreach idview [u myviewids] {
402		    if {[read-rr-by-name $dbfd $name $iddom $idview trr]} then {
403			set rm [rr-mailrole-by-view trr $idview]
404			if {[llength $rm] > 0} then {
405			    lappend lfound [display-mailrole $dbfd trr $idview $q]
406			}
407		    }
408		}
409	    }
410	}
411	mac -
412	inet -
413	cidr {
414	    d error [mc "Invalid search query '%s'" $q]
415	}
416	default {
417	    d error [mc "Internal error: unknown type"]
418	}
419    }
420
421    return $lfound
422}
423
424proc cgi-search-400-group {dbfd q val type} {
425    set lfound {}
426
427    set idgrp [u groupid $val]
428    if {$idgrp ne ""} then {
429	#
430	# Get all login names for this group
431	#
432	set lcor {}
433	set sql "SELECT login FROM global.nmuser
434				WHERE idgrp = $idgrp
435				ORDER BY login"
436	pg_select $dbfd $sql tab {
437	    lappend lcor $tab(login)
438	}
439
440	h mask-next
441	set link [h mask-link $val]
442	set title [mc "%s is a Netmagis group" $link]
443
444	# members of the group
445	if {[llength $lcor] == 0} then {
446	    set desc [mc "Empty group (no user)"]
447	} else {
448	    set desc ""
449	    foreach login $lcor {
450		set n [read-user $dbfd $login tabuid msg]
451		if {$n != 1} then {
452		    d error $msg
453		}
454		append desc "\n<p>\n"
455		append desc [display-user tabuid]
456	    }
457	}
458	set desc [h mask-text $desc]
459	lappend lfound "$title\n$desc"
460    }
461    return $lfound
462}
463
464##############################################################################
465# Display empty page
466##############################################################################
467
468d cgi-register {q {}} {} {
469
470    #
471    # Not an error, strictly speaking, but treated as an error.
472    #
473
474    display-message "" ""
475}
476
477##############################################################################
478# Display given address (or my current IP address)
479##############################################################################
480
481d cgi-register {q .+} {} {
482    global conf
483    global env
484
485    #
486    # Parse query, check consistancy and deduce search cases
487    #
488
489    set msg [parse-query $dbfd $q sel val type]
490    if {$msg ne ""} then {
491	display-message $q $msg
492    }
493
494    #
495    # Loop through all possible search cases
496    #
497
498    set lfound {}
499    foreach s $sel {
500	set lfound [concat $lfound [$s $dbfd $q $val $type]]
501    }
502
503    #
504    # Did we find something?
505    #
506
507    if {[llength $lfound] == 0} then {
508	display-message $val [mc "String '%s' not found" $val]
509    }
510
511    #
512    # Join all HTML lines in lfound
513    #
514
515    set html ""
516    foreach f $lfound {
517	append html [::webapp::helem "li" $f]
518	append html "\n"
519    }
520    set result [::webapp::helem "ul" $html]
521
522    #
523    # Cosmetic clean-up
524    #
525
526    if {$q eq "_"} then {
527	set q ""
528    } else {
529	set q [::webapp::post-string $q]
530    }
531
532    #
533    # End of script: output page and close database
534    #
535
536    d urlset "%URLFORM%" $conf(next) {}
537    d result $conf(page) [list \
538				[list %CRITERE% $q] \
539				[list %RESULTAT% $result] \
540			    ]
541}
542
543d cgi-dispatch "dns" ""
544