#!/usr/local/rib/rib-1.0/bin/perl
use lib '/usr/local/rib/rib-1.0/lib';
# NHSE Repository in a Box (RIB)
#
# The author of this software is Paul McMahan.
# Copyright (c) 1998 by the University of Tennessee.
# Permission to use, copy, modify, and distribute this software for any
# purpose without fee is hereby granted, provided that this entire notice
# is included in all copies of any software which is or includes a copy
# or modification of this software and in all copies of the supporting
# documentation for such software.
# THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTY.  IN PARTICULAR, NEITHER THE AUTHORS NOR UNIVERSITY OF TENNESSEE
# MAKE ANY REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE
# MERCHANTABILITY OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
#

use strict;
use RIB::Util ();
#use HTTP::Status;
require LWP::UserAgent;

use Getopt::Std;
my %opts;
unless (getopts('e:', \%opts)) {
    usage();
}
my $opt_e = $opts{e}; # email address
my $email_message = '';

my $util = RIB::Util->new();

my $repository = $util->GetRepoName();
if (!$repository) {
  $email_message .= "Couldn't derive repository name.\nQuitting.\n";
  &quit ($email_message);
}

my $filepath = $util->GetRibDir() . "/repositories/" . $repository;
my $urlpath  = $util->GetRibUrl() . "/repositories/" . $repository;

$|=1;

my $mirrorfile = $filepath . "/files/.mirror";

unless (-e $mirrorfile) {
  $email_message .= "No mirror file at $mirrorfile.\nQuitting.\n";
  &quit ($email_message);
}
unless (-s $mirrorfile) {
  $email_message .= "Mirror file at $mirrorfile is empty.\nQuitting.\n";
  &quit ($email_message);
}

# the mirror file should not be readable until this program
# needs it.  that's because it might contain username/passwd
# pairs used for mirroring.  after we read the file in we should
# set the permissions back to unreadable.  this prevents people
# from retrieving the file via http
unless (chmod 0600, $mirrorfile) {
  $email_message .= "Can't chmod mirror file : $!\nQuitting.\n";
  &quit ($email_message);
}

unless (open (MIRROR, "<$mirrorfile")) {
  chmod 0000, $mirrorfile;
  $email_message .= "Can't open $mirrorfile : $!\nQuitting\n";
  &quit ($email_message);
}
undef ($/);
my $buf = <MIRROR>;
$/= "\n";
my @mirror_list;
if ($buf) {
  my $tmp = eval "my $buf";
  @mirror_list = @$tmp;
  undef $tmp;
}
undef $buf;
close (MIRROR);
# so people can't retrieve this file via http.  don't test
# return status of call, just hope it works since call above
# worked (this is not a good time to bug out)
unless (chmod 0000, $mirrorfile) {
  $email_message .= "Error - can't chmod $mirrorfile back to 0000 : $!\n";
  $email_message .= "Proceeding anyway...\n";
}

my $basedir = $filepath . "/files";
my ($mirror,$rc, $res);

my $x;
my $ua = new LWP::UserAgent;

foreach $mirror (@mirror_list) {
  $email_message .= $mirror->{URL} . " => $basedir/". $mirror->{filename}. "\n";
  $res = &mirror($ua, $mirror->{URL}, $basedir."/".$mirror->{filename},
                      $mirror->{username}, $mirror->{password});
  $email_message .= "Results:\n      ";
  if ($res->code == 200) {
    $email_message .= "File has changed.  Downloading new version.\n";
  } else {
    $email_message .= &HTTP::Status::status_message($res->code). "\n";
  }
}

#file gets touched to show when this script ran last
open (FOO, ">$basedir/.last_check"); close (FOO);

&quit($email_message);

# this subroutine ripped from LWP package and modified slightly to
# allow username and password in mirroring.

sub mirror
{
    my($ua, $url, $file, $username, $password) = @_;

    my $request = new HTTP::Request('GET', $url);

    if ($username or $password) {
      $request->authorization_basic($username, $password);
    }

    if (-e $file) {
        my($mtime) = (stat($file))[9];
        if($mtime) {
            $request->header('If-Modified-Since' =>
                             HTTP::Date::time2str($mtime));
        }
    }
    my $tmpfile = "$file-$$";

    my $response = $ua->request($request, $tmpfile);
    if ($response->is_success) {

        my $file_length = (stat($tmpfile))[7];
        my($content_length) = $response->header('Content-length');

        if (defined $content_length and $file_length < $content_length) {
            unlink($tmpfile);
            $email_message .= "\n!! Transfer truncated: " .
                "only $file_length out of $content_length bytes received\n";
            &quit($email_message);
        } elsif (defined $content_length and $file_length > $content_length) {
            unlink($tmpfile);
            $email_message .= "Content-length mismatch: " .
                "expected $content_length bytes, got $file_length\n";
            &quit($email_message);
        } else {
            # OK
            if (-e $file) {
                # Some dosish systems fail to rename if the target exists
                chmod 0777, $file;
                unlink $file;
            }
            unless (rename($tmpfile, $file)) {
                $email_message .= "Cannot rename '$tmpfile' to '$file': $!\n";
                &quit($email_message);
            }
        }
    } else {
        unlink($tmpfile);
    }
    return $response;
}


sub quit {
    my $email_message = shift;
    $email_message.="\n";
    if ($opt_e =~ /^[\w\-\.~:,]+\@[\w\-\.~:,]+$/) {
      my $ua = new LWP::UserAgent;
      my $req = HTTP::Request->new(POST => "mailto:$opt_e");
      $req->header("Subject", "results of RIB mirroring update");
      $req->content($email_message);
      my $res = $ua->request($req);
   } else {
      print STDERR $email_message;
   }
   exit (0);
}