#!/bin/sh
# \
	exec tclsh "$0" ${1+"$@"} 

#
# Copyright C 2001-2002 Sun Microsystems, Inc. Some preexisting portions Copyright
# C 1998-2000 Innosoft International Inc. All rights reserved.
# 
# Sun, Sun Microsystems, and the Sun logo are trademarks or registered
# trademarks of Sun Microsystems, Inc. in the United States and other
# countries.
# 

#
# $Revision: 1.11.2.1 $ $Date: 2004/01/29 14:33:59 $
#

array set status { eof eof "gets eof" "gets eof" timeout timeout wait wait }

for {set i 1} {$i <= 256} {incr i} {
    set c [format %c $i]
    if {![string match \[a-zA-Z0-9\] $c]} {
        set map($c) %[format %.2x $i]
    }
}

array set map { \n %0d%0a , , . . "(" "(" ")" ")" "-" "-"}

array set tbl { \
        0 A 1 B 2 C 3 D 4 E 5 F 6 G 7 H \
        8 I 9 J 10 K 11 L 12 M 13 N 14 O 15 P \
        16 Q 17 R 18 S 19 T 20 U 21 V 22 W 23 X \
        24 Y 25 Z 26 a 27 b 28 c 29 d 30 e 31 f \
        32 g 33 h 34 i 35 j 36 k 37 l 38 m 39 n \
        40 o 41 p 42 q 43 r 44 s 45 t 46 u 47 v \
        48 w 49 x 50 y 51 z 52 0 53 1 54 2 55 3 \
        56 4 57 5 58 6 59 7 60 8 61 9 62 + 63 / \
    }

proc encode { v } {
    global tbl
    set null [format "%c" 0]
    set length [expr [string length $v]]
    switch -exact [expr $length % 3] {
        0 {
            set trim [expr [expr [expr $length + 0] / 3 * 4] - 1]
            set tag ""
        }
        1 {
            append v $null
            append v $null
            set trim [expr [expr [expr $length + 2] / 3 * 4] - 3]
            set tag "=="
        }
        2 {
            append v $null
            set trim [expr 1]
            set trim [expr [expr [expr $length + 1] / 3 * 4] - 2]
            set tag "="
        }
    }
    
    set n ""
    
    foreach { a b c } [split $v {}] {
        scan $a %c x
        scan $b %c y
        scan $c %c z
        append n $tbl([expr ($x & 0xFC) >> 2])
        append n $tbl([expr [expr ($x & 0x3) << 4] | [expr ($y & 0xF0) >> 4]])
        append n $tbl([expr [expr ($y & 0xF) << 2] | [expr ($z & 0xC0) >> 6]])
        append n $tbl([expr 0x3F & $z])
    }
    
    return "[string range $n 0 $trim]$tag"
}

proc escape { x } {
    global map
    regsub -all \[^a-zA-Z0-9\] $x {$map(&)} x
    regsub -all \n $x {\\n} x
    regsub -all \t $x {\\t} x
    regsub -all {[][{})\\]\)} $x {\\&} x
    return [subst $x]
} 

proc parm { xName value } {
    upvar $xName x

    return "&$value=[escape $x($value)]"
}

proc send { verbose sName text {suppress ""}} {
    upvar $sName sock
    if {$verbose} {
	if [string length $suppress] {
	    regsub -all $suppress $text "********" msg
	} else {
	    set msg $text
	}
	puts stdout $msg
    }
    puts $sock $text
}

proc echo { sock } {
    global echo
    global status
    if [eof $sock] {
	close $sock
	set echo(status) $status(eof)
    } else {
	if [catch {gets $sock line} result] {
	    close $sock
	    set echo(status) $status("gets eof")
	} else {
	    if [info exists echo(recv)] {
		lappend echo(recv) $line
	    } else {
		set echo(recv) $line
	    }
	}
    }
}

proc serverid { x } {
    if [regexp "\[\.\]" $x] {
	regexp "(\[^\.\]+)." $x a x
    }
    return "dps-$x"
}

proc fetchAdmin { xName } {
    upvar $xName x
    return [info hostname]
}

proc fetchAdminport { xName } {
    upvar $xName x
    set iName [file join $x(root) admin-serv/config/adm.conf]

    set iFile [open $iName r]

    set port ""

    while {[gets $iFile line] >= 0} {
	if [regexp -nocase "^port\:" $line] {
	    regexp -nocase "(\[^\:\]+)\:(.+)$" $line a b port
	}
    }

    close $iFile

    if [string length $port] {
    } else {
	error "Could not find admin server port number"
    }

    return [string trim $port]
}

proc fetchHandle { xName } {
    upvar $xName x
    set iName [file join $x(root) admin-serv/config/adm.conf]

    set iFile [open $iName r]

    set server ""

    while {[gets $iFile line] >= 0} {
	if [regexp -nocase "^isie\:" $line] {
	    regexp -nocase "(\[^,\]+),(.+)$" $line a b server
	}
    }

    close $iFile

    if [string length $server] {
    } else {
	error "Could not find isie"
    }

    return "cn=Sun ONE Directory Proxy Server, $server"
}

proc processConfigdn { xName } {
    upvar $xName x

    sendurl x "/$x(serverid)/tasks/XTL?task=remove-configuration-user[parm x port][parm x host][parm x user][parm x configdn][parm x passwd][parm x serverid]" $x(passwd)
}

proc cmd { name } {
    global tcl_platform

    if [string equal $tcl_platform(platform) unix] {
    } else {
	append name ".exe"
    }

    return $name
}

# Handle is the ISIE 
proc processHandle { xName } {
    upvar $xName x

    # Let s delete from the  CDS the SIE of the serverid being removed
    sendurl x "/$x(serverid)/tasks/XTL?task=delete-directory-entry[parm x port][parm x host][parm x user][parm x passwd]&handle=[escape cn=$x(serverid),$x(handle)]" $x(passwd)

    cd [file join $x(root) shared bin]
    set cmd [list [cmd ./ldapdelete] \
		-h $x(host) \
		-p $x(port) \
		-D $x(user) \
		-w $x(passwd) \
		$x(handle)]

    # Let's try to delete from the CDS the ISIE
    #  - will succeed when the last SIE (last instance) has just been removed
    #  - will silently failed if some instances still exist
    set rc [catch [linsert $cmd 0 exec] result]
}

proc processPing { xName } {
    upvar $xName x
    sendurl x "/$x(serverid)/tasks/XTL?task=getserverids[parm x port][parm x host][parm x user][parm x handle][parm x passwd]" $x(passwd)
}

proc sendurl { xName url {suppress ""}} {
    global status
    global echo
    upvar $xName x

    set auth [encode "$x(uid):$x(passwd)"]
    
    set send(status) $status(wait)
    set id [after [expr $x(wait) * 1000] {set send(status) $status(timeout)}]
    set sock [socket -async $x(admin) $x(adminport)]
    fileevent $sock w {set send(status) $status(wait)}
    vwait send(status)

    if [string equal $send(status) $status(wait)] {
	fileevent $sock w [list]
	set echo(status) $status(wait)
	fconfigure $sock -buffering line
	fileevent $sock readable [list echo $sock]
	
	send $x(v) sock "GET $url HTTP/1.0" $suppress
	send $x(v) sock "Host: $x(admin)"
	send $x(v) sock "User-Agent: Tcl/Tk dpsClean.tcl"
	send $x(v) sock "Authorization: BASIC $auth"
	send $x(v) sock ""
	flush $sock
    
	after [expr $x(wait) * 1000] {set echo(status) $status(timeout)}
	
	while {$echo(status) == $status(wait)} {
	    vwait echo(status)
	}
    }

    if [info exists echo(recv)] {
	if [string length $x(out)] {
	    set oFile [open $x(out) a]
	    foreach i $echo(recv) {
		puts $oFile $i
	    }
	    close $oFile
	}
	if $x(v) {
	    foreach i $echo(recv) {
		puts stdout "$i"
	    }
	}
	unset echo(recv)
    }
}

set errmsg [list]
set mode ""
set usage 0

set x(admin) ""
set x(adminport) ""
set x(configdn) "ou=dar-config, o=NetscapeRoot"
set x(delete) 0
set x(handle) ""
set x(host) ""
set x(out) ""
set x(passwd) ""
set x(port) ""
set x(root) ""
set x(serverid) ""
set x(uid) ""
set x(user) ""
set x(v) 0
set x(wait) "60"

foreach i $argv {
    switch -exact -- $mode {
	"" {
	    set j [string tolower $i]
	    set mode [string range $j 1 end]
	    switch -exact -- $j {
		-? {
		    set usage 1
		    set mode ""
		}
		-admin { }
		-adminport { }
		-configdn { }
		-delete {
		    set mode ""
		    set x(delete) 1
		}
		-handle { }
		-help {
		    set usage 1
		    set mode ""
		}
		-host { }
		-out { }
		-passwd { }
		-port { }
		-root { }
		-serverid { }
		-uid { }
		-user { }
		-v {
		    set mode ""
		    set x(v) 1
		}
		-wait { }
		default {
		    lappend errmsg [list "Unknown option $mode"]
		    set mode ""
		}
	    }
	}
	admin {
	    set x($mode) $i
	    set mode ""
	    if [regexp "\[\.\]" $i] {
	    } else {
		# lappend errmsg [list "The -admin value ($x(admin)) doesn't appear to be fully qualified."]
	    }
	}
	host {
	    set x($mode) $i
	    set mode ""
	    if [regexp "\[\.\]" $i] {
	    } else {
		# unix installs can be without a domain
		# lappend errmsg [list "The -host value ($x(host)) doesn't appear to be fully qualified."]
	    }
	}
	default {
	    set x($mode) $i
	    set mode ""
	}
    }
}

if [string length $mode] {
    lappend errmsg [list "Error: -$mode was not given a parameter."]
}

if [llength $errmsg] {
} else {
    foreach i [list host passwd root uid user] {
	if [string length $x($i)] {
	} else {
	    lappend errmsg [list "No value stipulated for -$i"]
	}
    }
}

if [llength $errmsg] {
    foreach i $errmsg {
	foreach j $i {
	    puts stderr $j
	}
    }
    set usage 1
}

set rc 0

if {$usage} {
    puts stderr "dpsClean.tcl \[-admin adminHost\] \[-adminport adminPort\] -host configHost"
    puts stderr "\t\t-port configPort -passwd password -uid uid \[-serverid serverid\]"
    puts stderr "\t\t-user uidDN \[-wait timeout\] \[-out filename\] -delete"
    puts stderr "\t\t\[-configdn configdn | -handle handle\] \[-v\]"
    if [llength $errmsg] {
	set rc 1
    }
} else {
    if [string length $x(admin)] {
    } else {
	set x(admin) [fetchAdmin x]
    }
    if [string length $x(adminport)] {
    } else {
	set x(adminport) [fetchAdminport x]
    }
    if [string length $x(serverid)] {
    } else {
	set x(serverid) [serverid $x(admin)]
    }
    if [string length $x(handle)] {
    } else {
	set x(handle) [fetchHandle x]
    }

    if {$x(delete)} {
	processConfigdn x
	processHandle x
    } else {
	processPing x
    }
    set rc [expr [string equal $echo(status) $status(eof)] == 0]
}

exit $rc
