The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Lufs::Http;

use Net::HTTP;
use HTTP::Headers;
use HTTP::Response;
use HTTP::Date;
use URI::WithBase;
use Fcntl qw/:DEFAULT :mode/;
use HTML::TokeParser::Simple;
use strict;

sub init {
	my $self = shift;
	$self->{config} = shift;
	$self->{config}{uri} ||= 'http://ftp.student.utwente.nl/';
	$self->{root} = URI->new($self->{config}{uri});
	1;
}

sub mount {
	my $self = shift;
	$self->head->is_success;
}

sub stat {
	my $self = shift;
	my $node = shift;
	$node =~ s{/\.$}{};
	my $resp = $self->head($node);
	if ($resp->code =~ /^[45]/) {
		return 0;
	}
	my $add = $self->_format_statref($node, $resp);

	map {$_[0]->{$_}=$add->{$_}} grep /^f_/, keys %{$add};
	1;
}

sub readlink {
	my $self = shift;
	my $node = shift;
	my $resp = $self->head($node);
	my $stat = $self->_format_statref($node, $resp);
	if (( $stat->{f_mode} & S_IFLNK) == S_IFLNK) {
		my $to = URI->new($resp->header('Location'));
		my $root = $self->{root}->path;
		my $path = $to->path;
		unless ($path =~ s/^\Q$root\E//) { return 0 }
		$_[0] = $path;
		return 1;
	}
	return 0;
}

sub open {
	my $self = shift;
	my $node = shift;
	my $mode = shift;
	if (exists $self->{handles}{$node}) {
		return 0;
	}
	if (($mode & O_WRONLY) == O_WRONLY) {
		return 0;
	}
	my ($h, $resp) = $self->get($node);
	unless ($resp->is_success) { return 0 }
	$self->{handles}{$node} = $h;
	1;
}

sub release {
	my $self = shift;
	my $node = shift;
	delete $self->{handles}{$node};
	1;
}

sub umount {
	my $self = shift;

}

sub read {
	my $self = shift;
	my $node = shift;
	my $offset = shift;
	my $count = shift;
	my $len;
	$_[0] = '';
	my $handle;
	unless ($handle = $self->{handles}{$node}) {
		return -1;
	}
	if ($handle->_rbuf_length) {
		my $buf = ${*$handle}{http_buf};
		$len = length($buf);
		$_[0] = substr($buf, 0, $len);
		${*$handle}{http_buf} = '';
	}
	my $buf;
	my $total = $len;
	while ($total < $count) {
		my $ret = $handle->sysread($buf, $count - $total);
		$_[0] .= substr($buf, 0, $ret) if $ret;
		$total += $ret;
		last if $ret == 0;
	}
	$total;
}

sub write { 0 }

sub readdir {
	my $self = shift;
	my $node = shift;
	my $list = shift;
	$self->{_pwd} = '';
	my ($c, $r) = $self->get($node.'/');
	unless ($r->is_success) { return 0 }
	my $html;
	my %dir;
	while (<$c>) { $html .= $_ }
	my $parser = HTML::TokeParser::Simple->new(\$html) or return 1;
	while ( my $token = $parser->get_token ) {
		if ($token->is_start_tag) {
			my $ref = $token->return_attr->{href} || $token->return_attr->{src};
			next unless $ref;
			my $uri = URI::WithBase->new($ref, $self->{root}.'/')->rel;
#			print STDERR sprintf "REL: '%s' ABS '%s'\n", $uri, $uri->abs;
			# we want only links that to stuff in this dir
			next if $uri->scheme;
			next unless $uri->can('host');
			next if $uri->host;
			next if length($self->{root}->path) and $uri->path =~ /^\//;
			my $path = $uri->path;
			$path =~ s{^\.?/}{};
			my @s = split/\//, $path;
			if (@s > 1) {
				my $d = $s[0];
				my $stat = $self->_statref($d);
				$stat->{_forcedir} = 1;
				$dir{$d}++;
			}
			else {
				$dir{$path}++;
			}
		}
	}
	push @$list, keys %dir;
	$self->{_pwd} = $node;
	return 1;
}

sub head {
	my $self = shift;
	my $path = $self->base_uri($_[0]);
	my $c = Net::HTTP->new(Host => $self->{root}->host);
	$c->write_request(HEAD => $path);
	my($code, $mess, %h) = $c->read_response_headers;
	$self->TRACE('HEAD', $path, $code, $mess, \%h);
	HTTP::Response->new($code, $mess, HTTP::Headers->new(%h));
}

sub get {
	my $self = shift;
	my $path = $self->base_uri($_[0]);
	my $c = Net::HTTP->new(Host => $self->{root}->host);
	$c->write_request(GET => $path);
	my($code, $mess, %h) = $c->read_response_headers;
	$self->TRACE('GET', $path, $code, $mess, \%h);
	($c,HTTP::Response->new($code, $mess, HTTP::Headers->new(%h)));
}

sub _format_statref {
	my $self = shift;
	my $node = shift;
	my $resp = shift;
	my $ref = $self->_statref($node);
	$ref->{f_ino} = $self->inode($node);
	if ($self->{_forcedir}) {
		print STDERR "FORCE DIR voor $node\n";
		$ref->{f_mode} |= S_IFDIR;
	}
	elsif ($resp->is_redirect) {
		my $to = URI->new($resp->header('Location'))->path;
		my $from = $self->base_uri($node);
		if ($to eq $from.'/') {
			$ref->{f_mode} |= S_IFDIR;
		}
		else {
			$ref->{f_mode} |= S_IFLNK;
		}
	}
	elsif ((split/\//, $node)[-1] =~ /\.\w+/) {
		$ref->{f_mode} |= S_IFREG;
	}
	else {
		$ref->{f_mode} |= S_IFREG;
		#$ref->{f_mode} |= S_IFDIR;
	}
	if ($resp->code != 403) {
		$ref->{f_mode} |= 0755;
	}
	$ref->{f_size} = $resp->header('Content-Length') || ~1;
	if ($resp->header('Date')) {
		$ref->{f_mtime} = str2time($resp->header('Date'));
	}
	if ($node eq '/' || $node eq '') {
		$ref->{f_mode} = S_IFDIR;
	}
	if (($ref->{f_mode} & S_IFDIR) == S_IFDIR) {
		$ref->{f_mode} |= 0755;
		$ref->{f_size} = 4096;
	}
	$ref;
}

sub base_uri {
	my $self = shift;
	my $node = shift;
	if ($node !~ /^\//) { $node = "$self->{_pwd}/$node" }
	my $u = $self->{root}->path. '/' . $node;
	$u =~ s{/+}{/}g;
	$u;
}

sub inode {
	my $self = shift;
	my $node = $self->base_uri($_[0]);
	if (exists $self->{_inodes}{$node}) {
		return $self->{_inodes}{$node};
	}
	else {
		return $self->{_inodes}{$node} = ++$self->{_maxino};
	}
}

sub _statref {
	my $self = shift;
	my $ino = $self->inode($_[0]);
	$self->{_stat}{$ino} ||= { f_ino => $ino};
}

1;