use Cache::Memcached;
use Digest::MD5 qw(md5_base64);
use Data::Dump qw(dump);
+use LWP::Simple;
+use Carp qw(confess);
+
+use WarnColor;
my $buckets = {
- files => 5800,
- session => 5801,
+ users => 5800,
+ files => 5801,
+ session => 5802,
};
sub new {
my $port = $buckets->{$bucket};
my $server = new Cache::Memcached {
'servers' => [ "127.0.0.1:$port" ],
- 'debug' => $ENV{DEBUG},
+ 'debug' => defined $ENV{DEBUG} && $ENV{DEBUG} > 3,
# 'compress_threshold' => 10_000,
};
#$server->set_servers($array_ref);
}
- warn "# new ",dump $self;
+ warn "# new ",dump $self if $ENV{DEBUG};
return $self;
}
+sub json_set {
+ my ($self,$bucket,$key,$data) = @_;
+ confess "data not ref ",dump($data) unless ref $data;
+ my $json = encode_json $data;
+ $self->{$bucket}->set( $key => $json );
+ warn "## json_set $bucket $key $json\n";
+ return $json;
+}
+
+sub json_get {
+ my ($self,$bucket,$key,$data) = @_;
+ if ( my $json = $self->{$bucket}->get($key) ) {
+ warn "## json_get $bucket $key $json\n";
+ return decode_json $json;
+ }
+}
+
+sub user_set {
+ my ($self,$data) = @_;
+ $self->json_set( 'users', $data->{login}, $data );
+}
+
+sub user_get {
+ my ($self,$login) = @_;
+ $login = $login->{login} if ref $login;
+ my $user = $self->json_get( 'users', $login );
+ $user->{usage} = $self->usage( $login );
+ $user->{status} = $self->status( $login );
+ warn "## user ",dump($user) if $ENV{DEBUG};
+ return $user;
+}
+
+sub status {
+ my ($self,$login,$message) = @_;
+ $login = $login->{login} if ref $login;
+ if ( $message ) {
+ $self->{session}->set( "$login:status" => $message );
+ return $message;
+ } else {
+ $self->{session}->get( "$login:status" );
+ }
+}
+
sub usage_decr {
my ($self,$data) = @_;
$self->{session}->decr( $data->{login} . ':usage' => $data->{size} );
}
sub usage {
- my ($self,$data) = @_;
- $self->{session}->get( $data->{login} . ':usage' );
+ my ($self,$login) = @_;
+ $login = $login->{login} if ref $login;
+ $self->{session}->get( $login . ':usage' );
+}
+
+sub couchdb {
+ my $self = shift @_;
+ my $fmt = shift @_;
+ my $url = sprintf $fmt, @_;
+
+ warn "# couchdb $url\n";
+ if ( my $json = get $url ) {
+ warn "## $url $json\n";
+ my $r = decode_json $json;
+ return $r;
+ }
}
-sub _key {
+sub usage_init {
+ my ($self,$login) = @_;
+ $login = $login->{login} if ref $login;
+
+ my $usage = 0;
+
+ if ( my $r = $self->couchdb(
+ 'http://localhost:5984/files/_design/files/_view/login_usage?group=true&connection_timeout=60000&limit=1&skip=0&start_key="%s"&end_key="%s"&stale=update_after'
+ , $login
+ , $login
+ )) {
+
+ $usage = $r->{rows}->[0]->{value};
+ $usage = 0 unless defined $usage;
+ }
+
+ $self->{session}->set( $login . ':usage' => $usage );
+}
+
+sub _file_key {
my $data = shift;
#md5_base64( $data->{login} . '/' . $data->{file} );
$data->{login} . ':' . $data->{file};
sub file_set {
my ($self,$data) = @_;
- my $k = _key $data;
- my $json = encode_json $data;
- $self->{files}->set( $k => $json );
- return $json;
+ $self->json_set( 'files', _file_key($data), $data );
}
sub file_get {
my ($self,$data) = @_;
- my $k = _key $data;
- if ( my $json = $self->{files}->get($k) ) {
- return decode_json $json;
- }
+ $self->json_get( 'files', _file_key($data) );
}
sub modify_file {
sub remove_file {
my ( $self, $data ) = @_;
$self->usage_decr( $data );
- my $k = _key $data;
+ my $k = _file_key $data;
$self->{files}->delete( $k );
}
}
+sub new_link {
+ my ( $self, $data ) = @_;
+
+ warn "# new_link ",dump $data;
+
+ if ( $data->{file} =~ m{^(.*/?)\.send/([^/]+)/(.+)$} ) {
+ my ( $dir, $to, $name ) = ( $1, $2, $3 );
+ my $path = "users/$data->{login}/blob/" . $data->{file};
+ my $link_to = readlink $path;
+ warn "$link_to";
+ if ( $link_to =~ s{^\Q/rsyncd-munged/\E}{/} ) {
+
+ my $s = $path;
+ $s =~ s{/[^/]+$}{}; # strip filename
+ while ( $link_to =~ s{/../}{/} ) {
+ $s =~ s{/[^/]+$}{} || die "can't strip $s";
+ warn "## simplify $s $link_to\n";
+ }
+ $s .= $link_to;
+
+ my $d = "users/$to/blob";
+ if ( ! -e $d ) {
+ warn "ERROR: no to user $to in $d";
+ return;
+ }
+ $d .= "/$name";
+
+ # $name can contain directories so we must create them
+ my $to_dir = $d;
+ $to_dir =~ s{/[^/]+$}{};
+ make_path $to_dir if ! -e $to_dir;
+
+ if ( ! -e $s ) {
+ warn "ERROR: can't find source $s";
+ } else {
+
+ warn "link $s -> $d\n";
+ link $s, $d;
+
+ my ($l,$f) = ($1,$2) if $s =~ m{users/([^/]+)/blob/(.+)};
+
+ my $origin = $self->file_get({
+ login => $l,
+ file => $f,
+ });
+ $self->new_file($origin);
+ warn "INFO: sent file ",dump($origin);
+ }
+
+
+ } else {
+ warn "ERROR: can't SEND To:$to Name:$name Link:$link_to";
+ }
+ }
+}
+
sub transfer {
my ( $self,$data ) = @_;
my $blob = "users/$data->{login}/blob";
my $path = "$blob/$data->{file}";
- if ( $data->{itemize} =~ m/^[c>]([fd])/ ) { # received change/create
+ if ( $data->{itemize} =~ m/^[c>]([fdL])/ ) { # received change/create
my $type = $1;
if ( $type eq 'f' ) {
$self->dedup( $data, $path );
} elsif ( $type eq 'd' ) {
$self->make_dir( $data );
+ } elsif ( $type eq 'L' ) {
+ $self->new_link( $data );
} else {
die "unknown type $type ", dump $data;
}
size => -s $new,
};
$self->new_file($fake);
- warn "fake ",dump($fake);
+ warn "import from $path ",dump($fake);
} else {
md5pool $new => $md5;
}
projects / cloudstore.git / blobdiff