├── .github └── workflows │ └── test.yml ├── .gitignore ├── .travis.yml ├── Build.PL ├── Changes ├── Dockerfile ├── LICENSE ├── META.json ├── Makefile ├── README.md ├── cpanfile ├── lib └── Slack │ └── RTM │ ├── Bot.pm │ └── Bot │ ├── Client.pm │ ├── Information.pm │ └── Response.pm ├── minil.toml └── t ├── 00_compile.t ├── 01_new.t ├── 02_connect.t ├── 03_action.t ├── 04_say.t ├── 05_actions.t ├── 06_channel_is_hash.t └── 07_information.t /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: test 2 | on: push 3 | jobs: 4 | test: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v2 8 | - name: test 9 | uses: ./. 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.build/ 2 | /_build/ 3 | /Build 4 | /Build.bat 5 | /blib 6 | /pm_to_blib 7 | 8 | /carton.lock 9 | /.carton/ 10 | /local/ 11 | 12 | nytprof.out 13 | nytprof/ 14 | 15 | cover_db/ 16 | 17 | *.bak 18 | *.old 19 | *~ 20 | *.swp 21 | *.o 22 | *.obj 23 | 24 | !LICENSE 25 | 26 | /_build_params 27 | 28 | MYMETA.* 29 | 30 | /Slack-RTM-Bot-* 31 | /.idea/ 32 | /sample/ 33 | 34 | .DS_Store 35 | sample.pl 36 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | sudo: false 3 | perl: 4 | - "5.26" 5 | - "5.24" 6 | - "5.22" 7 | - "5.20" 8 | - "5.18" 9 | - "5.16" 10 | - "5.14" 11 | - "5.12" 12 | before_install: 13 | - eval $(curl https://travis-perl.github.io/init) --auto 14 | 15 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Slack-RTM-Bot 2 | 3 | {{$NEXT}} 4 | 5 | 1.15 2022-11-13T06:40:31Z 6 | 7 | - #38 Users -> Members fix 8 | - #40 Use rtm connect api 9 | - #41 fix failed to send direct messages 10 | - #42 Use rtm.connect instead of rtm.start 11 | 12 | 1.13 2020-07-05T15:03:42Z 13 | 14 | - #35 Use conversations.list 15 | 16 | 1.12 2019-05-04T01:44:52Z 17 | 18 | - #30 Avoid getting killed by a bug in Slack. 19 | 20 | 1.11 2019-04-27T00:39:51Z 21 | 22 | - #29 Slack changed the limit maximum 23 | - #28 Added missing license meta 24 | 25 | 1.10 2019-04-17T11:56:22Z 26 | 27 | - Fix parameter key 28 | 29 | 1.09 2019-04-13T10:17:17Z 30 | 31 | - Clarify a few die() errors 32 | - Fix missing conversations 33 | 34 | 1.08 2019-01-20T00:39:26Z 35 | 36 | - Migrate channels/groups to conversations api 37 | 38 | 1.07 2019-01-10T22:57:02Z 39 | 40 | - Fix url getting channels 41 | 42 | 1.06 2018-12-29T14:19:45Z 43 | 44 | - Fix a bug that spawn zombies without stop_RTM 45 | 46 | 1.05 2017-05-20T05:01:16Z 47 | 48 | - Fix channel or group not found 49 | 50 | 1.04 2017-04-08T03:30:26Z 51 | 52 | - Fix dying when response to new channel/group 53 | 54 | 1.03 2017-04-05T23:11:07Z 55 | 56 | - Fix a bug that zombies spawn when stop_RTM 57 | - Fix a problem that main process stop when die in callback process 58 | 59 | 1.02 2017-03-29T23:12:01Z 60 | 61 | - Add x_static_install flag 62 | 63 | 1.01 2017-03-25T00:20:55Z 64 | 65 | - Improve that max_message_size can be set to Protocol::WebSocket::Client 66 | - Remove reconnect (not working method) 67 | 68 | 1.00 2017-03-15T17:07:06Z 69 | 70 | - Restore threads to fork (but on MSWin32, using threads) 71 | - Fix to wait establish connection on start_RTM 72 | 73 | 0.14 2017-02-18T16:06:25Z 74 | 75 | - Fix tests without threads 76 | 77 | 0.13 2017-02-11T04:35:24Z 78 | 79 | - Using thread instead of fork 80 | - Fixes say() 81 | 82 | 0.12 2016-10-08T14:29:19Z 83 | 84 | - Fixes reading/writing to private channels 85 | 86 | 0.11 2016-10-05T14:23:02Z 87 | 88 | - Add a error message 89 | - Add a How To Contribute section in POD 90 | 91 | 0.10 2016-09-17T08:15:46Z 92 | 93 | - Fix synopsis 94 | 95 | 0.09 2016-08-28T06:31:34Z 96 | 97 | - Add options 98 | 99 | 0.08 2016-08-04T18:04:39Z 100 | 101 | - Fix action matching process 102 | 103 | 0.07 2016-06-25T00:26:06Z 104 | 105 | - Fix Garbled characters 106 | - Improve execution timing of "say" method 107 | 108 | 0.06 2016-06-24T00:55:32Z 109 | 110 | - Fix a bug that isn't working without using "say" 111 | 112 | 0.05 2016-06-23T16:13:50Z 113 | 114 | - Fix a bug that isn't working on Linux 115 | 116 | 0.04 2016-06-23T12:09:44Z 117 | 118 | - Fix cpanfile 119 | 120 | 0.03 2016-06-22T23:04:39Z 121 | 122 | - Turned off verifying the hostname. 123 | 124 | 0.02 2016-06-22T15:55:41Z 125 | 126 | - Fix a bug that child process will be zombie without stop_RTM. 127 | 128 | 0.01 2016-06-21T22:20:24Z 129 | 130 | - original version 131 | 132 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM perl:5.24 2 | 3 | MAINTAINER shunsuke maeda 4 | 5 | RUN apt-get update && apt-get install -y git curl libio-socket-ssl-perl libnet-ssleay-perl 6 | 7 | WORKDIR /workdir 8 | 9 | COPY cpanfile . 10 | RUN cpanm --installdeps . 11 | 12 | COPY . . 13 | 14 | RUN make build 15 | 16 | ENTRYPOINT ["make"] 17 | CMD ["test"] 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Shunsuke Maeda 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "This is a perl module helping to create slack bot with Real Time Messaging(RTM) API.", 3 | "author" : [ 4 | "Shunsuke Maeda \r" 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.1.20, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "mit" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : 2 14 | }, 15 | "name" : "Slack-RTM-Bot", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "Test::CPAN::Meta" : "0", 37 | "Test::MinimumVersion::Fast" : "0.04", 38 | "Test::PAUSE::Permissions" : "0.07", 39 | "Test::Pod" : "1.41", 40 | "Test::Spellunker" : "v0.2.7" 41 | } 42 | }, 43 | "runtime" : { 44 | "requires" : { 45 | "Data::Dumper" : "0", 46 | "Encode" : "0", 47 | "HTTP::Request::Common" : "0", 48 | "IO::Socket::SSL" : "0", 49 | "JSON" : "0", 50 | "LWP::Protocol::https" : "0", 51 | "LWP::UserAgent" : "0", 52 | "Protocol::WebSocket::Client" : "0", 53 | "perl" : "5.008001" 54 | } 55 | }, 56 | "test" : { 57 | "requires" : { 58 | "Test::Exception" : "0", 59 | "Test::More" : "0.98" 60 | } 61 | } 62 | }, 63 | "release_status" : "unstable", 64 | "resources" : { 65 | "bugtracker" : { 66 | "web" : "https://github.com/duck8823/Slack-RTM-Bot/issues" 67 | }, 68 | "homepage" : "https://github.com/duck8823/Slack-RTM-Bot", 69 | "repository" : { 70 | "type" : "git", 71 | "url" : "https://github.com/duck8823/Slack-RTM-Bot.git", 72 | "web" : "https://github.com/duck8823/Slack-RTM-Bot" 73 | } 74 | }, 75 | "version" : "1.15", 76 | "x_contributors" : [ 77 | "Matt Hallacy ", 78 | "Matt Hallacy ", 79 | "Mohammad S Anwar ", 80 | "Paulo Bu ", 81 | "Tomas Cohen Arazi ", 82 | "dada ", 83 | "kimjackson ", 84 | "makamaka ", 85 | "poptix ", 86 | "shmaeda " 87 | ], 88 | "x_serialization_backend" : "JSON::PP version 4.06", 89 | "x_static_install" : 1 90 | } 91 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | perl Build.PL && ./Build 3 | 4 | test: build 5 | ./Build test 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Slack::RTM::Bot - This is a perl module helping to create slack bot with Real Time Messaging(RTM) API. 4 | 5 | # SYNOPSIS 6 | 7 | use Slack::RTM::Bot; 8 | my $bot = Slack::RTM::Bot->new( token => ''); 9 | 10 | $bot->on({ 11 | channel => 'general', 12 | text => qr/.*/ 13 | }, 14 | sub { 15 | my ($response) = @_; 16 | print $response->{text}."\n"; 17 | } 18 | ); 19 | 20 | $bot->start_RTM(sub { 21 | 22 | $bot->say( 23 | channel => 'general', 24 | text => ' hello, world.' 25 | ); 26 | 27 | $bot->say( 28 | channel => '@username', 29 | text => 'hello, world.' 30 | ); 31 | 32 | while(1) { sleep 10; print "I'm not dead\n"; } 33 | }); 34 | 35 | # METHODS 36 | 37 | ## new 38 | 39 | method new(token => $token) 40 | 41 | Constructs a [Slack::RTM::Bot](https://metacpan.org/pod/Slack%3A%3ARTM%3A%3ABot) object. 42 | 43 | The `$token` is the slack API token. 44 | 45 | ## on 46 | 47 | method on(\%event, $callback) 48 | 49 | `$callback` will be executed when it fitted the `\%event` conditions. 50 | The `\%event` key is equal to a key of json received from slack, and value is estimated as regex. 51 | 52 | `$callback` is handed JSON object of message received from Slack. 53 | 54 | ## start\_RTM 55 | 56 | method start_RTM($callback) 57 | 58 | It start Real Time Messaging API. 59 | `$callback` will be executed when establish connection. 60 | `start_RTM` make child process. Thus, you must call `stop_RTM` if you want to kill child processes before stop main process. 61 | 62 | ## stop\_RTM 63 | 64 | method stop_RTM() 65 | 66 | It stop Real Time Messaging API. 67 | 68 | ## say 69 | 70 | method say(%options) 71 | 72 | It sent a message to a Slack. The channel name can be used to designate channel. 73 | if you want to send a direct message, let designate the @username as a channel. 74 | 75 | # SOURCE CODE 76 | 77 | This is opensource software. 78 | 79 | https://github.com/duck8823/Slack-RTM-Bot 80 | 81 | # HOW TO CONTRIBUTE 82 | 83 | ## with installing 84 | The fastest way to get started working with the code is to run the following commands: 85 | 86 | $ git clone https://github.com/duck8823/Slack-RTM-Bot.git 87 | $ cd Slack-RTM-Bot 88 | $ cpanm --installdeps . 89 | $ perl Build.PL 90 | $ ./Build 91 | $ ./Build install 92 | $ ./Build test # run the tests 93 | 94 | ## without installing 95 | or without installing Slack-RTM-Bot, run the following commands: 96 | 97 | $ git clone https://github.com/duck8823/Slack-RTM-Bot.git 98 | $ cd Slack-RTM-Bot 99 | $ cpanm --installdeps . # install dependencies 100 | 101 | and run your script with \`-I/path/to/Slack-RTM-Bot/lib\` option. 102 | 103 | $ perl -I/path/to/Slack-RTM-Bot/lib your_script.pl 104 | 105 | # SEE ALSO 106 | 107 | https://api.slack.com/rtm 108 | 109 | # LICENSE 110 | 111 | The MIT License (MIT) 112 | 113 | Copyright (c) 2016 Shunsuke Maeda 114 | 115 | See LICENSE file. 116 | 117 | # AUTHOR 118 | 119 | Shunsuke Maeda 120 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'Encode'; 2 | requires 'HTTP::Request::Common'; 3 | requires 'IO::Socket::SSL'; 4 | requires 'JSON'; 5 | requires 'Data::Dumper'; 6 | requires 'LWP::Protocol::https'; 7 | requires 'LWP::UserAgent'; 8 | requires 'Protocol::WebSocket::Client'; 9 | requires 'perl', '5.008001'; 10 | 11 | on configure => sub { 12 | requires 'Module::Build::Tiny', '0.035'; 13 | }; 14 | 15 | on test => sub { 16 | requires 'Test::Exception'; 17 | requires 'Test::More', '0.98'; 18 | }; 19 | -------------------------------------------------------------------------------- /lib/Slack/RTM/Bot.pm: -------------------------------------------------------------------------------- 1 | package Slack::RTM::Bot; 2 | 3 | use 5.008001; 4 | use strict; 5 | use warnings; 6 | 7 | use POSIX qw/sys_wait_h/; 8 | 9 | use JSON; 10 | use Slack::RTM::Bot::Client; 11 | 12 | our $VERSION = "1.15"; 13 | 14 | pipe(READH, WRITEH); 15 | select(WRITEH);$|=1; 16 | pipe(READH2, WRITEH2); 17 | select(WRITEH2);$|=1; 18 | select(STDOUT); 19 | 20 | sub new { 21 | my $pkg = shift; 22 | my $self = { 23 | @_ 24 | }; 25 | die 'need token!' unless $self->{token}; 26 | return bless $self, $pkg; 27 | } 28 | 29 | sub start_RTM { 30 | my $self = shift; 31 | my ($sub) = @_; 32 | $self->_connect($self->{options}); 33 | 34 | my $parent = $$; 35 | 36 | if ($^O ne 'MSWin32') { 37 | my @children = (); 38 | 39 | my $pid = fork; 40 | push @children, $pid; 41 | unless ($pid) { 42 | while (1) { 43 | unless (kill 0, $pid) { 44 | kill 9, $pid; 45 | waitpid($pid, WUNTRACED); 46 | last; 47 | } 48 | print WRITEH "\n"; 49 | sleep 1; 50 | } 51 | } else { 52 | my $pid = fork; 53 | push @children, $pid; 54 | unless ($pid) { 55 | $self->{client}->{pids} = [$parent, @children]; 56 | my $i = 0; 57 | while (1) { 58 | unless (kill 0, $parent) { 59 | kill 9, $pid; 60 | waitpid($pid, WUNTRACED); 61 | last; 62 | } 63 | if ($self->{client}->read) { 64 | print WRITEH2 "\n"; 65 | } 66 | (my $buffer = ) =~ s/\n.*$//; 67 | if ($buffer) { 68 | $self->{client}->write( 69 | %{JSON::from_json(Encode::decode_utf8($buffer))} 70 | ); 71 | } 72 | if (++$i % 30 == 0) { 73 | $self->{client}->write( 74 | id => $i, 75 | type => 'ping' 76 | ); 77 | } 78 | } 79 | } else { 80 | $self->{children} = \@children; 81 | # wait until connected 82 | ; 83 | &$sub($self) if $sub; 84 | } 85 | }; 86 | } else { 87 | require threads; 88 | require Thread::Queue; 89 | 90 | threads->create( 91 | sub { 92 | while (kill 0, $parent) { 93 | print WRITEH "\n"; 94 | sleep 1; 95 | } 96 | } 97 | )->detach; 98 | 99 | threads->create( 100 | sub { 101 | my $i = 0; 102 | while (kill 0, $parent) { 103 | if ($self->{client}->read) { 104 | print WRITEH2 "\n"; 105 | } 106 | (my $buffer = ) =~ s/\n.*$//; 107 | if ($buffer) { 108 | $self->{client}->write( 109 | %{JSON::from_json(Encode::decode_utf8($buffer))} 110 | ); 111 | } 112 | if (++$i % 30 == 0) { 113 | $self->{client}->write( 114 | id => $i, 115 | type => 'ping' 116 | ); 117 | } 118 | } 119 | } 120 | )->detach; 121 | 122 | $self->{queue} = Thread::Queue->new(); 123 | $self->{worker} = threads->create(sub { 124 | while (defined(my $req = $self->{queue}->dequeue())) { 125 | print WRITEH $req; 126 | } 127 | }); 128 | 129 | # wait until connected 130 | ; 131 | &$sub($self) if $sub; 132 | } 133 | } 134 | 135 | sub stop_RTM { 136 | my $self = shift; 137 | 138 | sleep 1; 139 | $self->{client}->disconnect; 140 | undef $self->{client}; 141 | 142 | if ($^O ne 'MSWin32') { 143 | for my $child (@{$self->{children}}) { 144 | kill 9, $child; 145 | waitpid($child, WUNTRACED); 146 | } 147 | undef $self->{children}; 148 | } else { 149 | $self->{queue}->end(); 150 | $self->{worker}->join(); 151 | } 152 | } 153 | 154 | sub _connect { 155 | my $self = shift; 156 | 157 | my $client = Slack::RTM::Bot::Client->new( 158 | token => $self->{token}, 159 | actions => $self->{actions}, 160 | options => $self->{options} 161 | ); 162 | $client->connect($self->{token}); 163 | 164 | $self->{client} = $client; 165 | } 166 | 167 | sub say { 168 | my $self = shift; 169 | my $args; 170 | if(!@_ || scalar @_ % 2 != 0) { 171 | die "argument is not a HASH or ARRAY." 172 | } 173 | $args = {@_}; 174 | if(!defined $args->{text} || !defined $args->{channel}) { 175 | die "argument needs keys 'text' and 'channel'."; 176 | } 177 | 178 | die "RTM not started." unless $self->{client}; 179 | 180 | my $request = JSON::to_json({ 181 | type => 'message', 182 | subtype => 'bot_message', 183 | bot_id => $self->{client}->{info}->{self}->{id}, 184 | %$args, 185 | channel => $self->{client}->find_conversation_id($args->{channel}) 186 | })."\n"; 187 | print WRITEH $request; 188 | } 189 | 190 | sub on { 191 | my $self = shift; 192 | die "RTM already started." if $self->{info}; 193 | my ($events, $routine) = @_; 194 | push @{$self->{actions}}, { 195 | events => $events, 196 | routine => $routine 197 | }; 198 | } 199 | 200 | sub add_action { 201 | my $self = shift; 202 | $self->on(@_); 203 | } 204 | 205 | 1; 206 | __END__ 207 | 208 | =encoding utf-8 209 | 210 | =head1 NAME 211 | 212 | Slack::RTM::Bot - This is a perl module helping to create slack bot with Real Time Messaging(RTM) API. 213 | 214 | =head1 SYNOPSIS 215 | 216 | use Slack::RTM::Bot; 217 | my $bot = Slack::RTM::Bot->new( token => ''); 218 | 219 | $bot->on({ 220 | channel => 'general', 221 | text => qr/.*/ 222 | }, 223 | sub { 224 | my ($response) = @_; 225 | print $response->{text}."\n"; 226 | } 227 | ); 228 | 229 | $bot->start_RTM(sub { 230 | 231 | $bot->say( 232 | channel => 'general', 233 | text => ' hello, world.' 234 | ); 235 | 236 | $bot->say( 237 | channel => '@username', 238 | text => 'hello, world.' 239 | ); 240 | 241 | while(1) { sleep 10; print "I'm not dead\n"; } 242 | }); 243 | 244 | =head1 METHODS 245 | 246 | =head2 new 247 | 248 | method new(token => $token) 249 | 250 | Constructs a L object. 251 | 252 | The C<$token> is the slack API token. 253 | 254 | =head2 on 255 | 256 | method on(\%event, $callback) 257 | 258 | C<$callback> will be executed when it fitted the C<\%event> conditions. 259 | The C<\%event> key is equal to a key of json received from slack, and value is estimated as regex. 260 | 261 | C<$callback> is handed JSON object of message received from Slack. 262 | 263 | =head2 start_RTM 264 | 265 | method start_RTM($callback) 266 | 267 | It start Real Time Messaging API. 268 | C<$callback> will be executed when establish connection. 269 | C make child process. Thus, you must call C if you want to kill child processes before stop main process. 270 | 271 | =head2 stop_RTM 272 | 273 | method stop_RTM() 274 | 275 | It stop Real Time Messaging API. 276 | 277 | =head2 say 278 | 279 | method say(%options) 280 | 281 | It sent a message to a Slack. The channel name can be used to designate channel. 282 | if you want to send a direct message, let designate the @username as a channel. 283 | 284 | =head1 SOURCE CODE 285 | 286 | This is opensource software. 287 | 288 | https://github.com/duck8823/Slack-RTM-Bot 289 | 290 | =head1 HOW TO CONTRIBUTE 291 | 292 | =head2 with installing 293 | The fastest way to get started working with the code is to run the following commands: 294 | 295 | $ git clone https://github.com/duck8823/Slack-RTM-Bot.git 296 | $ cd Slack-RTM-Bot 297 | $ cpanm --installdeps . 298 | $ perl Build.PL 299 | $ ./Build 300 | $ ./Build install 301 | $ ./Build test # run the tests 302 | 303 | =head2 without installing 304 | or without installing Slack-RTM-Bot, run the following commands: 305 | 306 | $ git clone https://github.com/duck8823/Slack-RTM-Bot.git 307 | $ cd Slack-RTM-Bot 308 | $ cpanm --installdeps . # install dependencies 309 | 310 | and run your script with `-I/path/to/Slack-RTM-Bot/lib` option. 311 | 312 | $ perl -I/path/to/Slack-RTM-Bot/lib your_script.pl 313 | 314 | =head1 SEE ALSO 315 | 316 | https://api.slack.com/rtm 317 | 318 | =head1 LICENSE 319 | 320 | The MIT License (MIT) 321 | 322 | Copyright (c) 2016 Shunsuke Maeda 323 | 324 | See LICENSE file. 325 | 326 | =head1 AUTHOR 327 | 328 | Shunsuke Maeda Educk8823@gmail.comE 329 | 330 | =cut 331 | 332 | -------------------------------------------------------------------------------- /lib/Slack/RTM/Bot/Client.pm: -------------------------------------------------------------------------------- 1 | package Slack::RTM::Bot::Client; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use JSON; 7 | use Encode; 8 | use Data::Dumper; 9 | use HTTP::Request::Common qw(POST GET); 10 | use LWP::UserAgent; 11 | use LWP::Protocol::https; 12 | 13 | use Protocol::WebSocket::Client; 14 | use IO::Socket::SSL qw/SSL_VERIFY_NONE/; 15 | 16 | use Slack::RTM::Bot::Information; 17 | use Slack::RTM::Bot::Response; 18 | 19 | my $ua = LWP::UserAgent->new( 20 | ssl_opts => { 21 | verify_hostname => 0, 22 | SSL_verify_mode => SSL_VERIFY_NONE 23 | } 24 | ); 25 | $ua->agent('Slack::RTM::Bot'); 26 | 27 | sub new { 28 | my $pkg = shift; 29 | my $self = { 30 | @_ 31 | }; 32 | die "token is required." unless $self->{token}; 33 | return bless $self, $pkg; 34 | } 35 | 36 | sub connect { 37 | my $self = shift; 38 | my ($token) = @_; 39 | 40 | my $res = $ua->request(POST 'https://slack.com/api/rtm.connect', [ token => $token ]); 41 | my $content; 42 | eval { 43 | $content = JSON::from_json($res->content); 44 | }; 45 | if ($@) { 46 | die 'connect response fail:'.Dumper $res->content; 47 | } 48 | die 'connect response fail: '.$res->content unless ($content->{ok}); 49 | 50 | $self->{info} = Slack::RTM::Bot::Information->new(%{$content}); 51 | $self->_connect; 52 | } 53 | 54 | sub _connect { 55 | my $self = shift; 56 | my ($host) = $self->{info}->{url} =~ m{wss://(.+)/websocket}; 57 | my $socket = IO::Socket::SSL->new( 58 | SSL_verify_mode => SSL_VERIFY_NONE, 59 | PeerHost => $host, 60 | PeerPort => 443 61 | ); 62 | $socket->blocking(0); 63 | $socket->connect; 64 | 65 | my $ws_client = Protocol::WebSocket::Client->new(url => $self->{info}->{url}); 66 | $ws_client->{hs}->req->{max_message_size} = $self->{options}->{max_message_size} if $self->{options}->{max_message_size}; 67 | $ws_client->{hs}->res->{max_message_size} = $self->{options}->{max_message_size} if $self->{options}->{max_message_size}; 68 | $ws_client->on(read => sub { 69 | my ($cli, $buffer) = @_; 70 | $self->_listen($buffer); 71 | }); 72 | $ws_client->on(write => sub { 73 | my ($cli, $buffer) = @_; 74 | syswrite $socket, $buffer; 75 | }); 76 | $ws_client->on(connect => sub { 77 | print "RTM (re)connected.\n" if ($self->{options}->{debug}); 78 | }); 79 | $ws_client->on(error => sub { 80 | my ($cli, $error) = @_; 81 | print STDERR 'error: '. $error; 82 | }); 83 | $ws_client->connect; 84 | 85 | $self->{ws_client} = $ws_client; 86 | $self->{socket} = $socket; 87 | } 88 | 89 | sub disconnect { 90 | my $self = shift; 91 | $self->{ws_client}->disconnect; 92 | undef $self; 93 | } 94 | 95 | sub read { 96 | my $self = shift; 97 | my $data = ''; 98 | while (my $line = readline $self->{socket}) { 99 | $data .= $line; 100 | } 101 | if ($data) { 102 | $self->{ws_client}->read($data); 103 | return $data =~ /.*hello.*/; 104 | } 105 | } 106 | 107 | sub write { 108 | my $self = shift; 109 | $self->{ws_client}->write(JSON::encode_json({@_})); 110 | } 111 | 112 | sub find_conversation_id { 113 | my $self = shift; 114 | my ($name) = @_; 115 | my $id = $self->{info}->_find_conversation_id($name); 116 | $id ||= $self->_refetch_conversation_id($name) or die "There are no conversations of such name: $name"; 117 | return $id; 118 | } 119 | 120 | sub _refetch_conversation_id { 121 | my $self = shift; 122 | my ($name) = @_; 123 | $self->_refetch_conversations; 124 | return $self->{info}->_find_conversation_id($name); 125 | } 126 | 127 | sub find_conversation_name { 128 | my $self = shift; 129 | my ($id) = @_; 130 | my $name = $self->{info}->_find_conversation_name($id); 131 | $name ||= $self->_refetch_conversation_name($id) or warn "There are no conversations of such id: $id"; 132 | $name ||= $id; 133 | return $name; 134 | } 135 | 136 | sub _refetch_conversation_name { 137 | my $self = shift; 138 | my ($id) = @_; 139 | $self->_refetch_conversations; 140 | return $self->{info}->_find_conversation_name($id); 141 | } 142 | 143 | sub _refetch_conversations { 144 | my $self = shift; 145 | my $cursor = ""; 146 | do { 147 | my $res = $ua->request(POST 'https://slack.com/api/conversations.list', [ token => $self->{token}, types => "public_channel,private_channel,im", cursor => $cursor ]); 148 | my $content; 149 | eval { 150 | $content = JSON::decode_json($res->content); 151 | }; 152 | if ($@) { 153 | die 'connect response fail:' . Dumper $res->content; 154 | } 155 | die 'connect response fail: ' . $res->content unless ($content->{ok}); 156 | 157 | for my $channel (@{$content->{channels}}) { 158 | if ($channel->{is_im}) { 159 | my $user_id = $channel->{user}; 160 | my $name = $self->{info}->_find_user_name($user_id); 161 | $name ||= $self->_refetch_user_name($user_id) or warn "There are no users of such id: $user_id"; 162 | $self->{info}->{channels}->{$channel->{id}} = { %$channel, name => '@'.$name }; 163 | next; 164 | } 165 | $self->{info}->{channels}->{$channel->{id}} = $channel; 166 | } 167 | 168 | $cursor = $content->{response_metadata}->{next_cursor}; 169 | } until ($cursor eq ""); 170 | } 171 | 172 | sub find_user_name { 173 | my $self = shift; 174 | my ($id) = @_; 175 | my $name = $self->{info}->_find_user_name($id); 176 | $name ||= $self->_refetch_user_name($id) or warn "There are no users of such id: $id"; 177 | $name ||= $id; 178 | return $name; 179 | } 180 | 181 | sub _refetch_user_id { 182 | my $self = shift; 183 | my ($name) = @_; 184 | $self->_refetch_users; 185 | return $self->{info}->_find_user_id($name); 186 | } 187 | 188 | sub _refetch_user_name { 189 | my $self = shift; 190 | my ($id) = @_; 191 | $self->_refetch_users; 192 | return $self->{info}->_find_user_name($id); 193 | } 194 | 195 | sub _refetch_users { 196 | my $self = shift; 197 | my $res; 198 | eval { 199 | my $users = {}; 200 | my $cursor = ""; 201 | do { 202 | $res = $ua->request(GET "https://slack.com/api/users.list?token=$self->{token}&cursor=$cursor"); 203 | my $args = JSON::from_json($res->content); 204 | for my $user (@{$args->{members}}) { 205 | $users->{$user->{id}} = $user; 206 | } 207 | if (defined($args->{response_metadata}->{next_cursor})) { 208 | $cursor = $args->{response_metadata}->{next_cursor}; 209 | } 210 | } until ($cursor eq ""); 211 | $self->{info}->{users} = $users; 212 | }; 213 | if ($@) { 214 | die '_refetch_users response fail:'.Dumper $res->content; 215 | } 216 | } 217 | 218 | sub _listen { 219 | my $self = shift; 220 | my ($buffer) = @_; 221 | my $buffer_obj; 222 | eval { 223 | $buffer_obj = JSON::from_json($buffer); 224 | }; 225 | if ($@) { 226 | die "response is not json string. : $buffer"; 227 | } 228 | if ($buffer_obj->{type} && $buffer_obj->{type} eq 'reconnect_url') { 229 | $self->{info}->{url} = $buffer_obj->{url}; 230 | } 231 | 232 | my ($user, $channel); 233 | if ($buffer_obj->{user} && !ref($buffer_obj->{user})) { 234 | $user = $self->find_user_name($buffer_obj->{user}); 235 | warn "There are no users of such id: $buffer_obj->{user}" unless $user; 236 | } 237 | if ($buffer_obj->{channel} && !ref($buffer_obj->{channel})) { 238 | $channel = $self->find_conversation_name($buffer_obj->{channel}); 239 | warn "There are no conversations of such id: $buffer_obj->{channel}" unless $channel; 240 | 241 | } 242 | my $response = Slack::RTM::Bot::Response->new( 243 | buffer => $buffer_obj, 244 | user => $user, 245 | channel => $channel 246 | ); 247 | ACTION: for my $action(@{$self->{actions}}){ 248 | for my $key(keys %{$action->{events}}){ 249 | my $regex = $action->{events}->{$key}; 250 | if(!defined $response->{$key} || $response->{$key} !~ $regex){ 251 | next ACTION; 252 | } 253 | } 254 | eval { 255 | $action->{routine}->($response); 256 | }; 257 | if ($@) { 258 | warn $@; 259 | kill 9, @{$self->{pids}}; 260 | exit(1); 261 | } 262 | } 263 | }; 264 | 265 | 1; 266 | -------------------------------------------------------------------------------- /lib/Slack/RTM/Bot/Information.pm: -------------------------------------------------------------------------------- 1 | package Slack::RTM::Bot::Information; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $pkg = shift; 8 | my ($args) = {@_}; 9 | my $self = { 10 | @_, 11 | }; 12 | $self->{users} = &_parse_users($args); 13 | $self->{channels} = &_parse_conversations($args); 14 | return bless $self, $pkg; 15 | } 16 | 17 | sub _parse_users { 18 | my $args = shift; 19 | my $users = {}; 20 | for my $user (@{$args->{users}}){ 21 | $users->{$user->{id}} = $user; 22 | } 23 | return $users; 24 | } 25 | 26 | sub _parse_conversations { 27 | my $args = shift; 28 | my $conversations = {}; 29 | for my $conversation (@{$args->{channels}}){ 30 | $conversations->{$conversation->{id}} = $conversation; 31 | } 32 | return $conversations; 33 | } 34 | 35 | sub _find_conversation_id { 36 | my $self = shift; 37 | my ($name) = @_; 38 | my $conversations = $self->{channels}; 39 | 40 | for my $key (keys %{$conversations}){ 41 | if($name eq $conversations->{$key}->{name}){ 42 | return $conversations->{$key}->{id}; 43 | } 44 | } 45 | return undef; 46 | } 47 | 48 | sub _find_conversation_name { 49 | my $self = shift; 50 | my ($id) = @_; 51 | my $conversations = $self->{channels}; 52 | return $conversations->{$id}->{name} if $conversations->{$id}; 53 | } 54 | 55 | sub _find_user_name { 56 | my $self = shift; 57 | my ($id) = @_; 58 | my $users = $self->{users}; 59 | return $users->{$id}->{name} if $users->{$id}; 60 | } 61 | 62 | 1; 63 | -------------------------------------------------------------------------------- /lib/Slack/RTM/Bot/Response.pm: -------------------------------------------------------------------------------- 1 | package Slack::RTM::Bot::Response; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $pkg = shift; 8 | my $args = {@_}; 9 | my $self = {%{$args->{buffer}}}; 10 | $self->{user} = $args->{user}; 11 | $self->{channel} = $args->{channel}; 12 | return bless $self, $pkg; 13 | } 14 | 15 | 1; -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "Slack-RTM-Bot" 2 | # badges = ["travis"] 3 | module_maker="ModuleBuildTiny" 4 | license = "mit" 5 | [Metadata] 6 | x_static_install = 1 7 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | 6 | local $SIG{__WARN__} = sub { fail shift }; 7 | 8 | use_ok $_ for qw( 9 | Slack::RTM::Bot 10 | ); 11 | 12 | done_testing; 13 | 14 | -------------------------------------------------------------------------------- /t/01_new.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | use Test::Exception; 6 | 7 | use Slack::RTM::Bot; 8 | 9 | local $SIG{__WARN__} = sub { fail shift }; 10 | 11 | my $bot = Slack::RTM::Bot->new( 12 | token => 'foobar' 13 | ); 14 | isa_ok $bot, 'Slack::RTM::Bot'; 15 | 16 | dies_ok { Slack::RTM::Bot->new(); }; 17 | 18 | done_testing; -------------------------------------------------------------------------------- /t/02_connect.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | use Test::Exception; 6 | 7 | use Slack::RTM::Bot; 8 | 9 | local $SIG{__WARN__} = sub { fail shift }; 10 | 11 | my $token = $ENV{SLACK_API_TOKEN}; 12 | 13 | subtest 'ENV', sub { 14 | SKIP: { 15 | skip 'No SLACK_API_TOKEN configured for testing.', 1 unless $token; 16 | my $bot = Slack::RTM::Bot->new( 17 | token => $token 18 | ); 19 | 20 | $bot->start_RTM; 21 | isa_ok $bot->{client}, 'Slack::RTM::Bot::Client'; 22 | 23 | $bot->stop_RTM; 24 | 25 | is defined $bot->{client}, ''; 26 | is defined $bot->{child}, ''; 27 | } 28 | }; 29 | 30 | subtest 'invalid_token', sub { 31 | my $bot = Slack::RTM::Bot->new( 32 | token => 'invalid_token' 33 | ); 34 | 35 | dies_ok {$bot->start_RTM}; 36 | }; 37 | 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/03_action.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | use Test::Exception; 6 | 7 | use Slack::RTM::Bot; 8 | 9 | local $SIG{__WARN__} = sub { fail shift }; 10 | 11 | my $bot = Slack::RTM::Bot->new( 12 | token => 'foobar' 13 | ); 14 | is @{$bot->{actions}}, 0; 15 | 16 | my $return; 17 | $bot->add_action( 18 | { 19 | foo => 'bar' 20 | },sub { 21 | $return = 1; 22 | } 23 | ); 24 | is @{$bot->{actions}}, 1; 25 | 26 | $bot->add_action( 27 | { 28 | foo => 'bar' 29 | },sub { 30 | $return = 2; 31 | } 32 | ); 33 | is @{$bot->{actions}}, 2; 34 | 35 | is ${$bot->{actions}}[0]->{events}->{foo}, 'bar'; 36 | 37 | is $return, undef; 38 | &{${$bot->{actions}}[0]->{routine}}; 39 | is $return, 1; 40 | 41 | done_testing(); -------------------------------------------------------------------------------- /t/04_say.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | use Test::Exception; 6 | 7 | use Slack::RTM::Bot; 8 | 9 | local $SIG{__WARN__} = sub { fail shift }; 10 | 11 | my $bot = Slack::RTM::Bot->new( 12 | token => 'foobar' 13 | ); 14 | 15 | dies_ok { 16 | $bot->say( 17 | 'hoge' 18 | ); 19 | }; 20 | like $@, qr/argument is not a HASH or ARRAY\..*/; 21 | 22 | dies_ok { 23 | $bot->say(); 24 | }; 25 | like $@, qr/argument is not a HASH or ARRAY\..*/; 26 | 27 | dies_ok { 28 | $bot->say( 29 | 'text' => 'hoge' 30 | ) 31 | }; 32 | like $@, qr/argument needs keys 'text' and 'channel'\..*/; 33 | 34 | dies_ok { 35 | $bot->say( 36 | 'channel' => 'hoge' 37 | ) 38 | }; 39 | like $@, qr/argument needs keys 'text' and 'channel'\..*/; 40 | 41 | dies_ok { 42 | $bot->say( 43 | 'channel' => 'hoge', 44 | 'text' => 'hoge' 45 | ) 46 | }; 47 | like $@, qr/RTM not started.*/; 48 | 49 | dies_ok { 50 | $bot->say( 51 | 'channel', 'hoge', 52 | 'text', 'hoge' 53 | ) 54 | }; 55 | like $@, qr/RTM not started.*/; 56 | 57 | SKIP: { 58 | my $token = $ENV{SLACK_API_TOKEN}; 59 | unless ($token) { 60 | skip 'No SLACK_API_TOKEN configured for testing.', 2; 61 | } 62 | 63 | my $tmp = "./test.tmp"; 64 | 65 | $bot = Slack::RTM::Bot->new( 66 | token => $token 67 | ); 68 | 69 | $bot->add_action( 70 | { 71 | type => 'message', 72 | channel => 'test' 73 | }, 74 | sub { 75 | my ($response) = shift; 76 | open TMP, ">$tmp" or die $!; 77 | print TMP $response->{text}; 78 | close TMP; 79 | } 80 | ); 81 | $bot->add_action( 82 | { 83 | type => 'error', 84 | }, 85 | sub { 86 | my ($response) = shift; 87 | open TMP, ">$tmp" or fail $!; 88 | print TMP $response->{error}->{msg}; 89 | close TMP; 90 | } 91 | ); 92 | 93 | $bot->start_RTM; 94 | 95 | $bot->say( 96 | channel => 'test', 97 | text => 'return' 98 | ); 99 | 100 | sleep 3; 101 | 102 | open TMP, "$tmp" or fail $!; 103 | my $result = ; 104 | close TMP; 105 | is $result, 'return'; 106 | 107 | dies_ok { 108 | $bot->say( 109 | channel => 'invalid_channel_id', 110 | text => 'return' 111 | ); 112 | } 113 | 114 | $bot->stop_RTM; 115 | unlink $tmp; 116 | } 117 | done_testing(); 118 | 119 | -------------------------------------------------------------------------------- /t/05_actions.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Slack::RTM::Bot; 6 | use JSON; 7 | 8 | my $json = JSON->new->utf8; 9 | my $ret = ''; 10 | my $cnt = 0; 11 | my $bot = Slack::RTM::Bot->new( 12 | token => 'foobar' 13 | ); 14 | 15 | 16 | $bot->add_action( 17 | { 18 | type => qr/foo/ 19 | }, sub { 20 | $ret = 'foo'; 21 | $cnt++; 22 | } 23 | ); 24 | 25 | $bot->add_action( 26 | { 27 | type => qr/bar/, 28 | hoge => qr/huga/, 29 | }, sub { 30 | $ret = 'bar'; 31 | $cnt++; 32 | } 33 | ); 34 | 35 | 36 | 37 | $bot->{ client } = Slack::RTM::Bot::Client->new( 38 | token => $bot->{token}, 39 | actions => $bot->{actions}, 40 | ); 41 | 42 | $bot->{ client }->_listen( $json->encode({'type' => 'foo'}) ); 43 | is $ret, 'foo', 'match type foo'; 44 | 45 | $bot->{ client }->_listen( $json->encode({'type' => 'bar'}) ); 46 | is $ret, 'foo', 'match type bar but mismatch another item'; 47 | 48 | $bot->{ client }->_listen( $json->encode({'type' => 'bar', 'hoge' => 'huga-'}) ); 49 | is $ret, 'bar', 'match type bar and another item hoge'; 50 | 51 | is $cnt, 2, 'tolal 2 matches'; 52 | 53 | done_testing(); 54 | -------------------------------------------------------------------------------- /t/06_channel_is_hash.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Slack::RTM::Bot; 6 | use JSON; 7 | 8 | my $json = JSON->new->utf8; 9 | my $ret = ''; 10 | my $cnt = 0; 11 | my $bot = Slack::RTM::Bot->new( 12 | token => 'foobar' 13 | ); 14 | 15 | $bot->add_action( 16 | { 17 | type => qr/message/ 18 | }, sub { 19 | my ( $ret ) = @_; 20 | is( $ret->{channel}, 'Test', 'channel was converted' ); 21 | is( $ret->{user}, 'Anne', 'user was converted' ); 22 | $cnt++; 23 | } 24 | ); 25 | 26 | $bot->add_action( 27 | { 28 | }, sub { 29 | my ( $ret ) = @_; 30 | $cnt++; 31 | } 32 | ); 33 | 34 | 35 | $bot->{ client } = Slack::RTM::Bot::Client->new( 36 | token => $bot->{token}, 37 | actions => $bot->{actions}, 38 | ); 39 | $bot->{client}->{info} = Slack::RTM::Bot::Information->new( 40 | channels => [ { id => 'C123', name => 'Test' } ], 41 | users => [ { id => 'U123', name => 'Anne' } ], 42 | ); 43 | 44 | 45 | $bot->{ client }->_listen( $json->encode( {'type' => 'message', 'user' => 'U123', 'text' => 'This is test.', 'channel' => 'C123'} ) ); 46 | is $cnt, 2, 'tolal 2 matches'; 47 | $bot->{ client }->_listen( $json->encode( {'type' => 'foo', 'channel' => +{} }) ); 48 | is $cnt, 3, 'tolal 3 matches'; 49 | 50 | 51 | done_testing(); 52 | -------------------------------------------------------------------------------- /t/07_information.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More 0.98; 5 | use Test::Exception; 6 | 7 | use Slack::RTM::Bot; 8 | 9 | local $SIG{__WARN__} = sub { fail shift }; 10 | 11 | my $info = Slack::RTM::Bot::Information->new( 12 | channels => [ { id => 'C123', name => 'Conversation' } ], 13 | users => [ { id => 'U123', name => 'User' } ], 14 | ); 15 | 16 | subtest 'find_conversation', sub { 17 | is $info->_find_conversation_id('Conversation'), 'C123', 'find conversation id.'; 18 | is $info->_find_conversation_name('C123'), 'Conversation', 'find conversation name.'; 19 | }; 20 | 21 | subtest 'find_user', sub { 22 | is $info->_find_user_name('U123'), 'User', 'find user id.'; 23 | is $info->_find_user_name('Undefined User'), undef, 'find undefined user id'; 24 | }; 25 | 26 | 27 | done_testing; 28 | --------------------------------------------------------------------------------