1package Growl::GNTP;
2
3use strict;
4use warnings;
5use IO::Socket::INET;
6use Data::UUID;
7use Crypt::CBC;
8use Digest::MD5 qw/md5_hex/;
9use Digest::SHA qw/sha1_hex sha256_hex/;
10our $VERSION = '0.21';
11
12sub new {
13    my $class = shift;
14    my %args  = @_;
15    $args{Proto}    ||= 'tcp';
16    $args{PeerHost} ||= 'localhost';
17    $args{PeerPort} ||= 23053;
18    $args{Timeout}  ||= 5;
19    $args{AppName}  ||= 'Growl::GNTP';
20    $args{AppIcon}  ||= '';
21    $args{Password} ||= '';
22    $args{PasswordHashAlgorithm} ||= 'MD5';
23    $args{EncryptAlgorithm}      ||= 'NONE';
24    $args{Debug}                 ||= 0;
25    $args{Callbacks} = [];
26    srand();
27    bless {%args}, $class;
28}
29
30sub register {
31    my $self = shift;
32    my $notifications = shift || [];
33
34    my $AppName = $self->{AppName};
35    $AppName =~ s!\r\n!\n!;
36    my $AppIcon = $self->{AppIcon};
37    $AppIcon =~ s!\r\n!\n!;
38    my $count = scalar @$notifications;
39
40    my $sock  = IO::Socket::INET->new(
41        PeerAddr => $self->{PeerHost},
42        PeerPort => $self->{PeerPort},
43        Proto    => $self->{Proto},
44        Timeout  => $self->{Timeout},
45    );
46    die $@ unless $sock;
47
48    my $identifier;
49    if (-f $AppIcon) {
50        open my $f, "<:raw", $AppIcon;
51        $identifier = do { local $/; <$f> };
52        close $f;
53        $AppIcon = "x-growl-resource://" . Digest::MD5::md5_hex(Digest::MD5->new->add($identifier)->digest);
54    }
55
56    my $form = <<EOF;
57Application-Name: $AppName
58Application-Icon: $AppIcon
59Notifications-Count: $count
60
61EOF
62    $form =~ s!\n!\r\n!g;
63
64    $count = 0;
65    for my $notification ( @{$notifications} ) {
66        $count++;
67        my %data = (
68            Name        => $notification->{Name} || "Growl::GNTP Notify$count",
69            DisplayName => $notification->{DisplayName}
70              || $notification->{Name} || "Growl::GNTP Notify$count",
71            Enabled     => _translate_bool($notification->{Enabled} || 'True'),
72            Icon        => $notification->{Icon} || '', # will default to Application-Icon if not specified.
73        );
74        $data{$_} =~ s!\r\n!\n! for ( keys %data );
75
76        my $subform .= <<EOF;
77Notification-Name: \$(Name)
78Notification-Display-Name: \$(DisplayName)
79Notification-Enabled: \$(Enabled)
80Notification-Icon: \$(Icon)
81
82EOF
83        $subform =~ s!\n!\r\n!g;
84        $subform =~ s/\$\((\w+)\)/$data{$1}/ge;
85        $form .= $subform;
86    }
87    if ($identifier) {
88        $form.=sprintf("Identifier: %s\r\r\n",substr($AppIcon, 19));
89        $form.=sprintf("Length: %d\r\r\n\r\r\n",length $identifier);
90        $form =~ s!\r\r\n!\r\n!g;
91        $form .= $identifier;
92        $form .= "\r\n\r\n";
93    }
94
95    print $form if $self->{Debug};
96    $form = _gen_header($self, 'REGISTER', $form);
97    $sock->send($form);
98
99    my $ret = <$sock>;
100    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
101    print "$_\n" if $self->{Debug};
102
103    my $description = 'failed to register';
104    if ($ret ne 'OK') {
105        while (<$sock>) {
106            $_ =~ s!\r\n!!g;
107            print "$_\n" if $self->{Debug};
108            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
109            last if length($_) == 0;
110        }
111    }
112    close $sock;
113
114    die $description if $ret ne 'OK';
115}
116
117sub notify {
118    my ( $self, %args ) = @_;
119    my %data = (
120        AppName             => $self->{AppName},
121        Name                => $args{Name} || $args{Event} || '',
122        Title               => $args{Title} || '',
123        Message             => $args{Message} || '',#optional
124        Icon                => $args{Icon} || '', #optional
125        ID                  => $args{ID} || '', # optional
126        CoalescingID        => $args{CoalescingID} || '', # optional
127        Priority            => _translate_int($args{Priority} || 0), #optional
128        Sticky              => _translate_bool($args{Sticky} || 'False'), #optional
129        CallbackContext     => $args{CallbackContext} || '',#optional
130        CallbackContextType => $args{CallbackContextType} || '',#optional, required if CallbackContext
131        CallbackTarget      => $args{CallbackTarget} || '', #optional exclusive of CallbackContext[-Type] #!# for now, needs Context pair until GfW v2.0.0.20
132        CallbackFunction    => $args{CallbackFunction} || {}, #optional
133        Custom              => $args{Custom} || '', # optional
134    );
135    $data{$_} =~ s!\r\n!\n! for ( keys %data );
136
137    my $identifier;
138    if (-f $data{Icon}) {
139        open my $f, "<:raw", $data{Icon};
140        $identifier = do { local $/; <$f> };
141        close $f;
142        $data{Icon} = "x-growl-resource://" . Digest::MD5::md5_hex(Digest::MD5->new->add($identifier)->digest);
143    }
144
145    # once GfW v2.0.0.20, this CallbackTarget can be removed.
146    if ($data{CallbackTarget}) {
147        $data{CallbackContext} = $data{CallbackContext} || 'TARGET';
148        $data{CallbackContextType} = $data{CallbackContextType} || 'TARGET';
149    }
150
151    my $sock = IO::Socket::INET->new(
152        PeerAddr => $self->{PeerHost},
153        PeerPort => $self->{PeerPort},
154        Proto    => $self->{Proto},
155        Timeout  => $self->{Timeout},
156    );
157    die $@ unless $sock;
158
159    my $form;
160    $form.=sprintf("Application-Name: %s\r\r\n",$data{AppName});
161    $form.=sprintf("Notification-Name: %s\r\r\n",$data{Name});
162    $form.=sprintf("Notification-Title: %s\r\r\n",$data{Title});
163    $form.=sprintf("Notification-ID: %s\r\r\n",$data{ID}) if $data{ID};
164    $form.=sprintf("Notification-Priority: %s\r\r\n",$data{Priority}) if $data{Priority};
165    $form.=sprintf("Notification-Text: %s\r\r\n",$data{Message}) if $data{Message};
166    $form.=sprintf("Notification-Sticky: %s\r\r\n",$data{Sticky}) if $data{Sticky};
167    $form.=sprintf("Notification-Icon: %s\r\r\n",$data{Icon}) if $data{Icon};
168    $form.=sprintf("Notification-Coalescing-ID: %s\r\r\n",$data{CoalescingID}) if $data{CoalescingID};
169    if ($data{CallbackContext}) {
170        $form.=sprintf("Notification-Callback-Context: %s\r\r\n",$data{CallbackContext});
171        $form.=sprintf("Notification-Callback-Context-Type: %s\r\r\n",$data{CallbackContextType});
172    }
173    if ($data{CallbackTarget}) { # BOTH method are provided here for GfW compatability.
174        $form.=sprintf("Notification-Callback-Context-Target: %s\r\r\n",$data{CallbackTarget});
175        $form.=sprintf("Notification-Callback-Target: %s\r\r\n",$data{CallbackTarget});
176    }
177    if (ref($data{Custom}) eq 'HASH') {
178        foreach my $header (sort keys %{$data{Custom}}){
179            $form.=sprintf("X-%s: %s\r\r\n",$header,$data{Custom}{$header});
180        }
181    }
182
183    if ($identifier) {
184        $form .= "\r\r\n";
185        $form.=sprintf("Identifier: %s\r\r\n",substr($data{Icon}, 19));
186        $form.=sprintf("Length: %d\r\r\n\r\r\n",length $identifier);
187        $form =~ s!\r\r\n!\r\n!g;
188        $form .= $identifier;
189        $form .= "\r\n";
190    } else {
191        $form =~ s!\r\r\n!\r\n!g;
192    }
193    $form .= "\r\n";
194    print $form if $self->{Debug};
195
196    $form = _gen_header($self, 'NOTIFY', $form);
197    $sock->send($form);
198
199    my $ret = <$sock>;
200    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
201    print "$_\n" if $self->{Debug};
202
203    my $description = 'failed to notify';
204    if ($ret ne 'OK') {
205        while (<$sock>) {
206            $_ =~ s!\r\n!!g;
207            print "$_\n" if $self->{Debug};
208            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
209            last if length($_) == 0;
210        }
211    }
212    close $sock;
213
214    die $description if $ret ne 'OK';
215}
216
217sub subscribe {
218    my ( $self, %args ) = @_;
219    chomp(my $hostname = `hostname`);
220    my %data = (
221        ID                  => $args{ID} || Data::UUID->new->create_str,
222        Name                => $args{Name} || $hostname,
223        Port                => $args{Port} || 23053,
224    );
225    $data{$_} =~ s!\r\n!\n! for ( keys %data );
226    my $password = $args{Password} || '';
227    my $callback = $args{CallbackFunction} || '';
228
229    my $sock = IO::Socket::INET->new(
230        PeerAddr => $self->{PeerHost},
231        PeerPort => $self->{PeerPort},
232        Proto    => $self->{Proto},
233        Timeout  => $self->{Timeout},
234    );
235    die $@ unless $sock;
236
237    my $form = <<EOF;
238Subscriber-ID: \$(ID)
239Subscriber-Name: \$(Name)
240Subscriber-Port: \$(Port)
241
242EOF
243    $form =~ s!\r?\n!\r\n!g;
244    $form =~ s/\$\((\w+)\)/$data{$1}/ge;
245
246    $form = _gen_header($self, 'SUBSCRIBE', $form);
247    $sock->send($form);
248
249    my $ret = <$sock>;
250    $ret = $1 if $ret =~ /^GNTP\/1\.0 -?(\w+)/;
251    print "$_\n" if $self->{Debug};
252
253    my $description = 'failed to register';
254    if ($ret ne 'OK') {
255        while (<$sock>) {
256            $_ =~ s!\r\n!!g;
257            print "$_\n" if $self->{Debug};
258            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
259            last if length($_) == 0;
260        }
261        die $description if $ret ne 'OK';
262    }
263
264    $sock = IO::Socket::INET->new(
265        LocalPort => $data{Port},
266        Proto => 'tcp',
267        Listen => 10,
268        Timeout => $self->{Timeout},
269    );
270    die $@ unless $sock;
271
272    $description = 'failed to subscribe';
273    while (1) {
274        my $client = $sock->accept();
275        my ($Title, $Message) = ('', '');
276        while (<$client>){
277            $_ =~ s!\r\n!!g;
278            print "$_\n" if $self->{Debug};
279            $ret     = $1 if $_ =~ /^GNTP\/1\.0 -?(\w+)/;
280            $description  = $1 if $_ =~ /^Error-Description:\s*(.*)$/;
281            $Title   = $1 if $_ =~ /^Notification-Title: (.*)\r\n/;
282            $Message = $1 if $_ =~ /^Notification-Text: (.*)\r\n/;
283            # TODO
284            # handling more GNTP protocols.
285            # currently, can't treat multiline header which include LF.
286            ## hrmmm...
287            last if length($_) == 0;
288        }
289        $client->close();
290
291        if ($Title && ref($callback) eq 'CODE') {
292            $callback->($Title, $Message);
293        }
294    }
295
296    die $description if $ret ne 'OK';
297}
298
299sub wait {
300    my $self = shift;
301    my $waitall = shift || 1;
302
303    my @callbacks = @{$self->{Callbacks}};
304    my @old = @callbacks;
305    my $bits = "";
306    while (@callbacks) {
307        vec($bits, fileno($_->{Socket}), 1) = 1 for @callbacks;
308        next unless select($bits, undef, undef, 0.1);
309        for (my $i = 0; $i < @callbacks; $i++) {
310            my $callback = $callbacks[$i];
311            my $sock = $callback->{Socket};
312            if (vec($bits, fileno($sock), 1)) {
313                my ($result, $type, $context, $id, $timestamp) = ('', '', '','','');
314                while (<$sock>) {
315                    $_ =~ s!\r\n!!g;
316                    print "$_\n" if $self->{Debug};
317                    $id        = $1 if $_ =~ /^Notification-ID: (.*)$/;
318                    $timestamp = $1 if $_ =~ /^Notification-Callback-Timestamp: (.*)$/;
319                    $result    = $1 if $_ =~ /^Notification-Callback-Result: (.*)$/;
320                    $context   = $1 if $_ =~ /^Notification-Callback-Context: (.*)$/;
321                    $type      = $1 if $_ =~ /^Notification-Callback-Context-Type: (.*)$/;
322                    last if length($_) == 0;
323                }
324                if (ref($callback->{Function}) eq 'CODE') {
325                    $callback->{Function}->($result, $type, $context,$id,$timestamp);
326                }
327                splice(@callbacks, $i, 1);
328            }
329        }
330        last unless $waitall;
331    };
332
333    for (my $i = 0; $i < @{$self->{Callbacks}}; ++$i) {
334        if (grep { $_->{Socket} eq $self->{Callbacks}[$i]->{Socket} } @old) {
335            splice(@{$self->{Callbacks}}, $i--, 1);
336        }
337    }
338    1;
339}
340
341sub _translate_int {
342    return 0 + shift;
343}
344
345sub _translate_bool {
346    my $value = shift;
347    return 'True' if $value =~ /^([Tt]rue|[Yy]es)$/;
348    return 'False' if $value =~ /^([Ff]alse|[Nn]o)$/;
349    return 'True' if $value;
350    return 'False';
351}
352
353sub _gen_header {
354    my ($ctx, $method, $form) = @_;
355
356    if ($ctx->{Password}) {
357        my ($hash, $salt) = _gen_hash($ctx);
358        my $crypt = _gen_encrypt($ctx, $salt, \$form);
359        if ($crypt eq 'NONE') {
360            $form = "GNTP/1.0 $method NONE $hash\r\n$form\r\n";
361        } else {
362            $form = "GNTP/1.0 $method $crypt $hash\r\n$form\r\n\r\n";
363        }
364    } else {
365        $form = "GNTP/1.0 $method NONE\r\n$form\r\n";
366    }
367    return $form;
368}
369
370sub _gen_salt {
371    my $count = shift;
372    my @salt = ( '.', '/', 0 .. 9, 'A' .. 'Z', 'a' .. 'z' );
373    my $salt;
374    $salt .= (@salt)[rand @salt] for 1..$count;
375    return $salt;
376}
377
378sub _gen_hash {
379    my $ctx = shift;
380    my $hash_algorithm = $ctx->{PasswordHashAlgorithm};
381    my $password       = $ctx->{Password};
382    return 'NONE' if $hash_algorithm eq 'NONE';
383
384    my $salt = _gen_salt(8);
385    my $salthex = uc unpack("H*", $salt);
386
387    my %hashroll = (
388        'MD5'    => sub { my ($password, $salt) = @_; return uc Digest::MD5::md5_hex(Digest::MD5->new->add($password)->add($salt)->digest); },
389        'SHA1'   => sub { my ($password, $salt) = @_; return uc Digest::SHA::sha1_hex(Digest::SHA->new(1)->add($password)->add($salt)->digest); },
390        'SHA256' => sub { my ($password, $salt) = @_; return uc Digest::SHA::sha256_hex(Digest::SHA->new(256)->add($password)->add($salt)->digest); },
391    );
392    my $key = $hashroll{$hash_algorithm}->($password, $salt);
393    return "$hash_algorithm:$key.$salthex", $salt;
394}
395
396sub _gen_encrypt {
397    my ($ctx, $salt, $data) = @_;
398    my $hash_algorithm  = $ctx->{PasswordHashAlgorithm};
399    my $crypt_algorithm = $ctx->{EncryptAlgorithm};
400    my $password        = $ctx->{Password};
401    return 'NONE' if $crypt_algorithm eq 'NONE';
402
403    my %hashroll = (
404        'MD5'    => sub { my ($password, $salt) = @_; return Digest::MD5->new->add($password)->add($salt)->digest },
405        'SHA1'   => sub { my ($password, $salt) = @_; return Digest::SHA->new(1)->add($password)->add($salt)->digest },
406        'SHA256' => sub { my ($password, $salt) = @_; return Digest::SHA->new(256)->add($password)->add($salt)->digest },
407    );
408    my $key = $hashroll{$hash_algorithm}->($password, $salt);
409
410    my %cryptroll = (
411        'AES'  => sub {
412            my ($data, $key) = @_;
413            my $iv = Crypt::CBC->random_bytes(16);
414            my $cbc = Crypt::CBC->new(
415                -key => substr($key, 0, 24),
416                -iv => $iv,
417				-keysize => 24,
418                -header => 'none',
419                -literal_key => 1,
420                -padding => 'standard',
421                -cipher => 'Crypt::OpenSSL::AES',
422            );
423            return $cbc->encrypt($data), uc unpack("H*", $iv);
424        },
425        'DES'  => sub {
426            my ($data, $key) = @_;
427            my $iv = Crypt::CBC->random_bytes(8);
428            my $cbc = Crypt::CBC->new(
429                -key => substr($key, 0, 8),
430                -iv => $iv,
431                -header => 'none',
432                -literal_key => 1,
433                -padding => 'standard',
434                -cipher => 'DES',
435            );
436            return $cbc->encrypt($data), uc unpack("H*", $iv);
437        },
438        '3DES' => sub {
439            my ($data, $key) = @_;
440            my $iv = Crypt::CBC->random_bytes(8);
441            $key = $key.substr($key,0,24-length($key)) if length($key) < 24;
442            my $cbc = Crypt::CBC->new(
443                -key => substr($key, 0, 24),
444                -iv => $iv,
445                -header => 'none',
446                -literal_key => 1,
447                -padding => 'standard',
448                -cipher => 'DES_EDE3',
449            );
450            return $cbc->encrypt($data), uc unpack("H*", $iv);
451        },
452    );
453    ($$data, my $hash) = $cryptroll{$crypt_algorithm}->($$data, $key);
454    return "$crypt_algorithm:$hash";
455}
456
457sub _debug {
458    my ($name, $data) = @_;
459    open my $f, ">", $name;
460    binmode $f;
461    print $f $data;
462    close $f;
463}
464
4651;
466__END__
467
468=head1 NAME
469
470Growl::GNTP - Perl implementation of GNTP Protocol (Client Part)
471
472=head1 SYNOPSIS
473
474  use Growl::GNTP;
475  my $growl = Growl::GNTP->new(AppName => "my perl app");
476  $growl->register([
477      { Name => "foo", },
478      { Name => "bar", },
479  ]);
480
481  $growl->notify(
482      Name => "foo",
483      Title => "my notify",
484      Message => "my message",
485      Icon => "http://www.example.com/my-face.png",
486  );
487
488=head1 DESCRIPTION
489
490Growl::GNTP is Perl implementation of GNTP Protocol (Client Part)
491
492=head1 CONSTRUCTOR
493
494=over 4
495
496=item new ( ARGS )
497
498Initialize Growl::GNTP object. You can set few parameter of
499IO::Socket::INET. and application name will be given 'Growl::GNTP' if you
500does not specify it.
501
502=over 4
503
504  PeerHost                # 'localhost'
505  PeerPort                # 23053
506  Timeout                 # 5
507  AppName                 # 'Growl::GNTP'
508  AppIcon                 # ''
509  Password                # ''
510  PasswordHashAlgorithm   # 'MD5'
511  EncryptAlgorithm        # ''
512
513=back
514
515=back
516
517=head1 OBJECT METHODS
518
519=over 4
520
521=item register ( [ARGS] )
522
523Register notification definition. You should be specify ARRAY reference of
524HASH reference like a following.
525
526  {
527      Name        => 'MY_GROWL_NOTIFY',
528      DisplayName => 'My Growl Notify',
529      Enabled     => 'True',
530      Icon        => ''
531  }
532
533=item notify ( ARGS )
534
535Notify item. You should be specify HASH reference like a following.
536
537  {
538      Name                => 'Warn', # name of notification
539      Title               => 'Foo!',
540      Message             => 'Bar!',
541      Icon                => 'http://www.example.com/myface.png',
542      CallbackTarget      => '', # Used for causing a HTTP/1.1 GET request exactly as specificed by this URL. Exclusive of CallbackContext
543      CallbackContextType => time, # type of the context
544      CallbackContext     => 'Time',
545      CallbackFunction    => sub { warn 'callback!' }, # should only be used when a callback in use, and CallbackContext in use.
546      ID                  => '', # allows for overriding/updateing an existing notification when in use, and discriminating between alerts of the same Name
547      Custom              => { CustomHeader => 'value' }, # These will be added as custom headers as X-KEY : value, where 'X-' is prefixed to the key
548      Priority            => 0,  # -2 .. 2 low -> severe
549      Sticky              => 'False'
550  }
551
552And callback function is given few arguments.
553
554    CallbackFunction => sub {
555        my ($result, $type, $context, $id, $timestamp) = @_;
556        print "$result: $context ($type)\n";
557    }
558
559=item wait ( WAIT_ALL )
560
561Wait callback items. If WAIT_ALL is not 0, this function wait all callbacks
562as CLICK, CLOSED, TIMEOUT.
563
564=item subscribe ( ARGS )
565
566Subscribe notification. You should be specify HASH reference like a following.
567
568    {
569        Port => 23054,
570        Password => 'secret',
571        CallbackFunction => sub {
572            my ($Title, $Message) = @_;
573            print decode_utf8($Title),",",decode_utf8($Message),"\n";
574        },
575    }
576
577=back
578
579=head1 AUTHOR
580
581Yasuhiro Matsumoto E<lt>mattn.jp@gmail.comE<gt>
582
583=head1 SEE ALSO
584
585L<Net::Growl>, L<Net::GrowlClient>, L<Mac::Growl>,
586F<http://www.growlforwindows.com/gfw/help/gntp.aspx>
587
588=head1 LICENSE
589
590This library is free software; you can redistribute it and/or modify
591it under the same terms as Perl itself.
592
593=cut
594
595
596