1 | use strict; |
---|
2 | use warnings; |
---|
3 | |
---|
4 | package BarnOwl::Module::Zulip; |
---|
5 | |
---|
6 | our $VERSION=0.1; |
---|
7 | our $queue_id; |
---|
8 | our $last_event_id; |
---|
9 | our %cfg; |
---|
10 | our $max_retries = 1000; |
---|
11 | our $retry_timer; |
---|
12 | our $tls_ctx; |
---|
13 | our %msg_id_map; |
---|
14 | our $presence_timer; |
---|
15 | |
---|
16 | use AnyEvent; |
---|
17 | use AnyEvent::HTTP; |
---|
18 | use AnyEvent::TLS; |
---|
19 | use JSON; |
---|
20 | use MIME::Base64; |
---|
21 | use URI; |
---|
22 | use URI::Encode; |
---|
23 | use BarnOwl::Hooks; |
---|
24 | use BarnOwl::Message::Zulip; |
---|
25 | use HTTP::Request::Common; |
---|
26 | use Getopt::Long qw(GetOptionsFromArray); |
---|
27 | |
---|
28 | sub fail { |
---|
29 | my $msg = shift; |
---|
30 | undef %cfg; |
---|
31 | undef $queue_id; |
---|
32 | undef $last_event_id; |
---|
33 | |
---|
34 | BarnOwl::admin_message('Zulip Error', $msg); |
---|
35 | die("Zulip Error: $msg\n"); |
---|
36 | } |
---|
37 | |
---|
38 | |
---|
39 | sub initialize { |
---|
40 | my $conffile = BarnOwl::get_config_dir() . "/zulip"; |
---|
41 | |
---|
42 | if (open(my $fh, "<", "$conffile")) { |
---|
43 | read_config($fh); |
---|
44 | close($fh); |
---|
45 | } |
---|
46 | if ($cfg{'api_url'} =~ /^https/) { |
---|
47 | if (exists $cfg{'ssl_key_file'}) { |
---|
48 | $tls_ctx = new AnyEvent::TLS(verify => $cfg{'ssl_verify'}, |
---|
49 | sslv3 => 0, verify_peername => "http", |
---|
50 | ca_file => $cfg{'ssl_ca_file'}, |
---|
51 | cert_file => $cfg{'ssl_cert_file'}, |
---|
52 | key_file => $cfg{'ssl_key_file'}); |
---|
53 | } else { |
---|
54 | $tls_ctx = new AnyEvent::TLS(verify => $cfg{'ssl_verify'}, |
---|
55 | sslv3 => 0, verify_peername => "http", |
---|
56 | ca_file => $cfg{'ssl_ca_file'}); |
---|
57 | } |
---|
58 | } else { |
---|
59 | # we still want it for a unique id |
---|
60 | $tls_ctx = int(rand(1024)); |
---|
61 | } |
---|
62 | } |
---|
63 | |
---|
64 | |
---|
65 | sub authorization { |
---|
66 | return "Basic " . encode_base64($cfg{'user'} . ':' . $cfg{'apikey'}, "") |
---|
67 | } |
---|
68 | |
---|
69 | sub read_config { |
---|
70 | my $fh = shift; |
---|
71 | |
---|
72 | my $raw_cfg = do {local $/; <$fh>}; |
---|
73 | close($fh); |
---|
74 | eval { |
---|
75 | $raw_cfg = from_json($raw_cfg); |
---|
76 | }; |
---|
77 | if($@) { |
---|
78 | fail("Unable to parse config file: $@"); |
---|
79 | } |
---|
80 | |
---|
81 | if(! exists $raw_cfg->{user}) { |
---|
82 | fail("Account has no username set."); |
---|
83 | } |
---|
84 | my $user = $raw_cfg->{user}; |
---|
85 | if(! exists $raw_cfg->{apikey}) { |
---|
86 | fail("Account has no api key set."); |
---|
87 | } |
---|
88 | my $apikey = $raw_cfg->{apikey}; |
---|
89 | if(! exists $raw_cfg->{api_url}) { |
---|
90 | fail("Account has no API url set."); |
---|
91 | } |
---|
92 | my $api_url = $raw_cfg->{api_url}; |
---|
93 | |
---|
94 | if(! exists $raw_cfg->{default_realm}) { |
---|
95 | fail("Account has no default realm set."); |
---|
96 | } |
---|
97 | my $default_realm = $raw_cfg->{default_realm}; |
---|
98 | |
---|
99 | if( exists $raw_cfg->{ssl}) { |
---|
100 | # mandatory parameters |
---|
101 | if (! exists $raw_cfg->{ssl}->{ca_file}) { |
---|
102 | fail("SSL parameters specified, but no CA file set"); |
---|
103 | } |
---|
104 | $cfg{'ssl_ca_file'} = $raw_cfg->{ssl}->{ca_file}; |
---|
105 | $cfg{'ssl_verify'} = 1; |
---|
106 | # optional parameters |
---|
107 | if ( (exists $raw_cfg->{ssl}->{cert_file}) && exists $raw_cfg->{ssl}->{key_file}) { |
---|
108 | $cfg{'ssl_cert_file'} = $raw_cfg->{ssl}->{cert_file}; |
---|
109 | $cfg{'ssl_key_file'} = $raw_cfg->{ssl}->{key_file}; |
---|
110 | } else { |
---|
111 | warn "SSL parameters specified, but no client credentials set."; |
---|
112 | } |
---|
113 | } else { |
---|
114 | $cfg{'ssl_verify'} = 0; |
---|
115 | my $msg = "SSL parameters not specified. WILL NOT VERIFY SERVER CERTIFICATE. See README for details."; |
---|
116 | BarnOwl::admin_message('Zulip Warning', "Zulip: $msg"); |
---|
117 | warn $msg; |
---|
118 | } |
---|
119 | |
---|
120 | $cfg{'user'} = $user; |
---|
121 | $cfg{'apikey'} = $apikey; |
---|
122 | $cfg{'api_url'} = $api_url; |
---|
123 | $cfg{'realm'} = $default_realm; |
---|
124 | } |
---|
125 | |
---|
126 | sub register { |
---|
127 | my $retry_count = 0; |
---|
128 | my $callback; |
---|
129 | |
---|
130 | if(!exists $cfg{'api_url'}) { |
---|
131 | die("Zulip not configured, cannot poll for events"); |
---|
132 | } |
---|
133 | $callback = sub { |
---|
134 | BarnOwl::debug("In register callback"); |
---|
135 | my ($body, $headers) = @_; |
---|
136 | if($headers->{Status} > 399) { |
---|
137 | warn "Failed to make event queue registration request ($headers->{Status})"; |
---|
138 | if($retry_count >= $max_retries) { |
---|
139 | fail("Giving up"); |
---|
140 | } else { |
---|
141 | $retry_count++; |
---|
142 | http_post($cfg{'api_url'} . "/register", "", |
---|
143 | session => $tls_ctx, |
---|
144 | sessionid => $tls_ctx, |
---|
145 | tls_ctx => $tls_ctx, |
---|
146 | headers => { "Authorization" => authorization }, |
---|
147 | $callback); |
---|
148 | return; |
---|
149 | } |
---|
150 | } else { |
---|
151 | my $response = decode_json($body); |
---|
152 | if($response->{result} ne "success") { |
---|
153 | fail("Failed to register event queue; error was $response->{msg}"); |
---|
154 | } else { |
---|
155 | $last_event_id = $response->{last_event_id}; |
---|
156 | $queue_id = $response->{queue_id}; |
---|
157 | $presence_timer = AnyEvent->timer(after => 1, interval => 60, cb => sub { |
---|
158 | my $presence_url = $cfg{'api_url'} . "/users/me/presence"; |
---|
159 | my %presence_params = (status => "active", new_user_input => "true"); |
---|
160 | my $presence_body = POST($presence_url, \%presence_params)->content; |
---|
161 | http_post($presence_url, $presence_body, headers => { "Authorization" => authorization, |
---|
162 | "Content-Type" => "application/x-www-form-urlencoded" }, |
---|
163 | session => $tls_ctx, |
---|
164 | sessionid => $tls_ctx, |
---|
165 | tls_ctx => $tls_ctx, |
---|
166 | sub { |
---|
167 | my ($body, $headers) = @_; |
---|
168 | if($headers->{Status} > 399) { |
---|
169 | warn("Error sending presence"); |
---|
170 | warn(encode_json($headers)); |
---|
171 | warn($body); |
---|
172 | }}); |
---|
173 | return;}); |
---|
174 | do_poll(); |
---|
175 | return; |
---|
176 | } |
---|
177 | } |
---|
178 | }; |
---|
179 | |
---|
180 | http_post($cfg{'api_url'} . "/register", "", |
---|
181 | headers => { "Authorization" => authorization }, |
---|
182 | session => $tls_ctx, |
---|
183 | sessionid => $tls_ctx, |
---|
184 | tls_ctx => $tls_ctx, |
---|
185 | $callback); |
---|
186 | return; |
---|
187 | } |
---|
188 | |
---|
189 | sub parse_response { |
---|
190 | my ($body, $headers) = @_; |
---|
191 | if($headers->{Status} > 399) { |
---|
192 | return 0; |
---|
193 | } |
---|
194 | my $response = decode_json($body); |
---|
195 | if($response->{result} ne "success") { |
---|
196 | return 0; |
---|
197 | } |
---|
198 | return $response; |
---|
199 | } |
---|
200 | sub do_poll { |
---|
201 | my $uri = URI->new($cfg{'api_url'} . "/events"); |
---|
202 | $uri->query_form("queue_id" => $queue_id, |
---|
203 | "last_event_id" => $last_event_id); |
---|
204 | my $retry_count = 0; |
---|
205 | my $callback; |
---|
206 | $callback = sub { |
---|
207 | my ($body, $headers) = @_; |
---|
208 | my $response = parse_response($body, $headers); |
---|
209 | if(!$response) { |
---|
210 | warn "Failed to poll for events in do_poll: $headers->{Reason}"; |
---|
211 | if($retry_count >= $max_retries) { |
---|
212 | warn "Retry count exceeded in do_poll, giving up"; |
---|
213 | fail("do_poll: Giving up"); |
---|
214 | $presence_timer->cancel; |
---|
215 | } else { |
---|
216 | warn "Retrying"; |
---|
217 | $retry_count++; |
---|
218 | $retry_timer = AnyEvent->timer(after => 10, cb => sub { warn "retry number $retry_count"; |
---|
219 | http_get($uri->as_string, |
---|
220 | "headers" => { "Authorization" => authorization }, |
---|
221 | session => $tls_ctx, |
---|
222 | sessionid => $tls_ctx, |
---|
223 | tls_ctx => $tls_ctx, |
---|
224 | $callback); |
---|
225 | return; |
---|
226 | }); |
---|
227 | return; |
---|
228 | } |
---|
229 | } else { |
---|
230 | event_cb($response); |
---|
231 | } |
---|
232 | }; |
---|
233 | http_get($uri->as_string, "headers" => { "Authorization" => authorization }, |
---|
234 | session => $tls_ctx, |
---|
235 | sessionid => $tls_ctx, |
---|
236 | tls_ctx => $tls_ctx,$callback); |
---|
237 | return; |
---|
238 | } |
---|
239 | |
---|
240 | sub event_cb { |
---|
241 | my $response = $_[0]; |
---|
242 | if($response->{result} ne "success") { |
---|
243 | fail("event_cb: Failed to poll for events; error was $response->{msg}"); |
---|
244 | } else { |
---|
245 | for my $event (@{$response->{events}}) { |
---|
246 | if($event->{type} eq "message") { |
---|
247 | my $msg = $event->{message}; |
---|
248 | my %msghash = ( |
---|
249 | type => 'Zulip', |
---|
250 | sender => $msg->{sender_email}, |
---|
251 | recipient => $msg->{recipient_id}, |
---|
252 | direction => 'in', |
---|
253 | class => $msg->{display_recipient}, |
---|
254 | instance => $msg->{subject}, |
---|
255 | unix_time => $msg->{timestamp}, |
---|
256 | source => "zulip", |
---|
257 | location => "zulip", |
---|
258 | body => $msg->{content}, |
---|
259 | zid => $msg->{id}, |
---|
260 | sender_full_name => $msg->{sender_full_name}, |
---|
261 | opcode => ""); |
---|
262 | $msghash{'body'} =~ s/\r//gm; |
---|
263 | if($msg->{type} eq "private") { |
---|
264 | $msghash{private} = 1; |
---|
265 | my @raw_recipients = @{$msg->{display_recipient}}; |
---|
266 | my @display_recipients; |
---|
267 | if (scalar(@raw_recipients) > 1) { |
---|
268 | my $recip; |
---|
269 | for $recip (@raw_recipients) { |
---|
270 | unless ($recip->{email} eq $cfg{user}) { |
---|
271 | push @display_recipients, $recip->{email}; |
---|
272 | } |
---|
273 | } |
---|
274 | $msghash{recipient} = join " ", @display_recipients; |
---|
275 | } else { |
---|
276 | $msghash{recipient} = $msg->{display_recipient}->[0]->{email}; |
---|
277 | } |
---|
278 | $msghash{class} = "message"; |
---|
279 | if($msg->{sender_email} eq $cfg{user}) { |
---|
280 | $msghash{direction} = 'out'; |
---|
281 | } |
---|
282 | } |
---|
283 | my $bomsg = BarnOwl::Message->new(%msghash); |
---|
284 | # queue_message returns the message round-tripped |
---|
285 | # through owl_message. In particular, this means it |
---|
286 | # has a meaningful id. |
---|
287 | my $rtmsg = BarnOwl::queue_message($bomsg); |
---|
288 | # note that only base messages, not edits, end up in |
---|
289 | # here. Tim promises me that we will never see an |
---|
290 | # update to an update, so we shouldn't need to |
---|
291 | # retrieve updated messages via this |
---|
292 | $msg_id_map{$rtmsg->zid} = $rtmsg->id; |
---|
293 | } elsif($event->{type} eq "update_message") { |
---|
294 | my $id = $event->{message_id}; |
---|
295 | if(!exists $msg_id_map{$id}) { |
---|
296 | BarnOwl::debug("Got update for unknown message $id, discarding"); |
---|
297 | } else { |
---|
298 | my $base_msg = BarnOwl::get_message_by_id($msg_id_map{$id}); |
---|
299 | my %new_msghash = ( |
---|
300 | type => 'Zulip', |
---|
301 | sender => $base_msg->sender, |
---|
302 | recipient => $base_msg->recipient, |
---|
303 | direction => $base_msg->direction, |
---|
304 | class => $base_msg->class, |
---|
305 | # instance needs to be potentially determined from new message |
---|
306 | unix_time => $event->{edit_timestamp}, |
---|
307 | source => "zulip", |
---|
308 | location => "zulip", |
---|
309 | # content needs to be potentially determined from new message |
---|
310 | zid => $base_msg->id, |
---|
311 | sender_full_name => $base_msg->long_sender, |
---|
312 | opcode => "EDIT"); |
---|
313 | if (exists $$event{'subject'}) { |
---|
314 | $new_msghash{'instance'} = $event->{subject}; |
---|
315 | } else { |
---|
316 | $new_msghash{'instance'} = $base_msg->instance; |
---|
317 | } |
---|
318 | if (exists $$event{'content'}) { |
---|
319 | $new_msghash{'body'} = $event->{content}; |
---|
320 | } else { |
---|
321 | $new_msghash{'body'} = $base_msg->body; |
---|
322 | } |
---|
323 | my $bomsg = BarnOwl::Message->new(%new_msghash); |
---|
324 | BarnOwl::queue_message($bomsg); |
---|
325 | } |
---|
326 | |
---|
327 | } else { |
---|
328 | BarnOwl::debug("Got unknown message"); |
---|
329 | BarnOwl::debug(encode_json($event)); |
---|
330 | } |
---|
331 | $last_event_id = $event->{id}; |
---|
332 | do_poll(); |
---|
333 | return; |
---|
334 | } |
---|
335 | } |
---|
336 | |
---|
337 | } |
---|
338 | |
---|
339 | sub zulip { |
---|
340 | my ($type, $recipient, $subject, $msg) = @_; |
---|
341 | # only care about it for its url encoding |
---|
342 | my $builder = URI->new("http://www.example.com"); |
---|
343 | my %params = ("type" => $type, "to" => $recipient, "content" => $msg); |
---|
344 | if ($subject ne "") { |
---|
345 | $params{"subject"} = $subject; |
---|
346 | } |
---|
347 | my $url = $cfg{'api_url'} . "/messages"; |
---|
348 | my $req = POST($url, \%params); |
---|
349 | http_post($url, $req->content, "headers" => {"Authorization" => authorization, "Content-Type" => "application/x-www-form-urlencoded"}, |
---|
350 | session => $tls_ctx, |
---|
351 | sessionid => $tls_ctx, |
---|
352 | tls_ctx => $tls_ctx,sub { |
---|
353 | my ($body, $headers) = @_; |
---|
354 | if($headers->{Status} < 400) { |
---|
355 | BarnOwl::message("Zulipgram sent"); |
---|
356 | } else { |
---|
357 | BarnOwl::message("Error sending zulipgram: $headers->{Reason}!"); |
---|
358 | BarnOwl::debug($body); |
---|
359 | }}); |
---|
360 | return; |
---|
361 | } |
---|
362 | |
---|
363 | |
---|
364 | sub update_subs { |
---|
365 | my ($add_list, $remove_list, $cb) = @_; |
---|
366 | my @add_param = (); |
---|
367 | my @remove_param = (); |
---|
368 | for my $add (@$add_list) { |
---|
369 | push @add_param, {name => $add}; |
---|
370 | } |
---|
371 | my $url = $cfg{'api_url'} . "/users/me/subscriptions"; |
---|
372 | my %params = ("add" => encode_json(\@add_param), "delete" => encode_json($remove_list)); |
---|
373 | my $req = POST($url, \%params); |
---|
374 | http_request('PATCH' => $url, |
---|
375 | "body" => $req->content, |
---|
376 | "headers" => {"Authorization" => authorization, "Content-Type" => "application/x-www-form-urlencoded"}, |
---|
377 | session => $tls_ctx, |
---|
378 | sessionid => $tls_ctx, |
---|
379 | tls_ctx => $tls_ctx,sub { |
---|
380 | my ($body, $headers) = @_; |
---|
381 | if($headers->{Status} < 400) { |
---|
382 | &$cb(); |
---|
383 | } else { |
---|
384 | BarnOwl::message("Error updating subscriptions: $headers->{Reason}!"); |
---|
385 | BarnOwl::debug($body); |
---|
386 | }}); |
---|
387 | return; |
---|
388 | } |
---|
389 | |
---|
390 | sub get_subs { |
---|
391 | my $url = $cfg{'api_url'} . "/users/me/subscriptions"; |
---|
392 | http_get($url, headers => { "Authorization" => authorization }, |
---|
393 | session => $tls_ctx, sessionid => $tls_ctx, |
---|
394 | tls_ctx => $tls_ctx, sub { |
---|
395 | my ($body, $headers) = @_; |
---|
396 | if ($headers->{Status} > 399) { |
---|
397 | BarnOwl::message("Error retrieving subscription list: $headers->{Reason}"); |
---|
398 | BarnOwl::debug($body); |
---|
399 | } |
---|
400 | my $data = decode_json($body); |
---|
401 | my @subs; |
---|
402 | for my $s (@{$data->{subscriptions}}) { |
---|
403 | push @subs, $s->{name}; |
---|
404 | } |
---|
405 | BarnOwl::popless_text(join "\n", @subs); |
---|
406 | }); |
---|
407 | return; |
---|
408 | } |
---|
409 | |
---|
410 | sub cmd_zulip_sub { |
---|
411 | my ($cmd, $stream) = @_; |
---|
412 | update_subs([$stream], [], sub { |
---|
413 | BarnOwl::message("Subscribed to $stream");}); |
---|
414 | |
---|
415 | } |
---|
416 | |
---|
417 | sub cmd_zulip_unsub { |
---|
418 | my ($cmd, $stream) = @_; |
---|
419 | update_subs([], [$stream], sub { |
---|
420 | BarnOwl::message("Unsubscribed from $stream");}); |
---|
421 | |
---|
422 | } |
---|
423 | |
---|
424 | sub cmd_zulip_getsubs { |
---|
425 | get_subs(); |
---|
426 | } |
---|
427 | |
---|
428 | sub cmd_zulip_login { |
---|
429 | register(); |
---|
430 | } |
---|
431 | |
---|
432 | sub cmd_zulip_write { |
---|
433 | my $cmdline = join " ", @_; |
---|
434 | my $cmd = shift; |
---|
435 | my $stream; |
---|
436 | my $subject; |
---|
437 | my $type; |
---|
438 | my $to; |
---|
439 | my $ret = GetOptionsFromArray(\@_, |
---|
440 | "c=s" => \$stream, |
---|
441 | "i=s" => \$subject); |
---|
442 | unless($ret) { |
---|
443 | die("Usage: zulip:write [-c stream] [-i subject] [recipient] ..."); |
---|
444 | } |
---|
445 | # anything left is a recipient |
---|
446 | if (scalar(@_) > 0) { |
---|
447 | my @addresses = map { |
---|
448 | if(/@/) { |
---|
449 | $_; |
---|
450 | } else { |
---|
451 | $_ . "\@$cfg{'realm'}"; |
---|
452 | }} @_; |
---|
453 | $to = encode_json(\@addresses); |
---|
454 | $type = "private"; |
---|
455 | |
---|
456 | } else { |
---|
457 | $type = "stream"; |
---|
458 | $to = $stream |
---|
459 | } |
---|
460 | BarnOwl::start_edit(prompt => $cmdline, type => 'edit_win', |
---|
461 | callback => sub { |
---|
462 | my ($text, $should_send) = @_; |
---|
463 | unless ($should_send) { |
---|
464 | BarnOwl::message("zulip:write cancelled"); |
---|
465 | return; |
---|
466 | } |
---|
467 | zulip($type, $to, $subject, $text); |
---|
468 | }); |
---|
469 | |
---|
470 | } |
---|
471 | |
---|
472 | BarnOwl::new_command('zulip:login' => sub { cmd_zulip_login(@_); }, |
---|
473 | { |
---|
474 | summary => "Log in to Zulip", |
---|
475 | usage => "zulip:login", |
---|
476 | description => "Start receiving Zulip messages" |
---|
477 | }); |
---|
478 | |
---|
479 | BarnOwl::new_command('zulip:write' => sub { cmd_zulip_write(@_); }, |
---|
480 | { |
---|
481 | summary => "Send a zulipgram", |
---|
482 | usage => "zulip:login [-c stream] [-i subject] [recipient(s)]", |
---|
483 | description => "Send a zulipgram to a stream, person, or set of people" |
---|
484 | }); |
---|
485 | |
---|
486 | BarnOwl::new_command('zulip:subscribe' => sub { cmd_zulip_sub(@_); }, |
---|
487 | { |
---|
488 | summary => "Subscribe to a Zulip stream", |
---|
489 | usage => "zulip:subscribe <stream name>", |
---|
490 | description => "Subscribe to a Zulip stream" |
---|
491 | }); |
---|
492 | |
---|
493 | BarnOwl::new_command('zulip:unsubscribe' => sub { cmd_zulip_unsub(@_); }, |
---|
494 | { |
---|
495 | summary => "Unsubscribe from a Zulip stream", |
---|
496 | usage => "zulip:unsubscribe <stream name>", |
---|
497 | description => "Unsubscribe to a Zulip stream" |
---|
498 | }); |
---|
499 | |
---|
500 | BarnOwl::new_command('zulip:getsubs' => sub { cmd_zulip_getsubs(@_); }, |
---|
501 | { |
---|
502 | summary => "Display the list of subscribed Zulip streams", |
---|
503 | usage => "zulip:getsubs", |
---|
504 | description => "Display the list of Zulip streams you're subscribed to in a popup window" |
---|
505 | }); |
---|
506 | |
---|
507 | |
---|
508 | sub user { |
---|
509 | return $cfg{'user'}; |
---|
510 | } |
---|
511 | |
---|
512 | sub default_realm { |
---|
513 | return $cfg{'realm'}; |
---|
514 | } |
---|
515 | |
---|
516 | initialize(); |
---|
517 | |
---|
518 | 1; |
---|
519 | |
---|
520 | # Local Variables: |
---|
521 | # indent-tabs-mode: nil |
---|
522 | # End: |
---|