lib/PublicInbox/GzipFilter.pm

   1 # Copyright (C) 2020 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # Qspawn filter
   5 package PublicInbox::GzipFilter;
   6 use strict;
   7 use parent qw(Exporter);
   8 use Compress::Raw::Zlib qw(Z_FINISH Z_OK);
   9 our @EXPORT_OK = qw(gzip_maybe gzf_maybe);
  10 my %OPT = (-WindowBits => 15 + 16, -AppendOutput => 1);
  11 my @GZIP_HDRS = qw(Vary Accept-Encoding Content-Encoding gzip);
  12
  13 sub new { bless {}, shift }
  14
  15 # for Qspawn if using $env->{'pi-httpd.async'}
  16 sub attach {
  17         my ($self, $fh) = @_;
  18         $self->{fh} = $fh;
  19         $self
  20 }
  21
  22 sub gzip_maybe ($$) {
  23         my ($res_hdr, $env) = @_;
  24         return if (($env->{HTTP_ACCEPT_ENCODING}) // '') !~ /\bgzip\b/;
  25
  26         my ($gz, $err) = Compress::Raw::Zlib::Deflate->new(%OPT);
  27         return if $err != Z_OK;
  28
  29         # in case Plack::Middleware::Deflater is loaded:
  30         $env->{'plack.skip-deflater'} = 1;
  31
  32         push @$res_hdr, @GZIP_HDRS;
  33         $gz;
  34 }
  35
  36 sub gzf_maybe ($$) {
  37         my ($res_hdr, $env) = @_;
  38         my $gz = gzip_maybe($res_hdr, $env) or return 0;
  39         bless { gz => $gz }, __PACKAGE__;
  40 }
  41
  42 # for GetlineBody (via Qspawn) when NOT using $env->{'pi-httpd.async'}
  43 # Also used for ->getline callbacks
  44 sub translate ($$) {
  45         my $self = $_[0];
  46
  47         # allocate the zlib context lazily here, instead of in ->new.
  48         # Deflate contexts are memory-intensive and this object may
  49         # be sitting in the Qspawn limiter queue for a while.
  50         my $gz = $self->{gz} //= do {
  51                 my ($g, $err) = Compress::Raw::Zlib::Deflate->new(%OPT);
  52                 $err == Z_OK or die "Deflate->new failed: $err";
  53                 $g;
  54         };
  55         my $zbuf = delete($self->{zbuf});
  56         if (defined $_[1]) { # my $buf = $_[1];
  57                 my $err = $gz->deflate($_[1], $zbuf);
  58                 die "gzip->deflate: $err" if $err != Z_OK;
  59                 return $zbuf if length($zbuf) >= 8192;
  60
  61                 $self->{zbuf} = $zbuf;
  62                 '';
  63         } else { # undef == EOF
  64                 my $err = $gz->flush($zbuf, Z_FINISH);
  65                 die "gzip->flush: $err" if $err != Z_OK;
  66                 $zbuf;
  67         }
  68 }
  69
  70 sub write {
  71         # my $ret = bytes::length($_[1]); # XXX does anybody care?
  72         $_[0]->{fh}->write(translate($_[0], $_[1]));
  73 }
  74
  75 sub close {
  76         my ($self) = @_;
  77         my $fh = delete $self->{fh};
  78         $fh->write(translate($self, undef));
  79         $fh->close;
  80 }
  81
  82 1;