Kill WebDAV entirely; now only the PUT and OPTIONS are left.
[pr0n] / perl / pr0n-upload.pl
1 #! /usr/bin/perl
2
3 #
4 # Small multithreaded pr0n uploader. Use like
5 #
6 #   pr0n-upload.pl http://pr0n.sesse.net/webdav/upload/random/ *.JPG
7 #
8 # Adjust $threads to your own liking.
9 #
10
11 use strict;
12 use warnings;
13 use LWP::UserAgent;
14 use threads;
15 use Thread::Queue;
16 use File::Spec;
17 use URI;
18
19 my $threads = 40;
20 my $running_threads :shared = 0;
21 my $queue :shared = Thread::Queue->new;
22 my @succeeded :shared = ();
23 my @failed :shared = ();
24
25 # Enqueue all the images.
26 my $url = shift @ARGV;
27 $url .= '/' if ($url !~ m#/$#);
28 $queue->enqueue(@ARGV);
29
30 # Fetch username and password, and check that they actually work.
31 my ($user, $pass) = get_credentials();
32 my $ua = init_ua($url, $user, $pass);
33
34 # Fire up the worker threads, and wait for them to finish.
35 my @threads = ();
36 for my $i (1..$threads) {
37         push @threads, threads->create(\&upload_thread);
38 }
39 while ($running_threads > 0) {
40         printf "%d threads running, %d images queued\n", $running_threads, $queue->pending;
41         sleep 1;
42 }
43 for my $thread (@threads) {
44         $thread->join();
45 }
46
47 if (scalar @failed != 0 && scalar @succeeded != 0) {
48         # Output failed files in an easily-pastable format.
49         print "\nFailed files: ", join(' ', @failed), "\n";
50 }
51
52 sub upload_thread {
53         $running_threads++;
54
55         my $ua = init_ua($url, $user, $pass);
56         while (my $filename = $queue->dequeue_nb) {
57                 my (undef, undef, $basename) = File::Spec->splitpath($filename);
58                 my $newurl = $url . $basename;
59                 my $req = HTTP::Request->new(PUT => $newurl);
60                 {
61                         local $/ = undef;
62                         open my $fh, "<", $filename
63                                 or die "Couldn't find $filename: $!";
64                         $req->content(<$fh>);
65                         close $fh;
66                 }
67
68                 my $res = $ua->request($req);
69                 if ($res->is_success) {
70                         push @succeeded, $filename;
71                 } else {
72                         push @failed, $filename;
73                         warn "Couldn't upload $filename: " . $res->message . "\n";
74                 }
75         }
76         
77         $running_threads--;
78 }
79
80 sub init_ua {
81         my ($url, $user, $pass) = @_;
82         my $ua = LWP::UserAgent->new;
83         $ua->agent('pr0n-uploader/v1.0');
84         my $urlobj = URI->new($url);
85         my $hostport = $urlobj->host . ':' . $urlobj->port;
86         $ua->credentials($hostport, 'pr0n.sesse.net', $user, $pass);
87
88         # Check that it works.
89         my $req = HTTP::Request->new(OPTIONS => $url);
90         my $res = $ua->request($req);
91         die "$url: " . $res->status_line if (!$res->is_success);
92
93         return $ua;
94 }
95
96 sub get_credentials {
97         print "\nEnter username for $url: ";
98         chomp (my $user = <STDIN>);
99         exit if (!defined($user));
100         print "Password: ";
101         system("stty -echo");
102         chomp (my $pass = <STDIN>);
103         system("stty echo");
104         print "\n";
105
106         return ($user, $pass);
107 }