#!/usr/bin/perl -Tw
#!/usr/bin/perl -w

=head1 NAME

fix-link.cgi - allow a user to repair databases

=head1 DESCRIPTION

With this cgi, links within an infostructure can be repaired.  It
accepts a list of fields corresponding to the urls to be changed, and
containing the url they are to be changed to.  It then calls the
correct functions to repair those links.

Generally, this program will be triggered from a form generated by
link-report.cgi

=head1 ARGUMENTS

=head2 orig-url

The url to be fixed

=head2 canned-suggestion

the canned-suggestion parameter is used for returning values from a list of choices.  If the parameter is given the value "user" then 

=head2 user-suggestion

=head1 SEE ALSO

L<verify-link-control(1)>; L<extract-links(1)>; L<build-schedule>
L<link-report(1)>; L<fix-link(1)>; L<link-report.cgi(1)>; L<fix-link.cgi>
L<suggest(1)>; L<link-report.cgi(1)>; L<configure-link-control>

The LinkController manual in the distribution in HTML, info, or
postscript formats, included in the distribution.

http://scotclimb.org.uk/software/linkcont - the
LinkController homepage.

=cut

BEGIN {
  $ENV{PATH} = "/bin:/usr/bin";
  delete @ENV{qw(HOME IFS CDPATH ENV BASH_ENV)};   # Make %ENV safer
}

use CDB_File::BiIndex;
use WWW::Link;
use WWW::Link::Repair;
use WWW::Link::Repair::Substitutor;
use CGI::Request;
use Fcntl;
use DB_File;
use strict;
use HTML::Stream;
use CGI::Response;
use MLDBM qw(DB_File);
use vars qw($req @oldurls $oldurl $newurl $linkdbm);
use Cwd;

#if the config files are to be previously overridden then this must
#have already been "used"
use WWW::Link_Controller::ReadConf;

#FIXME
#Configuration - here we bypass tainting
# this basically means we trust the directory we are called in.. unwise!!
# this should never be an issue in a normal CGI which will be run from
# the user's hardwired script..

BEGIN {
  $DB::single = 1;
  my $icwd=getcwd();
  print "icwd: $icwd\n";
  (my $cwd) = ($icwd =~ m/(.*)/) ; #force launder
  print "cwd: $cwd\n";
  if ((! $fixed_config) && -r ".cgi-infostruc.pl") {
    my $file=$cwd . "/.cgi-infostruc.pl";
    defined (do $file) || do {
      die "parse of $file failed: $@" if $@;
      die "couldn't open $file: $!"
    }
  } else {
    warn "using default configuration";
  }
};

#controls - not really configuration yet.

$::secret_suggestions=0; #whether the user wants to tell others about changes
$::authorised=1; #whether the system has authenticated the user

$req=new CGI::Request;
$::hstr=new HTML::Stream;

print &CGI::Response::ContentType("text/html");

#what infostructure are we fixing?

#who does the server think this connection is coming from?

#Get to the owner of that infostructures uid and check the person is authorised.


#what url should we fix?


my ($tmpoldurl,$tmpnewurl);

$tmpoldurl=$req->param("orig-url");
die "arguments missing" unless $tmpoldurl;
print STDERR "got origurl $tmpoldurl\n";
$tmpnewurl=$req->param("canned-suggestion");
die "argument missing" unless $tmpoldurl;
print STDERR "got new $tmpnewurl\n";
$tmpnewurl=$req->param("user-suggestion") 
  unless ( defined $tmpnewurl and $tmpnewurl ne "user" );

die "called without url to change from\n" unless defined $tmpoldurl;
die "called without url to change to\n" unless defined $tmpnewurl;

# we take in the urls untainting them as we go.. this is potentially
# important for security if you are using this code to allow users to
# change url in HTML code.  Nothing should come through which might
# screw up the HTML code.

$tmpoldurl =~ m/([^\s<>"']*)/;
$oldurl = $1;
$tmpnewurl =~ m/([^\s<>"']*)/;
$newurl = $1;
die "oldurl tainted when should be clean" if is_tainted($oldurl);
die "newurl tainted when should be clean" if is_tainted($newurl);

$::hstr->HTML->HEAD
       ->TITLE->t("Results of Link Fix")->_TITLE
       ->_HEAD
       ->BODY
       ->H1->t("Results")->_H1;


unless ($oldurl eq $tmpoldurl and $newurl eq $tmpnewurl) {
  $::hstr->P ->t("The url you suggested wasn't a correct, full format," .
		 "url.  Aborting. Sorry.")
         ->_P;
  exit 1;
}

if ($::authorised) {
  #we have a known authorised user for this infostructure carry out all of the fixes.
  $::index = new CDB_File::BiIndex $::page_index, $::link_index;
  $::substitutor=WWW::Link::Repair::Substitutor::gen_substitutor($oldurl, $newurl, 0, 0);
  $::handler=WWW::Link::Repair::Substitutor::gen_simple_file_handler($::substitutor);

  warn ( "substituting $oldurl for $newurl" );

  WWW::Link::Repair::infostructure($::index, $::handler, $oldurl);
  $::hstr->P 
         -> t("Your link change of $oldurl\n to $newurl\n" .
              "has been carried out as requested.\n" )
         ->_P->nl;
} else {
  $::hstr->P ->t("you don't seem to be an authorised user so I can't directly" .
		 "carry out your suggested changes.  If you should be" .
		 "authorised then try typing your password again"
		);
}

unless ($::secret_suggestions) {
  $::linkdbm = tie %::links, "MLDBM", $::links, O_RDONLY, 0666, $::DB_HASH
    or die $!;
  my $link=$::links{$oldurl};
  accept_suggestion($link, $newurl);
  $::links{$oldurl} = $link; #MLDBMhack
}

$::hstr->_BODY->_HTML;

exit 0;

sub accept_suggestion {
  my $link=shift;
  my $suggestion=shift;
  my $oldurl = $link->url();
  if ( $link->add_suggestion($suggestion) ) {
    $::hstr->P 
           -> t("Your link change of $oldurl\n to $suggestion\n" .
                "has been added as a suggestion to the database.\n" .
		"Thankyou.")
	   ->_P->nl;
  } else {
    $::hstr->P 
           -> t("Your link change of $oldurl\n to $suggestion\n" .
                "is already recorded in the database.\n"  .
		"Thankyou for offering anyway.")
	   ->_P->nl;
  }
}


sub is_tainted {
  return ! eval {
    join('',@_), kill 0;
    1;
  };
}
