Upload files to "/"
This commit is contained in:
xocko
+449
@@ -0,0 +1,449 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature qw(say);
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use HTTP::Cookies;
|
||||
use JSON::PP qw(decode_json);
|
||||
use LWP::UserAgent;
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
use Time::HiRes qw(sleep);
|
||||
|
||||
binmode STDOUT, ':encoding(UTF-8)';
|
||||
binmode STDERR, ':encoding(UTF-8)';
|
||||
|
||||
my %stores = (
|
||||
'Australia' => 'https://www.kobo.com/au/en/ebook/',
|
||||
'Austria' => 'https://www.kobo.com/at/de/ebook/',
|
||||
'Belgium (Dutch)' => 'https://www.kobo.com/be/nl/ebook/',
|
||||
'Belgium (French)' => 'https://www.kobo.com/be/fr/ebook/',
|
||||
'Brazil' => 'https://www.kobo.com/br/pt/ebook/',
|
||||
'Canada (English)' => 'https://www.kobo.com/ca/en/ebook/',
|
||||
'Canada (French)' => 'https://www.kobo.com/ca/fr/ebook/',
|
||||
'Cyprus' => 'https://www.kobo.com/cy/en/ebook/',
|
||||
'Czech Republic' => 'https://www.kobo.com/cz/cs/ebook/',
|
||||
'Denmark' => 'https://www.kobo.com/dk/da/ebook/',
|
||||
'Eire' => 'https://www.kobo.com/ie/en/ebook/',
|
||||
'Estonia' => 'https://www.kobo.com/ee/en/ebook/',
|
||||
'Finland' => 'https://www.kobo.com/fi/fi/ebook/',
|
||||
'France' => 'https://www.kobo.com/fr/fr/ebook/',
|
||||
'Germany' => 'https://www.kobo.com/de/de/ebook/',
|
||||
'Greece' => 'https://www.kobo.com/gr/en/ebook/',
|
||||
'Hong Kong (Chinese)' => 'https://www.kobo.com/hk/zh/ebook/',
|
||||
'Hong Kong (English)' => 'https://www.kobo.com/hk/en/ebook/',
|
||||
'India' => 'https://www.kobo.com/in/en/ebook/',
|
||||
'Italy' => 'https://www.kobo.com/it/it/ebook/',
|
||||
'Japan' => 'https://www.kobo.com/jp/ja/ebook/',
|
||||
'Lithuania' => 'https://www.kobo.com/lt/en/ebook/',
|
||||
'Luxembourg' => 'https://www.kobo.com/lu/fr/ebook/',
|
||||
'Malaysia' => 'https://www.kobo.com/my/en/ebook/',
|
||||
'Malta' => 'https://www.kobo.com/mt/en/ebook/',
|
||||
'Mexico' => 'https://www.kobo.com/mx/es/ebook/',
|
||||
'Netherlands' => 'https://www.kobo.com/nl/nl/ebook/',
|
||||
'New Zealand' => 'https://www.kobo.com/nz/en/ebook/',
|
||||
'Norway' => 'https://www.kobo.com/no/nb/ebook/',
|
||||
'Philippines' => 'https://www.kobo.com/ph/en/ebook/',
|
||||
'Poland' => 'https://www.kobo.com/pl/pl/ebook/',
|
||||
'Portugal' => 'https://www.kobo.com/pt/pt/ebook/',
|
||||
'Romania' => 'https://www.kobo.com/ro/ro/ebook/',
|
||||
'Singapore' => 'https://www.kobo.com/sg/en/ebook/',
|
||||
'Slovak Republic' => 'https://www.kobo.com/sk/en/ebook/',
|
||||
'Slovenia' => 'https://www.kobo.com/si/en/ebook/',
|
||||
'South Africa' => 'https://www.kobo.com/za/en/ebook/',
|
||||
'Spain' => 'https://www.kobo.com/es/es/ebook/',
|
||||
'Sweden' => 'https://www.kobo.com/se/sv/ebook/',
|
||||
'Switzerland (French)' => 'https://www.kobo.com/ch/fr/ebook/',
|
||||
'Taiwan' => 'https://www.kobo.com/tw/zh/ebook/',
|
||||
'Thailand' => 'https://www.kobo.com/th/en/ebook/',
|
||||
'Turkey' => 'https://www.kobo.com/tr/tr/ebook/',
|
||||
'UK' => 'https://www.kobo.com/gb/en/ebook/',
|
||||
'USA' => 'https://www.kobo.com/us/en/ebook/',
|
||||
'World-wide' => 'https://www.kobo.com/ww/en/ebook/',
|
||||
);
|
||||
|
||||
my $delay = 1.5;
|
||||
my $retries = 3;
|
||||
my $timeout = 30;
|
||||
my $show_failed = 0;
|
||||
my $help = 0;
|
||||
|
||||
GetOptions(
|
||||
'delay=f' => \$delay,
|
||||
'retries=i' => \$retries,
|
||||
'timeout=i' => \$timeout,
|
||||
'show-failed!' => \$show_failed,
|
||||
'help|h' => \$help,
|
||||
) or usage(2);
|
||||
|
||||
usage(0) if $help;
|
||||
|
||||
my $input = shift @ARGV;
|
||||
usage(2) unless defined $input && length $input;
|
||||
|
||||
$delay = 0 if $delay < 0;
|
||||
$retries = 0 if $retries < 0;
|
||||
$timeout = 5 if $timeout < 5;
|
||||
|
||||
my $book = clean_book_slug($input);
|
||||
die "Could not determine the Kobo book slug from: $input\n" unless length $book;
|
||||
die "Invalid Kobo book slug: $book\n" unless $book =~ /\A[[:alnum:]_%+.,'()!-]+\z/;
|
||||
|
||||
my $jar = HTTP::Cookies->new;
|
||||
my $ua = LWP::UserAgent->new(
|
||||
timeout => $timeout,
|
||||
max_redirect => 8,
|
||||
cookie_jar => $jar,
|
||||
protocols_allowed => [qw(http https)],
|
||||
ssl_opts => { verify_hostname => 1 },
|
||||
);
|
||||
|
||||
# A normal desktop browser identity. The old script used libwww-perl's default
|
||||
# identity and launched every request at once, which commonly triggers 403s.
|
||||
$ua->agent(
|
||||
'Mozilla/5.0 (X11; Linux x86_64) '
|
||||
. 'AppleWebKit/537.36 (KHTML, like Gecko) '
|
||||
. 'Chrome/124.0 Safari/537.36'
|
||||
);
|
||||
$ua->default_header('Accept' =>
|
||||
'text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8');
|
||||
$ua->default_header('Accept-Language' => 'en-GB,en;q=0.9');
|
||||
$ua->default_header('DNT' => '1');
|
||||
$ua->default_header('Upgrade-Insecure-Requests' => '1');
|
||||
|
||||
my @results;
|
||||
my @failures;
|
||||
my $index = 0;
|
||||
my $total = scalar keys %stores;
|
||||
|
||||
for my $country (sort keys %stores) {
|
||||
++$index;
|
||||
my $url = $stores{$country} . $book;
|
||||
print STDERR sprintf("[%02d/%02d] %-22s ", $index, $total, $country);
|
||||
|
||||
my ($response, $attempts) = fetch_with_retries($ua, $url, $retries);
|
||||
|
||||
if (!$response->is_success) {
|
||||
my $status = $response->code . ' ' . $response->message;
|
||||
say STDERR "failed ($status)";
|
||||
push @failures, [$country, $status, $url];
|
||||
polite_pause($delay);
|
||||
next;
|
||||
}
|
||||
|
||||
my $html = $response->decoded_content(charset => 'none');
|
||||
my ($price, $currency) = extract_price($html);
|
||||
|
||||
if (!defined $price || !defined $currency) {
|
||||
say STDERR 'no price found';
|
||||
push @failures, [$country, 'page loaded but price was not found', $url];
|
||||
polite_pause($delay);
|
||||
next;
|
||||
}
|
||||
|
||||
say STDERR sprintf('ok (%s %.2f)', $currency, $price);
|
||||
push @results, {
|
||||
country => $country,
|
||||
currency => $currency,
|
||||
price => $price + 0,
|
||||
url => $url,
|
||||
};
|
||||
|
||||
polite_pause($delay);
|
||||
}
|
||||
|
||||
die "\nNo prices were retrieved. Try a larger delay, for example --delay 3.\n"
|
||||
unless @results;
|
||||
|
||||
my %rates_to_eur = fetch_rates_to_eur($ua, [map { $_->{currency} } @results]);
|
||||
|
||||
for my $row (@results) {
|
||||
my $currency = $row->{currency};
|
||||
$row->{eur} = $row->{price} * $rates_to_eur{$currency}
|
||||
if exists $rates_to_eur{$currency};
|
||||
}
|
||||
|
||||
my $country_width = 0;
|
||||
for my $row (@results) {
|
||||
my $length = length $row->{country};
|
||||
$country_width = $length if $length > $country_width;
|
||||
}
|
||||
|
||||
say '';
|
||||
for my $row (sort_results(@results)) {
|
||||
if (defined $row->{eur}) {
|
||||
printf "%-*s €%7.2f %3s %10.2f\n",
|
||||
$country_width, $row->{country}, $row->{eur},
|
||||
$row->{currency}, $row->{price};
|
||||
} else {
|
||||
printf "%-*s %-9s %3s %10.2f\n",
|
||||
$country_width, $row->{country}, '(no FX)',
|
||||
$row->{currency}, $row->{price};
|
||||
}
|
||||
}
|
||||
|
||||
my @converted = grep { defined $_->{eur} } @results;
|
||||
if (@converted) {
|
||||
my $minimum = (sort { $a->{eur} <=> $b->{eur} } @converted)[0]{eur};
|
||||
my @cheapest = grep { abs($_->{eur} - $minimum) < 0.005 } @converted;
|
||||
|
||||
printf "\nCheapest price: €%.2f\n", $minimum;
|
||||
if (@cheapest == 1) {
|
||||
printf "Country: %s\n", $cheapest[0]{country};
|
||||
printf "Original price: %s %.2f\n",
|
||||
$cheapest[0]{currency}, $cheapest[0]{price};
|
||||
printf "URL: %s\n", $cheapest[0]{url};
|
||||
} else {
|
||||
say "Countries tied for cheapest price:";
|
||||
for my $row (@cheapest) {
|
||||
printf " %s — %s %.2f — %s\n",
|
||||
$row->{country}, $row->{currency}, $row->{price}, $row->{url};
|
||||
}
|
||||
}
|
||||
} else {
|
||||
say "\nNo exchange rates were available, so no converted cheapest price was calculated.";
|
||||
}
|
||||
|
||||
printf STDERR "\nRetrieved %d of %d stores; %d failed.\n",
|
||||
scalar(@results), $total, scalar(@failures);
|
||||
|
||||
if ($show_failed && @failures) {
|
||||
say STDERR "\nFailed stores:";
|
||||
for my $failure (@failures) {
|
||||
printf STDERR " %-22s %s\n", $failure->[0], $failure->[1];
|
||||
}
|
||||
}
|
||||
|
||||
exit 0;
|
||||
|
||||
sub usage {
|
||||
my ($exit_code) = @_;
|
||||
print <<'USAGE';
|
||||
Usage:
|
||||
kobocompare-updated [options] KOBO_URL_OR_SLUG
|
||||
|
||||
Options:
|
||||
--delay SECONDS Pause between countries (default: 1.5)
|
||||
--retries NUMBER Retries for 403, 429 and server errors (default: 3)
|
||||
--timeout SECONDS Per-request timeout (default: 30)
|
||||
--show-failed Print a final list of failed stores
|
||||
--help Show this help
|
||||
|
||||
Examples:
|
||||
./kobocompare-updated wings-the-story-of-a-band-on-the-run
|
||||
./kobocompare-updated --delay 3 'https://www.kobo.com/es/es/ebook/wings-the-story-of-a-band-on-the-run'
|
||||
USAGE
|
||||
exit $exit_code;
|
||||
}
|
||||
|
||||
sub clean_book_slug {
|
||||
my ($value) = @_;
|
||||
$value =~ s/^\s+|\s+$//g;
|
||||
$value =~ s/[?#].*\z//; # Drop Kobo search/tracking parameters.
|
||||
$value =~ s{/+\z}{};
|
||||
$value =~ s{.*/}{};
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub polite_pause {
|
||||
my ($seconds) = @_;
|
||||
return if $seconds <= 0;
|
||||
sleep($seconds + rand(0.45));
|
||||
}
|
||||
|
||||
sub fetch_with_retries {
|
||||
my ($agent, $url, $max_retries) = @_;
|
||||
my $response;
|
||||
|
||||
for my $attempt (0 .. $max_retries) {
|
||||
$response = $agent->get(
|
||||
$url,
|
||||
'Referer' => 'https://www.kobo.com/',
|
||||
'Cache-Control' => 'no-cache',
|
||||
'Pragma' => 'no-cache',
|
||||
'Sec-Fetch-Dest' => 'document',
|
||||
'Sec-Fetch-Mode' => 'navigate',
|
||||
'Sec-Fetch-Site' => 'same-origin',
|
||||
'Sec-Fetch-User' => '?1',
|
||||
);
|
||||
|
||||
return ($response, $attempt + 1) if $response->is_success;
|
||||
|
||||
my $code = $response->code || 0;
|
||||
last unless $code == 403 || $code == 429 || $code >= 500 || $code == 0;
|
||||
last if $attempt == $max_retries;
|
||||
|
||||
my $retry_after = $response->header('Retry-After');
|
||||
my $backoff = (defined $retry_after && $retry_after =~ /^\d+(?:\.\d+)?$/)
|
||||
? $retry_after
|
||||
: (2 ** $attempt) + 1 + rand(1.0);
|
||||
sleep($backoff);
|
||||
}
|
||||
|
||||
return ($response, $max_retries + 1);
|
||||
}
|
||||
|
||||
sub extract_price {
|
||||
my ($html) = @_;
|
||||
|
||||
my $meta_price = extract_meta($html, 'og:price');
|
||||
my $meta_currency = extract_meta($html, 'og:currency_code');
|
||||
if (defined $meta_price && defined $meta_currency) {
|
||||
my $price = normalise_price($meta_price);
|
||||
return ($price, uc $meta_currency) if defined $price;
|
||||
}
|
||||
|
||||
while ($html =~ m{<script\b[^>]*type\s*=\s*(["'])application/ld\+json\1[^>]*>(.*?)</script>}gis) {
|
||||
my $json_text = $2;
|
||||
$json_text =~ s/^\s+|\s+$//g;
|
||||
next unless length $json_text;
|
||||
|
||||
my $data = eval { decode_json($json_text) };
|
||||
next if $@ || !defined $data;
|
||||
|
||||
my ($price, $currency) = find_price_in_json($data);
|
||||
return ($price, $currency) if defined $price && defined $currency;
|
||||
}
|
||||
|
||||
# Last-resort fallback for embedded JSON that is not valid JSON-LD.
|
||||
if ($html =~ /["']priceCurrency["']\s*:\s*["']([A-Z]{3})["']/i) {
|
||||
my $currency = uc $1;
|
||||
if ($html =~ /["'](?:salePrice|price)["']\s*:\s*["']?([0-9][0-9.,]*)/i) {
|
||||
my $price = normalise_price($1);
|
||||
return ($price, $currency) if defined $price;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub extract_meta {
|
||||
my ($html, $wanted) = @_;
|
||||
|
||||
while ($html =~ m{<meta\b[^>]*>}gi) {
|
||||
my $tag = $&;
|
||||
my $property = attribute_value($tag, 'property');
|
||||
$property = attribute_value($tag, 'name') unless defined $property;
|
||||
next unless defined $property && lc($property) eq lc($wanted);
|
||||
|
||||
my $content = attribute_value($tag, 'content');
|
||||
return $content if defined $content;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub attribute_value {
|
||||
my ($tag, $name) = @_;
|
||||
return $2 if $tag =~ /\b\Q$name\E\s*=\s*(["'])(.*?)\1/is;
|
||||
return $1 if $tag =~ /\b\Q$name\E\s*=\s*([^\s>]+)/is;
|
||||
return;
|
||||
}
|
||||
|
||||
sub find_price_in_json {
|
||||
my ($node) = @_;
|
||||
|
||||
if (ref $node eq 'ARRAY') {
|
||||
for my $item (@$node) {
|
||||
my ($price, $currency) = find_price_in_json($item);
|
||||
return ($price, $currency) if defined $price && defined $currency;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
return unless ref $node eq 'HASH';
|
||||
|
||||
my $raw_price = exists $node->{price} ? $node->{price}
|
||||
: exists $node->{lowPrice} ? $node->{lowPrice}
|
||||
: undef;
|
||||
my $currency = $node->{priceCurrency};
|
||||
|
||||
if (defined $raw_price && defined $currency) {
|
||||
my $price = normalise_price($raw_price);
|
||||
return ($price, uc $currency) if defined $price;
|
||||
}
|
||||
|
||||
for my $key (keys %$node) {
|
||||
my ($price, $found_currency) = find_price_in_json($node->{$key});
|
||||
return ($price, $found_currency)
|
||||
if defined $price && defined $found_currency;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub normalise_price {
|
||||
my ($raw) = @_;
|
||||
return unless defined $raw;
|
||||
|
||||
my $value = "$raw";
|
||||
$value =~ s/[\s\x{00A0}]//g;
|
||||
$value =~ s/[^0-9,.-]//g;
|
||||
return unless $value =~ /\d/;
|
||||
|
||||
if ($value =~ /,/ && $value =~ /\./) {
|
||||
my $last_comma = rindex($value, ',');
|
||||
my $last_dot = rindex($value, '.');
|
||||
if ($last_comma > $last_dot) {
|
||||
$value =~ s/\.//g;
|
||||
$value =~ tr/,/./;
|
||||
} else {
|
||||
$value =~ s/,//g;
|
||||
}
|
||||
} elsif ($value =~ /,/) {
|
||||
$value =~ tr/,/./;
|
||||
}
|
||||
|
||||
return unless looks_like_number($value);
|
||||
return $value + 0;
|
||||
}
|
||||
|
||||
sub fetch_rates_to_eur {
|
||||
my ($agent, $currencies) = @_;
|
||||
|
||||
my %wanted = map { uc($_) => 1 } grep { defined && /^[A-Za-z]{3}$/ } @$currencies;
|
||||
my %to_eur = (EUR => 1);
|
||||
delete $wanted{EUR};
|
||||
return %to_eur unless keys %wanted;
|
||||
|
||||
my $quotes = join ',', sort keys %wanted;
|
||||
my $url = "https://api.frankfurter.dev/v2/rates?base=EUR"es=$quotes";
|
||||
my $response = $agent->get($url, 'Accept' => 'application/json');
|
||||
|
||||
if (!$response->is_success) {
|
||||
warn "Could not retrieve current exchange rates: "
|
||||
. $response->status_line . "\n";
|
||||
return %to_eur;
|
||||
}
|
||||
|
||||
my $data = eval { decode_json($response->decoded_content) };
|
||||
if ($@ || ref $data ne 'ARRAY') {
|
||||
warn "Could not parse the exchange-rate response.\n";
|
||||
return %to_eur;
|
||||
}
|
||||
|
||||
# API rows are expressed as: 1 EUR = RATE quote-currency units.
|
||||
# Therefore 1 quote-currency unit = 1 / RATE EUR.
|
||||
for my $row (@$data) {
|
||||
next unless ref $row eq 'HASH';
|
||||
my $quote = uc($row->{quote} // '');
|
||||
my $rate = $row->{rate};
|
||||
next unless $quote =~ /^[A-Z]{3}$/;
|
||||
next unless defined $rate && looks_like_number($rate) && $rate > 0;
|
||||
$to_eur{$quote} = 1 / $rate;
|
||||
}
|
||||
|
||||
return %to_eur;
|
||||
}
|
||||
|
||||
sub sort_results {
|
||||
my @rows = @_;
|
||||
return sort {
|
||||
defined($a->{eur}) && defined($b->{eur}) ? $a->{eur} <=> $b->{eur}
|
||||
: defined($a->{eur}) ? -1
|
||||
: defined($b->{eur}) ? 1
|
||||
: $a->{country} cmp $b->{country}
|
||||
} @rows;
|
||||
}
|
||||
Reference in New Issue
Block a user