root/lang/perl/misc/WassrPod/wassrpod.pl @ 18691

Revision 18691, 9.2 kB (checked in by tokuhirom, 6 years ago)

quick & silly bug fix.
HTTP ENGINE DOES NOT SUPPORT PROXY SERVER

Line 
1#!/usr/bin/env perl
2package WassrPod;
3use Moose;
4use HTTP::Engine;
5use HTTP::Headers;
6use LWP::UserAgent;
7use JSON 2.11;
8use DateTime;
9use XML::Simple;
10use Encode;
11
12our $VERSION = '0.0.1';
13
14use Data::Dumper;
15
16with 'MooseX::Getopt';
17
18has port =>
19    is      => 'ro',
20    isa     => 'Int',
21    default => 9277; # 9277 = wassr
22
23has timeline_cache =>
24    is      => 'ro',
25    isa     => 'Int',
26    default => 100;
27
28my $timelines = [];
29sub timelines { $timelines };
30my $timeline_map = {};
31sub timeline_map { $timeline_map };
32my $timeline_queue = [];
33sub timeline_queue { $timeline_queue };
34my $channels = {};
35sub channels { $channels };
36
37sub run {
38    my $self = shift;
39    my $engine = HTTP::Engine->new(
40        interface => {
41            module => 'ServerSimple',
42            args   => {
43                host => '127.0.0.1',
44                port => $self->port,
45            },
46            request_handler => sub { $self->handler(@_) },
47        },
48    );
49    $engine->run;
50}
51
52sub handler {
53    my($self, $req) = @_;
54
55    (my $path = $req->path) =~ s!^//!/http://!; # work around, "HTTP::Engine does not support proxy server"
56
57    if ($path eq '/http://twitter.com/statuses/friends_timeline.xml') {
58        HTTP::Engine::Response->new(
59            content_type => 'application/xml',
60            body         => $self->friends_timeline($req),
61        );
62    } elsif ($path eq '/http://twitter.com/statuses/update.xml') {
63        HTTP::Engine::Response->new(
64            content_type => 'application/xml',
65            body         => $self->update($req),
66        );
67    } elsif ($path =~ '^/http://wassr.jp/.*$') {
68        my $ua = ua($req, 'wassr.jp');
69        my $res = $ua->get($req->path);
70
71        my $heres = HTTP::Engine::Response->new();
72        $heres->set_http_response($res);
73        $heres;
74    } else {
75        warn "INVALID PATH: " . $path;
76        HTTP::Engine::Response->new( status => 404, body => 'not found' );
77    }
78};
79
80sub ua {
81    my $req = shift;
82    my $host = shift || 'api.wassr.jp';
83
84    my $headers = $req->headers->clone;
85    $headers->remove_header('host');
86    $headers->header( Host => $host );
87    $headers->remove_header('user-agent');
88    $headers->header( 'User-Agent' => sprintf('%s/%s', __PACKAGE__, $VERSION) );
89
90    my $ua = LWP::UserAgent->new(
91        default_headers => $headers,
92    );
93    $ua->default_headers($headers);
94    $ua;
95}
96
97sub _gen_timeline_id { $_[0]->{type}.':'.$_[0]->{rid} };
98sub add_timeline {
99    my $self = shift;
100    return unless @_;
101    for my $data (@_) {
102        my $id = _gen_timeline_id $data;
103        next if $self->timeline_map->{$id};
104        unshift @{ $self->timelines }, $data;
105        my $pop;
106        $pop = pop @{ $self->timelines } if scalar(@{ $self->timelines }) > $self->timeline_cache;
107        next unless $pop;
108        my $delete_id = _gen_timeline_id $pop;
109        delete $self->timeline_map->{$delete_id} if exists $self->timeline_map->{$delete_id};
110    }
111}
112
113my $add_timeline_queue_id = 0;
114sub add_timeline_queue {
115    my($self, $text) = @_;
116    my $dt = DateTime->now;
117    my $tmp = {
118        created_at => $dt->strftime('%a %b %d %T %z %Y'),
119        id => sprintf('W:%s:%s', time, $add_timeline_queue_id++),
120        text => $text,
121        source => 'wassrpod.pl',
122        truncated => 'false',
123        in_reply_to_status_id => undef,
124        in_reply_to_user_id => undef,
125        favorited => undef,
126        user => {
127            id => '_WassrPod',
128            name => '_WassrPod',
129            screen_name => '_WassrPod',
130            location => undef,
131            description => undef,
132            profile_image_url => 'http://wassr.jp/user/staff/profile_img.png.128',
133            url => undef,
134            protected => 'false',
135            followers_count => 1,
136        },
137    };
138    push @{ $self->timeline_queue }, $tmp;
139}
140
141sub friends_timeline {
142    my($self, $req) = @_;
143
144    my $ua = ua $req;
145
146    my $ret = $ua->get('http://api.wassr.jp/statuses/friends_timeline.json');
147    my $json = eval { decode_json($ret->content) };
148    return '<statuses></statuses>' if $@ || !ref($json);
149
150    my $data = {
151        statuses => {
152            status => [
153            ]
154        }
155    };
156
157    for my $status (@{ $json }) {
158        my $dt = DateTime->from_epoch( epoch => $status->{epoch} );
159        # $dt->set_time_zone( 'Asia/Tokyo' );
160        my $text = $status->{text};
161        my $detect7 = decode('utf7', $text);
162        $text .= " ($detect7)" unless $text eq $detect7;
163
164        do {
165            require Acme::Encode::WhiteSpace8;
166            $text = encode('utf8', $text);
167            $text =~ s{([ \001\002\003\004\005\006\007\010\011\013\014\016\017\020\021]{2,})}{
168                my $str = decode('whitespace-8', $1);
169                " ($str) ";
170            }ge;
171            $text = decode('utf8', $text);
172        };
173
174        if ($status->{reply_user_login_id}) {
175            $text .= sprintf '[Re:%s/%s]', $status->{reply_user_login_id}, ($status->{reply_message} || '');
176        }
177        my $tmp = {
178            created_at => $dt->strftime('%a %b %d %T %z %Y'),
179            id => $status->{rid},
180            text => $text,
181            source => 'web',
182            truncated => 'false',
183            in_reply_to_status_id => undef,
184            in_reply_to_user_id => undef,
185            favorited => undef,
186
187            user => {
188                id => $status->{user_login_id},
189                name => $status->{user}->{screen_name},
190                screen_name => $status->{user_login_id},
191                location => undef,
192                description => undef,
193                profile_image_url => $status->{user}->{profile_image_url},
194                url => undef,
195                protected => ''.$status->{user}->{protected},
196                followers_count => 1,
197            },
198        };
199        push @{ $data->{statuses}->{status} }, $tmp;
200
201        $self->add_timeline({
202            type => 'friend',
203            user => $status->{user_login_id},
204            rid  => $status->{rid},
205            text => $status->{text},
206        });
207    }
208
209    while (my $row = shift @{ $self->timeline_queue }) {
210        push @{ $data->{statuses}->{status} }, $row;
211    }
212
213    my $xml = XMLout($data, NoAttr => 1, KeepRoot => 1, NumericEscape => 3 );
214    $xml =~ s/<statuses>/<statuses type="array">/;
215    $xml = qq{<?xml version="1.0" encoding="UTF-8"?>\n$xml};
216    $xml;
217}
218
219sub _fecth_replyid {
220    my($self, $user, $prefix) = @_;
221    for my $data (@{ $self->timelines }) {
222        next if $user && $data->{user} ne $user;
223        my $text = $data->{text};
224        $text =~ s/^@[\w\d\-_]+\s*//;
225        return $data->{rid} if $text =~ /$prefix/;
226    }
227    return;
228}
229
230sub update {
231    my($self, $req) = @_;
232
233    my $status = $req->param('status');
234    my $source = "WassrPod(@{[ $req->param('source') ]})";
235
236    my $ua = ua $req;
237    if ($status =~ /^#([a-z0-9_]+)\s+(.+)$/) {
238        my $ret = $ua->post('http://api.wassr.jp/channel_message/update.json', {
239            name_en => $1,
240            body    => $2,
241        });
242        return $ret->content;
243    } elsif (my($cmd, $args) = $status =~ /^W\s+([^\s]+)\s+(.+)$/) {
244
245        if ($cmd eq 'fadd') {
246            my $ret = $ua->post("http://api.wassr.jp/friendships/create/$args.json");
247            $self->add_timeline_queue("friend add: $args > " . $ret->content );
248        } elsif ($cmd eq 'fdel') {
249            my $ret = $ua->post("http://api.wassr.jp/friendships/destroy/$args.json");
250            $self->add_timeline_queue("friend delete: $args > " . $ret->content );
251        }
252
253        if ($cmd eq 'iine' || $cmd eq 'damene') {
254            my($user, $prefix) = split /\s/, $args;
255            my $rid = $self->_fecth_replyid($user, decode('utf8', $prefix));
256            return '' unless $rid;
257
258            my $ret = $ua->post(sprintf "http://api.wassr.jp/favorites/%s/%s.json",
259                ($cmd eq 'iine' ? 'create' : 'destroy'), $rid);
260            $self->add_timeline_queue("$cmd: " . decode('utf8', $args) . ' > ' . decode('utf8', $ret->content) );
261        }
262
263        if ($cmd eq '7') {
264            $status = encode('utf7', decode('utf8', $args));
265            $self->_update($ua, "$status encoding:utf7", $source);
266        } elsif ($cmd eq '16') {
267            $status = encode('utf16', decode('utf8', $args));
268            $self->_update($ua, "$status encoding:utf16", $source);
269        } elsif ($cmd eq '32') {
270            $status = encode('utf32', decode('utf8', $args));
271            $self->_update($ua, "$status encoding:utf32", $source);
272        } elsif ($cmd eq '932') {
273            $status = encode('cp932', decode('utf8', $args));
274            $self->_update($ua, "$status encoding:cp932", $source);
275        } elsif ($cmd eq 'WS') {
276            require Acme::Encode::WhiteSpace8;
277            $status = encode('whitespace-8', decode('utf8', $args));
278            $self->_update($ua, $status . 'encoding:whitespace8', $source);
279        }
280    } else {
281        $self->_update($ua, $status, $source);
282    }
283}
284
285sub _update {
286    my($self, $ua, $status, $source) = @_;
287
288    my $data = {
289        status => $status,
290        source => $source,
291    };
292    if (my($user, $prefix) = $status =~ /^(@[\w\d\-_]+)?.*>\s*([^>]+)$/i) {
293        my $rid = $self->_fecth_replyid($user, decode('utf8', $prefix));
294        $data->{reply_status_rid} = $rid if $rid;
295    }
296    my $ret = $ua->post('http://api.wassr.jp/statuses/update.json', $data);
297    return $ret->content;
298}
299
300package main;
301WassrPod->new_with_options->run;
302
Note: See TracBrowser for help on using the browser.