#!%TCLSH%

#
# Search informations (host name, IP address, MAC address, groups, etc.)
#
# Parameters (form or url):
#	- q: search query (ip, cidr, or fqdn, or _ for "here")
#
# History
#   2002/07/25 : pda      : design
#   2003/05/13 : pda/jean : use auth base
#   2004/01/14 : pda/jean : add IPv6
#   2004/08/06 : pda/jean : extend network access rights
#   2005/02/24 : pda      : add case role mail without IP address
#   2010/10/17 : pda      : add search case for "here"
#   2010/12/10 : pda      : i18n
#   2010/12/25 : pda      : use cgi-dispatch
#   2013/03/06 : pda/jean : multi-views
#   2013/03/13 : pda/jean : generalization to different object types
#   2013/20/06 : schplurtz: fix bug
#

#
# Template pages used by this script
#

set conf(page)		search.html

#
# Next actions
# 

set conf(next)		"search"

#
# Script parameters
#

set conf(form)	{
	{q	0 1 {}}
}

#
# Netmagis general library
#

source %LIBNETMAGIS%

# ::webapp::cgidebug ; exit

##############################################################################
# Utilities
##############################################################################

proc display-message {q msg} {
    global conf

    set qmsg [::webapp::html-string $msg]
    set qq   [::webapp::html-string $q]
    set result [::webapp::helem "font" $qmsg "color" "#FF0000"]
    d urlset "%URLFORM%" $conf(next) {}
    d result $conf(page) [list \
				[list %CRITERE% $qq] \
				[list %RESULTAT% $result] \
			    ]
    exit 0
}

#
# Parse a search query, which has the form
#	[<sel>:]<val>
# Examples:
#	192.168.1.2 01
#	01:02:03:04:05:06
#	www.example.com
#	host: www
#	net: lab
#
# Input:
#   - dbfd: database access
#   - q: user query
#   - _sel, _val, _type: see below
# Output:
#   - return value: empty string or error message
#   - sel: list of selector procedures (see cgi-search-* procedures)
#   - val: value to search
#   - type: detected value type (mac, inet, cidr or string)
#
# History:
#   2013/02/27: pda/jean : attempt to spec
#   2013/03/06: pda/jean : design
#   2013/06/20: schplurtz : return more accurate search func list
#

proc parse-query {dbfd q _sel _val _type} {
    global conf

    upvar $_sel sel
    upvar $_val val
    upvar $_type type

    set sel ""
    set val ""
    set type ""

    set matchproc *
    set q [string trim $q]
    #
    # Avoid case where the beginning of a MAC address is confused with
    # an operator
    #
    if {$q eq "_"} then {
	set sel "myaddr"
	set val "_"
	set type ""
	set matchproc myaddr
    } elseif {[check-mac-syntax $dbfd $q] eq ""} then {
	set sel ""
	set val $q
	set type "mac"
	set matchproc host
    } elseif {[check-ip-syntax $dbfd $q "inet"] eq ""} then {
	set sel ""
	set val $q
	set type "inet"
	set matchproc host
	set r ""
    } elseif {[check-ip-syntax $dbfd $q "cidr"] eq ""} then {
	set sel ""
	set val $q
	set type "cidr"
	set r ""
	set matchproc cidr ; # cgi-search*cidr not yet implemented
    } else {
	#
	# Check operator and value
	#

	if {[regexp {^(([a-z]+):\s*)?(\S+)$} $q dum1 dum2 sel val]} then {
	    # nothing
	} elseif {[regexp {^\S+$} $q val]} then {
	    set sel ""
	} else {
	    return [mc "Invalid search query '%s'" $q]
	}

	#
	# Recognize type
	#

	if {[check-ip-syntax $dbfd $val "inet"] eq ""} then {
	    set type "inet"
	    set matchproc host
	} elseif {[check-ip-syntax $dbfd $val "cidr"] eq ""} then {
	    set matchproc [set type "cidr"]
	} else {
	    set type "string"
	}
    }

    #
    # Verify operator/type compatibility
    #

    if {$sel eq ""} then {
	set sel [lsort [info procs "cgi-search-*-$matchproc"]]
    } else {
	set proc [info procs "cgi-search-*-$sel"]
	if {$proc eq ""} then {
	    return [mc "Invalid search operator '%s'" $sel]
	}
	set sel [list $proc]
    }

    return ""
}

proc display-host {dbfd _trr idview q} {
    upvar $_trr trr

    set rrtmpl {
	allowed-groups {search {q group:%s}}
	ip {edit {addr %1$s} {idview %2$s}}
    }

    array set t $rrtmpl
    lappend t(ip) {nextprog search}
    lappend t(ip) [list "nextargs" "q=$q"]
    set rrtmpl [array get t]

    lassign [display-rr-masked $dbfd trr $idview $rrtmpl] link desc
    set title [mc {%1$s is a host in view %2$s} $link [u viewname $idview]]
    return "$title $desc"
}


proc display-alias {dbfd _trr idview q} {
    upvar $_trr trr

    h mask-next
    set fqdn "$trr(name).$trr(domain)"
    set idalias [rr-cname-by-view trr $idview]
    if {! [read-rr-by-id $dbfd $idalias trra]} then {
	d error [mc {Cannot read host-id %s} $idalias]
    }

    set rrtmpl {
	allowed-groups {search {q group:%s}}
	ip {edit {addr %1$s} {idview %2$s}}
    }

    # Display aliased host
    lassign [display-rr-masked $dbfd trra $idview $rrtmpl] link desc
    set title [mc {%1$s is an alias of host %2$s in view %3$s} $fqdn $link [u viewname $idview]]

    return "$title $desc"
}

proc display-all-mx {dbfd _trr idview q} {
    upvar $_trr trr

    h mask-next
    set fqdn "$trr(name).$trr(domain)"
    set lmx [rr-mx-by-view trr $idview]

    set rrtmpl {
	allowed-groups {search {q group:%s}}
	ip {edit {addr %1$s} {idview %2$s}}
    }

    set lfound {}
    foreach mx $lmx {
	lassign $mx prio idtarget
	if {! [read-rr-by-id $dbfd $idtarget trrt]} then {
	    d error [mc {Cannot read MX with id %s} $idtarget]
	}

	# Display MX target host
	lassign [display-rr-masked $dbfd trrt $idview $rrtmpl] link desc
	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]]

	lappend lfound "$title $desc"
    }

    return $lfound
}

proc display-mailrole {dbfd _trr idview q} {
    upvar $_trr trr

    h mask-next
    set fqdn "$trr(name).$trr(domain)"
    lassign [rr-mailrole-by-view trr $idview] idheb idviewheb
    if {! [read-rr-by-id $dbfd $idheb trrh]} then {
	d error [mc {Cannot read host-id %s} $idheb]
    }

    set rrtmpl {
	allowed-groups {search {q group:%s}}
	ip {edit {addr %1$s} {idview %2$s}}
    }

    # Display aliased host
    lassign [display-rr-masked $dbfd trrh $idviewheb $rrtmpl] link desc
    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]]

    return "$title $desc"
}


##############################################################################
# Search cases
##############################################################################

proc cgi-search-100-myaddr {dbfd q val type} {
    global env

    set lfound {}
    if {[info exists env(REMOTE_ADDR)] && $val eq "_"} then {
	set val $env(REMOTE_ADDR)
	foreach idview [u myviewids] {
	    if {[read-rr-by-ip $dbfd $val $idview trr]} then {
		lappend lfound [display-host $dbfd trr $idview $q]
	    }
	}
	if {[llength $lfound] == 0} then {
	    lappend lfound [mc "Searched address: %s" $val]
	}
    }
    return $lfound
}

proc cgi-search-150-host {dbfd q val type} {
    set lfound {}

    switch $type {
	mac {
	    #
	    # Attempt to search for the host. It if exists, trr will
	    # be filled. If it does not exists, trr will not be created.
	    # We don't test result, since existence of trr(idrr) will
	    # suffice for next steps.
	    #
	    if {[read-rr-by-mac $dbfd $val trr]} then {
		set lhost {}
		foreach idview [u myviewids] {
		    if {[llength [rr-ip-by-view trr $idview]] > 0} then {
			lappend lhost $idview
			break
		    }
		}
		foreach idview $lhost {
		    lappend lfound [display-host $dbfd trr $idview $q]
		}
	    }
	}
	inet {
	    #
	    # Attempt to search for the host. It if exists, trr will
	    # be filled. If it does not exists, trr will not be created.
	    # We don't test result, since existence of trr(idrr) will
	    # suffice for next steps.
	    #
	    foreach idview [u myviewids] {
		if {[read-rr-by-ip $dbfd $val $idview trr]} then {
		    lappend lfound [display-host $dbfd trr $idview $q]
		}
	    }
	}
	cidr {
	}
	string {
	    if {[regexp {^[^.]+\..+$} $val]} then {
		#
		# Name and domain
		#
		set msg [check-fqdn-syntax $dbfd $val name domain iddom]
		if {$msg ne ""} then {
		    display-message $val $msg
		}
		set ldom [list $iddom]
	    } else {
		set msg [check-name-syntax $val]
		if {$msg ne ""} then {
		    display-message $val $msg
		}
		set ldom [u myiddom]
		set name $val
	    }

	    foreach iddom $ldom {
		foreach idview [u myviewids] {
		    if {[read-rr-by-name $dbfd $name $iddom $idview trr]} then {
			if {[llength [rr-ip-by-view trr $idview]] > 0} then {
			    lappend lfound [display-host $dbfd trr $idview $q]
			}
			if {[rr-cname-by-view trr $idview] ne ""} then {
			    lappend lfound [display-alias $dbfd trr $idview $q]
			}
			if {[rr-mx-by-view trr $idview] ne ""} then {
			    foreach l [display-all-mx $dbfd trr $idview $q] {
				lappend lfound $l
			    }
			}
		    }
		}
	    }
	}
	default {
	    d error [mc "Internal error: unknown type"]
	}
    }

    return $lfound
}

proc cgi-search-160-mailrole {dbfd q val type} {
    set lfound {}

    switch $type {
	string {
	    if {[regexp {^[^.]+\..+$} $val]} then {
		#
		# Name and domain
		#
		set msg [check-fqdn-syntax $dbfd $val name domain iddom]
		if {$msg ne ""} then {
		    display-message $val $msg
		}
		set ldom [list $iddom]
	    } else {
		set msg [check-name-syntax $val]
		if {$msg ne ""} then {
		    display-message $val $msg
		}
		set ldom [u myiddom]
		set name $val
	    }

	    foreach iddom $ldom {
		foreach idview [u myviewids] {
		    if {[read-rr-by-name $dbfd $name $iddom $idview trr]} then {
			set rm [rr-mailrole-by-view trr $idview]
			if {[llength $rm] > 0} then {
			    lappend lfound [display-mailrole $dbfd trr $idview $q]
			}
		    }
		}
	    }
	}
	mac -
	inet -
	cidr {
	    d error [mc "Invalid search query '%s'" $q]
	}
	default {
	    d error [mc "Internal error: unknown type"]
	}
    }

    return $lfound
}

proc cgi-search-400-group {dbfd q val type} {
    set lfound {}

    set idgrp [u groupid $val]
    if {$idgrp ne ""} then {
	#
	# Get all login names for this group
	#
	set lcor {}
	set sql "SELECT login FROM global.nmuser
				WHERE idgrp = $idgrp
				ORDER BY login"
	pg_select $dbfd $sql tab {
	    lappend lcor $tab(login)
	}

	h mask-next
	set link [h mask-link $val]
	set title [mc "%s is a Netmagis group" $link]

	# members of the group
	if {[llength $lcor] == 0} then {
	    set desc [mc "Empty group (no user)"]
	} else {
	    set desc ""
	    foreach login $lcor {
		set n [read-user $dbfd $login tabuid msg]
		if {$n != 1} then {
		    d error $msg
		}
		append desc "\n<p>\n"
		append desc [display-user tabuid]
	    }
	}
	set desc [h mask-text $desc]
	lappend lfound "$title\n$desc"
    }
    return $lfound
}

##############################################################################
# Display empty page
##############################################################################

d cgi-register {q {}} {} {

    #
    # Not an error, strictly speaking, but treated as an error.
    #

    display-message "" ""
}

##############################################################################
# Display given address (or my current IP address)
##############################################################################

d cgi-register {q .+} {} {
    global conf
    global env

    #
    # Parse query, check consistancy and deduce search cases
    #

    set msg [parse-query $dbfd $q sel val type]
    if {$msg ne ""} then {
	display-message $q $msg
    }

    #
    # Loop through all possible search cases
    #

    set lfound {}
    foreach s $sel {
	set lfound [concat $lfound [$s $dbfd $q $val $type]]
    }

    #
    # Did we find something?
    #

    if {[llength $lfound] == 0} then {
	display-message $val [mc "String '%s' not found" $val]
    }

    #
    # Join all HTML lines in lfound
    #

    set html ""
    foreach f $lfound {
	append html [::webapp::helem "li" $f]
	append html "\n"
    }
    set result [::webapp::helem "ul" $html]

    #
    # Cosmetic clean-up
    #

    if {$q eq "_"} then {
	set q ""
    } else {
	set q [::webapp::post-string $q]
    }

    #
    # End of script: output page and close database
    #

    d urlset "%URLFORM%" $conf(next) {}
    d result $conf(page) [list \
				[list %CRITERE% $q] \
				[list %RESULTAT% $result] \
			    ]
}

d cgi-dispatch "dns" ""