#!/usr/local/bin/tclsh8.6

#
# 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
#   2017/03/14 : bahram123: Added wildcard search (zip patch)
#   2018/04/06 :fmeynadier: zip patch turned into Pull Request 
#

#
# 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 {}}
}

#
# Valid query types
# This list has the form {re1 type1 re2 type2 ...}
#
# Each re is matched against the query string (without selector). If
# a match occurs, the search stops with the recognized type.
#

set retype {
    {^_$}					myaddr
    {^\d+\.\d+\.\d+\.\d+$}			inet
    {^\d+\.[\d.]*\*}				inet
    {^([0-9a-f]{1,2}:){5}[0-9a-f]{1,2}$}	mac
    {^[0-9a-f]{1,2}:[0-9a-f:]*\*}		mac
    {^(([0-9a-f]{1,4}:){7,7}[0-9a-f]{1,4}|([0-9a-f]{1,4}:){1,7}:|([0-9a-f]{1,4}:){1,6}:[0-9a-f]{1,4}|([0-9a-f]{1,4}:){1,5}(:[0-9a-f]{1,4}){1,2}|([0-9a-f]{1,4}:){1,4}(:[0-9a-f]{1,4}){1,3}|([0-9a-f]{1,4}:){1,3}(:[0-9a-f]{1,4}){1,4}|([0-9a-f]{1,4}:){1,2}(:[0-9a-f]{1,4}){1,5}|[0-9a-f]{1,4}:((:[0-9a-f]{1,4}){1,6})|:((:[0-9a-f]{1,4}){1,7}|:)|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-f]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$}					inet
    {^[0-9a-f]{4}:[0-9a-f:]*\*}			inet
    {.}						str
}

#
# Netmagis general library
#

source /usr/local/lib/netmagis/libnetmagis.tcl

# ::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
}

#
# Guess the type of the query
#
# Input:
#   - dbfd: database access
#   - q: user query (without selector)
# Output:
#   - return value: guessed type or error
#

proc query-type {dbfd q} {
    global retype

    set r error
    foreach {re type} $retype {
	if {[regexp -nocase $re $q]} then {
	    set r $type
	    break
	}
    }
    return $r
}

#
# Parse a search query, which has the form
#	[<sel>:]<val>
# Examples:
#	192.168.1.2
#	01:02:03:04:05:06
#	www.example.com
#	host: www
#	net: lab
#
# Input:
#   - dbfd: database access
#   - q: user query
#   - _handlers, _val: see below
# Output:
#   - return value: empty string or error message
#   - handlers: list of selector procedures (see cgi-search-* procedures)
#   - val: value to search
#
# 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
#   2018/07/18: pda/jean : rewrite
#

proc parse-query {dbfd q _handlers _val} {
    global conf

    upvar $_handlers handlers
    upvar $_val val

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

    #
    # Gather available handlers (see cgi-search-* procs)
    #

    set lh {}
    foreach p [info procs cgi-search-*] {
	if {[regexp {^cgi-search-\d+-([^-]+)} $p dummy h]} then {
	    # do not count host twice since there is both
	    # cgi-search-xxx-host-str and ...-host-inet
	    if {! ($h in $lh)} then {
		lappend lh $h
	    }
	}
    }

    #
    # First word in query is one of these selectors (i.e. handlers)?
    #

    set resel [join $lh "|"]
    set resel "^(($resel):)?\\s*(\\S+)\\s*\$"

    if {[regexp $resel $q dum1 dum2 sel val]} then {
	#
	# Valid query syntax (with or without a selector/handler).
	# Guess type of queried string
	#
	set type [query-type $dbfd $val]

    } else {
	#
	# empty query, or query with spaces inside
	#
	if {[string trim $q] eq ""} then {
	    set type "empty"
	} else {
	    set type "error"
	}
    }

    if {$type eq "error"} then {
	return [mc "Invalid search query '%s'" $q]
    }

    #
    # Determine which procs may handle this query
    # - sel = nature of objects to be searched for [host, group, etc.]
    # - type = guessed type of query [inet, str, inet, etc.]
    #

    if {$sel eq ""} then {
	set sel "*"
    }

    set pattern "cgi-search-*-$sel-$type"
    set handlers [lsort [info procs $pattern]]
    if {[llength $handlers] == 0} then {
	return [mc "Invalid search query '%s'" $q]
    }

    return ""
}

#
# Quote a string which may contain SQL special characters (%, _)
# for LIKE operator
#

proc quote-escape {str} {
    set str [::pgsql::quote $str]
    regsub -all {[%_]} $str {\\&} str
    return $str
}


###############################################################################
# Display search results
###############################################################################

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 : my own address
##############################################################################

proc cgi-search-100-myaddr-myaddr {dbfd idgrp q val} {
    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
}

##############################################################################
# Search cases : host
#
# MAC and STR searches always use the 'LIKE' SQL operator.
# For efficiency reasons, we try to perform a direct match (using '=' SQL
# operator) for IP addresses only.
##############################################################################

proc cgi-search-150-host-mac {dbfd idgrp q val} {
    # canonicalize MAC address for matching with ILIKE
    set l {}
    foreach byte [split $val ":"] {
	regsub -nocase {^[0-9a-f]$} $byte {0&} byte
	lappend l $byte
    }
    set qval [join $l ":"]

    set qval [quote-escape $qval]
    set qval [string map {* % ? _} $qval]
    set qval [string tolower $qval]
    set w "r.mac::text ILIKE '$qval'"
    return [host-search $dbfd $idgrp $q $w]
}

proc cgi-search-150-host-str {dbfd idgrp q val} {
    set qval [quote-escape $val]
    set qval [string map {* % ? _} $qval]
    if {[string first "." $val] == -1} then {
	set w "r.name ILIKE '$qval'"
    } else {
	set w "r.name || '.' || d.name ILIKE '$qval'"
    }
    return [host-search $dbfd $idgrp $q $w]
}

proc host-search {dbfd idgrp q w} {
    set lfound {}
    set sql "SELECT r.idrr
		FROM dns.rr r
		    INNER JOIN dns.domain d USING (iddom)
		    INNER JOIN dns.p_dom pd USING (iddom)
		    INNER JOIN dns.p_view pv USING (idview)
		WHERE $w
		    AND pd.idgrp = $idgrp 
		    AND pv.idgrp = $idgrp 
	    "
    pg_select $dbfd $sql tab {
	set idrr $tab(idrr)
	if {[read-rr-by-id $dbfd $idrr trr]} then {
	    set idview $trr(idview)
	    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
		}
	    }
		set rm [rr-mailrole-by-view trr $idview]
		if {[llength $rm] > 0} then {
		    lappend lfound [display-mailrole $dbfd trr $idview $q]
		}
	}
    }
    return $lfound
}

proc cgi-search-150-host-inet {dbfd idgrp q val} {
    set qval [quote-escape $val]
    set qval [string map {* % ? _} $qval]
    if {[check-ip-syntax $dbfd $val "inet"] eq ""} then {
	set w "i.addr = '$qval'"
    } else {
	set w "host (i.addr)::text ILIKE '$qval'"
    }

    set sql "SELECT DISTINCT (r.idrr)
		FROM dns.rr r
		    NATURAL JOIN dns.rr_ip i
		    INNER JOIN dns.domain d USING (iddom)
		    INNER JOIN dns.p_dom pd USING (iddom)
		    INNER JOIN dns.p_view pv USING (idview)
		WHERE $w
		    AND pd.idgrp = $idgrp
		    AND pv.idgrp = $idgrp
		    AND dns.check_ip_grp (i.addr, $idgrp)
	    "
    set lfound {}
    pg_select $dbfd $sql tab {
	if {[read-rr-by-id $dbfd $tab(idrr) trr]} then {
	    lappend lfound [display-host $dbfd trr $trr(idview) $q]
	}
    }
    return $lfound
}

##############################################################################
# Search cases : group
##############################################################################

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

    set qval [quote-escape $val]
    set qval [string map {* % ? _} $qval]
    set sql "SELECT g.name, g.idgrp, string_agg (u.login, ' ') AS members
		    FROM global.nmgroup g
			NATURAL INNER JOIN global.nmuser u
		    WHERE g.name ILIKE '$qval'
		    GROUP BY g.name, g.idgrp
		    "
    pg_select $dbfd $sql tab {
	h mask-next
	set link [h mask-link $tab(name)]
	set title [mc "%s is a Netmagis group" $link]

	# let's pray for not having Tcl special characters in login names
	set lcor [split $tab(members) " "]

	# 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 handlers val]
    if {$msg ne ""} then {
	display-message $q $msg
    }

    #
    # Loop through all possible search cases
    #

    set idgrp $tabuid(idgrp)
    set lfound {}
    foreach h $handlers {
	set lfound [concat $lfound [$h $dbfd $idgrp $q $val]]
    }

    #
    # 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::html-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" ""
