Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Cipher.pm

   1 package File::KDBX::Cipher;
   2 # ABSTRACT: A block cipher mode or cipher stream
   3
   4 use warnings;
   5 use strict;
   6
   7 use Devel::GlobalDestruction;
   8 use File::KDBX::Constants qw(:cipher :random_stream);
   9 use File::KDBX::Error;
  10 use File::KDBX::Util qw(erase format_uuid);
  11 use Module::Load;
  12 use Scalar::Util qw(looks_like_number);
  13 use namespace::clean;
  14
  15 our $VERSION = '999.999'; # VERSION
  16
  17 my %CIPHERS;
  18
  19 =method new
  20
  21 =method new_from_uuid
  22
  23 =method new_from_stream_id
  24
  25     $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
  26     # OR
  27     $cipher = File::KDBX::Cipher->new_from_uuid($uuid, key => $key, iv => $iv);
  28
  29     $cipher = File::KDBX::Cipher->new(stream_id => $id, key => $key);
  30     # OR
  31     $cipher = File::KDBX::Cipher->new_from_stream_id($id, key => $key);
  32
  33 Construct a new L<File::KDBX::Cipher>.
  34
  35 This is a factory method which returns a subclass.
  36
  37 =cut
  38
  39 sub new {
  40     my $class = shift;
  41     my %args = @_;
  42
  43     return $class->new_from_uuid(delete $args{uuid}, %args) if defined $args{uuid};
  44     return $class->new_from_stream_id(delete $args{stream_id}, %args) if defined $args{stream_id};
  45
  46     throw 'Must pass uuid or stream_id';
  47 }
  48
  49 sub new_from_uuid {
  50     my $class = shift;
  51     my $uuid  = shift;
  52     my %args  = @_;
  53
  54     $args{key} or throw 'Missing encryption key';
  55     $args{iv}  or throw 'Missing encryption IV';
  56
  57     my $formatted_uuid = format_uuid($uuid);
  58
  59     my $cipher = $CIPHERS{$uuid} or throw "Unsupported cipher ($formatted_uuid)", uuid => $uuid;
  60     ($class, my %registration_args) = @$cipher;
  61
  62     my @args = (%args, %registration_args, uuid => $uuid);
  63     load $class;
  64     my $self = bless {@args}, $class;
  65     return $self->init(@args);
  66 }
  67
  68 sub new_from_stream_id {
  69     my $class = shift;
  70     my $id    = shift;
  71     my %args  = @_;
  72
  73     $args{key} or throw 'Missing encryption key';
  74
  75     my $cipher = $CIPHERS{$id} or throw "Unsupported stream cipher ($id)", id => $id;
  76     ($class, my %registration_args) = @$cipher;
  77
  78     my @args = (%args, %registration_args, stream_id => $id);
  79     load $class;
  80     my $self = bless {@args}, $class;
  81     return $self->init(@args);
  82 }
  83
  84 =method init
  85
  86     $self->init;
  87
  88 Initialize the cipher. Called by </new>.
  89
  90 =cut
  91
  92 sub init { $_[0] }
  93
  94 sub DESTROY { !in_global_destruction and erase \$_[0]->{key} }
  95
  96 =attr uuid
  97
  98     $uuid = $cipher->uuid;
  99
 100 Get the UUID if the cipher was constructed with one.
 101
 102 =cut
 103
 104 sub uuid { $_[0]->{uuid} }
 105
 106 =attr stream_id
 107
 108     $stream_id = $cipher->stream_id;
 109
 110 Get the stream ID if the cipher was constructed with one.
 111
 112 =cut
 113
 114 sub stream_id { $_[0]->{stream_id} }
 115
 116 =attr key
 117
 118     $key = $cipher->key;
 119
 120 Get the raw encryption key.
 121
 122 =cut
 123
 124 sub key { $_[0]->{key} }
 125
 126 =attr iv
 127
 128     $iv = $cipher->iv;
 129
 130 Get the initialization vector.
 131
 132 =cut
 133
 134 sub iv { $_[0]->{iv} }
 135
 136 =attr iv_size
 137
 138     $size = $cipher->iv_size;
 139
 140 Get the expected size of the initialization vector, in bytes.
 141
 142 =cut
 143
 144 sub iv_size { 0 }
 145
 146 =attr key_size
 147
 148     $size = $cipher->key_size;
 149
 150 Get the size the mode or stream expects the key to be, in bytes.
 151
 152 =cut
 153
 154 sub key_size { -1 }
 155
 156 =attr block_size
 157
 158     $size = $cipher->block_size;
 159
 160 Get the block size, in bytes.
 161
 162 =cut
 163
 164 sub block_size { 0 }
 165
 166 =method encrypt
 167
 168     $ciphertext = $cipher->encrypt($plaintext, ...);
 169
 170 Encrypt some data.
 171
 172 =cut
 173
 174 sub encrypt { die "Not implemented" }
 175
 176 =method decrypt
 177
 178     $plaintext = $cipher->decrypt($ciphertext, ...);
 179
 180 Decrypt some data.
 181
 182 =cut
 183
 184 sub decrypt { die "Not implemented" }
 185
 186 =method finish
 187
 188     $ciphertext .= $cipher->finish; # if encrypting
 189     $plaintext  .= $cipher->finish; # if decrypting
 190
 191 Finish the stream.
 192
 193 =cut
 194
 195 sub finish { '' }
 196
 197 =method encrypt_finish
 198
 199     $ciphertext = $cipher->encrypt_finish($plaintext, ...);
 200
 201 Encrypt and finish a stream in one call.
 202
 203 =cut
 204
 205 sub encrypt_finish {
 206     my $self = shift;
 207     my $out = $self->encrypt(@_);
 208     $out .= $self->finish;
 209     return $out;
 210 }
 211
 212 =method decrypt_finish
 213
 214     $plaintext = $cipher->decrypt_finish($ciphertext, ...);
 215
 216 Decrypt and finish a stream in one call.
 217
 218 =cut
 219
 220 sub decrypt_finish {
 221     my $self = shift;
 222     my $out = $self->decrypt(@_);
 223     $out .= $self->finish;
 224     return $out;
 225 }
 226
 227 =method register
 228
 229     File::KDBX::Cipher->register($uuid => $package, %args);
 230
 231 Register a cipher. Registered ciphers can be used to encrypt and decrypt KDBX databases. A cipher's UUID
 232 B<must> be unique and B<musn't change>. A cipher UUID is written into each KDBX file and the associated cipher
 233 must be registered with the same UUID in order to decrypt the KDBX file.
 234
 235 C<$package> should be a Perl package relative to C<File::KDBX::Cipher::> or prefixed with a C<+> if it is
 236 a fully-qualified package. C<%args> are passed as-is to the cipher's L</init> method.
 237
 238 =cut
 239
 240 sub register {
 241     my $class   = shift;
 242     my $id      = shift;
 243     my $package = shift;
 244     my @args    = @_;
 245
 246     my $formatted_id = looks_like_number($id) ? $id : format_uuid($id);
 247     $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/;
 248
 249     my %blacklist = map { (looks_like_number($_) ? $_ : File::KDBX::Util::uuid($_)) => 1 }
 250         split(/,/, $ENV{FILE_KDBX_CIPHER_BLACKLIST} // '');
 251     if ($blacklist{$id} || $blacklist{$package}) {
 252         alert "Ignoring blacklisted cipher ($formatted_id)", id => $id, package => $package;
 253         return;
 254     }
 255
 256     if (defined $CIPHERS{$id}) {
 257         alert "Overriding already-registered cipher ($formatted_id) with package $package",
 258             id      => $id,
 259             package => $package;
 260     }
 261
 262     $CIPHERS{$id} = [$package, @args];
 263 }
 264
 265 =method unregister
 266
 267     File::KDBX::Cipher->unregister($uuid);
 268
 269 Unregister a cipher. Unregistered ciphers can no longer be used to encrypt and decrypt KDBX databases, until
 270 reregistered (see L</register>).
 271
 272 =cut
 273
 274 sub unregister {
 275     delete $CIPHERS{$_} for @_;
 276 }
 277
 278 BEGIN {
 279     __PACKAGE__->register(CIPHER_UUID_AES128,   'CBC',    algorithm => 'AES',     key_size => 16);
 280     __PACKAGE__->register(CIPHER_UUID_AES256,   'CBC',    algorithm => 'AES',     key_size => 32);
 281     __PACKAGE__->register(CIPHER_UUID_SERPENT,  'CBC',    algorithm => 'Serpent', key_size => 32);
 282     __PACKAGE__->register(CIPHER_UUID_TWOFISH,  'CBC',    algorithm => 'Twofish', key_size => 32);
 283     __PACKAGE__->register(CIPHER_UUID_CHACHA20, 'Stream', algorithm => 'ChaCha');
 284     __PACKAGE__->register(CIPHER_UUID_SALSA20,  'Stream', algorithm => 'Salsa20');
 285     __PACKAGE__->register(STREAM_ID_CHACHA20,   'Stream', algorithm => 'ChaCha');
 286     __PACKAGE__->register(STREAM_ID_SALSA20,    'Stream', algorithm => 'Salsa20');
 287 }
 288
 289 1;
 290 __END__
 291
 292 =head1 SYNOPSIS
 293
 294     use File::KDBX::Cipher;
 295
 296     my $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
 297
 298     my $ciphertext = $cipher->encrypt('data');
 299     $ciphertext .= $cipher->encrypt('more data');
 300     $ciphertext .= $cipher->finish;
 301
 302     my $plaintext = $cipher->decrypt('data');
 303     $plaintext .= $cipher->decrypt('more data');
 304     $plaintext .= $cipher->finish;
 305
 306 =head1 DESCRIPTION
 307
 308 A cipher is used to encrypt and decrypt KDBX files. The L<File::KDBX> distribution comes with several
 309 pre-registered ciphers ready to go:
 310
 311 =for :list
 312 * C<61AB05A1-9464-41C3-8D74-3A563DF8DD35> - AES128 (legacy)
 313 * C<31C1F2E6-BF71-4350-BE58-05216AFC5AFF> - AES256
 314 * C<D6038A2B-8B6F-4CB5-A524-339A31DBB59A> - ChaCha20
 315 * C<716E1C8A-EE17-4BDC-93AE-A977B882833A> - Salsa20
 316 * C<098563FF-DDF7-4F98-8619-8079F6DB897A> - Serpent
 317 * C<AD68F29F-576F-4BB9-A36A-D47AF965346C> - Twofish
 318
 319 B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and
 320 algorithm that they support. From the list above, AES256 and ChaCha20 are well-supported. You should avoid
 321 AES128 for new databases.
 322
 323 You can also L</register> your own cipher. Here is a skeleton:
 324
 325     package File::KDBX::Cipher::MyCipher;
 326
 327     use parent 'File::KDBX::Cipher';
 328
 329     File::KDBX::Cipher->register(
 330         # $uuid, $package, %args
 331         "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__,
 332     );
 333
 334     sub init { ... } # optional
 335
 336     sub encrypt { ... }
 337     sub decrypt { ... }
 338     sub finish  { ... }
 339
 340     sub key_size   { ... }
 341     sub iv_size    { ... }
 342     sub block_size { ... }
 343
 344 =cut