# Header FilterProxy Module

# Copyright (C) 2000, 2001 Bob McElrath.
# See the file COPYING for redistribution and modification terms.
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# FIXME need better way of specifying what a filter can filter than mime-types

package FilterProxy::Header;

use strict;
no strict 'subs';
use vars qw($VERSION $CONFIG);

push @FilterProxy::MODULES, "Header"; # add myself to FilterProxy's list of modules.
$VERSION = 0.02;
$CONFIG = {};
$CONFIG->{order} = [-10, 10]; 
  # -10: after client request is received, before request sent off to server
  # 10: after all filtering is finished, before response sent to client.

$CONFIG->{mime_types} = [ "" ]; # Note that ALL mime-types match this, but this
                                # cleverly doesn't get added to the list of things
                                # that are filterable (i think) (this is a bit of
                                # a hack => FIXME) 
$CONFIG->{dump_headers} = 0;

my($SITECONFIG); # this doesn't do anything, but illustrates what should be in
                 # the $siteconfig parameter to filter()
$SITECONFIG->{remove} = [ # Note case insensitive
    'referer',
    'x-meta.*',
    'user-agent',
    'cookie',
    'set-cookie'
];

$SITECONFIG->{add} = { }; # Hash of things to add.

*logger = \&FilterProxy::logger;

sub filter {
  my($req, $res, $siteconfig, $order) = @_;
  # logger(DEBUG, Data::Dumper->Dump([$siteconfig], ["$siteconfig"]));
  # NEVER MODIFY $req!!!!!!!!!
  # Remove headers
  my(@remove) = ();

  foreach my $site (@$siteconfig) {
    if(defined $site->{remove} && ref($site->{remove}) eq "ARRAY") {
      $res->scan(sub {
          my($header, $value) = @_;
          foreach my $remove (@{$site->{remove}}) {
            if($header =~ /^$remove$/i) {
              push @remove, $header;
              logger(DEBUG, "  I'm thinking about removing $remove\n");
            }
          }
      });
    }
    # Now check for any allows...
    foreach my $site (@$siteconfig) {
      if(defined $site->{allow} && ref($site->{allow}) eq "ARRAY") {
        foreach my $allow (@{$site->{allow}}) {
          for (my $i=$#remove; $i>=0; $i--) {
            if ($allow =~ /^$remove[$i]$/i) {
              splice @remove, $i, 1;
              logger(DEBUG, "  Change of heart: allow $allow\n");
            }
          }
        }
      }
    }
    foreach my $header (@remove) {
      $res->remove_header($header);
      logger(DEBUG, "  Removing header $header\n");
    }
  }
# Add headers
  foreach my $site (@$siteconfig) {
    if(defined $site->{add} && ref($site->{add}) eq "ARRAY") {
      foreach my $header (@{$site->{add}}) {
        if($header =~ /^(.*?):\s*(.*)/) {
          my($header, $value) = ($1, $2);
          $res->push_header($header, $value);
        } else {
          logger(ERROR, "Malformed header: ", $header);
        }
      }
    }
  }
  $res->remove_header('Proxy-Connection');
  $res->remove_header('Xonnection'); # This isn't a valid header...
  if(defined $res->header('Connection')) { # rfc2616, section 14.10 remove 'per-hop' headers (usually keep-alive)
      foreach my $hdr ($res->header('Connection')) { $res->remove_header($hdr); }
      $res->remove_header('Connection');
  }
  if($order == -10) { # outgoing request must conform to HTTP/1.0 (LWP limitation)
    $res->protocol("HTTP/1.0");
    $res->push_header('Connection', 'close'); # LWP is HTTP/1.0 only
    # Sanitize the request for HTTP/1.0
    $res->remove_header('Keep-Alive');
    $res->remove_header('Proxy-Connection');
    # enables auth for other proxies if FilterProxy's auth is disabled.
    $res->remove_header('Proxy-Authorization') if $FilterProxy::CONFIG->{authenable}; 
    # Add the Via header (rfc2616, section 14.45)
    $res->push_header('Via' => "1.1 $FilterProxy::HOSTNAME");
    # Remove authorization stuff intended for FilterProxy
    if($res->header('Host') =~ /([^:]+)(:([0-9]+))?/) {  # FIXME will this break using a secondary proxy?
        my($hostname) = $1;
        my($tohost) = (gethostbyname($hostname))[1];
        my($myhost) = (gethostbyname($FilterProxy::HOSTNAME))[1];
        my($port) = (defined $2)?$3:80;
        if(defined($tohost) && defined($myhost) && $tohost eq $myhost 
            && $port == $FilterProxy::LISTEN_PORT) {
            $res->remove_header("Authorization"); # request is not destined for FilterProxy.
        }
    } else {
        $res->remove_header("Authorization"); # request is not destined for FilterProxy.
    }
    # HTTP::Daemon doesn't recognize Proxy-Connection (netscape hack).
    if((defined $req->header('Proxy-Connection') && $req->header('Proxy-Connection') =~ /\bclose\b/i)
      || (defined $req->header('Connection') && $req->header('Connection') =~ /\bclose\b/i)) {
      $FilterProxy::client->force_last_request();  
      # This is baaad.  But which is worse?  Munging headers in FilterProxy.pl?  Or
      # accessing FilterProxy::client from FilterProxy::Header?
    }
    logger(DEBUG, "  Outgoing Header to server for ", $req->uri, ": \n", $res->headers_as_string) if($CONFIG->{dump_headers});
  } elsif($order == 10) { # Incoming response from server, for client
    $res->protocol($req->protocol()); # respond to client with version it likes
    if(defined $res->header('Transfer-Encoding')) { # Need to remove this header and un-transform the content
      my(@encodings) = $res->header('Transfer-Encoding');
      if($encodings[$#encodings] =~ /^\s*chunked\s*$/i) { pop @encodings; }
      if($#encodings != -1) { 
          $res->header('Transfer-Encoding' => \@encodings); 
          logger(WARNING, "  Undecoded Transfer-Encoding found: ", join(' ', @encodings), "\n");
      }
      else { $res->remove_header('Transfer-Encoding'); }
    }
    # Handle connection headers
    if($res->protocol() =~ /HTTP\/1.1/i) {
      $res->push_header('Connection' => 'keep-alive');  # The "right" header to manage connection
      $res->header('Keep-Alive' => 
          (defined $req->header('Keep-Alive'))?$req->header('Keep-Alive'):$FilterProxy::CONFIG->{timeout});
      unless($res->code < 200 || $res->code == 204 || $res->code == 304 || $req->method eq 'HEAD') {
          if(defined($res->header('Transfer-Encoding'))) {
              $res->header('Transfer-Encoding' => $res->header('Transfer-Encoding') . "," . "chunked");
          } else {
              $res->header('Transfer-Encoding' => "chunked");
          }
      }
      $res->remove_header('Content-Length') # RFC2616, section 4.4, length will be delimited by chunk.
          unless(defined $res->header('Cache-Control') && $res->header('Cache-Control') =~ /\bno-transform\b/i);
    } elsif($res->protocol() =~ /HTTP\/1.0/i) { # Straight HTTP/1.0
      if($req->header("User-Agent") =~ /^Mozilla\/4/) {  # Netscape hacks
        $res->header('Proxy-Connection' => 'keep-alive');
        $res->push_header('Connection' => 'keep-alive');  # The "right" header to manage connection
        $res->header('Keep-Alive' => 
          (defined $req->header('Keep-Alive'))?$req->header('Keep-Alive'):$FilterProxy::CONFIG->{timeout});
      } else {
        $res->push_header('Connection' => 'close');
      }
      if(defined $res->content && $res->content) { 
        $res->header('Content-Length' => length ${$res->content_ref}); 
      }
    } else {
      logger(ERROR, "Header doesn't know what to do for protocol: ", $res->protocol());
    }
    if($res->content) {
      unless(defined $res->content_type) { # Should I test content to see if it's really html?
        $res->header("Content-Type" => "text/html");
      }
    }
    # Add the Via header (rfc2616, section 14.45)
    $res->push_header('Via' => "1.1 $FilterProxy::HOSTNAME");
    logger(DEBUG, "  Outgoing Header to client for ", $req->uri, ": \n", $res->headers_as_string) if($CONFIG->{dump_headers});
  } else {
    logger(ERROR, "  Header doesn't know what to do for order $order.");
  } 
}

sub Config {
  my($req, $cgi, $siteconfig) = @_;
  my($message) = "";



  if($cgi->param('global')) {
      if(defined $cgi->param('dump_headers')) {
        $CONFIG->{dump_headers} = 1;
        $message .= "Will now dump headers to log file.";
      } else {
        $CONFIG->{dump_headers} = 0;
        $message .= "Will no longer dump headers to log file.";
      }
  }
  if($cgi->param('remove') || $cgi->param('add')) {

    if($cgi->param('remove')) {
      $siteconfig->{'remove'} = [split(/\s*[\r\n]+/, $cgi->param('remove'))];
      $message = "remove successfully updated";
    }
    else {
      $siteconfig->{'remove'}="";
    }

    if($cgi->param('add')) {
      $siteconfig->{'add'} = [split(/\s*[\r\n]+/, $cgi->param('add'))];
      $message .= ", add successfully updated";
    }
    else {
      $siteconfig->{'add'}="";
    }

    if($cgi->param('allow')) {
      $siteconfig->{'allow'} = [split(/\s*[\r\n]+/, $cgi->param('allow'))];
      $message .= ", allow successfully updated";
    }
    else {
      $siteconfig->{'allow'}="";
    }

    if($cgi->param('priority')) {
      $siteconfig->{'priority'} = $cgi->param('priority');
      $message .= ", priority successfully updated";
    }

  }
  return $message; # message printed to user
}