lib/MooseX/Storage/Base/WithChecksum.pm

   1 package MooseX::Storage::Base::WithChecksum;
   2 use Moose::Role;
   3
   4 with 'MooseX::Storage::Basic';
   5
   6 use Digest       ();
   7 use Data::Dumper ();
   8
   9 our $VERSION   = '0.32';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 our $DIGEST_MARKER = '__DIGEST__';
  13
  14 around pack => sub {
  15     my $orig = shift;
  16     my $self = shift;
  17     my @args = @_;
  18
  19     my $collapsed = $self->$orig( @args );
  20
  21     $collapsed->{$DIGEST_MARKER} = $self->_digest_packed($collapsed, @args);
  22
  23     return $collapsed;
  24 };
  25
  26 around unpack  => sub {
  27     my ($orig, $class, $data, @args) = @_;
  28
  29     # check checksum on data
  30     my $old_checksum = delete $data->{$DIGEST_MARKER};
  31
  32     my $checksum = $class->_digest_packed($data, @args);
  33
  34     ($checksum eq $old_checksum)
  35         || confess "Bad Checksum got=($checksum) expected=($old_checksum)";
  36
  37     $class->$orig( $data, @args );
  38 };
  39
  40
  41 sub _digest_packed {
  42     my ( $self, $collapsed, @args ) = @_;
  43
  44     my $d = $self->_digest_object(@args);
  45
  46     {
  47         local $Data::Dumper::Indent   = 0;
  48         local $Data::Dumper::Sortkeys = 1;
  49         local $Data::Dumper::Terse    = 1;
  50         local $Data::Dumper::Useqq    = 0;
  51         local $Data::Dumper::Deparse  = 0; # FIXME?
  52         my $str = Data::Dumper::Dumper($collapsed);
  53         # NOTE:
  54         # Canonicalize numbers to strings even if it
  55         # mangles numbers inside strings. It really
  56         # does not matter since its just the checksum
  57         # anyway.
  58         # - YK/SL
  59         $str =~ s/(?<! ['"] ) \b (\d+) \b (?! ['"] )/'$1'/gx;
  60         $d->add( $str );
  61     }
  62
  63     return $d->hexdigest;
  64 }
  65
  66 sub _digest_object {
  67     my ( $self, %options ) = @_;
  68     my $digest_opts = $options{digest};
  69
  70     $digest_opts = [ $digest_opts ]
  71         if !ref($digest_opts) or ref($digest_opts) ne 'ARRAY';
  72
  73     my ( $d, @args ) = @$digest_opts;
  74
  75     if ( ref $d ) {
  76         if ( $d->can("clone") ) {
  77             return $d->clone;
  78         }
  79         elsif ( $d->can("reset") ) {
  80             $d->reset;
  81             return $d;
  82         }
  83         else {
  84             die "Can't clone or reset digest object: $d";
  85         }
  86     }
  87     else {
  88         return Digest->new($d || "SHA-1", @args);
  89     }
  90 }
  91
  92 no Moose::Role;
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 MooseX::Storage::Base::WithChecksum - A more secure serialization role
 103
 104 =head1 DESCRIPTION
 105
 106 This is an early implementation of a more secure Storage role,
 107 which does integrity checks on the data. It is still being
 108 developed so I recommend using it with caution.
 109
 110 Any thoughts, ideas or suggestions on improving our technique
 111 are very welcome.
 112
 113 =head1 METHODS
 114
 115 =over 4
 116
 117 =item B<pack (?$salt)>
 118
 119 =item B<unpack ($data, ?$salt)>
 120
 121 =back
 122
 123 =head2 Introspection
 124
 125 =over 4
 126
 127 =item B<meta>
 128
 129 =back
 130
 131 =head1 BUGS
 132
 133 All complex software has bugs lurking in it, and this module is no
 134 exception. If you find a bug please either email me, or add the bug
 135 to cpan-RT.
 136
 137 =head1 AUTHOR
 138
 139 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 140
 141 Yuval Kogman
 142
 143 =head1 COPYRIGHT AND LICENSE
 144
 145 Copyright 2007-2008 by Infinity Interactive, Inc.
 146
 147 L<http://www.iinteractive.com>
 148
 149 This library is free software; you can redistribute it and/or modify
 150 it under the same terms as Perl itself.
 151
 152 =cut