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

package FilterProxy::Compress;

use strict;
no strict 'subs';
use vars qw($VERSION $CONFIG);
require Compress::Zlib;
if($Compress::Zlib::VERSION < 1.10) { # previous versions didn't have memGunzip
  die "FilterProxy::Compress requires Compress::Zlib version 1.10 or greater.\n" .
        "You have version $Compress::Zlib::VERSION\n"; 
}

push @FilterProxy::MODULES, "Compress"; # add myself to FilterProxy's list of known modules
$VERSION = 0.01;
$CONFIG = {};
$CONFIG->{order} = [-10, 1, 9];
$CONFIG->{mime_types} = [ # types which compress well.
    "text/html", 
    "text/plain",
    "application/postscript",
    "application/pdf", 
    "application/x-javascript"
];
$CONFIG->{transfer_encoding} = 0; # Use Transfer-Encoding header instead of Content-Encoding
                                  # (only for HTTP/1.1).  No browser I know of supports this
                                  # yet, but it's part of the HTTP/1.1 spec.  I'm hoping
                                  # Mozilla will support it soon.  See bug: 
                                  # http://bugzilla.mozilla.org/show_bug.cgi?id=59464
$CONFIG->{min_size} = 1024;     # Don't compress anything smaller than 1k.

*logger = \&FilterProxy::logger;

sub filter {
  my($req, $res, $siteconfig, $order) = @_;
  my($method);  # either "gzip", "deflate", or "compress"
  return unless (defined $req) && (ref $req) && (defined $res) && (ref $res);
  if($order eq -10) { # Add a TE header
    # why isn't $res->push_header working for this?
    # We'll accept these from servers. (FIXME enable this when/if we support HTTP/1.1 on outgoing connection)
#    $res->header('TE' => (defined $res->header('TE'))?$res->header('TE'):"" . "gzip,compress,identity");  
    # per RFC2616, section 14.39
    $res->header('Connection' => (defined $res->header('Connection'))?$res->header('Connection'):"" . "TE");
#    $res->push_header('Connection' => 'TE'); 
    $res->header('Accept-Encoding' => "gzip,compress,identity");  
  } elsif($order eq 9) { # Must compress content
    return unless (length ${$res->content_ref} > $CONFIG->{min_size});
    return unless grep($res->content_type, $CONFIG->{mime_types});
    return unless (!(defined $res->content_encoding && ($res->content_encoding || "") =~ /\S/) 
                and ((defined $req->header("accept-encoding") 
                     and ($req->header("accept-encoding") || "") =~ /(gzip|deflate|compress)/i) 
                    and ($method=$1 || 1))
                || ($req->header("TE") =~ /(gzip|deflate|compress)/i and ($method=$1 || 1)));
    return if defined $res->header("Cache-Control") && $res->header("Cache-Control") =~ /no-transform/i; # Must not modify message
    my($oldlength) = length ${$res->content_ref};

    if($method =~ /gzip/i) {
      $res->content(Compress::Zlib::memGzip($res->content_ref)); #will clobber file if fail
    } elsif($method =~ /compress/i) {
      $res->content(Compress::Zlib::compress($res->content_ref));
    } elsif($method =~ /deflate/i) {
      my($d) = Compress::Zlib::deflateInit();
      my($output, $status) = $d->deflate($res->content_ref);
    }
    if (defined ${$res->content_ref}) {
      # Note: using Transfer-Encoding would be better here, but Netscape doesn't 
      #    implement it.  (nor mozilla, nor konqueror)
      # Netscape: displays binary uncompressed gzip
      # Mozilla: pages blank, save-as results in "Unknown Error" [1 80004005] (saved file is blank)
      if($req->protocol eq "HTTP/1.1" && $CONFIG->{transfer_encoding} 
           && defined $req->header('TE') && $req->header('TE') =~ /(gzip|deflate|compress)/i) { # Required by section 14.39 of RFC 2616
        if(defined($res->header('Transfer-Encoding'))) {
          $res->header('Transfer-Encoding' => $res->header('Transfer-Encoding') . "," . $method);
        } else {
            $res->header('Transfer-Encoding' => $method);
        }
      } else {
        $res->header('Content-Encoding' => $method);
      }
      logger(DEBUG, "  Compress: shrunk from ".  $oldlength . " to " .
           (length ${$res->content_ref}) . " bytes\n");
    } else {
      logger(ERROR, "  Compress: gzip/deflate/compress failed!  Lost data!\n");
    }
  } elsif($order eq 1) { # must uncompress content.
    my($dogunzip) = 0;
    if(defined $res->header('Transfer-Encoding')) {
      my(@encodings) = $res->header('Transfer-Encoding');
      if($encodings[$#encodings] =~ /^\s*(gzip|deflate|compress)\s*$/i) { 
        pop @encodings; 
        $dogunzip = 1; 
        $method = $1;
        logger(DEBUG, "  Compress: Decoding Transfer-Encoding: ", $res->header('Transfer-Encoding'), "\n");
      }
      if($#encodings != -1) { $res->header('Transfer-Encoding' => \@encodings); }
      else { $res->remove_header('Transfer-Encoding'); }
    }
    if(defined $res->content_encoding) {
      logger(DEBUG, "  Compress: Decoding Content-Encoding: ", $res->content_encoding, "\n");
      if($res->content_encoding =~ /\b(gzip|deflate|compress)\b/i) { $dogunzip = 1; $method = $1; }
      $res->remove_header('Content-Encoding');
    }
    if($dogunzip) {
#      if($method =~ /gzip/i) {
        $res->content(Compress::Zlib::memGunzip(${$res->content_ref})); #will clobber file if fail
#      } elsif ($method =~ /compress/i) {
#        $res->content(Compress::Zlib::uncompress($res->content_ref));
#      } elsif ($method =~ /deflate/i) {
#        my($i) = Compress::Zlib::inflateInit();
#        my($output, $status) = $i->inflate($res->content_ref);
#        $res->content($output);
#      }
      unless(defined $res->content_ref && defined ${$res->content_ref}) {
        logger(ERROR, "  Compress: gunzip/uncompress failed!  Lost data!\n");
        $res->code(500);
        $res->content("FilterProxy::Compress failed.\n");
      }
    }
  }
}

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

  if($cgi->param()) {
    if(defined $cgi->param('min_size')) {
      $CONFIG->{min_size} = $cgi->param('min_size');
      $message = "Minimum size changed successfully.\n";
    }
    if(defined $cgi->param('transfer_encoding')) {
      $CONFIG->{transfer_encoding} = 1;
    } else {
      $CONFIG->{transfer_encoding} = 0;
    }
    if(defined $cgi->param('mime_types')) {
      $CONFIG->{mime_types} = [split(/\s*[\r\n]+/, $cgi->param('mime_types'))];
      $message = "Mime Types changed successfully.\n";
    }
  }
  return $message; 
}