lib/CloudStore/Store.pm

   1 package CloudStore::Store;
   2 use warnings;
   3 use strict;
   4
   5 use autodie;
   6 use JSON::XS;
   7 use File::Path qw(make_path);
   8 use File::Slurp qw();
   9 use Digest::MD5 qw(md5_base64);
  10 use Data::Dump qw(dump);
  11 use Carp qw(confess);
  12 use BerkeleyDB;
  13
  14 use WarnColor;
  15
  16 sub new {
  17         my ($class) = @_;
  18
  19         my $self = {};
  20         bless $self, $class;
  21
  22         my %md5;
  23         $self->{db} = tie %md5, 'BerkeleyDB::Hash', -Filename => '/tmp/md5.db', -Flags => DB_CREATE;
  24         $self->{md5} = \%md5;
  25
  26         warn "# new ",dump $self if $ENV{DEBUG};
  27
  28         return $self;
  29 }
  30
  31 sub user_set {
  32         my ( $self,$data ) = @_;
  33 }
  34
  35 sub user_get {
  36         my ( $self,$data ) = @_;
  37 }
  38
  39 sub modify_file {
  40         my ( $self,$data ) = @_;
  41
  42 #       if ( my $old = $self->file_get( $data ) ) {
  43 #               $self->usage_decr( $data );
  44 #       }
  45
  46         $self->new_file($data);
  47 }
  48
  49 sub new_file {
  50         my ( $self,$data ) = @_;
  51 #       $self->file_set($data);
  52 #       $self->usage_incr($data);
  53 }
  54
  55 sub remove_file {
  56         my ( $self, $data ) = @_;
  57 #       $self->usage_decr( $data );
  58 }
  59
  60 sub make_dir {
  61         my ( $self, $data ) = @_;
  62
  63 }
  64
  65 sub new_link {
  66         my ( $self, $data ) = @_;
  67
  68         warn "# new_link ",dump $data;
  69
  70         if ( $data->{file} =~ m{^(.*/?)\.send/([^/]+)/(.+)$} ) {
  71                 my ( $dir, $to, $name ) = ( $1, $2, $3 );
  72                 my $path = "users/$data->{login}/blob/" . $data->{file};
  73                 my $link_to = readlink $path;
  74                 warn "$link_to";
  75                 if ( $link_to =~ s{^\Q/rsyncd-munged/\E}{/} ) {
  76
  77                         my $s = $path;
  78                         $s =~ s{/[^/]+$}{}; # strip filename
  79                         while ( $link_to =~ s{/../}{/} ) {
  80                                 $s =~ s{/[^/]+$}{} || die "can't strip $s";
  81                                 warn "## simplify $s $link_to\n";
  82                         }
  83                         $s .= $link_to;
  84
  85                         my $d = "users/$to/blob";
  86                         if ( ! -e $d ) {
  87                                 warn "ERROR: no to user $to in $d";
  88                                 return;
  89                         }
  90                         $d .= "/$name";
  91
  92                         # $name can contain directories so we must create them
  93                         my $to_dir = $d;
  94                         $to_dir =~ s{/[^/]+$}{};
  95                         make_path $to_dir if ! -e $to_dir;
  96
  97                         if ( ! -e $s ) {
  98                                 warn "ERROR: can't find source $s";
  99                         } else {
 100
 101                                 warn "link $s -> $d\n";
 102                                 link $s, $d;
 103
 104                                 my ($l,$f) = ($1,$2) if $s =~ m{users/([^/]+)/blob/(.+)};
 105
 106 #                               my $origin = $self->file_get({
 107 #                                       login => $l,
 108 #                                       file  => $f,
 109 #                               });
 110 #                               $self->new_file($origin);
 111                                 warn "INFO: sent file ",dump($l,$f);
 112                                 my $md5 = $self->{md5}->{$s} || die "no md5 for $s";
 113                                 $self->{md5}->{$d} = $md5;
 114                         }
 115
 116
 117                 } else {
 118                         warn "ERROR: can't SEND To:$to Name:$name Link:$link_to";
 119                 }
 120         }
 121 }
 122
 123 sub transfer {
 124         my ( $self,$data ) = @_;
 125
 126         my $blob = "users/$data->{login}/blob";
 127         my $path = "$blob/$data->{file}";
 128
 129         if ( $data->{itemize} =~ m/^[c>]([fdL])/ ) { # received change/create
 130                 my $type = $1;
 131
 132                 if ( $type eq 'f' ) {
 133                         $self->modify_file( $data );
 134                         $self->dedup( $data, $path );
 135                 } elsif ( $type eq 'd' ) {
 136                         $self->make_dir( $data );
 137                 } elsif ( $type eq 'L' ) {
 138                         $self->new_link( $data );
 139                 } else {
 140                         die "unknown type $type ", dump $data;
 141                 }
 142         } elsif ( $data->{itemize} =~ m/\*deleting/ ) {
 143                 $self->remove_file($data);
 144         }
 145         return $data;
 146 }
 147
 148 sub md5pool {
 149         my ( $self, $path, $md5 ) = @_;
 150
 151         my $pool = 'md5'; # FIXME sharding?
 152         mkdir $pool unless -e $pool;
 153
 154         if ( -e "$pool/$md5" ) {
 155                 warn "dedup hit $md5 $path\n";
 156                 my $dedup = $path . '.dedup';
 157                 rename $path, $dedup;
 158                 link "$pool/$md5", $path;
 159                 unlink $dedup;
 160                 # FIXME fix perms?
 161         } else {
 162                 link $path, "$pool/$md5";
 163         }
 164
 165         $self->{md5}->{$path} = $md5;
 166         warn "++ $md5 $path\n";
 167 }
 168
 169 my $empty_md5 = " " x 32;
 170
 171 sub dedup {
 172         my ( $self, $data, $path ) = @_;
 173
 174         if ( $data->{file} =~ /^(.+\/)?md5sum$/ ) {
 175                 my $dir = $1;
 176                 my $imported = 0;
 177                 warn "IMPORT ", $data->{file}, "\n";
 178                 open(my $md5sum, '<', $path);
 179                 while(<$md5sum>) {
 180                         chomp;
 181                         my ( $md5, $file ) = split(/\s+/,$_,2);
 182                         if ( ! -e "md5/$md5" ) {
 183                                 warn "MISSING $md5 $file\n";
 184                                 next;
 185                         }
 186                         my $new = "users/$data->{login}/blob/$dir$file";
 187                         if ( ! -e $new ) {
 188                                 # create path from md5sum file
 189                                 my $only_dir = $1 if $new =~ m{^(.+)/[^/]+$};
 190                                 make_path $only_dir unless -d $only_dir;
 191                                 $imported += link "md5/$md5", $new;
 192                                 my $fake = {
 193                                         login => $data->{login},
 194                                         host => $data->{host},
 195                                         file => $dir . $file,
 196                                         md5 => $md5,
 197                                         size => -s $new,
 198                                 };
 199                                 $self->new_file($fake);
 200                                 warn "import from $path ",dump($fake);
 201                         } else {
 202                                 $self->md5pool( $new => $md5 );
 203                         }
 204                 }
 205                 print "INFO imported $imported files from ",dump($data);
 206         }
 207
 208         if ( $data->{md5} ne $empty_md5 ) {
 209                 $self->md5pool( $path => $data->{md5} );
 210         } else {
 211                 warn "empty md5", dump $data;
 212         }
 213 }
 214
 215 1;