#!/usr/bin/perl -w

use LWP::UserAgent;
use HTTP::Date qw(time2str str2time);
use HTTP::Request;
use IO::File;
use Digest::MD5;
use Digest::SHA1;
use File::Basename;

use strict;

my $VERSION = '0.1';

$| = 1;

sub err ($) { printf STDERR "%s: %s\n", basename($0), $_[0]; exit 1; }

sub callback ($$$$) {
	my ($uri, $filename, $md5ctx, $sha1ctx) = @_;
	my ($started, $failed) = (0, 0);
	my $handle = new IO::File;

	return sub {
		my ($data, $res, $proto) = @_;

		die if $failed;

		unless ($started) {
			unless ($handle->open($filename, "w")) {
				$failed = 1;
				die "couldn't open $filename ($!)";
			}
			printf "200 URI Start\n";
			printf "URI: %s\n", $uri;
			printf "Size: %d\n", $res->content_length;
			printf "Last-Modified: %s\n", time2str($res->last_modified) if $res->last_modified;
			#print "Resume-Point: 0\n";
			printf "\n";

			$started = 1;
		}
		unless ($handle->print($data)) {
			$failed = 1;
			$handle->close;
			die "couldn't write to $filename ($!)";
		}
		$md5ctx->add($data);
		$sha1ctx->add($data);
	}
}

sub acquire ($$) {
	my ($message, $ua) = @_;

	my $uri = $message->{URI};
	my $file = $message->{Filename};

	if ($uri =~ /^https:\/\/([^\/]+)\/(.+)$/) {
		my $host = $1;
		my $md5ctx = new Digest::MD5;
		my $sha1ctx = new Digest::SHA1;

		my $req = new HTTP::Request('GET', $uri);
		$req->if_modified_since(str2time($message->{'Last-Modified'})) if $message->{'Last-Modified'};

		printf "102 Status\nURI: %s\nMessage: Connecting to %s\n\n", $uri, $host;
		my $res = $ua->request($req, callback($uri, $file, $md5ctx, $sha1ctx), 65536);

		if (defined $res->header('X-Died') and $res->header('X-Died') =~ /^(.+) at .*?/) {
			printf "401 General failure\nURI: %s\nMessage: %s\n\n", $uri, $1;
		} elsif ($res->is_error) {
			printf "400 URI Failure\nURI: %s\nMessage: failed (%s %s)\n\n", $uri, $res->code, $res->message;
		} else {
			printf "201 URI Done\nURI: %s\nFilename: %s\n", $uri, $file;
			printf "Size: %d\n", $res->content_length if $res->content_length;
			printf "Last-Modified: %s\n",  HTTP::Date::time2str($res->last_modified) if $res->last_modified;
			printf "MD5-Hash: %s\n", $md5ctx->hexdigest;
			printf "SHA1-Hash: %s\n", $sha1ctx->hexdigest;
			printf "IMS-Hit: true\n" if $res->code eq '304';
			printf "\n";
		}
	} else {
		print "401 General failure\nMessage: Invalid URI\n\n";
	}

	return;
}

sub configure ($$) {
	my $message = shift;
	my ($k, $v);
	local $_;

	while (($_, $v) = each %{$message->{config}}) {
		/^Acquire::https::Cert-File$/ 		&& do { $ENV{HTTPS_CERT_FILE} = $v; next; };
		/^Acquire::https::Key-File$/ 		&& do { $ENV{HTTPS_KEY_FILE} = $v; next; };
		/^Acquire::https::CA-File$/ 		&& do { $ENV{HTTPS_CA_FILE} = $v; next; };
		/^Acquire::https::CA-Dir$/ 		&& do { $ENV{HTTPS_CA_DIR} = $v; next; };
		/^Acquire::https::PKCS12-File$/ 	&& do { $ENV{HTTPS_PKCS12_FILE} = $v; next; };
		/^Acquire::https::PKCS12-Password$/ 	&& do { $ENV{HTTPS_PKCS12_PASSWORD} = $v; next; };
		/^Acquire::https::Version$/ 		&& do { $ENV{HTTPS_VERSION} = $v; next; };
		/^Acquire::https::Debug$/ 		&& do { $ENV{HTTPS_DEBUG} = $v; next; };
		/^Acquire::https::Proxy$/ 		&& do { $ENV{HTTPS_PROXY} = $v; next; };
		/^Acquire::https::Proxy-Username$/	&& do { $ENV{HTTPS_PROXY_USERNAME} = $v; next; };
		/^Acquire::https::Proxy-Password$/ 	&& do { $ENV{HTTPS_PROXY_PASSWORD} = $v; next; };
	}
}

sub credentials ($$) {
	my $message = shift;

	# Current versions of APT do not implement the auth 402/602 handshake.
	print "401 General failure\nMessage: credential challenge not supported\n\n";
}

sub mediachange ($$) {
	my $message = shift;

	print "401 General failure\nMessage: media changing not supported\n\n";
}

sub unknown ($$) {
	my $message = shift;

	print "401 General failure\nMessage: unrecognised apt message\n\n";
}

# get on with it.
print "100 Capabilities\n";
print "Version: $VERSION\n";
print "Send-Config: true\n";
print "Pipeline: false\n";
print "\n";

my $ua = new LWP::UserAgent(
	keep_alive => 1,
	agent => "SSL-APT/$VERSION"
);

my $message = {};
while (my $line = <>) {
	chomp $line;

	# parse first line
	unless (defined $message->{code}) {
		($message->{code}) = $line =~ /^(\d{3}) .*/;
		err("invalid APT message syntax, aborting\n") unless defined $message->{code};
		next;
	}

	# end of input - act upon message
	if ($line =~ /^$/) {
		switch: for ($message->{code}) {
			acquire($message, $ua), last switch if /600/;
			configure($message, $ua), last switch if /601/;
			credentials($message, $ua), last switch if /602/;
			mediachange($message, $ua), last switch if /603/;
			unknown($message, $ua), last switch;
		}
		$message = {};
		next;
	}

	# parse input
	my ($k, $v) = split ': ', $line, 2;
	if ($k eq 'Config-Item') {
		($k, $v) = split '=', $v, 2;
		$message->{config}{$k} = $v;
	} else {
		$message->{$k} = $v;
	}
}

exit 0;

__END__

=head1 NAME

apt-method-https - An HTTPS method for Debian APT.

=head1 SYNOPSIS

=head2 in APT's sources.list(5):

	deb https://secure.example.com/debian unstable main
	deb-src https://secure.example.com/debian unstable main

=head2 in apt.conf(5) files:

	Acquire
	{
	  https
	  {
	    // To require server certificate verification:
	    CA-File "/etc/ssl/certs/ca-certificates.crt";
	    CA-Dir "/etc/ssl/certs";

	    // To do client certificate authentication:
	    Cert-File "/etc/ssl/certs/client.crt";
	    Key-File "/etc/ssl/private/system.key";

	    // or instead PKCS12 client certificate authentication:
	    PKCS12-File "/path/to/client.p12";
	    PKCS12-Password "mypassword";

	    // To pass through a CONNECT-style proxy (e.g. Squid)
	    Proxy "http://proxy.example.com:3128";
	    // with authentication:
	    Proxy-Username "myusername";
	    Proxy-Password "mypassword";
	    
	    // To set the SSL version in use (2, 23, or 3):
	    Version "3";

	    // Turn on Crypt::SSLeay debugging
	    Debug "1";
	  };
	};

These options corresponding directly to the options available in the
Perl module Crypt::SSLeay.

=head1 AUTHOR

Joshua Goodall <joshua@roughtrade.net>

=head1 LICENSE

Copyright (C) Joshua Goodall 2004.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<Crypt::SSLeay>, L<LWP>, L<sources.list(5)>, L<apt.conf(5)>

=cut

