first working /.send/ implementation for all cases

[cloudstore.git] / lib / CloudStore / Couchbase.pm

diff --git a/lib/CloudStore/Couchbase.pm b/lib/CloudStore/Couchbase.pm
index ddd5c8b..c59a1ac 100644 (file)
--- a/lib/CloudStore/Couchbase.pm
+++ b/lib/CloudStore/Couchbase.pm
@@ -12,6 +12,8 @@ use Data::Dump qw(dump);
 use LWP::Simple;
 use Carp qw(confess);
 
+use WarnColor;
+
 my $buckets = {
        users => 5800,
        files => 5801,
@@ -28,7 +30,7 @@ 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);
@@ -48,14 +50,14 @@ sub json_set {
        confess "data not ref ",dump($data) unless ref $data;
        my $json = encode_json $data;
        $self->{$bucket}->set( $key => $json );
-       warn "## $bucket set $key $json\n";
+       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 "## $bucket get $key $json\n";
+               warn "## json_get $bucket $key $json\n";
                return decode_json $json;
        }
 }
@@ -71,7 +73,7 @@ sub user_get {
        my $user = $self->json_get( 'users', $login );
        $user->{usage} = $self->usage( $login );
        $user->{status} = $self->status( $login );
-       warn "## user ",dump($user);
+       warn "## user ",dump($user) if $ENV{DEBUG};
        return $user;
 }
 
@@ -80,6 +82,7 @@ sub status {
        $login = $login->{login} if ref $login;
        if ( $message ) {
                $self->{session}->set( "$login:status" => $message );
+               return $message;
        } else {
                $self->{session}->get( "$login:status" );
        }
@@ -185,24 +188,50 @@ sub new_link {
        if ( $data->{file} =~ m{^(.*/?)\.send/([^/]+)/(.+)$} ) {
                my ( $dir, $to, $name ) = ( $1, $2, $3 );
                my $path = "users/$data->{login}/blob/" . $data->{file};
-               my $file = readlink $path;
-               warn "## $path -> $file";
-               if ( $file =~ s{^\Q/rsyncd-munged/../../\E}{$dir} ) {
-                       warn "SEND To:$to Name:$name File:$file\n";
-                       my $s = "users/$data->{login}/blob/$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";
-                       die "no user $to" unless -e $d;
+                       if ( ! -e $d ) {
+                               warn "ERROR: no to user $to in $d";
+                               return;
+                       }
                        $d .= "/$name";
 
-                       # since $name can contain directories we must create them
+                       # $name can contain directories so we must create them
                        my $to_dir = $d;
                        $to_dir =~ s{/[^/]+$}{};
                        make_path $to_dir if ! -e $to_dir;
 
-                       warn "link $s -> $d\n";
-                       link $s, $d;
+                       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 File:$file";
+                       warn "ERROR: can't SEND To:$to Name:$name Link:$link_to";
                }
        }
 }
@@ -280,7 +309,7 @@ sub dedup {
                                        size => -s $new,
                                };
                                $self->new_file($fake);
-                               warn "fake ",dump($fake);
+                               warn "import from $path ",dump($fake);
                        } else {
                                md5pool $new => $md5;
                        }