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 = shift;
  18
  19         my $self = {@_};
  20         bless $self, $class;
  21
  22         die "no dir" unless $self->{dir};
  23         $self->{md5pool} = $self->{dir} . '/md5';
  24
  25         warn "# new ",dump $self if $ENV{DEBUG};
  26
  27         return $self;
  28 }
  29
  30 sub user_set {
  31         my ( $self,$data ) = @_;
  32 }
  33
  34 sub user_get {
  35         my ( $self,$data ) = @_;
  36 }
  37
  38 sub modify_file {
  39         my ( $self,$data ) = @_;
  40
  41 #       if ( my $old = $self->file_get( $data ) ) {
  42 #               $self->usage_decr( $data );
  43 #       }
  44
  45         $self->new_file($data);
  46 }
  47
  48 sub new_file {
  49         my ( $self,$data ) = @_;
  50 #       $self->file_set($data);
  51 #       $self->usage_incr($data);
  52 }
  53
  54 sub remove_file {
  55         my ( $self, $data ) = @_;
  56 #       $self->usage_decr( $data );
  57
  58         my $md5sum = $self->md5sum($data);
  59         if ( ! exists $md5sum->{ $data->{file} } ) {
  60                 warn "ERROR: no md5 for ",dump $data;
  61                 return;
  62         }
  63         my $md5 = $md5sum->{ $data->{file} };
  64         my $path = $self->{md5pool} . '/' . $md5;
  65         my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  66                 $atime,$mtime,$ctime,$blksize,$blocks)
  67                         = stat($path);
  68         if ( $nlink == 1 ) {
  69                 my $id = getpwnam 'md5';
  70                 chown $id,$gid, $path;
  71                 warn "# chown $id $gid $path";
  72         }
  73 }
  74
  75 sub make_dir {
  76         my ( $self, $data ) = @_;
  77
  78 }
  79
  80 sub new_link {
  81         my ( $self, $data ) = @_;
  82
  83         warn "# new_link ",dump $data;
  84
  85         if ( $data->{file} =~ m{^(.*/?)\.send/([^/]+)/(.+)$} ) {
  86                 my ( $dir, $to, $name ) = ( $1, $2, $3 );
  87                 my $path = $self->blob_path($data);
  88                 my $link_to = readlink $path;
  89                 warn "$link_to";
  90                 if ( $link_to =~ s{^\Q/rsyncd-munged/\E}{/} ) {
  91
  92                         my $s = $path;
  93                         $s =~ s{/[^/]+$}{}; # strip filename
  94                         while ( $link_to =~ s{/../}{/} ) {
  95                                 $s =~ s{/[^/]+$}{} || die "can't strip $s";
  96                                 warn "## simplify $s $link_to\n";
  97                         }
  98                         $s .= $link_to;
  99
 100                         my $d = $self->blob_path({
 101                                 pid => $data->{pid},
 102                                 file => $name
 103                         });
 104
 105                         # $name can contain directories so we must create them
 106                         my $to_dir = $d;
 107                         $to_dir =~ s{/[^/]+$}{};
 108                         make_path $to_dir if ! -e $to_dir;
 109
 110                         if ( ! -e $s ) {
 111                                 warn "ERROR: can't find source $s";
 112                         } else {
 113
 114                                 warn "link $s -> $d\n";
 115                                 link $s, $d;
 116
 117                                 my ($l,$f) = ($1,$2) if $s =~ m{users/([^/]+)/blob/(.+)};
 118
 119 #                               my $origin = $self->file_get({
 120 #                                       login => $l,
 121 #                                       file  => $f,
 122 #                               });
 123 #                               $self->new_file($origin);
 124                                 warn "INFO: sent file ",dump($l,$f);
 125                                 my $md5sum = $self->md5sum($data);
 126
 127                                 my $md5 = $md5sum->{$s} || die "no md5 for $s";
 128                                 $md5sum->{$d} = $md5; # FIXME broken!
 129                         }
 130
 131
 132                 } else {
 133                         warn "ERROR: can't SEND To:$to Name:$name Link:$link_to";
 134                 }
 135         }
 136 }
 137
 138 our $md5_login;
 139 sub md5sum {
 140         my ( $self, $data ) = @_;
 141
 142         if ( exists $md5_login->{$data->{login}} ) {
 143                 return $md5_login->{$data->{login}};
 144         } elsif ( my $login = $data->{login} ) {
 145
 146                 my $md5_path = $self->{dir} || die "no dir?";
 147                 $login =~ s/^u//;
 148                 $md5_path .= "/$login/.md5.db";
 149
 150                 my %md5;
 151                 my $db = tie %md5, 'BerkeleyDB::Hash',
 152                         -Filename => $md5_path,
 153                         -Flags => DB_CREATE,
 154                 ;
 155
 156                 return $md5_login->{$login} = \%md5;
 157         } else {
 158                 confess "can't open md5sum";
 159         }
 160 }
 161
 162 sub rsync_log {
 163         my ( $self, $data ) = @_;
 164         if ( $data =~ m/\[(\d+)\] rsync \w+ (\S+) \w+ (\S+)/ ) {
 165                 my ( $pid, $module, $login ) = ( $1, $2, $3 );
 166
 167                 $login =~ s/\@.+//;
 168                 my ( undef, undef, $uid, $gid, undef, undef, $email, $dir, $shell ) =
 169                         getpwnam $login;
 170
 171                 $self->{pid}->{$pid} = {
 172                         login => $login,
 173                         uid => $uid,
 174                         gid => $gid,
 175                         email => $email,
 176                         dir => $dir,
 177                         shell => $shell,
 178                 };
 179
 180                 warn "created $pid";
 181
 182         } elsif ( $data =~ m/\[(\d+)\] sent \S+ bytes\s+received \S+ bytes/ ) {
 183                 my $pid = $1;
 184                 untie $md5_login->{ $self->{$pid}->{login} } && warn "untie $pid";
 185                 delete $self->{pid}->{$pid};
 186                 warn "removed $pid";
 187         } else {
 188 #               warn "## rsync_log $data";
 189         }
 190 }
 191
 192 sub blob_path {
 193         my ( $self, $data ) = @_;
 194         my $blob = $self->{pid}->{ $data->{pid} }->{dir} || die "no dir for $data->{pid} in ",dump( $self->{pid} );
 195         $blob .= '/' . $data->{file};
 196         return $blob;
 197 }
 198
 199
 200 sub rsync_transfer {
 201         my ( $self,$data ) = @_;
 202
 203         my $path = $self->blob_path($data);
 204
 205         if ( $data->{itemize} =~ m/^[c>]([fdL])/ ) { # received change/create
 206                 my $type = $1;
 207
 208                 if ( $type eq 'f' ) {
 209                         $self->modify_file( $data );
 210                         $self->dedup( $data, $path );
 211                 } elsif ( $type eq 'd' ) {
 212                         $self->make_dir( $data );
 213                 } elsif ( $type eq 'L' ) {
 214                         $self->new_link( $data );
 215                 } else {
 216                         die "unknown type $type ", dump $data;
 217                 }
 218         } elsif ( $data->{itemize} =~ m/\*deleting/ ) {
 219                 $self->remove_file($data);
 220         }
 221         return $data;
 222 }
 223
 224 sub md5pool {
 225         my ( $self, $data ) = @_;
 226
 227         my $pool = $self->{md5pool} || die "no md5pool in ",dump $self;
 228         mkdir $pool unless -e $pool;
 229
 230         my $md5 = $data->{md5} || die "no md5 in ",dump $data;
 231         my $path = $self->blob_path($data);
 232
 233         if ( -e "$pool/$md5" ) {
 234                 warn "dedup hit $md5 $path\n";
 235                 my $dedup = $path . '.dedup';
 236                 rename $path, $dedup;
 237                 link "$pool/$md5", $path;
 238                 unlink $dedup;
 239                 # FIXME fix perms?
 240         } else {
 241                 link $path, "$pool/$md5";
 242         }
 243
 244         my $md5sum = $self->md5sum($data);
 245         $md5sum->{ $data->{file} } = $md5;
 246 }
 247
 248 my $empty_md5 = " " x 32;
 249
 250 sub dedup {
 251         my ( $self, $data, $path ) = @_;
 252
 253         if ( $data->{file} =~ /^(.+\/)?md5sum$/ ) {
 254                 my $dir = $1;
 255                 my $imported = 0;
 256                 warn "IMPORT ", $data->{file}, "\n";
 257                 open(my $md5sum, '<', $path);
 258                 while(<$md5sum>) {
 259                         chomp;
 260                         my ( $md5, $file ) = split(/\s+/,$_,2);
 261                         if ( ! -e "$self->{md5path}/$md5" ) {
 262                                 warn "MISSING $md5 $file\n";
 263                                 next;
 264                         }
 265                         my $new = {
 266                                 pid => $data->{pid},
 267                                 file => "$dir$file",
 268                                 md5 => $md5,
 269                         };
 270                         my $new_path = $self->blob_path($new);
 271                         if ( ! -e $new_path ) {
 272                                 # create path from md5sum file
 273                                 my $only_dir = $1 if $new =~ m{^(.+)/[^/]+$};
 274                                 make_path $only_dir unless -d $only_dir;
 275                                 $imported += link "$self->{md5path}/$md5", $new_path;
 276                                 $self->new_file($new);
 277                                 warn "import from $path ",dump($new);
 278                                 $self->md5pool( $new );
 279                         } else {
 280                                 $self->md5pool( $new );
 281                         }
 282                 }
 283                 print "INFO imported $imported files from ",dump($data);
 284         }
 285
 286         if ( $data->{md5} ne $empty_md5 ) {
 287                 $self->md5pool( $data );
 288         } else {
 289                 warn "empty md5", dump $data;
 290         }
 291 }
 292
 293 1;