Line # Revision Author
1 3 ahitrov@rambler.ru package Contenido::File::Scheme::HTTP;
2
3 use strict;
4 use warnings;
5
6 use Contenido::Globals;
7 use Contenido::File;
8 use IO::Scalar;
9 use Data::Dumper;
10 use HTTP::Request;
11 use HTTP::Headers;
12 use LWP::UserAgent;
13 use File::Temp;
14
15 my %LWP_ARGS = (timeout => 5);
16
17 sub fetch {
18 my $path = shift || return;
19
20 my $fh = File::Temp->new(
21 TEMPLATE => 'tempXXXXX',
22 DIR => $keeper->state()->{tmp_dir},
23 SUFFIX => '.dat'
24 );
25
26 my $ua = LWP::UserAgent->new(%LWP_ARGS);
27
28 my $res = $ua->get(
29 $path,
30 ':read_size_hint' => 10 * 1024,
31 ':content_cb' => sub {
32 $fh->write(shift());
33 },
34 );
35
36 seek $fh, 0, 0;
37
38 return $res->is_success() ? $fh : undef;
39 }
40
41 sub store {
42 my $path = shift || return;
43 my $fh = shift || return;
44 my $dt = shift;
45
46 local $/ = undef;
47
48 my $content = <$fh>;
49
50 my $ua = LWP::UserAgent->new(%LWP_ARGS);
51 my $req = HTTP::Request->new(PUT => $path);
52 $req->content_length(length $content);
53 $req->content($content);
54 $req->header(Date => $dt->strftime('%a %b %d %H:%M:%S %Y')) if $dt and ref $dt eq "DateTime";
55
56 my $res = $ua->request($req);
57 # my $res = $ua->request($req, sub { my $buffer; read $fh, $buffer, 10000; return $buffer });
58
59 unless ($res->is_success()) {
60 warn $req->headers()->as_string()."\nreturned NOT OK result: ".$res->message()."(".$res->code.") result is: ".$res->as_string."\n";
61 return;
62 }
63
64 1;
65 }
66
67 sub remove {
68 my $path = shift;
69
70 my $ua = LWP::UserAgent->new(%LWP_ARGS);
71 my $req = HTTP::Request->new(DELETE => $path);
72 my $res = $ua->request($req);
73
74 unless ($res->is_success()) {
75 warn $req->headers()->as_string()."\nreturned NOT OK result: ".$res->message()."(".$res->code.") result is: ".$res->as_string."\n";
76 return;
77 }
78
79 1;
80 }
81
82 sub size {
83 my $path = shift;
84
85 my $ua = LWP::UserAgent->new(%LWP_ARGS);
86 my $req = HTTP::Request->new(HEAD => $path);
87 my $res = $ua->request($req);
88
89 return unless $res->is_success();
90 return $res->content_length();
91 }
92
93 sub listing {
94 my $path = shift;
95
96 return unless Contenido::File::scheme($path) eq "http";
97
98 my $files = {};
99 my $buffer = "";
100 my $ua = LWP::UserAgent->new(%LWP_ARGS);
101
102 $ua->get($path,
103 ":content_cb" => sub {
104 $buffer .= shift;
105
106 while ($buffer =~ s/^(.*?)(?:\r?\n)+//) {
107 next unless my $line = $1;
108 $line =~ s/^[ \t]+//;
109 $line =~ s/[ \t]+$//;
110 if ($line =~ /^<.+?>(.+?)<.+?>.+?(\d+)$/) {
111 $files->{$1} = $2;
112 }
113 }
114 },
115 ":read_size_hint" => 102400,
116 );
117
118 return $files;
119 }
120
121 sub get_fh {
122 my $path = shift;
123 my $fh;
124
125 return unless Contenido::File::scheme($path) eq "http";
126
127 my $ua = LWP::UserAgent->new(%LWP_ARGS);
128
129 my $response = $ua->get($path);
130
131 if ($response->is_success()) {
132 $fh = IO::Scalar->new(\($response->content()));
133 } else {
134 warn $response->status_line();
135 }
136
137 return $fh;
138 }
139
140 1;