1# Copyright (C) 2005-2011 Quentin Sculo <squentin@free.fr>
2#
3# This file is part of Gmusicbrowser.
4# Gmusicbrowser is free software; you can redistribute it and/or modify
5# it under the terms of the GNU General Public License version 3, as
6# published by the Free Software Foundation
7
8package Simple_http;
9use strict;
10use warnings;
11use Socket;# 1.3; ?
12use Fcntl;
13use IO::Handle;
14
15use constant { EOL => "\015\012" };
16my %ipcache; #FIXME purge %ipcache from time to time
17my $UseCache= *GMB::Cache::add{CODE};
18
19my $gzip_ok;
20BEGIN
21{	eval { require IO::Uncompress::Gunzip; $gzip_ok=1; };
22}
23
24sub get_with_cb
25{	my $self=bless {};
26	my $error;
27	if (ref $_[0]) {$self=shift; $error='Too many redirections' if 5 < $self->{redirect}++; }
28	my %params=@_;
29	$self->{params}=\%params;
30	delete $params{cache} unless $UseCache;
31	my ($callback,$url,$post)=@params{qw/cb url post/};
32	if (my $cached= $params{cache} && GMB::Cache::get($url))
33	{	warn "cached result\n" if $::debug;
34		Glib::Timeout->add(10,sub { $callback->( ${$cached->{data}}, type=>$cached->{type}, filename=>$cached->{filename}, ); 0});
35		return $self;
36	}
37	warn "simple_http : fetching $url\n" if $::debug;
38
39	my ($host,$port,$file);
40	my $socket;
41	{	last if $error;
42
43		if ( $url=~s#^([a-z]+)://## && $1 ne 'http' )
44		 { $error="Protocol $1 not supported"; last; }
45		($host,$port,$file)= $url=~m#^([^/:]+)(?::(\d+))?(.*)$#;
46		if (defined $host)
47		{	$port=80 unless defined $port;
48			$file='/' if $file eq '';
49		}
50		else	{ $error='Bad url : http://'.$url; last; }
51
52		my $proxyhost=$::Options{Simplehttp_ProxyHost};
53		if ($::Options{Simplehttp_Proxy} && defined $proxyhost && $proxyhost ne '')
54		{	$file="http://$host:".$port.$file;
55			$host=$proxyhost;
56			$port=$::Options{Simplehttp_ProxyPort};
57			$port=80 unless defined $port && $port=~m/^\d+$/;
58		}
59		my $addr;
60		if ($host=~m#^\d+\.\d+\.\d+.\d+$#) {$addr=inet_aton($host);}
61		else { $addr=$ipcache{$host}||=inet_aton($host)}#FIXME not asynchronous, use a fork ?
62		unless ($addr)
63		 { $error="Can't resolve host $host"; last; }
64		socket($socket, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
65		my $paddr=pack_sockaddr_in(0, INADDR_ANY);
66		unless ( bind $socket,$paddr )
67		 { $error=$!; last; }
68		$self->{file}=$file;
69		$self->{port}=$port;
70		$self->{host}=$host;
71		my $sin=sockaddr_in($port,$addr);
72		fcntl $socket,F_SETFL,O_NONBLOCK; #unless $^O eq "MSWin32"
73		connect $socket,$sin;
74	}
75	$self->{sock}=$socket;
76	if (defined $error)
77	{	$error="Cannot connect to server $host:$port : $error" if $host;
78		warn "$error\n";
79		Glib::Timeout->add(10,sub { $callback->(undef,error=>$error); 0 });
80		return $self;
81	}
82	$self->{buffer}='';
83	$self->{watch}=Glib::IO->add_watch(fileno($socket),['out','hup'],\&connecting_cb,$self);
84
85	return $self;
86}
87
88sub connecting_cb
89{	my $failed= ($_[1] >= 'hup'); #connection failed
90	my $self=$_[2];
91	my $socket=$self->{sock};
92	my $port=$self->{port};
93	my $host=$self->{host};
94	my $params= $self->{params};
95
96	if ($failed)
97	{	warn "Cannot connect to server $host:$port\n";
98		close $socket;
99		$params->{cb}(undef,error=>"Connection failed");
100		return 0;
101	}
102
103#binmode $socket,':encoding(iso-8859-1)';
104	my $post=$params->{post};
105	my $method=defined $post ? 'POST' : 'GET';
106	my $useragent= $params->{user_agent} || 'Mozilla/5.0';
107	my $accept= $params->{'accept'} || '';
108	print $socket "$method $self->{file} HTTP/1.0".EOL;
109	print $socket "Host: $host:$port".EOL;
110	print $socket "User-Agent: $useragent".EOL;
111	print $socket "Referer: $params->{referer}".EOL if $params->{referer};
112	print $socket "Accept: $accept".EOL;
113	print $socket "Accept-Encoding: gzip".EOL if $gzip_ok;
114	#print $socket "Connection: Keep-Alive".EOL;
115	if (defined $post)
116	{ print $socket 'Content-Type: application/x-www-form-urlencoded; charset=utf-8'.EOL;
117	  print $socket "Content-Length: ".length($post).EOL.EOL;
118	  print $socket $post.EOL;
119	}
120	print $socket EOL;
121
122	$socket->autoflush(1);
123	$self->{buffer}='';
124	$self->{watch}=Glib::IO->add_watch(fileno($socket),['in','hup'],\&receiving_cb,$self);
125
126	return 0;
127}
128
129sub progress
130{	my $self=shift;
131	my ($length)= $self->{buffer}=~m/\015\012Content-Length:\s*(\d+)\015\012/i;
132	my $pos= index $self->{buffer}, EOL.EOL;
133	my $progress;
134	my $size=0;
135	if ($pos>=0)
136	{	$size=length($self->{buffer})-2-$pos;
137		if ($length)
138		{	$progress= $size/$length;
139			$progress=undef if $progress>1;
140		}
141	}
142	# $progress is undef or between 0 and 1
143	return $progress,$size;
144}
145
146sub receiving_cb
147{	my $self=$_[2];
148	return 1 if read $self->{sock},$self->{buffer},1024,length($self->{buffer});
149	close $self->{sock};
150	$self->{sock}=$self->{watch}=undef;
151	#warn "watch done\n";
152	my $url=$self->{params}{url};
153	my $callback=$self->{params}{cb};
154	my $EOL=EOL;
155	my ($headers,$response)=split /$EOL$EOL/o,delete $self->{buffer},2;
156	$headers='empty answer' unless defined $headers;
157	(my$result,$headers)=split /$EOL/o,$headers,2;
158	if ($::debug)
159	{	warn "0|$_\n" for $result,split /$EOL/o,$headers;
160	}
161	$headers.=EOL;
162	my %headers;
163	$headers{lc $1}=$2 while $headers=~m/([^:]*): (.*?)$EOL/og;
164
165	my $filename;
166	if ($headers{'content-disposition'} && $headers{'content-disposition'}=~m#^\s*\w+\s*;\s*filename(\*)?=(.*)$#mgi)
167	{	$filename=$2; my $rfc5987=$1;
168		#decode filename, not perfectly, but good enough (http://greenbytes.de/tech/tc2231/ is a good reference)
169		$filename=~s#\\(.)#"\x00".ord($1)."\x00"#ge;
170		my $enc='iso-8859-1';
171		if ($rfc5987 && $filename=~s#^([A-Za-z0-9_-]+)'\w*'##) {$enc=$1; $filename=::decode_url($filename)} #RFC5987
172		else
173		{	if ($filename=~s/^"(.*)"$/$1/) { $filename=~s#\x00(\d+)\x00#chr($1)#ge; $filename=~s#\\(.)#"\x00".ord($1)."\x00"#ge; }
174			elsif ($filename=~m#[^A-Za-z0-9_.\x00-]#) {$filename=''}
175		}
176		$filename=~s#\x00(\d+)\x00#chr($1)#ge;
177		$filename= eval {Encode::decode($enc,$filename)};
178	}
179	if (my $enc=$headers{'content-encoding'})
180	{	if ($enc eq 'gzip' && $gzip_ok)
181		{	my $gzipped= $response;
182			IO::Uncompress::Gunzip::gunzip( \$gzipped, \$response )
183				or do {warn "simple_http : gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n"; $result='gunzip error';};
184		}
185		else
186		{	warn "simple_http_wget : can't decode '$enc' encoding\n";
187			$result='gzipped';
188		}
189	}
190	if ($result=~m#^HTTP/1\.\d+ 200 OK#)
191	{	#warn "ok $url\n$callback\n";
192		my $type=$headers{'content-type'};
193		if ($self->{params}{cache} && defined $response)
194		{	GMB::Cache::add($url,{data=>\$response,type=>$type,size=>length($response),filename=>$filename});
195		}
196		$callback->($response, type=>$type, url=>$self->{params}{url}, filename=>$filename);
197	}
198	elsif ($result=~m#^HTTP/1\.\d+ 30[123]# && $headers{location}) #redirection
199	{	my $url=$headers{location};
200		unless ($url=~m#^http://#)
201		{	my $base=$self->{params}{url};
202			if ($url=~m#^/#){$base=~s#^(?:http://)?([^/]+).*$#$1#;}
203			else		{$base=~s#[^/]*$##;}
204			$url=$base.$url;
205		}
206		$self->{params}{url}=$url;
207		$self->get_with_cb( %{$self->{params}} );
208	}
209	else
210	{	warn "Error fetching $url : $result\n";
211		$callback->(undef,error=>$result);
212	}
213	return 0;
214}
215
216sub abort
217{	my $self=$_[0];
218	Glib::Source->remove($self->{watch}) if defined $self->{watch};
219	close $self->{sock} if defined $self->{sock};
220	$self->{sock}=$self->{watch}=undef;
221}
222
2231;
224