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(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 # returns `0' and not `undef' on failure (see Www*Stream)
  23 sub gzf_maybe ($$) {
  24         my ($res_hdr, $env) = @_;
  25         return 0 if (($env->{HTTP_ACCEPT_ENCODING}) // '') !~ /\bgzip\b/;
  26         my ($gz, $err) = Compress::Raw::Zlib::Deflate->new(%OPT);
  27         return 0 if $err != Z_OK;
  28
  29         # in case Plack::Middleware::Deflater is loaded:
  30         $env->{'plack.skip-deflater'} = 1;
  31         push @$res_hdr, @GZIP_HDRS;
  32         bless { gz => $gz }, __PACKAGE__;
  33 }
  34
  35 sub qsp_maybe ($$) {
  36         my ($res_hdr, $env) = @_;
  37         return if ($env->{HTTP_ACCEPT_ENCODING} // '') !~ /\bgzip\b/;
  38         my $hdr = join("\n", @$res_hdr);
  39         return if $hdr !~ m!^Content-Type\n
  40                                 (?:(?:text/(?:html|plain))|
  41                                 application/atom\+xml)\b!ixsm;
  42         return if $hdr =~ m!^Content-Encoding\ngzip\n!smi;
  43         return if $hdr =~ m!^Content-Length\n[0-9]+\n!smi;
  44         return if $hdr =~ m!^Transfer-Encoding\n!smi;
  45         # in case Plack::Middleware::Deflater is loaded:
  46         return if $env->{'plack.skip-deflater'}++;
  47         push @$res_hdr, @GZIP_HDRS;
  48         bless {}, __PACKAGE__;
  49 }
  50
  51 sub gzip_or_die () {
  52         my ($gz, $err) = Compress::Raw::Zlib::Deflate->new(%OPT);
  53         $err == Z_OK or die "Deflate->new failed: $err";
  54         $gz;
  55 }
  56
  57 # for GetlineBody (via Qspawn) when NOT using $env->{'pi-httpd.async'}
  58 # Also used for ->getline callbacks
  59 sub translate ($$) {
  60         my $self = $_[0]; # $_[1] => input
  61
  62         # allocate the zlib context lazily here, instead of in ->new.
  63         # Deflate contexts are memory-intensive and this object may
  64         # be sitting in the Qspawn limiter queue for a while.
  65         my $gz = $self->{gz} //= gzip_or_die();
  66         my $zbuf = delete($self->{zbuf});
  67         if (defined $_[1]) { # my $buf = $_[1];
  68                 my $err = $gz->deflate($_[1], $zbuf);
  69                 die "gzip->deflate: $err" if $err != Z_OK;
  70                 return $zbuf if length($zbuf) >= 8192;
  71
  72                 $self->{zbuf} = $zbuf;
  73                 '';
  74         } else { # undef == EOF
  75                 my $err = $gz->flush($zbuf, Z_FINISH);
  76                 die "gzip->flush: $err" if $err != Z_OK;
  77                 $zbuf;
  78         }
  79 }
  80
  81 sub write {
  82         # my $ret = bytes::length($_[1]); # XXX does anybody care?
  83         $_[0]->{fh}->write(translate($_[0], $_[1]));
  84 }
  85
  86 # similar to ->translate; use this when we're sure we know we have
  87 # more data to buffer after this
  88 sub zmore {
  89         my $self = $_[0]; # $_[1] => input
  90         my $err = $self->{gz}->deflate($_[1], $self->{zbuf});
  91         die "gzip->deflate: $err" if $err != Z_OK;
  92         undef;
  93 }
  94
  95 # flushes and returns the final bit of gzipped data
  96 sub zflush ($;$) {
  97         my $self = $_[0]; # $_[1] => final input (optional)
  98         my $zbuf = delete $self->{zbuf};
  99         my $gz = delete $self->{gz};
 100         my $err;
 101         if (defined $_[1]) {
 102                 $err = $gz->deflate($_[1], $zbuf);
 103                 die "gzip->deflate: $err" if $err != Z_OK;
 104         }
 105         $err = $gz->flush($zbuf, Z_FINISH);
 106         die "gzip->flush: $err" if $err != Z_OK;
 107         $zbuf;
 108 }
 109
 110 sub close {
 111         my ($self) = @_;
 112         my $fh = delete $self->{fh};
 113         $fh->write(zflush($self));
 114         $fh->close;
 115 }
 116
 117 1;