File Coverage

blib/lib/Growl/GNTP.pm

Criterion	Covered	Total	%
statement	45	293	15.3
branch	1	138	0.7
condition	11	79	13.9
subroutine	9	28	32.1
pod	5	5	100.0
total	71	543	13.0

package Growl::GNTP;

use strict;
use warnings;
use IO::Socket::INET;
use Data::UUID;
use Crypt::CBC;
use Digest::MD5 qw/md5_hex/;
use Digest::SHA qw/sha1_hex sha256_hex/;
our $VERSION = '0.20';

sub new {
    my $class = shift;
    my %args  = @_;
    $args{Proto}    ||= 'tcp';
    $args{PeerHost} ||= 'localhost';
    $args{PeerPort} ||= 23053;
    $args{Timeout}  ||= 5;
    $args{AppName}  ||= 'Growl::GNTP';
    $args{AppIcon}  ||= '';
    $args{Password} ||= '';
    $args{PasswordHashAlgorithm} ||= 'MD5';
    $args{EncryptAlgorithm}      ||= 'NONE';
    $args{Debug}                 ||= 0;
    $args{Callbacks} = [];
    srand();
    bless {%args}, $class;
}

sub register {
    my $self = shift;
    my $notifications = shift || [];

    my $AppName = $self->{AppName};
    $AppName =~ s!\r\n!\n!;
    my $AppIcon = $self->{AppIcon};
    $AppIcon =~ s!\r\n!\n!;
    my $count = scalar @$notifications;

    my $sock  = IO::Socket::INET->new(
        PeerAddr => $self->{PeerHost},
        PeerPort => $self->{PeerPort},
        Proto    => $self->{Proto},
        Timeout  => $self->{Timeout},
    );
    die $@ unless $sock;

    my $identifier;
    if (-f $AppIcon) {
        open my $f, "<:raw", $AppIcon;
        $identifier = do { local $/; <$f> };
        close $f;
        $AppIcon = "x-growl-resource://" . Digest::MD5::md5_hex(Digest::MD5->new->add($identifier)->digest);
    }

    my $form = <
Application-Name: $AppName
Application-Icon: $AppIcon
Notifications-Count: $count

EOF
    $form =~ s!\n!\r\n!g;

    $count = 0;
    for my $notification ( @{$notifications} ) {
        $count++;
        my %data = (
            Name        => $notification->{Name} || "Growl::GNTP Notify$count",
            DisplayName => $notification->{DisplayName}
              || $notification->{Name} || "Growl::GNTP Notify$count",
            Enabled     => _translate_bool($notification->{Enabled} || 'True'),
            Icon        => $notification->{Icon} || '', # will default to Application-Icon if not specified.
        );
        $data{$_} =~ s!\r\n!\n! for ( keys %data );

        my $subform .= <
Notification-Name: \$(Name)
Notification-Display-Name: \$(DisplayName)
Notification-Enabled: \$(Enabled)
Notification-Icon: \$(Icon)

EOF
        $subform =~ s!\n!\r\n!g;
        $subform =~ s/\$\((\w+)\)/$data{$1}/ge;
        $form .= $subform;
    }
    if ($identifier) {
        $form.=sprintf("Identifier: %s\r\r\n",substr($AppIcon, 19));
        $form.=sprintf("Length: %d\r\r\n\r\r\n",length $identifier);
        $form =~ s!\r\r\n!\r\n!g;
        $form .= $identifier;
        $form .= "\r\n\r\n";
    }

    print $form if $self->{Debug};
    $form = _gen_header($self, 'REGISTER', $form);
    $sock->send($form);

    my $ret = <$sock>;
    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
    print "$_\n" if $self->{Debug};

    my $description = 'failed to register';
    if ($ret ne 'OK') {
        while (<$sock>) {
            $_ =~ s!\r\n!!g;
            print "$_\n" if $self->{Debug};
            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
            last if length($_) == 0;
        }
    }
    close $sock;

    die $description if $ret ne 'OK';
}

sub notify {
    my ( $self, %args ) = @_;
    my %data = (
        AppName             => $self->{AppName},
        Name                => $args{Name} || $args{Event} || '',
        Title               => $args{Title} || '',
        Message             => $args{Message} || '',#optional
        Icon                => $args{Icon} || '', #optional
        ID                  => $args{ID} || '', # optional
        CoalescingID        => $args{CoalescingID} || '', # optional
        Priority            => _translate_int($args{Priority} || 0), #optional
        Sticky              => _translate_bool($args{Sticky} || 'False'), #optional
        CallbackContext     => $args{CallbackContext} || '',#optional
        CallbackContextType => $args{CallbackContextType} || '',#optional, required if CallbackContext
        CallbackTarget      => $args{CallbackTarget} || '', #optional exclusive of CallbackContext[-Type] #!# for now, needs Context pair until GfW v2.0.0.20
        CallbackFunction    => $args{CallbackFunction} || {}, #optional
        Custom              => $args{Custom} || '', # optional
    );
    $data{$_} =~ s!\r\n!\n! for ( keys %data );

    my $identifier;
    if (-f $data{Icon}) {
        open my $f, "<:raw", $data{Icon};
        $identifier = do { local $/; <$f> };
        close $f;
        $data{Icon} = "x-growl-resource://" . Digest::MD5::md5_hex(Digest::MD5->new->add($identifier)->digest);
    }

    # once GfW v2.0.0.20, this CallbackTarget can be removed.
    if ($data{CallbackTarget}) {
        $data{CallbackContext} = $data{CallbackContext} || 'TARGET';
        $data{CallbackContextType} = $data{CallbackContextType} || 'TARGET';
    }

    my $sock = IO::Socket::INET->new(
        PeerAddr => $self->{PeerHost},
        PeerPort => $self->{PeerPort},
        Proto    => $self->{Proto},
        Timeout  => $self->{Timeout},
    );
    die $@ unless $sock;

    my $form;
    $form.=sprintf("Application-Name: %s\r\r\n",$data{AppName});
    $form.=sprintf("Notification-Name: %s\r\r\n",$data{Name});
    $form.=sprintf("Notification-Title: %s\r\r\n",$data{Title});
    $form.=sprintf("Notification-ID: %s\r\r\n",$data{ID}) if $data{ID};
    $form.=sprintf("Notification-Priority: %s\r\r\n",$data{Priority}) if $data{Priority};
    $form.=sprintf("Notification-Text: %s\r\r\n",$data{Message}) if $data{Message};
    $form.=sprintf("Notification-Sticky: %s\r\r\n",$data{Sticky}) if $data{Sticky};
    $form.=sprintf("Notification-Icon: %s\r\r\n",$data{Icon}) if $data{Icon};
    $form.=sprintf("Notification-Coalescing-ID: %s\r\r\n",$data{CoalescingID}) if $data{CoalescingID};
    if ($data{CallbackContext}) {
        $form.=sprintf("Notification-Callback-Context: %s\r\r\n",$data{CallbackContext});
        $form.=sprintf("Notification-Callback-Context-Type: %s\r\r\n",$data{CallbackContextType});
    }
    if ($data{CallbackTarget}) { # BOTH method are provided here for GfW compatability.
        $form.=sprintf("Notification-Callback-Context-Target: %s\r\r\n",$data{CallbackTarget});
        $form.=sprintf("Notification-Callback-Target: %s\r\r\n",$data{CallbackTarget});
    }
    if (ref($data{Custom}) eq 'HASH') {
        foreach my $header (sort keys %{$data{Custom}}){
            $form.=sprintf("X-%s: %s\r\r\n",$header,$data{Custom}{$header});
        }
    }

    if ($identifier) {
        $form .= "\r\r\n";
        $form.=sprintf("Identifier: %s\r\r\n",substr($data{Icon}, 19));
        $form.=sprintf("Length: %d\r\r\n\r\r\n",length $identifier);
        $form =~ s!\r\r\n!\r\n!g;
        $form .= $identifier;
        $form .= "\r\n";
    } else {
        $form =~ s!\r\r\n!\r\n!g;
    }
    $form .= "\r\n";
    print $form if $self->{Debug};

    $form = _gen_header($self, 'NOTIFY', $form);
    $sock->send($form);

    my $ret = <$sock>;
    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
    print "$_\n" if $self->{Debug};

    my $description = 'failed to notify';
    if ($ret ne 'OK') {
        while (<$sock>) {
            $_ =~ s!\r\n!!g;
            print "$_\n" if $self->{Debug};
            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
            last if length($_) == 0;
        }
    }
    close $sock;

    die $description if $ret ne 'OK';
}

sub subscribe {
    my ( $self, %args ) = @_;
    chomp(my $hostname = `hostname`);
    my %data = (
        ID                  => $args{ID} || Data::UUID->new->create_str,
        Name                => $args{Name} || $hostname,
        Port                => $args{Port} || 23053,
    );
    $data{$_} =~ s!\r\n!\n! for ( keys %data );
    my $password = $args{Password} || '';
    my $callback = $args{CallbackFunction} || '';

    my $sock = IO::Socket::INET->new(
        PeerAddr => $self->{PeerHost},
        PeerPort => $self->{PeerPort},
        Proto    => $self->{Proto},
        Timeout  => $self->{Timeout},
    );
    die $@ unless $sock;

    my $form = <
Subscriber-ID: \$(ID)
Subscriber-Name: \$(Name)
Subscriber-Port: \$(Port)

EOF
    $form =~ s!\r?\n!\r\n!g;
    $form =~ s/\$\((\w+)\)/$data{$1}/ge;

    $form = _gen_header($self, 'SUBSCRIBE', $form);
    $sock->send($form);

    my $ret = <$sock>;
    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
    print "$_\n" if $self->{Debug};

    my $description = 'failed to register';
    if ($ret ne 'OK') {
        while (<$sock>) {
            $_ =~ s!\r\n!!g;
            print "$_\n" if $self->{Debug};
            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
            last if length($_) == 0;
        }
        die $description if $ret ne 'OK';
    }

    $sock = IO::Socket::INET->new(
        LocalPort => $data{Port},
        Proto => 'tcp',
        Listen => 10,
        Timeout => $self->{Timeout},
    );
    die $@ unless $sock;

    $description = 'failed to subscribe';
    while (1) {
        my $client = $sock->accept();
        my ($Title, $Message) = ('', '');
        while (<$client>){
            $_ =~ s!\r\n!!g;
            print "$_\n" if $self->{Debug};
            $ret     = $1 if $_ =~ /^GNTP\/1\.0 -?(\w+)/;
            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
            $Title   = $1 if $_ =~ /^Notification-Title: (.*)\r\n/;
            $Message = $1 if $_ =~ /^Notification-Text: (.*)\r\n/;
            # TODO
            # handling more GNTP protocols.
            # currently, can't treat multiline header which include LF.
            ## hrmmm...
            last if length($_) == 0;
        }
        $client->close();

        if ($Title && ref($callback) eq 'CODE') {
            $callback->($Title, $Message);
        }
    }

    die $description if $ret ne 'OK';
}

sub wait {
    my $self = shift;
    my $waitall = shift || 1;

    my @callbacks = @{$self->{Callbacks}};
    my @old = @callbacks;
    my $bits = "";
    while (@callbacks) {
        vec($bits, fileno($_->{Socket}), 1) = 1 for @callbacks;
        next unless select($bits, undef, undef, 0.1);
        for (my $i = 0; $i < @callbacks; $i++) {
            my $callback = $callbacks[$i];
            my $sock = $callback->{Socket};
            if (vec($bits, fileno($sock), 1)) {
                my ($result, $type, $context, $id, $timestamp) = ('', '', '','','');
                while (<$sock>) {
                    $_ =~ s!\r\n!!g;
                    print "$_\n" if $self->{Debug};
                    $id        = $1 if $_ =~ /^Notification-ID: (.*)$/;
                    $timestamp = $1 if $_ =~ /^Notification-Callback-Timestamp: (.*)$/;
                    $result    = $1 if $_ =~ /^Notification-Callback-Result: (.*)$/;
                    $context   = $1 if $_ =~ /^Notification-Callback-Context: (.*)$/;
                    $type      = $1 if $_ =~ /^Notification-Callback-Context-Type: (.*)$/;
                    last if length($_) == 0;
                }
                if (ref($callback->{Function}) eq 'CODE') {
                    $callback->{Function}->($result, $type, $context,$id,$timestamp);
                }
                splice(@callbacks, $i, 1);
            }
        }
        last unless $waitall;
    };

    for (my $i = 0; $i < @{$self->{Callbacks}}; ++$i) {
        if (grep { $_->{Socket} eq $self->{Callbacks}[$i]->{Socket} } @old) {
            splice(@{$self->{Callbacks}}, $i--, 1);
        }
    }
    1;
}

sub _translate_int {
    return 0 + shift;
}

sub _translate_bool {
    my $value = shift;
    return 'True' if $value =~ /^([Tt]rue|[Yy]es)$/;
    return 'False' if $value =~ /^([Ff]alse|[Nn]o)$/;
    return 'True' if $value;
    return 'False';
}

sub _gen_header {
    my ($ctx, $method, $form) = @_;

    if ($ctx->{Password}) {
        my ($hash, $salt) = _gen_hash($ctx);
        my $crypt = _gen_encrypt($ctx, $salt, \$form);
        if ($crypt eq 'NONE') {
            $form = "GNTP/1.0 $method NONE $hash\r\n$form\r\n";
        } else {
            $form = "GNTP/1.0 $method $crypt $hash\r\n$form\r\n\r\n";
        }
    } else {
        $form = "GNTP/1.0 $method NONE\r\n$form\r\n";
    }
    return $form;
}

sub _gen_salt {
    my $count = shift;
    my @salt = ( '.', '/', 0 .. 9, 'A' .. 'Z', 'a' .. 'z' );
    my $salt;
    $salt .= (@salt)[rand @salt] for 1..$count;
    return $salt;
}

sub _gen_hash {
    my $ctx = shift;
    my $hash_algorithm = $ctx->{PasswordHashAlgorithm};
    my $password       = $ctx->{Password};
    return 'NONE' if $hash_algorithm eq 'NONE';

    my $salt = _gen_salt(8);
    my $salthex = uc unpack("H*", $salt);

    my %hashroll = (
        'MD5'    => sub { my ($password, $salt) = @_; return uc Digest::MD5::md5_hex(Digest::MD5->new->add($password)->add($salt)->digest); },
        'SHA1'   => sub { my ($password, $salt) = @_; return uc Digest::SHA::sha1_hex(Digest::SHA->new(1)->add($password)->add($salt)->digest); },
        'SHA256' => sub { my ($password, $salt) = @_; return uc Digest::SHA::sha256_hex(Digest::SHA->new(256)->add($password)->add($salt)->digest); },
    );
    my $key = $hashroll{$hash_algorithm}->($password, $salt);
    return "$hash_algorithm:$key.$salthex", $salt;
}

sub _gen_encrypt {
    my ($ctx, $salt, $data) = @_;
    my $hash_algorithm  = $ctx->{PasswordHashAlgorithm};
    my $crypt_algorithm = $ctx->{EncryptAlgorithm};
    my $password        = $ctx->{Password};
    return 'NONE' if $crypt_algorithm eq 'NONE';

    my %hashroll = (
        'MD5'    => sub { my ($password, $salt) = @_; return Digest::MD5->new->add($password)->add($salt)->digest },
        'SHA1'   => sub { my ($password, $salt) = @_; return Digest::SHA->new(1)->add($password)->add($salt)->digest },
        'SHA256' => sub { my ($password, $salt) = @_; return Digest::SHA->new(256)->add($password)->add($salt)->digest },
    );
    my $key = $hashroll{$hash_algorithm}->($password, $salt);

    my %cryptroll = (
        'AES'  => sub {
            my ($data, $key) = @_;
            my $iv = Crypt::CBC->random_bytes(16);
            my $cbc = Crypt::CBC->new(
                -key => substr($key, 0, 24),
                -iv => $iv,
				-keysize => 24,
                -header => 'none',
                -literal_key => 1,
                -padding => 'standard',
                -cipher => 'Crypt::OpenSSL::AES',
            );
            return $cbc->encrypt($data), uc unpack("H*", $iv);
        },
        'DES'  => sub {
            my ($data, $key) = @_;
            my $iv = Crypt::CBC->random_bytes(8);
            my $cbc = Crypt::CBC->new(
                -key => substr($key, 0, 8),
                -iv => $iv,
                -header => 'none',
                -literal_key => 1,
                -padding => 'standard',
                -cipher => 'DES',
            );
            return $cbc->encrypt($data), uc unpack("H*", $iv);
        },
        '3DES' => sub {
            my ($data, $key) = @_;
            my $iv = Crypt::CBC->random_bytes(8);
            $key = $key.substr($key,0,24-length($key)) if length($key) < 24;
            my $cbc = Crypt::CBC->new(
                -key => substr($key, 0, 24),
                -iv => $iv,
                -header => 'none',
                -literal_key => 1,
                -padding => 'standard',
                -cipher => 'DES_EDE3',
            );
            return $cbc->encrypt($data), uc unpack("H*", $iv);
        },
    );
    ($$data, my $hash) = $cryptroll{$crypt_algorithm}->($$data, $key);
    return "$crypt_algorithm:$hash";
}

sub _debug {
    my ($name, $data) = @_;
    open my $f, ">", $name;
    binmode $f;
    print $f $data;
    close $f;
}

1;
__END__