#!/usr/bin/perl 
# Copyright (c) 2002 DAASI International GmbH. All rights reserved.
# w2l.pl - WWW to LDAP Gateway
#
#


# hinzufuegen von Librarypaths:
unshift (@INC,"../lib/perlmodules/Net/SSLeay");
unshift (@INC,"../lib/perlmodules/Net");
unshift (@INC,"../lib/perlmodules");

# besser: unshift (@INC,"../lib/DAASI");


use strict;
use diagnostics;
#use Carp ();
#local $SIG{__WARN__} = \&Carp::cluck;

use Net::LDAP qw (LDAP_SUCCESS LDAP_PROTOCOL_ERROR LDAP_TIMELIMIT_EXCEEDED LDAP_SIZELIMIT_EXCEEDED LDAP_REFERRAL);
use Net::LDAP::Constant;
# folgende Zeile sollte weg:
use Net::LDAP::Util qw(ldap_explode_dn canonical_dn);
use Net::LDAP::Filter;


use CGI qw(:standard :html3);
use IO::Socket;
require Config::General;
require Net::LDAPS;
require URI;
require URI::Escape;
require HTML::Template;
require Data::Dumper;

# DAASI Lib sinnvoll aufspalten (lib/perlmodules/DAASI/LDAP2.pm):
#
# log, config, ldap, html-templ, html-form, smtp
#
#
require DAASI::LDAP2;

#array of hashes = @entries; control link value = $search; person counter = $listPersCount;

# Globale Variablen weg, lieber Pointer auf config-Struktur
# vergleiche:
# my $conf_obj = DAASI::D_CONFv1->create( Config => "../etc/evawiss.conf");
# Beispielreferenz: ( $conf_obj->{ldaphost} );
#                   ( $conf_obj->{ldapdata}{ldaphost} );
#                   ( $conf_obj->{ldapdata} );
use vars qw( %config $lang $search @entries $listPersCount $w2lversion $bindmech $version $binddn $bindpw $q $uri $uristring $conf $remote_host $proxy $dfnDistribution $aclreason $ldap $entry $uri_string $mesg $footer_template $header $lastbrowsedn );

$bindmech='';
# initialisiere ein leeres Array und ein int var
@entries = ();
$listPersCount = 0;

##
## Begin Main ####################################
##
&initlog();

dolog("\n\nw2l started");
# Lese Config
# wird durch eigene conflib obsolet:
$conf = new Config::General( -file => '../etc/w2l.conf', -LowerCaseNames => 1, -AllowMultiOptions => 'yes' );
%config = $conf->getall;
#print "\n\n<$config{sizelimitpers}>\n\n"; &do_exit;

# durch CONF obsolet
$q = new CGI;

# detect langugage
$lang = $q->param('lang');
if (!$lang) {
    $lang = $q->http('Accept-Language');
    if ($lang) {
	$lang = substr($lang, 0, 2);
	$lang = lc($lang);
    }
}

if ( ! ( defined ($config{supported_lang}) ) || ! ( defined ($config{supported_lang}{$lang})) ) {
    if ( !  $config{default_lang} ) {
	$lang = 'de';
    } else {
	$lang = $config{default_lang};
    }
}
$q->param('lang', $lang);

# this is a dirty hack:
$lang = 'de'; # strictly eva only de now

# get and check URI
$uristring = $q->param('uri') ? $q->param('uri') : $config{default_uri}; 

$lastbrowsedn="o=Eva-Wiss,c=de";

# HC, eingefügt, weil Mailbenachrichtigungen mit IsoLatin-Links 
# ausgestattet sind

unless ($uristring =~ m/Ã/ ) {
    $uristring = &iso2utf8($uristring);
}

$uri = URI->new( $uristring );
if ( !$uri || $uri->scheme !~ /^ldaps?$/ || $uri->_filter ) {
	errorpage($q, 200, "URI not supported: $uristring");
	&do_exit;
}

$uri->authority( URI->new($config{default_uri})->authority ) unless $uri->authority;

# get accessrights
$remote_host = $q->remote_host();
$proxy = '-';
# check for proxy
# bw: additionally possible (from tweb):
# http('VIA:') || -USER-AGENT && ( VIA || GATEWAY )
if ( defined $q->http('HTTP_VIA') ) {
	$proxy = $remote_host;
	$remote_host = $q->http('HTTP_X_FORWARDED_FOR') || '-';
}

my $is_errorpage = 0;
$dfnDistribution = undef;
# check with cfg file if server uses dfnschema
if ( $config{servers}{$uri->authority}{dfnschema} ) {
	# response format is "OK <n> <reason>|DELAYED|DENIED|ERROR <reason>"
	my $aclresponse = ambixacl($config{ambixacldhost},$config{ambixacldport},$remote_host,$proxy,$uri);
	chop $aclresponse;
	my @aclresponse = ();
	@aclresponse = split / /, $aclresponse;
	print STDERR "dfn acl check @aclresponse\n";
	if ( $aclresponse[0] eq 'OK' ) {
		$dfnDistribution = $aclresponse[1];
		$aclreason = defined $aclresponse[2] ? $aclresponse[2] : undef;
	} elsif ( $aclresponse[0] eq 'DELAYED' ) {
		my $template = HTML::Template->new(
			filename => "$config{template_dir}/dynamic-crawler.$lang.html", 
			loop_context_vars => 1,
			die_on_bad_params => 0,
			);
		$template->param(ref => $q->url."?".$ENV{"QUERY_STRING"});
		### new and not yet testet:
		$template->param('accessrestriction' => '1');
		$is_errorpage = 1;
		dolog("w2l: set is_errorpage to $is_errorpage");
		$template->param(errormessage => $q->param("message"));
		errorpage( $q, 403, $template->output );
		&do_exit;
	} elsif ( $aclresponse[0] eq 'DENIED' ) {
		errorpage( $q, 403, "Access denied." );
		&do_exit;
	} elsif ( $aclresponse[0] eq 'ERROR' ) {
		errorpage( $q, 504, "Error in ambixacld: ".$aclresponse[1] );
		&do_exit;
	}
}


# get server parameters
if ( defined $config{servers}{$uri->authority} ) {
	$bindmech = $config{servers}{$uri->authority}{bindmech};
	$version = $config{servers}{$uri->authority}{version};
	$binddn = $config{servers}{$uri->authority}{binddn};
	$bindpw = $config{servers}{$uri->authority}{bindpw};
}
$version = 3 unless $version;

# connect to LDAP Server
if ( $uri->scheme eq 'ldap' ) {
	$ldap = Net::LDAP->new( $uri->host, port=>$uri->port, version => $version );
} elsif ( $uri->scheme eq 'ldaps' ) {
	$ldap = Net::LDAPS->new( $uri->host, port=>$uri->port, version => $version );
}

if ( !$ldap ) {
	errorpage($q, 504, "Error creating ldap object");
	&do_exit;
}

# bind if necessary


while ( $version < 3 || $binddn || $bindpw || $bindmech ) {
	my $mesg;
	if ( $bindmech eq '' || $bindmech eq 'simple' ) {
		if ( $binddn eq '' || $bindpw eq '') {
			$mesg = $ldap->bind( version => $version );
		} else {
			$mesg = $ldap->bind( $binddn, password => $bindpw, version => $version );
		}
	}

	if ( $mesg->code == LDAP_SUCCESS ) {
		last;  # all ok
	} elsif ($version == 3) {
			# try to downgrade protocol version
			$version = 2;
			# XXX dolog
	} else {
		errorpage($q, 200, 'ldap_simple_bind', $mesg->code, $mesg->error);
	        &do_exit;

		goto UNBIND;

	}
}


dolog("w2l: uri->dn:  $uri->dn");
if ( length $uri->dn ) {

    # base search on DN
    my $mesg = $ldap->search(
			     base	=> $uri->dn,
			     scope	=> 'base',
			     filter	=> dfnDistributionFilter($dfnDistribution),
			     attrs	=> $version < 3 ? '' : ['*', 'hasSubordinates', 
								'structuralObjectClass'],
			     );
    
    if ( $mesg->code == LDAP_SUCCESS ) {
	dolog("w2l: LDAP_SUCCESS");
	# all ok
    } elsif ( $mesg->code == LDAP_REFERRAL ) {
	dolog("w2l: LDAP_REFERRAL");
	printHeader( $q, $version < 3 ? 'iso-8859-1' : 'utf-8', $uri->clone, 0, $is_errorpage );
	
	if ( exists $config{objectclass}{'referral'}{$lang.".pl"} ) {
	    $header = $config{objectclass}{'referral'}{$lang.".pl"};
	} else {
	    $header = 'referral';
	}
	print $q->p({class => 'subliste'}, $header ), 
	$q->start_ul({class => 'subliste'});
	foreach my $ref ( $mesg->referrals ) {
	    my $refuri = URI->new( $ref );
	    next unless $refuri; # handle error?
	    $refuri->dn( $uri->dn ) unless $refuri->dn;
	    
	    $q->param('uri', $refuri->as_string);
	    print $q->li(
			 $q->img({src=>'/icons/hand.right.gif', alt=>'->', 
				  border=>0, style=>'vertical-align:middle'}),
			 '&nbsp', $refuri->scheme =~/^ldaps?$/ 
			 ? $q->a({-href=>$q->self_url},$refuri->authority)
			 : $q->a({-href=>uri_escape($refuri->as_string)},
				 $refuri->authority) );
	}
	print $q->end_ul;
	goto FOOTER;
    } else { 
	dolog("w2l: not LDAP_SUCCESS and not LDAP_REFERRAL");
	
	errorpage($q, 200, $uri->dn.': '.$mesg->error.' ('.$mesg->code.')');
	goto UNBIND;
    }
    
    $entry = $mesg->entry(0);
    
}

&displayPicture if $q->param('picture');

# print header (logo, move upward links, searchbox)
dolog("w2l: now calling printHeader in main. is_errorpage now: $is_errorpage");
printHeader( $q, $version < 3 ? 'iso-8859-1' : 'utf-8', $uri->clone, hasSubordinates($entry), $is_errorpage );

debug_parameters($q) if $config{'debug'};

if ( $q->param('extendedsearch') || $q->param('advancedsearch') ) {
    #$q->delete('extendedsearch');
    #$q->delete('advancedsearch');
    #$q->param( 'uri', $config{'default_uri'} );
    #print $q->a({-href=>$q->self_url}, "Zur&uuml;ck zum Browsen ..." );
    goto FOOTER;
}

#print entry attributes unless world or search
if ( length $uri->dn && !$q->param('search') ) {
	printEntry( $q, $entry, $uri->clone );
	&displayFormButtons($q, $entry, %config);
}

# optionally list subordinate entries
if ( hasSubordinates($entry) || $q->param('search') || $uri->dn eq '' ) {
	listOnelevel( $q, $ldap, $uri->clone, $dfnDistribution );
}

FOOTER:

$footer_template = HTML::Template->new(
	filename => "$config{template_dir}/footer.$lang.html", 
	loop_context_vars => 1,
	die_on_bad_params => 0,
	);
$footer_template->param( version => $w2lversion );
print $footer_template->output;

print
	$q->end_html();

UNBIND:

$ldap->unbind;

&closelog();

##
## End Main ####################################
##