#!/usr/bin/perl -w
# Ad Banner server for ad-free webbing.
# Original code Waider 1997 or so.
# Revamped July 2000 when I learned a little more about Perl, but it's
# still disgusting. It's not multithreaded or anything.
#
# December 2001: Mozilla no longer groks XBMs, or at least not with
# the headers I'm putting out. So I'm switching to PNGs, as I'd
# planned on doing at some point anyway.
#
# While I was at it, I cleaned up the code a little. Not much, though.
#
# April 20, 2003: Conditionalised printing of request details
# 06/08/2003: fortune is no longer packaged on redhat, alas.
use Socket;
use GD;
use strict;

my $port = $ARGV[0] || 3129;
my $debug = 0;
$|=1;

my ($name, $aliases, $proto) = getprotobyname('tcp');
($name, $aliases, $port) = getservbyname($port, 'tcp')
  unless $port =~ /^\d+$/;

my $this = sockaddr_in( $port, "\0\0\0\0");

select(NS); $| = 1; select(STDOUT);

socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
bind(S, $this) || die "bind: $!";
listen(S, 5) || die "connect: $!";

select(S); $| = 1; select(STDOUT);

for (;;) {
  accept(NS,S) || die $!;

  my ($port, $inetaddr ) = sockaddr_in( getpeername( NS ));
  my ( $rin, $rout, $win, $wout, $ein, $eout, $nbytes, $buf, $line, $nfound );

  my $chunk = "";

  while( 1 ) {
	$rin=$rout=$win=$wout=$ein=$eout='';
	vec( $rin, fileno( NS ), 1) = 1;
	vec( $win, fileno( NS ), 1) = 1;
	$ein=$rin|$win;
	$nfound=select( $rout=$rin, $wout=$win, $eout=$ein, 0 );
	if ( $nfound ) {
	  if ( vec( $rout, fileno( NS ), 1 )) {
		$nbytes=sysread( NS, $buf, 1024 );
		last if !defined( $nbytes );
		last if $nbytes<1;
	  }
	}

	$chunk .= $buf if defined $buf;

	if ( length( $chunk ) && $nbytes ) {
	  $line = $chunk;
	  $line=~ s/\r\n/\n/g;
	  last if ( $line =~ /\n\n/ );
	}

	undef $buf;
	$nbytes = 0;
  }

  #print "Request: $chunk\n" if defined( $chunk );

  # Parse request
  #	GET http://ad.uk.doubleclick.net/ad/theregister.co.uk/regindex;area=regindex;pos=1;sz=468x60;tile=1;abr=!ie4;abr=!ie5;ord=12345? HTTP/1.0
  #   Referer: http://www.theregister.co.uk/
  #   Proxy-Connection: Keep-Alive
  #   User-Agent: Mozilla/4.74 [en] (X11; U; Linux 2.2.17pre13 i686)
  #   Pragma: no-cache
  #   Host: ad.uk.doubleclick.net
  #   Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png
  #   Accept-Encoding: gzip
  #   Accept-Language: en
  #   Accept-Charset: iso-8859-1,*,utf-8
  my ( $meth, $req ) = $chunk =~ m{^(GET|HEAD) (.*) HTTP/}mi;
  my ( $accept ) = $chunk =~ m{^Accept: (.*)$}mi;
  $meth ||= "GET";
  $accept ||= "image/*";
  $req ||= "";
  my ( $w, $h ) = $req =~ m{sz=(\d+)x(\d+)};
  my ( $im );

  # Fun!
  my $phrase = "NO ADVERTS, THANKS";
  if ( -x "/usr/games/fortune" ) {
	if ( open( YOW, "/usr/games/fortune -s|" )) { # short fortunes only
	  $phrase = join( '', <YOW> );
	  close( YOW );
	}
  }
  $phrase =~ s/\s+/ /g; # convert all whitespace to spaces
  $phrase =~ s/\s+$//; # and lose trailing whitespace.
  my @phrase;

  # Defaults derived from size of phrase
  # 468 x 60 is actually the 'standard' banner
  # This 
  if (!defined( $w )) {
	$w = length( $phrase ) * 6 + 6;
	if ( $w > 468 ) {
	  $w = 468; # which turns out to fit nicely
	}
  }

  my $pl = int(( $w - 6 ) / 6 );
  if ( length( $phrase ) > $pl ) {
	while ( $phrase ) {
	  my $ph = substr( $phrase, 0, $pl );
	  $ph =~ s/ [^ ]+$// if length( $ph ) == $pl;
	  if ( length( $ph )) {
		push @phrase, $ph;
	  } else {
		push @phrase, "Can't wrap the wittiness...";
		$phrase = "";
	  }
	  $phrase = substr( $phrase, length( $ph ));
	  $phrase =~ s/^\s+//;
	}
  } else {
	push @phrase, $phrase;
  }

  $h = 12 * scalar( @phrase ) + 5 if !defined( $h );

  $im = new GD::Image( $w, $h );

  # Now let's put something in it:
  my $white = $im->colorAllocate( 255, 255, 255 );
  my $black = $im->colorAllocate( 0, 0, 0 );
  $im->rectangle( 0, 0, $w - 1, $h - 1, $white );
  $im->rectangle( 1, 1, $w - 2, $h - 2, $black );

  my $y = 1;
  for $phrase ( @phrase ) {
	$im->string( gdSmallFont, 3, $y, $phrase, $black );
	$y += 12;
  }

  # Convert to a PNG for schlepping off to the client
  my $image = $im->png;

  # Parsed version, or, my regexps are working.
  if ( $debug ) {
	print "Method: $meth\n";
	print "Requesting: $req\n";
	print "Size: $w x $h\n" if ( defined ( $h ) && defined( $w ));
	print "Accepting: $accept\n";
  }

  if ( $chunk =~ /HEAD/ ) {
	$buf = "HTTP/1.0 200 OK\r\n";
	$buf .= "Date: Wed, 24 Feb 1999 12:27:10 GMT\r\n";
	$buf .= "Content-Type: image/png\r\n";
	$buf .= "\r\n";
  } else {
	$buf = "HTTP/1.0 200 OK\r\n";
	$buf .= "Content-Length: " . length( $image ) . "\r\n";
	$buf .= "Content-Type: image/png\r\n\r\n";
	$buf .= $image;
  }

  $nbytes = length( $buf );
  binmode NS;
  while( $nbytes>0 ) {
	my $written = syswrite( NS, $buf, $nbytes );
	last if !defined( $written );
	last if $written < 0;
	$nbytes -= $written;
	$buf = substr($buf, $written);
  }

  if ( vec( $eout, fileno( NS ), 1 )) {
	print "Error.\n" ;
	next;
  }

  # Close connection when client shuts down + kill child process
  close(NS);
  #print "Connection closed.\n";
}