| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package AnySan::Provider::Slack; | 
| 2 | 1 |  |  | 1 |  | 908 | use strict; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 35 |  | 
| 3 | 1 |  |  | 1 |  | 6 | use warnings; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 49 |  | 
| 4 |  |  |  |  |  |  | our $VERSION = '0.07'; | 
| 5 |  |  |  |  |  |  |  | 
| 6 | 1 |  |  | 1 |  | 6 | use base 'AnySan::Provider'; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 549 |  | 
| 7 |  |  |  |  |  |  | our @EXPORT = qw(slack); | 
| 8 | 1 |  |  | 1 |  | 775 | use AnySan; | 
|  | 1 |  |  |  |  | 12723 |  | 
|  | 1 |  |  |  |  | 41 |  | 
| 9 | 1 |  |  | 1 |  | 487 | use AnySan::Receive; | 
|  | 1 |  |  |  |  | 397 |  | 
|  | 1 |  |  |  |  | 33 |  | 
| 10 | 1 |  |  | 1 |  | 531 | use HTTP::Request::Common; | 
|  | 1 |  |  |  |  | 21684 |  | 
|  | 1 |  |  |  |  | 106 |  | 
| 11 | 1 |  |  | 1 |  | 821 | use AnyEvent::HTTP; | 
|  | 1 |  |  |  |  | 30639 |  | 
|  | 1 |  |  |  |  | 122 |  | 
| 12 | 1 |  |  | 1 |  | 787 | use AnyEvent::SlackRTM; | 
|  | 1 |  |  |  |  | 309801 |  | 
|  | 1 |  |  |  |  | 38 |  | 
| 13 | 1 |  |  | 1 |  | 9 | use JSON; | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 1 |  |  |  |  | 5 |  | 
| 14 | 1 |  |  | 1 |  | 133 | use Encode; | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 1 |  |  |  |  | 1225 |  | 
| 15 |  |  |  |  |  |  |  | 
| 16 |  |  |  |  |  |  | sub slack { | 
| 17 | 0 |  |  | 0 | 0 |  | my(%config) = @_; | 
| 18 |  |  |  |  |  |  |  | 
| 19 | 0 |  |  |  |  |  | my $self = __PACKAGE__->new( | 
| 20 |  |  |  |  |  |  | client => undef, | 
| 21 |  |  |  |  |  |  | config => \%config, | 
| 22 |  |  |  |  |  |  | ); | 
| 23 |  |  |  |  |  |  |  | 
| 24 |  |  |  |  |  |  | # join channels | 
| 25 | 0 |  |  |  |  |  | my @channels = keys %{ $config{channels} }; | 
|  | 0 |  |  |  |  |  |  | 
| 26 | 0 |  |  |  |  |  | for my $channel (@channels) { | 
| 27 |  |  |  |  |  |  | $self->_call('channels.join', [ | 
| 28 |  |  |  |  |  |  | name => $channel, | 
| 29 | 0 |  |  | 0 |  |  | ], sub {}); | 
| 30 |  |  |  |  |  |  | } | 
| 31 |  |  |  |  |  |  |  | 
| 32 | 0 |  |  |  |  |  | $self->start; | 
| 33 |  |  |  |  |  |  |  | 
| 34 | 0 |  |  |  |  |  | return $self; | 
| 35 |  |  |  |  |  |  | } | 
| 36 |  |  |  |  |  |  |  | 
| 37 | 0 |  |  | 0 | 0 |  | sub metadata { shift->{rtm}->metadata } | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | sub user { | 
| 40 | 0 |  |  | 0 | 0 |  | my ($self, $id) = @_; | 
| 41 | 0 |  |  |  |  |  | return $self->{_users}{$id}; | 
| 42 |  |  |  |  |  |  | } | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | sub bot { | 
| 45 | 0 |  |  | 0 | 0 |  | my ($self, $id) = @_; | 
| 46 | 0 |  |  |  |  |  | return $self->{_bots}{$id}; | 
| 47 |  |  |  |  |  |  | } | 
| 48 |  |  |  |  |  |  |  | 
| 49 |  |  |  |  |  |  | sub start { | 
| 50 | 0 |  |  | 0 | 0 |  | my $self = shift; | 
| 51 |  |  |  |  |  |  |  | 
| 52 | 0 | 0 |  |  |  |  | my $client_opt = $self->{config}{timeout} ? { timeout => $self->{config}{timeout} } : undef; | 
| 53 | 0 |  |  |  |  |  | my $rtm = AnyEvent::SlackRTM->new($self->{config}{token}, $client_opt); | 
| 54 |  |  |  |  |  |  | $rtm->on('hello' => sub { | 
| 55 |  |  |  |  |  |  | # create hash table of users | 
| 56 | 0 |  |  | 0 |  |  | my $users = {}; | 
| 57 | 0 |  |  |  |  |  | for my $user (@{$self->metadata->{users}}) { | 
|  | 0 |  |  |  |  |  |  | 
| 58 | 0 |  | 0 |  |  |  | $users->{$user->{id}} ||= $user; | 
| 59 | 0 |  | 0 |  |  |  | $users->{$user->{name}} ||= $user; | 
| 60 |  |  |  |  |  |  | } | 
| 61 | 0 |  |  |  |  |  | $self->{_users} = $users; | 
| 62 |  |  |  |  |  |  |  | 
| 63 | 0 |  |  |  |  |  | my $bots = {}; | 
| 64 | 0 |  |  |  |  |  | for my $bot (@{$self->metadata->{bots}}) { | 
|  | 0 |  |  |  |  |  |  | 
| 65 | 0 |  | 0 |  |  |  | $bots->{$bot->{id}} ||= $bot; | 
| 66 | 0 |  | 0 |  |  |  | $bots->{$bot->{name}} ||= $bot; | 
| 67 |  |  |  |  |  |  | } | 
| 68 | 0 |  |  |  |  |  | $self->{_bots} = $bots; | 
| 69 | 0 |  |  |  |  |  | }); | 
| 70 |  |  |  |  |  |  | $rtm->on('message' => sub { | 
| 71 | 0 |  |  | 0 |  |  | my ($rtm, $message) = @_; | 
| 72 | 0 | 0 |  |  |  |  | my $metadata = $self->metadata or return; | 
| 73 | 0 | 0 |  |  |  |  | if ($message->{subtype}) { | 
| 74 | 0 |  | 0 |  |  |  | my $filter = $self->{config}{subtypes} || []; | 
| 75 | 0 | 0 |  |  |  |  | return unless grep { $_ eq 'all' || $_ eq $message->{subtype} } @$filter; | 
|  | 0 | 0 |  |  |  |  |  | 
| 76 |  |  |  |  |  |  | } | 
| 77 |  |  |  |  |  |  |  | 
| 78 |  |  |  |  |  |  | # search user nickname | 
| 79 | 0 |  |  |  |  |  | my $nickname = ''; | 
| 80 | 0 |  | 0 |  |  |  | my $user_id = encode_utf8($message->{user} || ''); | 
| 81 | 0 |  |  |  |  |  | my $user = $self->user($user_id); | 
| 82 | 0 |  |  |  |  |  | my $bot = $self->bot($user_id); | 
| 83 | 0 | 0 |  |  |  |  | $nickname = $user->{name} if $user; | 
| 84 | 0 | 0 |  |  |  |  | $nickname = $bot->{name} if $bot; | 
| 85 |  |  |  |  |  |  |  | 
| 86 | 0 |  |  |  |  |  | my $receive; $receive = AnySan::Receive->new( | 
| 87 |  |  |  |  |  |  | provider      => 'slack', | 
| 88 |  |  |  |  |  |  | event         => 'message', | 
| 89 |  |  |  |  |  |  | message       => encode_utf8($message->{text} || ''), | 
| 90 |  |  |  |  |  |  | nickname      => encode_utf8($metadata->{self}{name} || ''), | 
| 91 |  |  |  |  |  |  | from_nickname => $nickname, | 
| 92 |  |  |  |  |  |  | attribute     => { | 
| 93 |  |  |  |  |  |  | channel => $message->{channel}, | 
| 94 |  |  |  |  |  |  | subtype => $message->{subtype}, | 
| 95 |  |  |  |  |  |  | user    => $user, | 
| 96 |  |  |  |  |  |  | bot     => $bot, | 
| 97 |  |  |  |  |  |  | }, | 
| 98 | 0 |  |  |  |  |  | cb            => sub { $self->event_callback($receive, @_) }, | 
| 99 | 0 |  | 0 |  |  |  | ); | 
|  |  |  | 0 |  |  |  |  | 
| 100 | 0 |  |  |  |  |  | AnySan->broadcast_message($receive); | 
| 101 | 0 |  |  |  |  |  | }); | 
| 102 |  |  |  |  |  |  | $rtm->on('finish' => sub { | 
| 103 |  |  |  |  |  |  | # reconnect | 
| 104 | 0 |  |  | 0 |  |  | undef $self->{rtm}; | 
| 105 | 0 |  |  |  |  |  | while (1) { | 
| 106 | 0 |  |  |  |  |  | eval { $self->start }; | 
|  | 0 |  |  |  |  |  |  | 
| 107 | 0 | 0 |  |  |  |  | last unless $@; | 
| 108 |  |  |  |  |  |  | } | 
| 109 | 0 |  |  |  |  |  | }); | 
| 110 |  |  |  |  |  |  | $rtm->on('user_change' => sub { | 
| 111 | 0 |  |  | 0 |  |  | my ($rtm, $message) = @_; | 
| 112 | 0 |  |  |  |  |  | my $user = $message->{user}; | 
| 113 | 0 |  |  |  |  |  | my $user_id = $user->{id}; | 
| 114 |  |  |  |  |  |  |  | 
| 115 |  |  |  |  |  |  | # remove from cache | 
| 116 | 0 | 0 |  |  |  |  | if (my $old_user = $self->{_users}{$user_id}) { | 
| 117 | 0 |  |  |  |  |  | delete $self->{_users}{$user_id}; | 
| 118 | 0 |  |  |  |  |  | delete $self->{_users}{$old_user->{name}}; | 
| 119 |  |  |  |  |  |  | } | 
| 120 |  |  |  |  |  |  |  | 
| 121 |  |  |  |  |  |  | # add new user info to cache | 
| 122 | 0 |  |  |  |  |  | $self->{_users}{$user_id} = $user; | 
| 123 | 0 |  |  |  |  |  | $self->{_users}{$user->{name}} = $user; | 
| 124 | 0 |  |  |  |  |  | }); | 
| 125 | 0 |  |  |  |  |  | $rtm->start; | 
| 126 | 0 |  |  |  |  |  | $self->{rtm} = $rtm; | 
| 127 |  |  |  |  |  |  | } | 
| 128 |  |  |  |  |  |  |  | 
| 129 |  |  |  |  |  |  | sub event_callback { | 
| 130 | 0 |  |  | 0 | 0 |  | my($self, $receive, $type, @args) = @_; | 
| 131 |  |  |  |  |  |  |  | 
| 132 | 0 | 0 |  |  |  |  | if ($type eq 'reply') { | 
| 133 |  |  |  |  |  |  | $self->_call('chat.postMessage', [ | 
| 134 |  |  |  |  |  |  | channel    => $receive->attribute('channel'), | 
| 135 |  |  |  |  |  |  | text       => $args[0], | 
| 136 |  |  |  |  |  |  | as_user    => $self->{config}->{as_user}    ? 'true' : 'false', | 
| 137 |  |  |  |  |  |  | link_names => $self->{config}->{link_names} ? 'true' : 'false', | 
| 138 | 0 | 0 |  | 0 |  |  | ], sub {}); | 
|  |  | 0 |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | } | 
| 140 |  |  |  |  |  |  | } | 
| 141 |  |  |  |  |  |  |  | 
| 142 |  |  |  |  |  |  | sub send_message { | 
| 143 | 0 |  |  | 0 | 0 |  | my($self, $message, %args) = @_; | 
| 144 |  |  |  |  |  |  |  | 
| 145 |  |  |  |  |  |  | $self->_call('chat.postMessage', [ | 
| 146 |  |  |  |  |  |  | text       => $message, | 
| 147 |  |  |  |  |  |  | channel    => $args{channel}, | 
| 148 |  |  |  |  |  |  | as_user    => $self->{config}->{as_user}    ? 'true' : 'false', | 
| 149 |  |  |  |  |  |  | link_names => $self->{config}->{link_names} ? 'true' : 'false', | 
| 150 | 0 | 0 |  |  |  |  | %{ $args{params} || +{} }, | 
| 151 | 0 | 0 |  | 0 |  |  | ], sub {}); | 
|  |  | 0 |  |  |  |  |  | 
| 152 |  |  |  |  |  |  | } | 
| 153 |  |  |  |  |  |  |  | 
| 154 |  |  |  |  |  |  | sub _call { | 
| 155 | 0 |  |  | 0 |  |  | my ($self, $method, $params, $cb) = @_; | 
| 156 |  |  |  |  |  |  | my $req = POST "https://slack.com/api/$method", [ | 
| 157 |  |  |  |  |  |  | token   => $self->{config}{token}, | 
| 158 | 0 |  |  |  |  |  | @$params, | 
| 159 |  |  |  |  |  |  | ]; | 
| 160 | 0 |  |  |  |  |  | my %headers = map { $_ => $req->header($_), } $req->headers->header_field_names; | 
|  | 0 |  |  |  |  |  |  | 
| 161 | 0 |  | 0 |  |  |  | my $jd = $self->{json_driver} ||= JSON->new->utf8; | 
| 162 | 0 |  |  |  |  |  | my $r; | 
| 163 |  |  |  |  |  |  | $r = http_post $req->uri, $req->content, headers => \%headers, sub { | 
| 164 | 0 |  |  | 0 |  |  | my $body = shift; | 
| 165 | 0 |  |  |  |  |  | my $res = $jd->decode($body); | 
| 166 | 0 |  |  |  |  |  | $cb->($res); | 
| 167 | 0 |  |  |  |  |  | undef $r; | 
| 168 | 0 |  |  |  |  |  | }; | 
| 169 |  |  |  |  |  |  | } | 
| 170 |  |  |  |  |  |  |  | 
| 171 |  |  |  |  |  |  | 1; | 
| 172 |  |  |  |  |  |  | __END__ |