LBS.pm

   1 =head1 NAME
   2
   3 LBS - Perl interface to Log-Structured Backup stores
   4
   5 =cut
   6
   7 package LBS;
   8
   9 use strict;
  10
  11 BEGIN {
  12     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
  13
  14     # Totally unstable API.
  15     $VERSION = '0.01';
  16
  17 =head1 SYNOPSIS
  18
  19     use LBS;
  20
  21     my $store = new LBS::Store;
  22
  23 =cut
  24
  25     require Exporter;
  26
  27     @ISA = qw(Exporter);
  28     @EXPORT = qw();
  29     @EXPORT_OK = qw(parse_headers);
  30
  31 =head1 DESCRIPTION
  32
  33 This module makes it easy to write Perl scripts that work with backup snapshots
  34 produced by LBS (the Log-Structured Backup System).  Various LBS utilities will
  35 use it.
  36
  37 =cut
  38
  39     use Carp qw(carp croak);
  40 }
  41
  42 =head1 CLASSES
  43
  44 =head2 LBS::ChecksumVerifier
  45
  46 =over 4
  47
  48 =item new LBS::ChecksumVerifier ( CHECKSUM )
  49
  50 Parse the checksum string C<CHECKSUM> and return an object which can be used to
  51 verify the integrity of a piece of data.  The data can be fed incrementally to
  52 the returned object, and at the end a call can be made to see if the data
  53 matches the originally-supplied checksum.
  54
  55 =cut
  56
  57 {
  58     package LBS::ChecksumVerifier;
  59     use Digest::SHA1;
  60
  61     sub new {
  62         my $class = shift;
  63         my $self = { };
  64         $self->{CHECKSUM} = shift;
  65
  66         if ($self->{CHECKSUM} !~ m/^(\w+)=([0-9a-f]+)$/) {
  67             die "Malformed checksum: $self->{CHECKSUM}";
  68         }
  69
  70         my $algorithm = $1;
  71         $self->{HASH} = $2;
  72         if ($algorithm ne 'sha1') {
  73             die "Unsupported checksum algorithm: $algorithm";
  74         }
  75
  76         $self->{DIGESTER} = new Digest::SHA1;
  77
  78         bless $self, $class;
  79         return $self;
  80     }
  81
  82     sub add {
  83         my $self = shift;
  84         my $data = shift;
  85         $self->{DIGESTER}->add($data);
  86     }
  87
  88     sub verify {
  89         my $self = shift;
  90         my $newhash = $self->{DIGESTER}->hexdigest();
  91         return ($self->{HASH} eq $newhash);
  92     }
  93 }
  94
  95 =head2 LBS::Store
  96
  97 =item new LBS::Store ( DIRECTORY )
  98
  99 Construct a new Store object, which is used to get access to segments and
 100 metadata files containing snapshots.  The data may be stored in a local
 101 directory, or might be fetched from a remote server.  The constructor above is
 102 for local access, and takes as a single argument the name of the directory
 103 containing all files.
 104
 105 =item load_ref ( REFSTR )
 106
 107 Load the object contents referenced by the given C<REFSTR>.  This will
 108 automatically validate any object checksums.
 109
 110 =cut
 111
 112 {
 113     package LBS::Store;
 114     use File::Temp qw(tempdir);
 115
 116     my $SEGMENT_PATTERN
 117         = '[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}';
 118
 119     sub new {
 120         my $class = shift;
 121         my $self = { };
 122         $self->{DIR} = shift;
 123         $self->{TMPDIR} = tempdir("lbs.XXXXXX", TMPDIR => 1);
 124
 125         print STDERR "### Tempdir is $self->{TMPDIR}\n";
 126
 127         $self->{EXTENSION} = ".gpg";
 128         $self->{FILTER} = "lbs-filter-gpg --decrypt";
 129
 130         $self->{CACHED} = [ ];
 131
 132         bless $self, $class;
 133         return $self;
 134     }
 135
 136     sub DESTROY {
 137         my $self = shift;
 138         $self->_lru_clean(0);
 139         print STDERR "### Cleaning temporary directory $self->{TMPDIR}\n";
 140         system("rm", "-rf", $self->{TMPDIR});
 141     }
 142
 143     sub _lru_update {
 144         my $self = shift;
 145         my $segment = shift;
 146         my @cache = @{$self->{CACHED}};
 147         @cache = grep { $_ ne $segment } @cache;
 148         push @cache, $segment;
 149         $self->{CACHED} = [ @cache ];
 150     }
 151
 152     sub _lru_clean {
 153         my $self = shift;
 154         my $limit = shift;
 155         $limit = 16 unless defined($limit);
 156
 157         my @cache = @{$self->{CACHED}};
 158         while (scalar @cache > $limit) {
 159             my $segment = shift @cache;
 160             my $dir = "$self->{TMPDIR}/$segment";
 161             print STDERR "### Cleaning segment $segment\n";
 162             system("rm", "-rf", $dir);
 163         }
 164         $self->{CACHED} = [ @cache ];
 165     }
 166
 167     sub _extract {
 168         my $self = shift;
 169         my $segment = shift;
 170
 171         if (grep { $_ eq $segment } @{$self->{CACHED}}) {
 172             $self->_lru_update($segment);
 173             return;
 174         }
 175
 176         my $file = "$self->{DIR}/$segment.tar$self->{EXTENSION}";
 177         die "Can't find segment $file" unless -f $file;
 178
 179         $self->_lru_clean();
 180         print STDERR "### Extracting segment $segment\n";
 181         system("$self->{FILTER} <$file | tar -C $self->{TMPDIR} -xf -");
 182         $self->_lru_update($segment);
 183     }
 184
 185     # Load an object, without any support for object slicing or checksum
 186     # verification.  This method can be overridden by a subclass, and will be
 187     # called by the full object reference parser below.
 188     sub load_object {
 189         my $self = shift;
 190         my $segment = shift;
 191         my $object = shift;
 192
 193         $self->_extract($segment);
 194         my $file = "$self->{TMPDIR}/$segment/$object";
 195         open OBJECT, "<", $file or die "Can't open file $file: $!";
 196         my $contents = join '', <OBJECT>;
 197         close OBJECT;
 198
 199         return $contents;
 200     }
 201
 202     sub load_ref {
 203         my $self = shift;
 204         my $ref = shift;
 205
 206         if ($ref !~ m/^([-0-9a-f]+)\/([0-9a-f]+)(\(\S+\))?(\[\S+\])?$/) {
 207             die "Malformed object reference: $ref";
 208         }
 209
 210         my ($segment, $object, $checksum, $range) = ($1, $2, $3, $4);
 211
 212         my $contents = $self->load_object($segment, $object);
 213
 214         # If a checksum was specified in the object reference, verify the
 215         # object integrity by computing a checksum of the read data and
 216         # comparing.
 217         if ($checksum) {
 218             $checksum =~ m/^\((\S+)\)$/;
 219             my $verifier = new LBS::ChecksumVerifier($1);
 220             $verifier->add($contents);
 221             if (!$verifier->verify()) {
 222                 die "Integrity check for object $ref failed";
 223             }
 224         }
 225
 226         # If a range was specified, then only a subset of the bytes of the
 227         # object are desired.  Extract just the desired bytes.
 228         if ($range) {
 229             if ($range !~ m/^\[(\d+)\+(\d+)\]$/) {
 230                 die "Malformed object range: $range";
 231             }
 232
 233             my $object_size = length $contents;
 234             my ($start, $length) = ($1 + 0, $2 + 0);
 235             if ($start >= $object_size || $start + $length > $object_size) {
 236                 die "Object range $range falls outside object bounds "
 237                     . "(actual size $object_size)";
 238             }
 239
 240             $contents = substr $contents, $start, $length;
 241         }
 242
 243         return $contents;
 244     }
 245
 246     sub list_segments {
 247         my $self = shift;
 248         my %segments = ();
 249         opendir DIR, $self->{DIR};
 250         foreach (readdir DIR) {
 251             if (m/^($SEGMENT_PATTERN)(\.\S+)?$/) {
 252                 $segments{$1} = 1;
 253             }
 254         }
 255         closedir DIR;
 256         return sort keys %segments;
 257     }
 258
 259     sub list_snapshots {
 260         my $self = shift;
 261         my @snapshots = ();
 262         opendir DIR, $self->{DIR};
 263         foreach (readdir DIR) {
 264             if (m/^snapshot-(.*)\.lbs$/) {
 265                 push @snapshots, $1;
 266             }
 267         }
 268         closedir DIR;
 269         return sort @snapshots;
 270     }
 271
 272     sub load_snapshot {
 273         my $self = shift;
 274         my $snapshot = shift;
 275         open SNAPSHOT, "$self->{DIR}/snapshot-$snapshot.lbs"
 276             or return undef;
 277         my $contents = join '', <SNAPSHOT>;
 278         close SNAPSHOT;
 279         return $contents;
 280     }
 281
 282     sub list_objects {
 283         my $self = shift;
 284         my $segment = shift;
 285         $self->_extract($segment);
 286         opendir DIR, "$self->{TMPDIR}/$segment";
 287         my @objects = grep { /[0-9a-f]{8}/ } readdir(DIR);
 288         closedir DIR;
 289         return sort @objects;
 290     }
 291 }
 292
 293 =head2 LBS::MetadataReader
 294
 295 =item new LBS::MetadataReader ( STORE, REF )
 296
 297 =cut
 298
 299 {
 300     package LBS::MetadataReader;
 301
 302     sub new {
 303         my $class = shift;
 304         my $self = { };
 305
 306         $self->{STORE} = shift;
 307         my %args = @_;
 308
 309         $self->{SPLIT_PATTERN} = $args{SPLIT} || '(?<=\n)';
 310
 311         bless $self, $class;
 312
 313         if (exists $args{REF}) {
 314             $self->{DATA} = [ $self->_read($args{REF}) ];
 315         } elsif (exists $args{DATA}) {
 316             my $pattern = $self->{SPLIT_PATTERN};
 317             $self->{DATA} = [ split /$pattern/, $args{DATA} ];
 318         } else {
 319             die "Must specify REF or DATA argument!";
 320         }
 321
 322         return $self;
 323     }
 324
 325     sub _read {
 326         my $self = shift;
 327         my $ref = shift;
 328         my $pattern = $self->{SPLIT_PATTERN};
 329         print STDERR "### Reading from $ref\n";
 330         my @pieces = split /$pattern/, $self->{STORE}->load_ref($ref);
 331         return @pieces;
 332     }
 333
 334     # FIXME: Bound recursion.
 335     sub get {
 336         my $self = shift;
 337
 338         # End of input?
 339         if (!@{$self->{DATA}}) {
 340             return undef;
 341         }
 342
 343         my $item = shift @{$self->{DATA}};
 344
 345         # Check for indirect references
 346         if ($item =~ m/^@(\S*)/) {
 347             unshift @{$self->{DATA}}, $self->_read($1);
 348             return $self->get();
 349         } else {
 350             return $item;
 351         }
 352     }
 353 }
 354
 355 =head2 LBS::MetadataParser
 356
 357 =item new LBS::MetadataParser ( STORE, REF )
 358
 359 =cut
 360
 361 {
 362     package LBS::MetadataParser;
 363
 364     sub new {
 365         my $class = shift;
 366         my $self = { };
 367
 368         $self->{STORE} = shift;
 369         my $ref = shift;
 370         $self->{READER} = new LBS::MetadataReader $self->{STORE}, REF => $ref;
 371
 372         bless $self, $class;
 373         return $self;
 374     }
 375
 376     sub get_item {
 377         my $self = shift;
 378         my %info = ();
 379         my $line;
 380         my $last_key;
 381
 382         $line = $self->{READER}->get();
 383         chomp $line if defined $line;
 384         while (defined($line) && $line ne "") {
 385             if ($line =~ m/^(\w+):\s*(.*)$/) {
 386                 $info{$1} = $2;
 387                 $last_key = $1;
 388             } elsif ($line =~/^\s/ && defined $last_key) {
 389                 $info{$last_key} .= $line;
 390             } else {
 391                 print STDERR "Junk in file metadata section: $line\n";
 392             }
 393
 394             $line = $self->{READER}->get();
 395             chomp $line;
 396         }
 397
 398         # Perform a bit of post-processing on the "data" field, which might
 399         # contain indirect references to blocks.  Pull all the references
 400         # inline.
 401         if (exists $info{data}) {
 402             my $reader = new LBS::MetadataReader($self->{STORE},
 403                                                  DATA => $info{data},
 404                                                  SPLIT => '\s+');
 405             my @blocks = ();
 406             while (($_ = $reader->get())) {
 407                 push @blocks, $_;
 408             }
 409             $info{data} = join " ", @blocks;
 410         }
 411
 412         # Don't return an empty result unless we've hit end-of-file.
 413         if (!%info && defined($line)) {
 414             return $self->get_item();
 415         }
 416
 417         return %info;
 418     }
 419 }
 420
 421 # Parse an RFC822-style list of headers and return a dictionary with the
 422 # results.
 423 sub parse_headers {
 424     my $data = shift;
 425     my %info = ();
 426     my $line;
 427     my $last_key;
 428
 429     foreach $line (split /\n/, $data) {
 430         if ($line =~ m/^(\w+):\s*(.*)$/) {
 431             $info{$1} = $2;
 432             $last_key = $1;
 433         } elsif ($line =~/^\s/ && defined $last_key) {
 434             $info{$last_key} .= $line;
 435         } else {
 436             undef $last_key;
 437             print STDERR "Ignoring line in backup descriptor: $line\n";
 438         }
 439     }
 440
 441     return %info;
 442 }
 443
 444 1;