package Palm::Keyring;

# $RedRiver: Keyring.pm,v 1.17 2007/01/30 05:16:16 andrew Exp $
#
# Perl class for dealing with Keyring for Palm OS databases.
#
#   This started as Memo.pm, I just made it work for Keyring.

use strict;
use warnings;
use Carp;

use base qw/ Palm::StdAppInfo /;

use Digest::MD5 qw(md5);
use Crypt::DES;
use Readonly;

Readonly my $ENCRYPT    => 1;
Readonly my $DECRYPT    => 0;
Readonly my $MD5_CBLOCK => 64;
Readonly my $kSalt_Size => 4;
Readonly my $EMPTY      => q{};
Readonly my $SPACE      => q{ };
Readonly my $NULL       => chr 0;

# One liner, to allow MakeMaker to work.
our $VERSION = 0.91;

sub new {
    my $classname = shift;
    my $pass      = shift;

    # Create a generic PDB. No need to rebless it, though.
    my $self = $classname->SUPER::new(@_);

    $self->{'name'}    = 'Keys-Gtkr';    # Default
    $self->{'creator'} = 'Gtkr';
    $self->{'type'}    = 'Gkyr';

    # The PDB is not a resource database by
    # default, but it's worth emphasizing,
    # since MemoDB is explicitly not a PRC.
    $self->{'attributes'}{'resource'} = 0;

    # Initialize the AppInfo block
    $self->{'appinfo'} = {};

    # Add the standard AppInfo block stuff
    Palm::StdAppInfo::seed_StdAppInfo( $self->{'appinfo'} );

    # Set the version
    $self->{'version'} = 4;

    if ( defined $pass ) {
        $self->Password($pass);
    }

    return $self;
}

sub import {
    Palm::PDB::RegisterPDBHandlers( __PACKAGE__, [ 'Gtkr', 'Gkyr' ], );
    return 1;
}

sub ParseRecord {
    my $self     = shift;

    my $rec = $self->SUPER::ParseRecord(@_);

    # skip the 0 record that holds the password
    return $rec if ! exists $self->{'records'}; 

    # skip records with no data (There shouldn't be any)
    return $rec if ! exists $rec->{'data'};

    my ( $name, $encrypted ) = split /$NULL/xm, $rec->{'data'}, 2;

    return $rec if ! $encrypted;
    $rec->{'data'} = $name;
    $rec->{'encrypted'} = $encrypted;

    return $rec;
}

sub PackRecord {
    my $self = shift;
    my $rec  = shift;

    my $rec0_id = $self->{'records'}->[0]->{'id'};

    if ($rec->{'encrypted'} && ! $rec->{'id'} == $rec0_id) {
        $rec->{'data'} = join $NULL, $rec->{'data'}, $rec->{'encrypted'};
        delete $rec->{'encrypted'};
    }

    return $self->SUPER::PackRecord($rec, @_);
}

sub Encrypt {
    my $self = shift;
    my $rec  = shift;
    my $data = shift;
    my $pass = shift || $self->{'password'};

    if ( ! $pass) {
        croak("'password' not set!\n");
    }

    if ( ! $rec) {
        croak("Needed parameter 'record' not passed!\n");
    }

    if ( ! $data) {
        croak("Needed parameter 'data' not passed!\n");
    }

    if ( ! $self->Password($pass)) {
        croak("Incorrect Password!\n");
    }

    $self->{'digest'} ||= _calc_keys( $pass );

    $data->{'account'}  ||= $EMPTY;
    $data->{'password'} ||= $EMPTY;
    $data->{'notes'}    ||= $EMPTY;

    my $plaintext = join $NULL, 
        $data->{'account'}, $data->{'password'}, $data->{'notes'};

    my $encrypted = _crypt3des( $plaintext, $self->{'digest'}, $ENCRYPT );

    return if ! $encrypted;

    $rec->{'data'} ||= $data->{'name'};
    $rec->{'encrypted'} = $encrypted;
    return 1;
}

sub Decrypt {
    my $self = shift;
    my $rec  = shift;
    my $pass = shift || $self->{'password'};

    if ( ! $pass) {
        croak("'password' not set!\n");
    }

    if ( ! $rec) {
        carp("Needed parameter 'record' not passed!\n");
        return;
    }

    if ( ! $self->Password($pass)) {
        croak("Invalid Password!\n");
    }

    if ( ! $rec->{'encrypted'} ) {
        croak("No encrypted content!");
    }

    $self->{'digest'} ||= _calc_keys( $pass );

    my $decrypted = 
        _crypt3des( $rec->{'encrypted'}, $self->{'digest'}, $DECRYPT );
    my ( $account, $password, $notes, $extra ) = split /$NULL/xm,
          $decrypted, 4;

    return {
        account  => $account,
        password => $password,
        notes    => $notes,
    };
}

sub Password {
    my $self = shift;
    my $pass = shift || $self->{'password'};
    my $new_pass = shift;

    if (! exists $self->{'records'}) {
        # Give the PDB the first record that will hold the encrypted password
        $self->{'records'} = [ $self->new_Record ];

        return $self->_password_update($pass);
    }

    if ($new_pass) {
        my @accts = ();
        foreach my $i (0..$#{ $self->{'records'} }) {
            if ($i == 0) {
                push @accts, undef;
                next;
            }
            my $acct = $self->Decrypt($self->{'records'}->[$i], $pass);
            if ( ! $acct ) {
                croak("Couldn't decrypt $self->{'records'}->[$i]->{'data'}");
            }
            push @accts, $acct;
        }

        if ( ! $self->_password_update($new_pass)) {
            croak("Couldn't set new password!");
        }
        $pass = $new_pass;

        foreach my $i (0..$#accts) {
            next if $i == 0;
            $self->Encrypt($self->{'records'}->[$i], $accts[$i], $pass);
        }
    }

    return $self->_password_verify($pass);
}

sub _calc_keys {
    my $pass = shift;
    if (! defined $pass) { croak('No password defined!'); };

    my $digest = md5($pass);

    my ( $key1, $key2 ) = unpack 'a8a8', $digest;

    #--------------------------------------------------
    # print "key1: $key1: ", length $key1, "\n";
    # print "key2: $key2: ", length $key2, "\n";
    #--------------------------------------------------

    $digest = unpack 'H*', $key1 . $key2 . $key1;

    #--------------------------------------------------
    # print "Digest: ", $digest, "\n";
    # print length $digest, "\n";
    #--------------------------------------------------

    return $digest;
}

sub _password_verify {
    my $self = shift;
    my $pass = shift;

    if (! $pass) { croak('No password specified!'); };

    if (defined $self->{'password'} && $pass eq $self->{'password'}) {
        # already verified this password
        return 1;
    }

    # AFAIK the thing we use to test the password is
    #     always in the first entry
    my $data = $self->{'records'}->[0]->{'data'};

    #die "No encrypted password in file!" unless defined $data;
    if ( ! defined $data) { return; };

    $data =~ s/$NULL$//xm;

    my $salt = substr $data, 0, $kSalt_Size;

    my $msg = $salt . $pass;

    $msg .= "\0" x ( $MD5_CBLOCK - length $msg );

    my $digest = md5($msg);

    if ( $data eq $salt . $digest ) {

# May as well generate the keys we need now, since we know the password is right
        $self->{'digest'} = _calc_keys($pass);
        if ( $self->{'digest'} ) {
            $self->{'password'} = $pass;
            return 1;
        }
    }
    return;
}

sub _password_update {

    # It is very important to Encrypt after calling this
    #     (Although it is generally only called by Encrypt)
    # because otherwise the data will be out of sync with the
    # password, and that would suck!
    my $self = shift;
    my $pass = shift;

    if (! defined $pass) { croak('No password specified!'); };

    my $salt;
    for ( 1 .. $kSalt_Size ) {
        $salt .= chr int rand 255;
    }

    my $msg = $salt . $pass;

    $msg .= "\0" x ( $MD5_CBLOCK - length $msg );

    my $digest = md5($msg);

    my $data = $salt . $digest;    # . "\0";

    # AFAIK the thing we use to test the password is
    #     always in the first entry
    $self->{'records'}->[0]->{'data'} = $data;

    $self->{'password'} = $pass;
    $self->{'digest'}   = _calc_keys( $self->{'password'} );

    return 1;
}

sub _crypt3des {
    my ( $plaintext, $passphrase, $flag ) = @_;

    $passphrase   .= $SPACE x ( 16 * 3 );
    my $cyphertext = $EMPTY;

    my $size = length $plaintext;

    #print "STRING: '$plaintext' - Length: " . (length $plaintext) . "\n";

    my @C;
    for ( 0 .. 2 ) {
        $C[$_] =
          new Crypt::DES( pack 'H*', ( substr $passphrase, 16 * $_, 16 ));
    }

    for ( 0 .. ( ($size) / 8 ) ) {
        my $pt = substr $plaintext, $_ * 8, 8;

        #print "PT: '$pt' - Length: " . length($pt) . "\n";
        if (! length $pt) { next; };
        if ( (length $pt) < 8 ) {
            if ($flag == $DECRYPT) { croak('record not 8 byte padded'); };
            my $len = 8 - (length $pt);

            #print "LENGTH: $len\n";
            #print "Binary:    '" . unpack("b*", $pt) . "'\n";
            $pt .= ($NULL x $len);

            #print "PT: '$pt' - Length: " . length($pt) . "\n";
            #print "Binary:    '" . unpack("b*", $pt) . "'\n";
        }
        if ( $flag == $ENCRYPT ) {
            $pt = $C[0]->encrypt($pt);
            $pt = $C[1]->decrypt($pt);
            $pt = $C[2]->encrypt($pt);
        }
        else {
            $pt = $C[0]->decrypt($pt);
            $pt = $C[1]->encrypt($pt);
            $pt = $C[2]->decrypt($pt);
        }

        #print "PT: '$pt' - Length: " . length($pt) . "\n";
        $cyphertext .= $pt;
    }

    $cyphertext =~ s/$NULL+$//xm;

    #print "CT: '$cyphertext' - Length: " . length($cyphertext) . "\n";

    return $cyphertext;
}

1;
__END__

=head1 NAME

Palm::Keyring - Handler for Palm Keyring databases.

=head1 DESCRIPTION

The Keyring PDB handler is a helper class for the Palm::PDB package. It
parses Keyring for Palm OS databases.  See
L<http://gnukeyring.sourceforge.net/>.

It has the standard Palm::PDB methods with 2 additional public methods.  
Decrypt and Encrypt.

It currently supports the v4 Keyring databases.  The v5 databases from 
the pre-release keyring-2.0 are not supported.

This module doesn't store the decrypted content.  It only keeps it until it 
returns it to you or encrypts it.

=head1 SYNOPSIS

    use Palm::PDB;
    use Palm::Keyring;
    
    my $pass = 'password';
    my $file = 'Keys-Gtkr.pdb';
    my $pdb  = new Palm::PDB;
    $pdb->Load($file);
    
    foreach (0..$#{ $pdb->{'records'} }) {
        next if $_ = 0; # skip the password record
        my $rec  = $pdb->{'records'}->[$_];
        my $acct = $pdb->Decrypt($rec, $pass);
        print $rec->{'data'}, ' - ', $acct->{'account'}, "\n";
    }

=head1 SUBROUTINES/METHODS

=head2 new

    $pdb = new Palm::Keyring([$password]);

Create a new PDB, initialized with the various Palm::Keyring fields
and an empty record list.

Use this method if you're creating a Keyring PDB from scratch otherwise you 
can just use Palm::PDB::new() before calling Load().

=head2 Encrypt

    $pdb->Encrypt($rec, $acct, [$password]);

Encrypts an account into a record, either with the password previously 
used, or with a password that is passed.

$rec is a record from $pdb->{'records'} or a newly generated record.
$acct is a hashref in the format below.

    my $acct = {
        account  => $account,
        password => $password,
        notes    => $notes,
    };

=head2 Decrypt

    my $acct = $pdb->Decrypt($rec[, $password]);

Decrypts the record and returns a hashref for the account as described 
under Encrypt();

    foreach (0..$#{ $pdb->{'records'}) {
        next if $_ == 0;
        my $rec = $pdb->{'records'}->[$_];
        my $acct = $pdb->Decrypt($rec[, $password]);
        # do something with $acct
    }

=head2 Password

    $pdb->Password([$password[, $new_password]]);

Either sets the password to be used to crypt, or if you pass $new_password, 
changes the password on the database.

If you have created a new $pdb, and you didn't set a password when you 
called new(), you only need to pass one password and it will set that as 
the password. 

If nothing is passed, and there has been a password used before, 
it just verifies that the password was correct.

=head1 DEPENDENCIES

Palm::StdAppInfo

Digest::MD5

Crypt::DES

Readonly

=head1 BUGS AND LIMITATIONS

Once this module is uploaded, you can 
Please report any bugs or feature requests to
C<bug-palm-keyring at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
notified of progress on your bug as I make changes.

=head1 AUTHOR

Andrew Fresh E<lt>andrew@mad-techies.orgE<gt>

=head1 LICENSE AND COPYRIGHT

Copyright 2004, 2005, 2006, 2007 Andrew Fresh, All Rights Reserved.

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

=head1 SEE ALSO

Palm::PDB(3)

Palm::StdAppInfo(3)

The Keyring for Palm OS website: 
L<http://gnukeyring.sourceforge.net/>