#!/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

will contain the string typed in by the user.

=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 strict;

use Cwd;
use CDB_File::BiIndex 0.026;
use CGI::Request;
use DB_File;
use Fcntl;
use HTML::Stream;
use CGI::Response;
use MLDBM qw(DB_File);
use WWW::Link;
use WWW::Link::Repair;
use WWW::Link::Repair::Substitutor;
use WWW::Link_Controller::InfoStruc;
use WWW::Link_Controller::URL;

use vars qw($req @oldurls $origuri $newuri $linkdbm $fixed_config);

#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 {
  print STDERR "links before $::links\n" if $::verbose;
  $DB::single = 1;
  my $icwd=cwd();
  print STDERR "icwd: $icwd\n"  if $::verbose;
  (my $cwd) = ($icwd =~ m/(.*)/) ; #force launder
  print STDERR "cwd: $cwd\n"  if $::verbose;
  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" if $::verbose;
  }

  print STDERR "links after $::links\n" if $::verbose;
};

#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 ($tmporiguri,$tmpnewuri);

$tmporiguri=$req->param("orig-url");
die "arguments missing" unless $tmporiguri;
warn "got origurl $tmporiguri\n" if $::verbose;
$tmpnewuri=$req->param("canned-suggestion");
die "argument missing" unless $tmporiguri;
warn "got newuri $tmpnewuri\n" if $::verbose;
$tmpnewuri=$req->param("user-suggestion") 
  unless ( defined $tmpnewuri and $tmpnewuri ne "user" );

die "called without url to change from\n" unless defined $tmporiguri;
die "called without url to change to\n" unless defined $tmpnewuri;

# 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.


$origuri=WWW::Link_Controller::URL::untaint_url($tmporiguri);
$newuri=WWW::Link_Controller::URL::untaint_url($tmpnewuri);
die "untaint of origuri failed" unless defined($origuri);
die "untaint of newuri failed" unless defined($newuri);

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

#print STDERR "$origuri eq $tmporiguri and $newuri eq $tmpnewuri\n";
unless ($origuri eq $tmporiguri and $newuri eq $tmpnewuri) {
  $::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.

  print STDERR "page index $::page_index, link index $::link_index\n"
    if $::verbose;

  $::index = new CDB_File::BiIndex $::page_index, $::link_index;

  #FIXME tree options?  Relative Links
  $::file_subs= WWW::Link::Repair::Substitutor::gen_file_substitutor
    ($origuri, $newuri, ($::tree ? ( tree_mode => 1 ) : () ),
     ($::relative ? ( relative => 1 , 
		      file_to_url => \&WWW::Link_Controller::InfoStruc::file_to_url)
                  : () ),
     );

  warn ( "substituting $origuri for $newuri" ) if $::verbose;

  my $trans_sub=\&WWW::Link_Controller::InfoStruc::url_to_file;
  my $fixed=WWW::Link::Repair::infostructure($origuri, $::index,$trans_sub,
					     $::file_subs);

  $::hstr->P 
         -> t("Your link change of $origuri\n to $newuri\n" .
              "has been carried out as requested.  We made" .
	      "$fixed fixeds in the process\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{$origuri};
  accept_suggestion($link, $newuri);
  $::links{$origuri} = $link; #MLDBMhack
}

$::hstr->_BODY->_HTML;

exit 0;

sub accept_suggestion {
  my $link=shift;
  my $suggestion=shift;
  my $origuri = $link->url();
  if ( $link->add_suggestion($suggestion) ) {
    $::hstr->P 
           -> t("Your link change of $origuri\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 $origuri\n to $suggestion\n" .
                "is already recorded in the database.\n"  .
		"Thankyou for offering anyway.")
	   ->_P->nl;
  }
}


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