eleksir/yadproxy
0
Fork 0
Code Activity

Начальный коммит

Browse Source
This commit is contained in:
eleksir
2021-05-18 12:32:46 +03:00
commit 0c147086c0
29 changed files with 2534 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored Normal file
View File

@@ -0,0 +1,4 @@
data/oauth/**
data/config.json
data/fileindex/**
vendor_perl/**

127
LICENSE Normal file
View File

@@ -0,0 +1,127 @@
The "Artistic License"
Preamble
The intent of this document is to state the conditions under which a
Package may be copied, such that the Copyright Holder maintains some
semblance of artistic control over the development of the package,
while giving the users of the package the right to use and distribute
the Package in a more-or-less customary fashion, plus the right to make
reasonable modifications.
Definitions:
"Package" refers to the collection of files distributed by the
Copyright Holder, and derivatives of that collection of files
created through textual modification.
"Standard Version" refers to such a Package if it has not been
modified, or has been modified in accordance with the wishes
of the Copyright Holder as specified below.
"Copyright Holder" is whoever is named in the copyright or
copyrights for the package.
"You" is you, if you're thinking about copying or distributing
this Package.
"Reasonable copying fee" is whatever you can justify on the
basis of media cost, duplication charges, time of people involved,
and so on. (You will not be required to justify it to the
Copyright Holder, but only to the computing community at large
as a market that must bear the fee.)
"Freely Available" means that no fee is charged for the item
itself, though there may be fees involved in handling the item.
It also means that recipients of the item may redistribute it
under the same conditions they received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
duplicate all of the original copyright notices and associated disclaimers.
2. You may apply bug fixes, portability fixes and other modifications
derived from the Public Domain or from the Copyright Holder. A Package
modified in such a way shall still be considered the Standard Version.
3. You may otherwise modify your copy of this Package in any way, provided
that you insert a prominent notice in each changed file stating how and
when you changed that file, and provided that you do at least ONE of the
following:
a) place your modifications in the Public Domain or otherwise make them
Freely Available, such as by posting said modifications to Usenet or
an equivalent medium, or placing the modifications on a major archive
site such as uunet.uu.net, or by allowing the Copyright Holder to include
your modifications in the Standard Version of the Package.
b) use the modified Package only within your corporation or organization.
c) rename any non-standard executables so the names do not conflict
with standard executables, which must also be provided, and provide
a separate manual page for each non-standard executable that clearly
documents how it differs from the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
4. You may distribute the programs of this Package in object code or
executable form, provided that you do at least ONE of the following:
a) distribute a Standard Version of the executables and library files,
together with instructions (in the manual page or equivalent) on where
to get the Standard Version.
b) accompany the distribution with the machine-readable source of
the Package with your modifications.
c) give non-standard executables non-standard names, and clearly
document the differences in manual pages (or equivalent), together
with instructions on where to get the Standard Version.
d) make other distribution arrangements with the Copyright Holder.
5. You may charge a reasonable copying fee for any distribution of this
Package. You may charge any fee you choose for support of this
Package. You may not charge a fee for this Package itself. However,
you may distribute this Package in aggregate with other (possibly
commercial) programs as part of a larger (possibly commercial) software
distribution provided that you do not advertise this Package as a
product of your own. You may embed this Package's interpreter within
an executable of yours (by linking); this shall be construed as a mere
form of aggregation, provided that the complete Standard Version of the
interpreter is so embedded.
6. The scripts and library files supplied as input to or produced as
output from the programs of this Package do not automatically fall
under the copyright of this Package, but belong to whoever generated
them, and may be sold commercially, and may be aggregated with this
Package. If such scripts or library files are aggregated with this
Package via the so-called "undump" or "unexec" methods of producing a
binary executable image, then distribution of such an image shall
neither be construed as a distribution of this Package nor shall it
fall under the restrictions of Paragraphs 3 and 4, provided that you do
not represent such an executable image as a Standard Version of this
Package.
7. C subroutines (or comparably compiled subroutines in other
languages) supplied by you and linked into this Package in order to
emulate subroutines and variables of the language defined by this
Package shall not be considered part of this Package, but are the
equivalent of input as in Paragraph 6, provided these subroutines do
not change the language in any way that would cause it to fail the
regression tests for the language.
8. Aggregation of this Package with a commercial distribution is always
permitted provided that the use of this Package is embedded; that is,
when no overt attempt is made to make this Package's interfaces visible
to the end user of the commercial distribution. Such use shall not be
construed as a distribution of this Package.
9. The name of the Copyright Holder may not be used to endorse or promote
products derived from this software without specific prior written permission.
10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End

62
README.md Normal file
View File

@@ -0,0 +1,62 @@
# YadProxy
## Что это?
Своего рода API, делающий запросы в Yandex.Disk и выставляющий наружу листинг публично доступных файлов.
## Зачем это нужно?
В моём случае Yandex.Disk хранит файлы пакетов для Slackware. Пакетов мало, поэтому бесплатного тарифа вполне
достаточно.
## Как это работает?
При загрузке файлов на диск сохраняется список урлов, по которым эти файлы будут доступны через веб-часть.
## Как это запустить?
Для запуска понадобятся:
* Аккаунт @yandex.ru, через который это всё будет работать
* uwsgi версии 2.0.15 или новее с поддержкой psgi
* perl-5.18 или новее (вплоть до 5.32.x)
* пакеты perl-App-cpanminus и perl-local-lib
Предполагается, что придётся подтянуть модули из CPAN-а с помощью [cpanm][4]. Для этого есть скрипт **bootstrap.sh**
Как только всё вышеописанное в арсенале появится, можно переходить к [регистрации][1] приложения. Для работы понадобятся
все привилегии в разделе **Яндекс.Диск REST API**. Полученные ID и Пароль надо вписать в **data/config.json**, пример
конфига **data/sample_config.json**. Также надо убедиться, что параметр "Код подтверждения" либо отсутствует в конфиге,
либо закоментирован.
Как только дело сделано, можно переходить к получению access_token. Для чего запускаем **bin/yad_get_token.pl**
переходим по ссылке, разрешаем приложению доступы и полученный "Код подтверждения" копи-пастим в конфиг.
Запускаем **bin/yad_get_token.pl** повторно, чтобы он внёс в локальную базку все необходимые данные. После этого
приложениями можно пользоваться.
Веб-часть я запускаю как [PSGI][2]-приложение, через [UWSGI][3].
```
/usr/bin/uwsgi --yaml /var/lib/yadproxy/yadproxy.yaml
```
## Статус пректа
RC. Пока он *не готов*, хотя в принципе работает. Формально, он выйдет в релиз, как только закончатся пункты из файла
TODO. :)
Ясное дело, что для серьёзного prodution-а это приложение не годится, во всяком случае в таком виде, как оно есть.
Как минимум необходимо организовать кэширование. Соответственно, корректно выдавать expires со стороны приложения,
чтобы, например, nginx мог без проблем кэшировать контент через proxy_cache.
## Завендоренные библиотеки
1. [Yandex::OAuth][5]
2. [Yandex::Disk][6]
[1]: https://oauth.yandex.ru/
[2]: https://uwsgi-docs.readthedocs.io/en/latest/Perl.html
[3]: https://github.com/unbit/uwsgi
[4]: https://github.com/miyagawa/cpanminus
[5]: https://metacpan.org/pod/Yandex::OAuth
[6]: https://metacpan.org/pod/Yandex::Disk

13
TODO Normal file
View File

@@ -0,0 +1,13 @@
* Реализовать проверку кэша на тухлость (Yandex.Диск зачем-то регулярно
обновляет ссылки, период обновления я пока не выявил). Делать по приходу
клиента.
* Не аплодить файлы, которые уже есть в диске (проверка по длине + md5 или sha).
* Докинуть пример строки запуска uwsgi-сервера.
* Исправить листинг каталогов, чтобы без слеша был 301-й редирект.
* Исправить листинг файлов, чтобы по ссылке на файл отображался локальный урл,
а при переходе на него происходил 302-й редирект.
* Добавить проверки corner-case-ов.
* Описать утилиты.
* Организовать многопоточную загрузку файлов на Yandex.Disk, вероятно, через
AnyEvent::HTTP, т.к. у него есть встроенное огранчение на количество
подключений к одному серверу, либо через CORO::LWP.

65
bin/yad_get_token.pl Executable file
View File

@@ -0,0 +1,65 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# Надо сменить рабочий каталог до запуска основной логики
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use CHI;
use CHI::Driver::BerkeleyDB;
use Yandex::OAuth;
use YadProxy::Conf qw (LoadConf);
my $c = LoadConf ();
my $oauth = Yandex::OAuth->new (
client_id => $c->{ID},
client_secret => $c->{'Пароль'},
);
unless (defined $c->{'Код подтверждения'}) {
# Первый шаг - получение проверочного кода
say "Шаг 1.\nСсылка для открывания в браузере: \n" . $oauth->get_code();
say '';
say 'Код подтверждения надо записать в config.json в параметр "Код подтверждения"';
say 'Понадобится запустить этот скрипт ещё раз, чтобы занести refresh_token и access_token в локальную базу для работы yadproxy.';
} else {
# Второй шаг - получение access-токена
my $token = $oauth->get_token ( code => $c->{'Код подтверждения'} );
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $c->{oauth_dir},
namespace => 'yad_auth'
);
# yad обычно выдаёт токен на год, скинем с этого 1 минуту :) чтобы уж точно
$cache->set ('refresh_token', $token->{refresh_token}, 'never');
$cache->set ('access_token', $token->{access_token}, $token->{expires_in} - 60);
printf "Шаг 2.\nrefresh_token (%s) и access_token (%s) сохранены в базе.\n\n", $token->{refresh_token}, $token->{access_token};
say 'Можно пользоваться yadproxy.';
}
exit 0;
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

142
bin/yad_index_repo.pl Executable file
View File

@@ -0,0 +1,142 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use File::Basename qw (basename dirname);
use File::Find qw (find);
use YadProxy::Conf qw (LoadConf);
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
my $c = LoadConf ();
my $remote_dir = $c->{remote_dir};
my $index_dir = $c->{index_dir};
my $index_url = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'url'
);
my $index_size = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'size'
);
my $index_md5 = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'md5'
);
my $index_sha256 = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'sha256'
);
my $index_dirs = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'dirs'
);
my $index_mtime = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'mtime'
);
my $disk = Yandex::Disk->new ( -token => GetAccessToken );
if (substr ($remote_dir, -1) eq '/') {
chop $remote_dir;
}
if (substr ($remote_dir, 0, 1) eq '/') {
$remote_dir = substr $remote_dir, 1;
}
unless (substr ($remote_dir, 0, 6) eq 'disk:/') {
$remote_dir = sprintf 'disk:/%s/', $remote_dir;
}
my $list = $disk->listAllFiles ( -path => 'REPO' ); # Note that this will give us first 999999 files
my $pattern = qr /$remote_dir/;
my %month = (
'01' => 'Jan',
'02' => 'Feb',
'03' => 'Mar',
'04' => 'Apr',
'05' => 'May',
'06' => 'Jun',
'07' => 'Jul',
'08' => 'Aug',
'09' => 'Sep',
'10' => 'Oct',
'11' => 'Nov',
'12' => 'Dec'
);
foreach (@{$list}) {
my $filename = $_->{path};
if ($filename =~ m/$pattern(.+)/) {
$filename = $1;
if (defined $filename) {
if (defined $_->{file} && defined $_->{size} && defined $_->{md5} && defined $_->{sha256} && defined $_->{modified}) {
$index_url->set ($filename, $_->{file}, 'never');
$index_size->set ($filename, $_->{size}, 'never');
$index_md5->set ($filename, $_->{md5}, 'never');
$index_sha256->set ($filename, $_->{sha256}, 'never');
my $time = sprintf (
'%s-%s-%s %s:%s',
substr ($_->{modified}, 8, 2),
$month{substr ($_->{modified}, 5, 2)},
substr ($_->{modified}, 0, 4),
substr ($_->{modified}, 11, 2),
substr ($_->{modified}, 14, 2)
);
$index_mtime->set ($filename, $time, 'never');
my $dir = dirname $filename;
if (defined $dir && $dir ne '' && $dir ne '.') {
my @dirs = split (/\//, $dir);
do {
unless (defined $index_dirs->get (join '/', @dirs)) {
$index_dirs->set (join ('/', @dirs), 1, 'never');
}
} while (pop @dirs);
}
} else {
warn "Yandex.Диск API вернуло неполные данные для $filename";
}
}
}
}

56
bin/yad_refresh_token.pl Executable file
View File

@@ -0,0 +1,56 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# Надо сменить рабочий каталог до запуска основной логики
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use CHI;
use CHI::Driver::BerkeleyDB;
use Yandex::OAuth;
use YadProxy::Conf qw (LoadConf);
my $c = LoadConf ();
my $oauth = Yandex::OAuth->new (
client_id => $c->{ID},
client_secret => $c->{'Пароль'},
);
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $c->{oauth_dir},
namespace => 'yad_auth'
);
my $refresh_token = $cache->get ('refresh_token');
if (defined $refresh_token) {
my $token = $oauth->refresh_token ( refresh_token => $refresh_token );
# yad обычно выдаёт токен на год, скинем с этого 1 минуту :) чтобы уж точно
$cache->set ('refresh_token', $token->{refresh_token}, 'never');
$cache->set ('access_token', $token->{access_token}, $token->{expires_in} - 60);
} else {
die "В локальной базе нет refresh token, возможно, для начала следует запустить yad_get_token.pl";
}
exit 0;
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

49
bin/yad_show_token.pl Executable file
View File

@@ -0,0 +1,49 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# Надо сменить рабочий каталог до запуска основной логики
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use CHI;
use CHI::Driver::BerkeleyDB;
use YadProxy::Conf qw (LoadConf);
my $c = LoadConf ();
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $c->{oauth_dir},
namespace => 'yad_auth'
);
my $refresh_token = $cache->get ('refresh_token');
my $access_token = $cache->get ('access_token');
if (defined $refresh_token && defined $access_token) {
printf "access_token:\n%s\n\nrefresh_token:\n%s\n", $access_token, $refresh_token;
} else {
say "Что-то пошло не так, токены не нашлись, попробуйте их пере-получить через скрипт yad_get_token.pl";
exit 1;
}
exit 0;
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

89
bin/yad_upload_dir.pl Executable file
View File

@@ -0,0 +1,89 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use File::Basename qw (basename dirname);
use File::Find qw (find);
use YadProxy::Conf qw (LoadConf);
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
my $c = LoadConf ();
my $disk = Yandex::Disk->new ( -token => GetAccessToken );
my $remote_dir = $c->{remote_dir};
my $local_dir = $c->{local_dir};
if (substr ($remote_dir, -1) eq '/') {
chop $remote_dir;
}
if (substr ($remote_dir, 0, 1) eq '/') {
$remote_dir = substr $remote_dir, 1;
}
if (substr ($local_dir, -1) eq '/') {
chop $local_dir;
}
# рекурсивненько зааплодим найденные файлы
find (
{
wanted => \&wanted,
no_chdir => 1
},
$local_dir
);
sub wanted {
my $file = $_;
my %targets;
if (-f $file) {
print "Uploading file: $file ... ";
my $target = substr $file, length ($local_dir) + 1;
$target = dirname $target;
if (defined $target && $target ne '' && $target ne '/') {
$target = sprintf '%s/%s', $remote_dir, $target;
} else {
$target = $remote_dir;
}
unless (defined $targets{$target}) {
unless ($disk->createFolder (-path => $target, -recursive => 1)) {
die "Невозможно создать каталог $c->{remote_dir} на Yandex.Диске";
}
$targets{$target} = 1;
}
$disk->uploadFile (
-file => $file,
-remote_path => $target,
-overwrite => 1
) or warn "Не могу за-аплодить файл в каталог $remote_dir на Yandex.Диске\n";
print "done.\n";
}
sleep 3;
}

5
bootstrap.sh Normal file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
cpanm -l vendor_perl --self-contained --force --update --installdeps .
# vim: set ft=sh noet ai ts=4 sw=4 sts=4:

7
cpanfile Normal file
View File

@@ -0,0 +1,7 @@
requires 'File::Basename';
requires 'CHI';
requires 'CHI::Driver::BerkeleyDB';
requires 'List::SomeUtils';
requires 'Plack::Util';
requires 'Yandex::Disk';
requires 'Yandex::OAuth';

24
data/sample_config.json Normal file
View File

@@ -0,0 +1,24 @@
{
# пока что тут лежит только базка с refresh_token и access_token
"oauth_dir" : "data/cache",
# базовый каталог на yandex.диске, куда складываются за-апложенные файлы
"remote_dir" : "REPO",
# каталог со списком файлов в yandex.disk
"index_dir" : "data/fileindex",
# префикс для показа в dirlist-е в web-приложении
# если браузером зайти на http://hostname/$prefix/ , будет показан верхний
# уровень того, что лежит в Yandex.Диске, точнее, в локальном индексе :)
"url_prefix" : "REPO",
# локальный каталог, для рекурсивного аплоада в yandex.диск
# желательно, абсолютный путь. Можно и относительный, но без . и ..
"local_dir" : "/tmp/REPO",
# Всё что относится к работе с yandex.api
"ID" : "ID полученный при регистрации прилодения на oauth.yandex.ru",
"Пароль" : "Пароль полученный при регистрации прилодения на oauth.yandex.ru",
"Код подтверждения" : "Циферьки из браузера - код подтверждения",
}

197
lib/YadProxy.pm Normal file
View File

@@ -0,0 +1,197 @@
package YadProxy;
# Выдаёт листинг каталогов в стиле nginx и редиректы для файлов
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use CHI;
use CHI::Driver::BerkeleyDB;
use File::Basename qw (basename dirname);
use List::SomeUtils qw (any);
use YadProxy::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (DirList);
my $c = LoadConf ();
my $index_dir = $c->{index_dir};
my $url_prefix = $c->{url_prefix};
sub DirList {
my $requested_path = shift;
if ((! defined $requested_path) || $requested_path eq '') {
$requested_path = '/';
} else {
while (substr ($requested_path, -1) eq '/') {
chop $requested_path;
}
if ((! defined $requested_path) || $requested_path eq '') {
$requested_path = '/';
}
}
my @output;
my @found;
my $status = '200';
my $content_type = 'text/plain';
my $index_url = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'url'
);
# прежде чем строить индекс, проверим-ка мы запрос на вшивость, вдруг, с нас запрашивают файл?
# в этом случае нам надо отдать 302
if (my $url = $index_url->get ($requested_path)) {
return ('302', 'text/plain', $url);
}
my $index_size = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'size'
);
my $index_md5 = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'md5'
);
my $index_sha256 = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'sha256'
);
my $index_dirs = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'dirs'
);
my $index_mtime = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'mtime'
);
my $index_of;
if ($requested_path eq '/') {
$index_of = $url_prefix;
} else {
$index_of = $url_prefix . '/' . $requested_path;
}
if (substr ($url_prefix, 0, 1) ne '/') {
$index_of = '/' . $index_of;
}
push @output, "<html>";
push @output, sprintf '<head><title>Index of %s/</title></head>', $index_of;
push @output, "<body>";
push @output, sprintf '<h1>Index of %s/</h1><hr><pre><a href="../">../</a>', $index_of;
# попробуем отловить все каталоги, начинающиеся с запрошенного пути
foreach my $key (sort ($index_dirs->get_keys ())) {
if (
(
(defined $key) &&
(length ($key) > length ($requested_path)) &&
(substr ($key, 0, length ($requested_path)) eq $requested_path)
) ||
$requested_path eq '/'
) {
my @dirs;
if ($requested_path eq '/') {
@dirs = split /\//, $key;
} else {
@dirs = split /\//, substr ($key, 1 + length ($requested_path));
}
if (defined $dirs[0] && (! any {$_ eq $dirs[0]} @found)) {
# у каталогов нету ctime или mtime, так что поставим 01-Jan-1970 00:00
push @found, $dirs[0];
my $str = $dirs[0];
my $len = 50 - (1 + length ($str));
if ($len < 0) {
$str = substr ($str, 0, 47);
$str .= '...';
$len = 0;
}
# there is no way to get dir mtime from yandex.disk
push @output, sprintf (
"<a href=\"%s/\">%s/</a>% ${len}s 01-Jan-1970 00:00 -",
$dirs[0],
$str,
''
);
}
}
}
# попробуем отловить все файлы, начинающиеся с запрошенного пути
foreach my $key (sort ($index_url->get_keys())) {
if (
(
(defined $key) &&
(length ($key) > length ($requested_path)) &&
(substr ($key, 0, length ($requested_path)) eq $requested_path)
) ||
$requested_path eq '/'
) {
my $str;
my @urls;
if ($requested_path eq '/') {
@urls = split /\//, $key;
} else {
@urls = split /\//, substr ($key, 1 + length ($requested_path));
}
if (defined $urls[0] && (! any {$_ eq $urls[0]} @found)) {
push @found, $urls[0];
$str = $urls[0];
}
if ($#urls < 1) {
my $len = 50 - length ($str);
if ($len < 0) {
$str = substr ($str, 0, 47);
$str .= '...';
$len = 0;
}
push @output, sprintf (
"<a href=\"%s/\">%s</a>% ${len}s %s % 19s",
$index_url->get ($key),
$str,
'',
$index_mtime->get ($key),
$index_size->get ($key)
);
}
}
}
push @output, "</pre><hr></body>";
push @output, "</html>";
return ('200', 'text/html', join "\n", @output);
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

41
lib/YadProxy/Conf.pm Normal file
View File

@@ -0,0 +1,41 @@
package YadProxy::Conf;
# loads config
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (LoadConf);
sub LoadConf {
my $c = 'data/config.json';
open my $CH, '<', $c or die "[FATAL] No conf at $c: $OS_ERROR\n";
binmode $CH;
my $len = (stat $c) [7];
my $json;
my $readlen = read $CH, $json, $len;
unless ($readlen) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATAL] Unable to read $c: $OS_ERROR\n";
}
if ($readlen != $len) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATAL] File $c is $len bytes on disk, but we read only $readlen bytes\n";
}
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($json);
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

76
lib/YadProxy/Lib.pm Normal file
View File

@@ -0,0 +1,76 @@
package YadProxy::Lib;
# Утилитарные функции для работы с ya.disk
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use CHI;
use CHI::Driver::BerkeleyDB;
use Log::Any qw ($log);
use YadProxy::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import);
our @EXPORT_OK = qw (GetAccessToken RefreshAccessToken);
my $c = LoadConf ();
sub GetAccessToken {
my $cache = CHI->new (
driver => 'BerkeleyDB',
root_dir => $c->{oauth_dir},
namespace => 'yad_auth'
);
my $access_token = $cache->get ('access_token');
unless (defined $access_token) {
my $refresh_token = $cache->get ('refresh_token');
unless (defined $refresh_token) {
$log->fatal ("No refresh_token found in base, please, register yaproxy application");
exit 1;
}
my $token = RefreshAccessToken ($refresh_token);
# yad обычно выдаёт токен на год, скинем с этого 1 минуту :) чтобы уж точно
$cache->set ('refresh_token', $token->{refresh_token}, 'never');
$cache->set ('access_token', $token->{access_token}, $token->{expires_in} - 60);
$access_token = $token->{access_token};
}
return $access_token;
}
sub RefreshAccessToken {
my $refresh_token = shift;
my $oauth = Yandex::OAuth->new (
client_id => $c->{ID},
client_secret => $c->{'Пароль'},
);
my $token;
my $counter = 0;
while ((! defined $token->{access_token}) || ($counter < 3)) {
$token = $oauth->refresh_token ( refresh_token => $refresh_token );
$counter++;
}
if (defined $token->{access_token}) {
return $token;
} else {
$log->fatal ("[FATAL] Unable to refresh access_token");
exit 1;
}
}
1;
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

631
lib/Yandex/Disk.pm Normal file
View File

@@ -0,0 +1,631 @@
package Yandex::Disk;
use 5.008001;
use strict;
use warnings;
use utf8;
use Yandex::Disk::Public;
use Carp qw/croak carp/;
use LWP::UserAgent;
use JSON::XS;
use File::Basename;
use URI::Escape;
use Encode;
use IO::Socket::SSL;
use Term::Sk;
our $VERSION = '0.06';
my $WAIT_RETRY = 20;
my $BUFF_SIZE = 2777216;
sub new {
my $class = shift;
my %opt = @_;
my $self = {};
$self->{token} = $opt{-token} || croak "Specify -token param";
my $ua = LWP::UserAgent->new(timeout => 10);
$ua->agent("Yandex::Disk perl module");
$ua->default_header('Accept' => 'application/json');
$ua->default_header('Content-Type' => 'application/json');
$ua->default_header('Connection' => 'keep-alive');
$ua->default_header('Authorization' => 'OAuth ' . $self->{token});
$self->{ua} = $ua;
$self->{public_info} = {};
return bless $self, $class;
}
sub getDiskInfo {
my $self = shift;
my $url = 'https://cloud-api.yandex.net/v1/disk/';
my $res = $self->__request($url, "GET");
if ($res->is_success) {
return __fromJson($res->decoded_content);
}
else {
croak "Cant execute request to $url: " . $res->status_line;
}
}
sub uploadFile {
my $self = shift;
my %opt = @_;
my $overwrite = $opt{-overwrite};
my $file = $opt{-file} || croak "Specify -file param";
my $remote_path = $opt{-remote_path} || croak "Specify -remote_path param";
my $show_progress_bar = $opt{-show_progress_bar};
$overwrite = 1 if not defined $overwrite;
if (not -f $file) {
croak "File $file not exists";
}
$overwrite = $overwrite ? 'true' : 'false';
#Delete end slash
$remote_path =~ s/^\/|\/$//g;
$remote_path = sprintf("/%s/%s", $remote_path, basename($file));
my $param = "?path=" . uri_escape($remote_path) . "&overwrite=$overwrite";
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/upload' . $param, "GET");
my $url_to_upload;
my $code = $res->code;
if ($code eq '409') {
croak "Folder $remote_path not exists";
}
elsif ($code eq '200') {
$url_to_upload = __fromJson($res->decoded_content)->{href};
}
else {
croak "Cant uploadFile: " . $res->status_line;
}
# Progress bar if need
my $term;
if ($show_progress_bar) {
$term = __prepareProgressBar(-s $file);
}
my $upl_code = __upload_file($url_to_upload, $file, $term);
if ($upl_code ne '201') {
croak "Cant upload file. Code: $code";
}
return 1;
}
sub createFolder {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $recursive = $opt{-recursive};
if ($recursive) {
my @half_path;
for my $l_path (split /\//, $path) {
push @half_path, $l_path;
$self->createFolder( -path => join('/', @half_path) );
}
}
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/?path=' . uri_escape($path), "PUT");
my $code = $res->code;
if ($code eq '409') {
#Папка или существует или не создана родительская папка
my $json_res = __fromJson($res->decoded_content);
if ($json_res->{error} eq 'DiskPathPointsToExistentDirectoryError') {
return 1;
}
croak $json_res->{description};
}
elsif ($code ne '201') {
croak "Cant create folder $path. Error: " . $res->status_line;
}
return 1;
}
sub deleteResource {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $wait = $opt{-wait};
my $permanently = $opt{-permanently};
$permanently = $permanently ? 'true' : 'false';
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources?path=' . uri_escape($path) . "&permanently=$permanently", "DELETE");
my $code = $res->code;
if ($code eq '204') {
#Free folder
return 1;
}
elsif ($code eq '202') {
if ($wait) {
my $href = __fromJson($res->decoded_content)->{href};
$self->__waitResponse($href, $WAIT_RETRY) or croak "Timeout to wait response. Try increase $WAIT_RETRY variable";
}
return 1;
}
else {
croak "Cant delete $path. Error: " . $res->status_line;
}
}
sub downloadFile {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $file = $opt{-file} || croak "Specify -file param";
my $show_progress_bar = $opt{-show_progress_bar};
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/download?path=' . uri_escape($path), "GET");
my $code = $res->code;
if ($code ne '200') {
croak "Error on request file $path: " . $res->status_line;
}
my $download_url = __fromJson($res->decoded_content)->{href};
my $term;
if ($show_progress_bar) {
if ($download_url =~ /[&?]fsize=(\d+)/) {
$term = __prepareProgressBar($1);
}
else {
carp "Can't get size of downloaded file. Progress bar will disabled.";
}
}
$self->__download($download_url, $file, $term);
return 1;
}
sub emptyTrash {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || '';
my $wait = $opt{-wait};
my $param = $path ? '?path=' . uri_escape($path) : '';
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/trash/resources/' . $path, 'DELETE');
my $code = $res->code;
if ($code eq '204') {
return 1;
}
elsif ($code eq '202') {
if ($wait) {
my $href = __fromJson($res->decoded_content)->{href};
$self->__waitResponse($href, $WAIT_RETRY) or croak "Timeout to wait response. Try increase $WAIT_RETRY variable";
}
return 1;
}
else {
$path = "by path $path" if $path;
croak "Cant empty trash$path. Error: " . $res->status_line;
}
}
sub fileInfo {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $param = '?path=' . uri_escape($path);
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources' . $param, 'GET');
my $code = $res->code;
if ($code ne '200') {
croak "Error on fileInfo. Error: " . $res->status_line;
}
my $json_res = __fromJson($res->{_content});
return $json_res;
}
sub listFiles {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $limit = $opt{-limit} || 999999;
my $offset = $opt{-offset};
$offset = 0 if not $offset;
my $param = '?path=' . uri_escape($path) . "&limit=$limit&offset=$offset&fields=_embedded.items";
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources' . $param, 'GET');
my $code = $res->code;
if ($code ne '200') {
croak "Error on listFiles. Error: " . $res->status_line;
}
my $json_res = __fromJson($res->decoded_content);
return $json_res->{_embedded}->{items};
}
sub listAllFiles {
my $self = shift;
my %opt = @_;
my $limit = $opt{-limit} || 999999;
my $media_type = $opt{-media_type};
my $offset = $opt{-offset};
$offset = 0 if not $offset;
my $param = "?limit=$limit&offset=$offset";
$param .= '&media_type=' . $media_type if $media_type;
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/files' . $param, 'GET');
my $code = $res->code;
if ($code ne '200') {
croak "Error on listFiles. Error: " . $res->status_line;
}
my $json_res = __fromJson($res->decoded_content);
return $json_res->{items};
}
sub lastUploadedFiles {
my $self = shift;
my %opt = @_;
my $limit = $opt{-limit} || 999999;
my $media_type = $opt{-media_type};
my $param = "?limit=$limit";
$param .= '&media_type=' . $media_type if $media_type;
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/last-uploaded' . $param, 'GET');
my $code = $res->code;
if ($code ne '200') {
croak "Error on listFiles. Error: " . $res->status_line;
}
my $json_res = __fromJson($res->decoded_content);
return $json_res->{items};
}
sub public {
my $self = shift;
return Yandex::Disk::Public->new( -token => $self->{token} );
}
sub __download {
my ($self, $url, $fname, $term) = @_;
my $ua = $self->{ua};
open my $FL, ">$fname" or croak "Cant open $fname to write $!";
binmode $FL;
my $res = $ua->get($url, ':read_size_hint' => $BUFF_SIZE, ':content_cb' =>
sub {
print $FL $_[0];
$term->up($BUFF_SIZE) if $term;
}
);
close $FL;
$term->close if $term;
if ($res->code eq '200') {
return 1;
}
croak "Cant download file $url to $fname. Error: " . $res->status_line;
}
sub __waitResponse {
#Дожидается ответа о статусе операции
my ($self, $url, $retry) = @_;
while ($retry > 0) {
my $res = $self->__request($url, "GET");
my $code = $res->code;
if ($code eq '200' && __fromJson($res->decoded_content)->{status} eq 'success') {
return 1;
}
sleep 1;
$retry--;
}
return;
}
sub __upload_file {
#Buffered chunked upload file
my ($url, $file, $term) = @_;
my $u1 = URI->new($url);
# $IO::Socket::SSL::DEBUG = 3;
my $host = $u1->host;
my $port = $u1->port;
my $path = $u1->path;
my $sock = IO::Socket::SSL->new(
PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
) or croak "Cant connect to $host:$port";
binmode $sock;
$sock->autoflush(1);
$sock->print("PUT $path HTTP/1.1\n");
$sock->print("HOST: $host\n");
$sock->print("Connection: close\n");
$sock->print("Content-Type: application/json\n");
$sock->print("Transfer-Encoding: chunked\n");
$sock->print("\n");
open my $FH, "<$file" or croak "Cant open $file $!";
binmode $FH;
my $filebuf;
while (my $bytes = read($FH, $filebuf, $BUFF_SIZE)) {
my $hex = sprintf("%X", $bytes);
$sock->print($hex) or croak "Cant print to socket";
$sock->print("\r\n") or croak "Cant print to socket";
$sock->print($filebuf) or croak "Cant print to socket";
$sock->print("\r\n") or croak "Cant print to socket";
$term->up($BUFF_SIZE) if $term;
}
close $FH;
$sock->print("0\r\n") or croak "Cant print to socket";
$sock->print("\r\n") or croak "Cant print to socket";
my @answer = $sock->getlines();
$sock->close();
$term->close if $term;
my ($code) = $answer[0] =~ /(\d{3})/;
return $code;
}
sub __request {
my ($self, $url, $type) = @_;
my $ua = $self->{ua};
my $req = HTTP::Request->new($type => $url);
my $res = $ua->request($req);
return $res;
}
sub __fromJson {
my $string = ref($_[0]) ? $_[1] : $_[0];
my $res = JSON::XS::decode_json($string);
return $res;
}
sub __prepareProgressBar {
my ($file_size) = @_;
my $format = '%2d Elapsed: %8t %21b %4p %2d (%8c of %11m bytes)';
my $target = $file_size;
my $term = Term::Sk->new($format, {
freq => 'd',
base => 0,
target => $target,
pdisp => '!',
}
);
return $term;
}
sub errstr {
return shift->{errstr};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
B<Yandex::Disk> - a simple API for Yandex Disk
=head1 VERSION
version 0.06
=head1 SYNOPSYS
use Yandex::Disk;
my $TOKEN = 'aaaabbbbccc'; #Auth token. You can get token from module L<Yandex::OAuth>
my $disk = Yandex::Disk->new( -token => $TOKEN );
#Get info about disk and print
my $diskinfo = $disk->getDiskInfo();
p $diskinfo;
#Upload file from local disk to Yandex disk
$disk->uploadFile(
-overwrite => 1,
-file => 'my_test_upload_file', # Path to file on local disk
-remote_path => "/Upload", # Folder on Yandex Disk
) or die "Cant upload file";
#Download file form Yandex Disk to local disk
$disk->downloadFile(
-path => "/Upload/my_test_upload_file", # Path to file on Yandex Disk
-file => 'my_test_upload_file', # Path to save file on local disk
) or die "Cant download file";
#Create folder on Yandex Disk
$disk->createFolder(
-path => '/Temp/new_folder', # Path to new folder on Yandex Disk
-recursive => 1, # Recursive create folder
#Share file and get public link
my $public = $disk->public();
$public->publicFile(
-path => "/Upload/my_test_upload_file", # Path to file, which need share
) or die "Cant public file";
my $publicUrl = $public->publicUrl() or die "Cant get public url";
=head1 METHODS
=head2 getDiskInfo()
Return disk info data as hashref
my $info = $disk->getDiskInfo();
$info:
Example output:
{
max_file_size 1073741824,
revision 14987326771107,
system_folders {
applications "disk:/Приложения",
downloads "disk:/Загрузки/",
facebook "disk:/Социальные сети/Facebook",
google "disk:/Социальные сети/Google+",
instagram "disk:/Социальные сети/Instagram",
mailru "disk:/Социальные сети/Мой Мир",
odnoklassniki "disk:/Социальные сети/Одноклассники",
photostream "disk:/Фотокамера/",
screenshots "disk:/Скриншоты/",
social "disk:/Социальные сети/",
vkontakte "disk:/Социальные сети/ВКонтакте"
},
total_space 67645734912,
trash_size 0,
used_space 19942927435,
user {
login "login",
uid 123456
}
}
=head2 uploadFile(%opt)
Upload file (-file) to Yandex Disk in folder (-remote_path). Return 1 if success
$disk->uploadFile(-file => '/root/upload', -remote_path => 'Temp', -overwrite => 0);
Options:
-overwrite => Owervrite file if exists (default: 1)
-remote_path => Path to upload file on disk
-file => Path to local file
-show_progress_bar => Show progress bar upload file
=head2 createFolder(%opt)
Create folder on disk
$disk->createFolder(-path => 'Temp/test', -recursive => 1);
Options:
-path => Path to folder,
-recursive => Recursive create folder (default: 0)
=head2 deleteResource(%opt)
Delete file or folder from disk. Return 1 if success
$disk->deleteResource(-path => 'Temp/test');
Options:
-path => Path to delete file or folder
-permanently => Do not move to trash, delete permanently (default: 0(moving file to trash))
-wait => Wait delete resource (defailt: 0)
=head2 downloadFile(%opt)
Download file from Yandex Disk to local file. Method overwrites local file if exists. Return 1 if success
$disk->downloadFile(-path => 'Temp/test', -file => 'test');
Options:
-path => Path to file on Yandex Disk
-file => Path to local destination
-show_progress_bar => Show progress bar download file
=head2 emptyTrash(%opt)
Empty trash. If -path specified, delete -path resource, otherwise - empty all trash. Return 1 if success
$disk->emptyTrash(-path => 'Temp/test'); #Delete '/Temp/test' from trash
Options:
-path => Path to resource on Yandex Disk to delete from trash
-wait => Wait empty trash (defailt: 0)
$disk->emptyTrash; #Full empty trash
=head2 fileInfo(%opt)
List properties of selected file. Return hashref(keys: "path", "type", "name", "preview", "created", "modified", "md5", "mime_type", "size")
$disk->fileInfo(-path => 'Temp/test');
Options:
-path => Path to file on Yandex Disk for which need get info
=head2 listFiles(%opt)
List files in folder. Return arrayref to hashref(keys: "path", "type", "name", "preview", "created", "modified", "md5", "mime_type", "size")
$disk->listFiles(-path => 'Temp/test');
Options:
-path => Path to resource (folder) on Yandex Disk for which need get info
-limit => Limit max files to output (default: unlimited)
-offset => Offset records from start (default: 0)
=head2 listAllFiles(%opt)
List all files on YandexDisk. Return arrayref to hashref(keys: "path", "type", "name", "preview", "created", "modified", "md5", "mime_type", "size")
$disk->listAllFiles();
Options:
-media_type => Type of file to return. Afaible types listed below. Multiple types can be specified by using a comma. (default: all types)
-limit => Limit max files to output (default: unlimited)
-offset => Offset records from start (default: 0)
Media types:
audio, backup, book, compressed, data, development, diskimage, document, encoded, executable, flash, font, image, settings, spreadsheet, text, unknown, video, web
=head2 lastUploadedFiles(%opt)
List last uploaded files. Return arrayref to hashref(keys: "path", "type", "name", "preview", "created", "modified", "md5", "mime_type", "size")
$disk->lastUploadedFiles();
Options:
-media_type => Type of file to return. Afaible types same as listAllFiles. Multiple types can be specified by using a comma. (default: all types)
-limit => Limit max files to output (default: unlimited)
=head2 Public files
my $public = $disk->public(); #Create L<Yandex::Disk::Public> object
=head1 CLI/API
Sparrow plugin https://sparrowhub.org/info/yandex-disk
=head1 DEPENDENCE
L<LWP::UserAgent>, L<JSON::XS>, L<URI::Escape>, L<IO::Socket::SSL>
=head1 AUTHORS
=over 4
=item *
Pavel Andryushin <vrag867@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017 by Pavel Andryushin.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

164
lib/Yandex/Disk/Public.pm Normal file
View File

@@ -0,0 +1,164 @@
#
#===============================================================================
#
# FILE: Public.pm
#
# DESCRIPTION:
#
# FILES: ---
# BUGS: ---
# NOTES: ---
# AUTHOR: YOUR NAME (),
# ORGANIZATION:
# VERSION: 1.0
# CREATED: 01.10.2017 12:34:59
# REVISION: ---
#===============================================================================
package Yandex::Disk::Public;
use 5.008001;
use strict;
use warnings;
use utf8;
use URI::Escape;
use Carp 'croak';
use base 'Yandex::Disk';
#Class for Public actions under Yandex Disk files and folders
our $VERSION = '0.06';
sub publicFile {
my $self = shift;
my %opt = @_;
my $path = $opt{-path} || croak "Specify -path param";
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/publish?path=' . uri_escape($path), "PUT");
my $code = $res->code;
if ($code ne '200') {
croak "Cant public file $path. Error: " . $res->status_line;
}
my $metainfo_href = $self->__fromJson($res->decoded_content)->{href};
my $res_get_metainfo = $self->__getPublicUrl($metainfo_href);
return $res_get_metainfo;
}
sub unpublicFile {
my $self = shift;
my %opt = @_;
$self->{public_info} = {};
my $path = $opt{-path} || croak "Specify -path param";
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/unpublish?path=' . uri_escape($path), "PUT");
my $code = $res->code;
if ($code ne '200') {
croak "Cant unpublic file $path. Error: " . $res->status_line;
}
return 1;
}
sub listPublished {
my $self = shift;
my %opt = @_;
my $limit = $opt{-limit};
my $offset = $opt{-offset} || 0;
my $type = $opt{-type};
$limit = 999999 if not defined $limit;
if ($type && ($type ne 'dir' && $type ne 'file')) {
croak "Wrong -type value (dir/file)";
}
my $param = "limit=$limit&offset=$offset";
$param .= "&type=$type" if $type;
my $res = $self->__request('https://cloud-api.yandex.net/v1/disk/resources/public?' . $param, "GET");
my $code = $res->code;
if ($code ne '200') {
croak "Cant get listPublished. Error: " . $res->status_line;
}
my $items = $self->__fromJson($res->decoded_content)->{items};
return $items;
}
sub __getPublicUrl {
my ($self, $href) = @_;
my $res = $self->__request($href, "GET");
my $code = $res->code;
if ($code ne '200') {
croak "Cant get public url by href: $href. Error: " . $res->status_line;
}
$self->{public_info} = $self->__fromJson($res->decoded_content);
return 1;
}
sub publicUrl {
return shift->{public_info}->{public_url};
}
sub publicType {
return shift->{public_info}->{type};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
B<Yandex::Disk::Public> - public and unpublic yandex disk resources(files and folders)
=head1 VERSION
version 0.06
=head1 SYNOPSIS
use Yandex::Disk;
my $token = "my token";
my $disk = Yandex::Disk( -token => $token); #Create Yandex::Disk object
my $public = $disk->public; #Create Yandex::Disk::Public object
#Public file '/Temp/small_file'
$public->publicFile (-path => '/Temp/small_file');
=head1 METHODS
=head2 publicFile(%opt)
Make file or folder as public
$public->publicFile ( -path => '/Temp/small_file' ) or die "Cant public file"; #Make file '/Temp/small_file' as public
Options:
-path => Path to resource on yandex disk, where need public
=head2 unpublicFile(%opt)
Remove public access to resources
$public->unpublicFile( -path => '/Temp/small_file' ) or die "Cant unpublic file";
Options:
-path => Path to resource on yandex disk, where need public
=head2 listPublished(%opt)
Return array hashref with published files
my $list = $public->listPublished();
Options:
-limit => Limit max files to output (default: unlimited)
-offset => Offset records from start (default: 0)
-type => dir/file (default: undef (display dirs and files)
=head2 publicUrl()
Get public url from published file. Return undef if error
=head2 publicType()
Get type of published resource. Retutn undef if error
=cut

162
lib/Yandex/OAuth.pm Normal file
View File

@@ -0,0 +1,162 @@
=encoding utf-8
=head1 NAME
Yandex::OAuth - module for get access token to Yandex.API
=head1 SYNOPSIS
use Yandex::OAuth;
my $oauth = Yandex::OAuth->new(
client_id => '76df1cf****************fb31d0289',
client_secret => 'e3a2855****************4de3c2afc',
);
# return link for open in browser
say $oauth->get_code();
# return JSON with access_token
say Dumper $oauth->get_token( code => 3557461 );
# return JSON with access_token
say Dumper $oauth->refresh_token( refresh_token => 3557461 );
=head1 DESCRIPTION
Yandex::OAuth is a module for get access token for Yandex.API
See more at https://tech.yandex.ru/oauth/doc/dg/concepts/ya-oauth-intro-docpage/
=cut
package Yandex::OAuth;
use 5.008001;
use utf8;
use Modern::Perl;
use JSON::XS;
use URI::Escape;
use LWP::UserAgent;
use Moo;
our $VERSION = "0.07";
has 'ua' => (
is => 'ro',
default => sub {
my $ua = LWP::UserAgent->new();
$ua->agent( 'Yandex::OAuth Perl API Client' );
$ua->timeout( 120 );
return $ua;
}
);
has 'auth_url' => (
is => 'ro',
default => 'https://oauth.yandex.ru/authorize',
);
has 'token_url' => (
is => 'ro',
default => 'https://oauth.yandex.ru/token',
);
has 'client_id' => (
is => 'rw',
required => 1,
);
has 'client_secret' => (
is => 'rw',
required => 1,
);
has 'demo' => (
is => 'rw'
);
=head1 METHODS
=over
=item B<get_code()>
return a link for open in browser
$oauth->get_code();
=cut
sub get_code {
my ( $self, %params ) = @_;
return $self->auth_url . "?response_type=code&client_id=".$self->client_id .
( ( defined $params{state} ) ? "&state=" . uri_escape( $params{state} ) : '' );
}
=item B<get_token()>
return a json with access_token or error if code has expired
$oauth->get_token( code => XXXXXX );
=cut
sub get_token {
my ( $self, %params ) = @_;
return JSON::XS::decode_json( $self->demo ) if $self->demo;
my $res = $self->ua->post($self->token_url, {
code => $params{code},
client_id => $self->client_id,
client_secret => $self->client_secret,
grant_type => 'authorization_code',
});
return JSON::XS::decode_json( $res->content );
}
=item B<refresh_token()>
return a json with access_token or error if refresh_token has already been used
$oauth->refresh_token( refresh_token => XXXXXX );
=cut
sub refresh_token {
my ( $self, %params ) = @_;
return JSON::XS::decode_json( $self->demo ) if $self->demo;
my $res = $self->ua->post($self->token_url, {
refresh_token => $params{refresh_token},
client_id => $self->client_id,
client_secret => $self->client_secret,
grant_type => 'refresh_token',
});
return JSON::XS::decode_json( $res->content );
}
1;
__END__
=back
=head1 LICENSE
Copyright (C) Andrey Kuzmin.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Andrey Kuzmin E<lt>chipsoid@cpan.orgE<gt>
=cut

253
lib/Yandex/OAuth/Client.pm Normal file
View File

@@ -0,0 +1,253 @@
=encoding utf-8
=head1 NAME
Yandex::OAuth::Client - base class for any Yandex.API modules
=head1 SYNOPSIS
use Yandex::OAuth::Client;
my $client = Yandex::OAuth::Client->new(token => '************', endpoint => 'https://api-metrika.yandex.ru/');
my $client->get(['stat','user_vars'], {
pretty => 1,
# other params specified for resource
});
# url converting to https://api-metrika.yandex.ru/stat/user_vars/?pretty=1
=head1 DESCRIPTION
Yandex::OAuth::Client is base class for any Yandex.API modules
Contains get, post, put, delete methods for queries to any APIs Yandex.
Looking for contributors for this and other Yandex.APIs
=cut
package Yandex::OAuth::Client;
use 5.008001;
use utf8;
use Modern::Perl;
use Data::Dumper;
use LWP::UserAgent;
use Storable qw/ dclone /;
use JSON::XS;
use Moo;
has 'ua' => (
is => 'ro',
default => sub {
my $ua = LWP::UserAgent->new();
$ua->agent( 'Yandex::OAuth Perl API Client' );
$ua->timeout( 120 );
return $ua;
}
);
has 'token' => (
is => 'rw',
required => 1,
);
has 'endpoint' => (
is => 'rw',
required => 1,
);
has 'next_url' => (
is => 'rw',
default => '',
writer => 'set_next_url',
);
has 'demo' => (
is => 'rw'
);
=head1 CONSTRUCTOR
=over
=item B<new()>
Require two arguments: token and endpoint. For module based on Yandex::OAuth::Client
you can override atribute 'endpoint'
extends 'Yandex::OAuth::Client';
has '+endpoint' => (
is => 'ro',
default => 'https://api-metrika.yandex.ru/',
);
=back
=head1 METHODS
=over
=item B<get()>
Send GET request.
$client->get(['stat','load']);
# or full link. for example, when using "next" link from previous response
$client->get('https://api-metrika.yandex.ru/stat/load/?pretty=1');
=cut
sub get {
my ($self, $url, $query) = @_;
return $self->request( 'get', $url, $query );
}
=item B<post()>
Send POST request.
$client->post(['counters'], {
# query params
}, {
# body params
});
=cut
sub post {
my ($self, $url, $query, $body) = @_;
return $self->request( 'post', $url, $query, $body );
}
=item B<put()>
Send PUT request.
$client->put(['counter', $counter_id], {
# query params
}, {
# body params
});
=cut
sub put {
my ($self, $url, $query, $body) = @_;
return $self->request( 'put', $url, $query, $body );
}
=item B<delete()>
Send DELETE request.
$client->delete(['counter', $counter_id]);
=cut
sub delete {
my ($self, $url, $query) = @_;
return $self->request( 'delete', $url, $query );
}
sub request {
my ( $self, $method, $url, $query, $body ) = @_;
my $req = HTTP::Request->new( uc $method => $self->make_url( $url, $query ) );
$self->prepare_request( $req, $body );
my $resp = $self->parse_response( $self->ua->request( $req )->content );
return $resp;
}
sub make_url {
my ( $self, $resource, $params ) = @_;
my @resources = ref $resource ? @$resource : ( $resource );
my $url = '';
if ( $resource =~ /^http/i ) {
$url = $resource;
}
else {
$url = $self->endpoint;
$url =~ s/[\\\/]+$//;
$url .= '/';
$url .= join '/', @resources;
}
if ( $params ) {
my $uri = URI->new( $url );
$uri->query_form( %$params );
$url = $uri->as_string;
}
return $url;
}
sub prepare_request {
my ( $self, $request, $body_param ) = @_;
my $body = '';
if ( $body_param ) {
my $params = dclone( $body_param );
state $json = JSON::XS->new->utf8;
$body = $json->encode( $params );
$request->content( $body );
}
$request->header( 'content-type' => 'application/json; charset=UTF-8' );
$request->header( 'content-length' => length( $body ) );
$request->header( 'Authorization' => 'Bearer ' . $self->token );
return 1;
}
sub parse_response {
my ( $self, $response ) = @_;
return unless $response;
my $json = JSON::XS::decode_json( $response );
my $next = '';
if ( defined $json->{links} && defined $json->{links}->{next} ) {
$next = $json->{links}->{next};
$next =~ s/^http:/https:/i;
$self->set_next_url( $next );
}
return $json;
}
1;
__END__
=back
=head1 LICENSE
Copyright (C) Andrey Kuzmin.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Andrey Kuzmin E<lt>chipsoid@cpan.orgE<gt>
=cut

2
test/test_file.txt Normal file
View File

@@ -0,0 +1,2 @@
lorem ipsum и всё такое, ну, вы знаете.
Съешь ещё этих французских булочек... да смотри, не подавись.

40
test/yad_file_info.pl Executable file
View File

@@ -0,0 +1,40 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use YadProxy::Conf qw (LoadConf);
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $c = LoadConf ();
my $remote_dir = '';
my $file = 'test_file.txt';
if ($c->{remote_dir} && $c->{remote_dir} ne '') {
$remote_dir = $c->{remote_dir};
}
my $disk = Yandex::Disk->new ( -token => GetAccessToken );
say Dumper $disk->fileInfo ( -path => sprintf ("%s/%s", $remote_dir, $file));
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

32
test/yad_info.pl Executable file
View File

@@ -0,0 +1,32 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $disk = Yandex::Disk->new ( -token => GetAccessToken() );
my $diskinfo = $disk->getDiskInfo();
say Dumper $diskinfo;
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

31
test/yad_list_all_files.pl Executable file
View File

@@ -0,0 +1,31 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $disk = Yandex::Disk->new ( -token => GetAccessToken );
say Dumper $disk->listAllFiles ();
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

32
test/yad_list_published.pl Executable file
View File

@@ -0,0 +1,32 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $disk = Yandex::Disk->new( -token => GetAccessToken );
my $public = $disk->public();
say Dumper $public->listPublished();
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

44
test/yad_mkdir.pl Executable file
View File

@@ -0,0 +1,44 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use YadProxy::Conf qw (LoadConf);
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $c = LoadConf ();
my $remote_dir = '/';
if ($c->{remote_dir} && $c->{remote_dir} ne '') {
$remote_dir = $c->{remote_dir};
$disk->createFolder (-path => $remote_dir, -recursive => 1) or do {
die "Невозможно создать каталог $c->{remote_dir} на Yandex.Диске";
};
}
my $disk = Yandex::Disk->new( -token => GetAccessToken );
$disk->createFolder(-path => 'myYaD/test', -recursive => 1);
say Dumper $disk->listFiles (-path => '/');
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

55
test/yad_upload_file.pl Executable file
View File

@@ -0,0 +1,55 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use File::Basename;
use YadProxy::Conf qw (LoadConf);
use YadProxy::Lib qw (GetAccessToken);
use Yandex::Disk;
use Data::Dumper;
my $c = LoadConf ();
my $remote_dir = '/';
my $file = 'test/test_file.txt';
my $disk = Yandex::Disk->new ( -token => GetAccessToken );
if ($c->{remote_dir} && $c->{remote_dir} ne '') {
$remote_dir = $c->{remote_dir};
$disk->createFolder (
-path => $remote_dir,
-recursive => 1
) or do {
die "Невозможно создать каталог $c->{remote_dir} на Yandex.Диске";
};
}
$disk->uploadFile (
-file => $file,
-remote_path => $remote_dir,
-overwrite => 1
) or die "Не могу зааплодить файл в каталог $remote_dir на Yandex.Диске";
say Dumper $disk->listFiles (-path =>$remote_dir);
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

41
test/yadproxy_dump_dircache.pl Executable file
View File

@@ -0,0 +1,41 @@
#!/usr/bin/perl
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use version; our $VERSION = qw (1.0);
my $workdir;
# сменим рабочий каталог
BEGIN {
use Cwd qw (chdir abs_path);
my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
if ($#CWD > 1) { $#CWD = $#CWD - 2; }
$workdir = join '/', @CWD;
chdir $workdir;
}
use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
use CHI;
use CHI::Driver::BerkeleyDB;
use Data::Dumper;
use YadProxy::Conf qw (LoadConf);
my $c = LoadConf ();
my $index_dir = $c->{index_dir};
my $index_dirs = CHI->new (
driver => 'BerkeleyDB',
root_dir => $index_dir,
namespace => 'dirs'
);
say join "\n", $index_dirs->get_keys ();
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

73
yadproxy.psgi Normal file
View File

@@ -0,0 +1,73 @@
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use version; our $VERSION = qw (1.1.0);
use lib qw (./lib ./vendor_perl/lib/perl5);
use YadProxy qw (DirList);
use YadProxy::Conf qw (LoadConf);
my $c = LoadConf ();
my $url_prefix = $c->{url_prefix};
if (substr ($url_prefix, -1) eq '/') {
chop $url_prefix;
}
if (substr ($url_prefix, 0, 1) eq '/') {
$url_prefix = substr $url_prefix, 1;
}
my $app = sub {
my $env = shift;
my $msg = "<html>\n<head><title>404 Not Found</title></head>\n<body>\n<center><h1>404 Not Found</h1></center>\n</body>\n</html>\n";
my $status = '404';
my $content = 'text/html';
if ($env->{PATH_INFO} =~ m/^\/$url_prefix\/(.*)/) {
my $path = $1;
($status, $content, $msg) = DirList ($path);
}
if ($status eq '302') {
my $message = << "EOM";
<html>
<head><title>302 Found</title></head>
<body>
<center><h1>302 Found</h1></center>
</body>
</html>
EOM
use bytes;
my $length = length $message;
no bytes;
return [
$status,
[
'Content-Type' => $content,
'Content-Length' => $length,
'Location' => $msg
],
[$message]
];
}
use bytes;
my $length = length $msg;
no bytes;
return [
$status,
[ 'Content-Type' => $content, 'Content-Length' => $length ],
[ $msg ],
];
};
__END__
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:

17
yadproxy.yaml Normal file
View File

@@ -0,0 +1,17 @@
uwsgi:
http-socket: 127.0.0.1:3081
socket-protocol: http
so-keepalive: 0
logformat: %(var.REMOTE_ADDR) %(var.REQUEST_METHOD) %(var.REQUEST_URI) %(status)
processes: 1
need-app: true
log-reopen: yes
reload-mercy: 5
buffer-size: 32768
die-on-term: true
pidfile: /run/yadproxy/yadproxy.pid
logto: /var/log/yadproxy/yadproxy.log
plugins: psgi
chdir: /var/lib/yadproxy
psgi: /var/lib/yadproxy/yadproxy.psgi
perl-local-lib: /var/lib/yadproxy/vendor_perl