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