├── .gitignore ├── .shipit ├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── docs └── schema.sql ├── lib ├── Komainu.pm └── Komainu │ ├── Agent.pm │ ├── Agent │ ├── Accesslog.pm │ ├── AccesslogSummary.pm │ ├── DeployLog.pm │ ├── Gather.pm │ ├── MySQLQuery.pm │ ├── MySQLSlow.pm │ └── Syslog.pm │ ├── Notify.pm │ └── Notify │ ├── Email.pm │ └── IRC.pm ├── t ├── 00_compile.t ├── Utils.pm ├── agent │ ├── accesslog │ │ ├── _mk_remote_exec_cmd.t │ │ ├── _normalize_host.t │ │ ├── _normalize_path.t │ │ ├── _parse_accesslog.t │ │ ├── _store.t │ │ ├── _whitelist.t │ │ ├── execute.t │ │ └── over_threshold.t │ ├── deploy_log │ │ └── logged.t │ └── syslog │ │ ├── _mk_remote_exec_cmd.t │ │ ├── execute.t │ │ └── over_threshold.t └── lib │ └── Mock.pm └── xt ├── 01_perlcritic.t ├── 02_pod.t └── perlcriticrc /.gitignore: -------------------------------------------------------------------------------- 1 | cover_db 2 | META.yml 3 | Makefile 4 | blib 5 | inc 6 | pm_to_blib 7 | Makefile.old 8 | old/ 9 | *.swp 10 | test.* 11 | *~ 12 | -------------------------------------------------------------------------------- /.shipit: -------------------------------------------------------------------------------- 1 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN 2 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Komainu 2 | 3 | 0.01 4 | Fri Sep 16 14:10:57 2011 5 | - initial release. 6 | 7 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | inc/Module/Install.pm 3 | inc/Module/Install/AuthorTests.pm 4 | inc/Module/Install/Base.pm 5 | inc/Module/Install/Can.pm 6 | inc/Module/Install/Fetch.pm 7 | inc/Module/Install/Makefile.pm 8 | inc/Module/Install/Metadata.pm 9 | inc/Module/Install/Repository.pm 10 | inc/Module/Install/Win32.pm 11 | inc/Module/Install/WriteAll.pm 12 | lib/Komainu.pm 13 | Makefile.PL 14 | MANIFEST This list of files 15 | META.yml 16 | README 17 | t/00_compile.t 18 | xt/01_perlcritic.t 19 | xt/02_pod.t 20 | xt/perlcriticrc 21 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \bRCS\b 2 | \bCVS\b 3 | ^MANIFEST\. 4 | ^Makefile$ 5 | ~$ 6 | ^# 7 | \.old$ 8 | ^blib/ 9 | ^pm_to_blib 10 | ^MakeMaker-\d 11 | \.gz$ 12 | \.cvsignore 13 | ^t/9\d_.*\.t 14 | ^t/perlcritic 15 | ^tools/ 16 | \.svn/ 17 | ^[^/]+\.yaml$ 18 | ^[^/]+\.pl$ 19 | ^\.shipit$ 20 | ^.git 21 | TODO 22 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | name 'Komainu'; 3 | all_from 'lib/Komainu.pm'; 4 | 5 | requires 'Any::Moose'; 6 | requires 'AnyEvent'; 7 | requires 'AnyEvent::IRC'; 8 | requires 'AnyEvent::JSONRPC::Lite'; 9 | requires 'Mouse'; 10 | requires 'Path::Class'; 11 | requires 'Net::SSH'; 12 | requires 'Parallel::ForkManager'; 13 | requires 'Email::Sender::Transport::SMTP'; 14 | requires 'Email::MIME'; 15 | requires 'Email::Sender::Simple'; 16 | requires 'Regexp::Trie'; 17 | requires 'Class::Load'; 18 | requires 'parent'; 19 | requires 'Time::Piece'; 20 | requires 'DBIx::Handler'; 21 | requires 'Text::Xslate'; 22 | requires 'Text::Xslate::Bridge::TT2Like'; 23 | 24 | test_requires 'Test::More' => '0.94'; 25 | test_requires 'Test::SharedFork'; 26 | test_requires 'Test::Mock::Guard'; 27 | 28 | tests 't/*.t t/*/*.t'; 29 | author_tests('xt'); 30 | 31 | auto_set_repository; 32 | 33 | WriteAll; 34 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is Perl module Komainu. 2 | 3 | INSTALLATION 4 | 5 | Komainu installation is straightforward. If your CPAN shell is set up, 6 | you should just be able to do 7 | 8 | % cpanm Komainu 9 | 10 | Download it, unpack it, then build it as per the usual: 11 | 12 | % perl Makefile.PL 13 | % make && make test 14 | 15 | Then install it: 16 | 17 | % make install 18 | 19 | DOCUMENTATION 20 | 21 | Komainu documentation is available as in POD. So you can do: 22 | 23 | % perldoc Komainu 24 | 25 | to read the documentation online with your favorite pager. 26 | 27 | Atsushi Kobayashi 28 | -------------------------------------------------------------------------------- /docs/schema.sql: -------------------------------------------------------------------------------- 1 | create table accesslog ( 2 | id int(10) unsigned NOT NULL auto_increment, 3 | role varchar(100) NOT NULL, 4 | service varchar(10) NOT NULL, 5 | component varchar(20) NOT NULL, 6 | host varchar(40) NOT NULL, 7 | server varchar(10) NOT NULL, 8 | status varchar(3) NOT NULL, 9 | path varchar(255) NOT NULL, 10 | method varchar(5) NOT NULL, 11 | logged_at datetime NOT NULL, 12 | count int(10) unsigned NOT NULL, 13 | digest varchar(255) NOT NULL, 14 | PRIMARY KEY (id), 15 | KEY accesslog_threshold_idx (role,logged_at) 16 | ) ENGINE=InnoDB; 17 | 18 | create table syslog ( 19 | id int(10) unsigned NOT NULL auto_increment, 20 | role varchar(100) NOT NULL, 21 | service varchar(10) NOT NULL, 22 | component varchar(20) NOT NULL, 23 | server varchar(10) NOT NULL, 24 | digest varchar(255) NOT NULL, 25 | log text NOT NULL, 26 | logged_on date NOT NULL, 27 | notifyed tinyint(4) unsigned NOT NULL, 28 | PRIMARY KEY (id), 29 | KEY syslog_dup_check_idx (role,service,component,server,digest,notifyed), 30 | KEY syslog_notify_idx (role, notifyed) 31 | ) ENGINE=InnoDB; 32 | 33 | create table mysqlquery_threshold ( 34 | id int(10) unsigned NOT NULL auto_increment, 35 | server varchar(10) NOT NULL, 36 | log varchar(255) NOT NULL, 37 | PRIMARY KEY (id) 38 | ) ENGINE=InnoDB; 39 | 40 | create table deploy_log ( 41 | id int(10) unsigned NOT NULL auto_increment, 42 | service varchar(10) NOT NULL, 43 | component varchar(20) NOT NULL, 44 | started_at int(10) unsigned, 45 | ended_at int(10) unsigned, 46 | PRIMARY KEY (id) 47 | ) ENGINE=InnoDB; 48 | 49 | -------------------------------------------------------------------------------- /lib/Komainu.pm: -------------------------------------------------------------------------------- 1 | package Komainu; 2 | use strict; 3 | use warnings; 4 | use Time::Piece; 5 | use DBIx::Handler; 6 | use Fcntl ":flock"; 7 | use Class::Load (); 8 | use Text::Xslate; 9 | use Text::Xslate::Bridge::TT2Like; 10 | 11 | our $VERSION = '0.01'; 12 | 13 | sub new { 14 | my ($class, $opts) = @_; 15 | 16 | $opts->{date} ||= do { my $dt = localtime; $dt }; 17 | 18 | my $self = bless $opts, $class; 19 | $self->_load_config; 20 | $self->_lock; 21 | $self; 22 | } 23 | 24 | sub role { $_[0]->{role} } 25 | sub roles { 26 | my $self = shift; 27 | $self->{roles} ||= do { 28 | [keys %{$self->role_config}] 29 | }; 30 | } 31 | 32 | sub global_config { $_[0]->{global_config} } 33 | sub role_config { $_[0]->{role_config} } 34 | sub config { $_[0]->{config} } 35 | 36 | sub date { $_[0]->{date} } 37 | sub today { 38 | my $self = shift; 39 | $self->{today} ||= do { 40 | $self->{date}->strftime('%Y-%m-%d'); 41 | }; 42 | } 43 | sub now { 44 | my $self = shift; 45 | $self->{now} ||= do { 46 | $self->{date}->strftime('%Y-%m-%d %H:%M:00'); 47 | }; 48 | } 49 | 50 | sub db { 51 | my $self = shift; 52 | $self->{db} ||= do { 53 | DBIx::Handler->new(@{$self->global_config->{connect_info}}); 54 | }; 55 | } 56 | 57 | sub view { 58 | my $self = shift; 59 | $self->{view} ||= do { 60 | Text::Xslate->new(+{ 61 | syntax => 'TTerse', 62 | module => [ 'Text::Xslate::Bridge::TT2Like' ], 63 | path => [ $self->global_config->{tmpl_dir} ], 64 | function => { 65 | c => $self, 66 | }, 67 | }); 68 | 69 | }; 70 | } 71 | 72 | sub render { 73 | my ($self, $tmpl, $vars) = @_; 74 | $self->view->render($tmpl, $vars); 75 | } 76 | 77 | sub _load_config { 78 | my $self = shift; 79 | 80 | die 'missing config' unless -f $self->{config_file}; 81 | my $config = do $self->{config_file}; 82 | die 'config should return HASHREF: '. $self->{config_file} unless ref($config) eq 'HASH'; 83 | 84 | $self->{role_config} = $config->{role}; 85 | $self->{global_config} = $config->{global}; 86 | } 87 | 88 | sub _lock { 89 | my $self = shift; 90 | 91 | my $filename = sprintf('/tmp/watch_cat_lock_%s', $self->global_config->{agent}); 92 | open my $fh , '>' , $filename or die $!; 93 | flock( $fh, LOCK_EX|LOCK_NB ) or die "cannot get the lock: $filename\n"; 94 | $self->{_flock} = $fh; # do not close the lock file 95 | } 96 | 97 | sub _load_class { 98 | my ($namespace, $pkg) = @_; 99 | 100 | my $class = $namespace.'::'.$pkg; 101 | Class::Load::load_class($class); 102 | $class; 103 | } 104 | 105 | sub run { 106 | my $self = shift; 107 | 108 | for my $role (@{$self->roles}) { 109 | $self->{role} = $role; 110 | $self->{config} = $self->role_config->{$role}; 111 | 112 | my $agent_class_s = $self->global_config->{agent}; 113 | die 'missing agent class. role: ' . $self->role unless $agent_class_s; 114 | my $agent_class = _load_class('Komainu::Agent', $agent_class_s); 115 | $agent_class->new()->run($self); 116 | } 117 | } 118 | 119 | sub notify { 120 | my ($self, $result) = @_; 121 | 122 | my $notify_agents = $self->config->{notify}; 123 | for my $notify (@{$notify_agents}) { 124 | die 'notify settings must be hashref' unless ref($notify) eq 'HASH'; 125 | my $notify_agent_s = $notify->{class}; 126 | my $options = $notify->{options} || +{}; 127 | my $notify_agent = _load_class('Komainu::Notify', $notify_agent_s); 128 | $notify_agent->new(+{options => $options})->run($self, $result); 129 | } 130 | } 131 | 132 | 1; 133 | __END__ 134 | 135 | =head1 NAME 136 | 137 | Komainu - 138 | 139 | =head1 SYNOPSIS 140 | 141 | use Komainu; 142 | 143 | =head1 DESCRIPTION 144 | 145 | Komainu is 146 | 147 | =head1 AUTHOR 148 | 149 | Atsushi Kobayashi Enekokak _at_ gmail _dot_ comE 150 | 151 | =head1 SEE ALSO 152 | 153 | =head1 LICENSE 154 | 155 | This library is free software; you can redistribute it and/or modify 156 | it under the same terms as Perl itself. 157 | 158 | =cut 159 | -------------------------------------------------------------------------------- /lib/Komainu/Agent.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent; 2 | use strict; 3 | use warnings; 4 | use Net::SSH qw/ssh_cmd/; 5 | 6 | sub new { bless {}, +shift } 7 | 8 | sub remote_exec { 9 | my ($self, $host, $cmd) = @_; 10 | ssh_cmd($host, $cmd); 11 | } 12 | 13 | 1; 14 | 15 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/Accesslog.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::Accesslog; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | use Parallel::ForkManager; 6 | use Regexp::Trie; 7 | use Digest::SHA1 qw(sha1_hex); 8 | 9 | sub run { 10 | my ($self, $c) = @_; 11 | 12 | $self->execute($c); 13 | my $result = $self->over_threshold($c); 14 | $c->notify($result) if scalar(@$result); 15 | } 16 | 17 | sub execute { 18 | my ($self, $c) = @_; 19 | 20 | my $servers = $c->config->{servers}; 21 | my $normalize_host = $c->config->{normalize_host}; 22 | my $normalize_path = $c->config->{normalize_path}; 23 | my $remote_exec_cmd = _mk_remote_exec_cmd($c); 24 | 25 | my $whitelist = _build_whitelist($c); 26 | my $whitelist_ua = _build_whitelist_ua($c); 27 | 28 | my $pm = Parallel::ForkManager->new($c->config->{workers} || 1); 29 | 30 | for my $server (@$servers) { 31 | $pm->start and next; 32 | 33 | my @logs = split /\n/, $self->remote_exec($server, $remote_exec_cmd); 34 | 35 | my $rows = +{}; 36 | for my $line (@logs) { 37 | my $log = _parse_accesslog($line); 38 | next unless $log; 39 | next if _match_whitelists($log, $whitelist, $whitelist_ua); 40 | 41 | $log->{path} =~ s/\?.+$//; 42 | $log->{host} = _normalize_host($log->{host}, $normalize_host) if $normalize_host; 43 | $log->{path} = _normalize_path($log->{path}, $normalize_path) if $normalize_path; 44 | 45 | $rows->{join "\t", $server, $log->{host}, $log->{status}, $log->{path}, $log->{method}}++; 46 | } 47 | 48 | for my $key (keys %$rows) { 49 | _store($c, $key, $rows->{$key}); 50 | } 51 | 52 | $pm->finish; 53 | } 54 | 55 | $pm->wait_all_children; 56 | } 57 | 58 | sub _build_whitelist { 59 | my $c = shift; 60 | 61 | my $whitelist; 62 | 63 | if (my $list = $c->config->{whitelist}) { 64 | my $rt = Regexp::Trie->new; 65 | $rt->add($_) for @$list; 66 | $whitelist = $rt->regexp; 67 | } 68 | return $whitelist; 69 | } 70 | 71 | sub _build_whitelist_ua { 72 | my $c = shift; 73 | 74 | my $whitelist_ua = +{}; 75 | my $whitelist_ua_conf = $c->config->{whitelist_ua}; 76 | 77 | for my $key (keys %$whitelist_ua_conf) { 78 | my $list = $whitelist_ua_conf->{$key}; 79 | my $rt = Regexp::Trie->new; 80 | $rt->add($_) for @$list; 81 | $whitelist_ua->{$key} = $rt->regexp; 82 | } 83 | return $whitelist_ua; 84 | } 85 | 86 | sub _match_whitelists { 87 | my ($log, $whitelist, $whitelist_ua) = @_; 88 | 89 | return 1 if $whitelist && $log->{path} =~ m/$whitelist/smo; 90 | 91 | for my $ua (keys %$whitelist_ua) { 92 | my $path_regex = $whitelist_ua->{$ua}; 93 | return 1 if $log->{useragent} =~ /$ua/ && $log->{path} =~ m/$path_regex/smo; 94 | } 95 | 96 | return 0; 97 | } 98 | 99 | sub _mk_remote_exec_cmd { 100 | my $c = shift; 101 | 102 | my $file = $c->date->strftime($c->config->{file}); 103 | my $regexp = $c->config->{regexp}; 104 | 105 | my $greptime = $c->date->strftime('%H:('); 106 | my @min; 107 | for my $i (1..5) { 108 | my $t = $c->date - (60 * $i); 109 | push @min, $t->strftime('%M'); 110 | } 111 | $greptime .= join '|', @min; 112 | $greptime .= '):'; 113 | 114 | "test -e $file && /bin/egrep '$greptime' $file | /bin/egrep '$regexp'" 115 | } 116 | 117 | sub _normalize_host { 118 | my ($host, $normalize_host) = @_; 119 | $host =~ s/$normalize_host/$1/o; 120 | $host; 121 | } 122 | 123 | sub _normalize_path { 124 | my ($path, $normalize_path) = @_; 125 | $path =~ s/$normalize_path/$1/o; 126 | $path; 127 | } 128 | 129 | sub _parse_accesslog { 130 | my $line = shift; 131 | chomp $line; 132 | $line =~ / 133 | ^ 134 | (\S+)\s # $1 IP 135 | (\S+)\s # $2 HOST 136 | (\S+)\s # $3 PORT 137 | \[(.+)\]\s # $4 DATE 138 | \" 139 | (\S+)\s # $5 METHOD 140 | (\S+)\s # $6 PATH 141 | (\S+) # $7 HTTP 142 | \"\s 143 | (\S+)\s # $8 HTTP STATUS 144 | (\S+)\s # $9 SIZE 145 | \" 146 | (.+?) # $10 USER AGENT 147 | \"\s 148 | .+ 149 | $ 150 | /x or return; 151 | 152 | return +{ 153 | ip => $1, 154 | host => $2, 155 | port => $3, 156 | date => $4, 157 | method => $5, 158 | path => $6, 159 | status => $8, 160 | useragent => $10, 161 | }; 162 | } 163 | 164 | sub _store { 165 | my ($c, $key, $count) = @_; 166 | 167 | my ($server, $host, $status, $path, $method) = split "\t", $key; 168 | 169 | my $dbh = $c->db->dbh; 170 | $dbh->do( 171 | 'INSERT INTO accesslog (role,service,component,logged_at,host,status,path,method,server,digest,count) VALUES (?,?,?,?,?,?,?,?,?,?,?)', undef, 172 | $c->role, $c->config->{service}, $c->config->{component}, $c->now, $host, $status, $path, $method, $server, sha1_hex($key), $count 173 | ); 174 | } 175 | 176 | sub over_threshold { 177 | my ($self, $c) = @_; 178 | 179 | my $dbh = $c->db->dbh; 180 | 181 | my $rows = $dbh->selectall_arrayref( 182 | q{ 183 | SELECT host, status, path, method, server, digest, SUM(count) AS current_count 184 | FROM accesslog 185 | WHERE 186 | role = ? 187 | AND logged_at = ? 188 | GROUP BY host, status, path, method, server, digest 189 | }, 190 | +{ Slice => +{} }, 191 | $c->role, $c->now, 192 | ); 193 | 194 | my $old_rows = $dbh->selectall_hashref( 195 | q{ 196 | SELECT digest, SUM(count) AS old_count 197 | FROM accesslog 198 | WHERE 199 | role = ? 200 | AND DATE_FORMAT(logged_at, "%Y-%m-%d") = ? 201 | AND logged_at != ? 202 | GROUP BY digest 203 | }, 204 | 'digest', undef, 205 | $c->role, $c->today, $c->now, 206 | ); 207 | 208 | for my $row (@$rows) { 209 | $row->{old_count} = $old_rows->{$row->{digest}}->{old_count} || 0; 210 | } 211 | 212 | my $result = []; 213 | if (my $threshold = $c->config->{threshold}) { 214 | for my $row (@$rows) { 215 | unless ($threshold->{$row->{status}}) { 216 | push @$result, $row; 217 | next; 218 | } 219 | if ($threshold->{$row->{status}} && $threshold->{$row->{status}} <= $row->{current_count}) { 220 | push @$result, $row; 221 | next; 222 | } 223 | } 224 | } else { 225 | $result = $rows; 226 | } 227 | 228 | $result; 229 | } 230 | 231 | 1; 232 | 233 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/AccesslogSummary.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::AccesslogSummary; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | 6 | sub run { 7 | my ($self, $c) = @_; 8 | 9 | my $result = $self->over_threshold($c); 10 | $c->notify($result) if scalar(@$result); 11 | } 12 | 13 | sub over_threshold { 14 | my ($self, $c) = @_; 15 | 16 | my $dbh = $c->db->dbh; 17 | my $rows = $dbh->selectall_arrayref( 18 | q{ 19 | SELECT host, status, path, method, server, SUM(count) current_count 20 | FROM accesslog 21 | WHERE 22 | role = ? 23 | AND DATE_FORMAT(logged_at, "%Y-%m-%d") = ? 24 | GROUP BY host, status, path, method, server 25 | }, 26 | +{ Slice => +{} }, 27 | $c->role, $c->config->{component}, $c->today, # FIXME yesterday 28 | ); 29 | 30 | $rows; 31 | } 32 | 33 | 1; 34 | 35 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/DeployLog.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::DeployLog; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | 6 | sub logged { 7 | my ($self , $c) = @_; 8 | 9 | my $dbh = $c->db->dbh; 10 | my $mode = $c->{deploy_mode}; 11 | my $service = $c->{service}; 12 | my $component = $c->{component}; 13 | 14 | if ($mode eq 'start') { 15 | $dbh->do('INSERT INTO deploy_log (service, component, started_at) VALUES (?,?,UNIX_TIMESTAMP())', undef, $service, $component); 16 | } else { 17 | my $row = $dbh->selectrow_arrayref( 18 | 'SELECT id FROM deploy_log WHERE service = ? AND component = ? AND ended_at IS NULL ORDER BY id DESC LIMIT 1', 19 | undef, 20 | $service, $component 21 | ); 22 | $dbh->do('UPDATE deploy_log set ended_at = UNIX_TIMESTAMP() WHERE id = ?', undef, $row->[0]); 23 | } 24 | } 25 | 26 | 1; 27 | 28 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/Gather.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::Gather; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | use Time::Seconds; 6 | 7 | sub run { 8 | my ($self, $c) = @_; 9 | 10 | my $log = $self->process($c); 11 | if (scalar(@$log)) { 12 | $c->notify( 13 | +{ 14 | logs => $log, 15 | service => $c->config->{service}, 16 | component => $c->config->{component}, 17 | } 18 | ); 19 | } 20 | } 21 | 22 | sub process { 23 | my ($self, $c) = @_; 24 | 25 | my $servers = $c->config->{servers}; 26 | my $regexp = $c->config->{regexp}; 27 | my $date = $c->config->{yesterday} ? $c->date - ONE_DAY : $c->date; 28 | 29 | my @log; 30 | for my $filename (@{$c->config->{files}}) { 31 | 32 | my $file = $date->strftime($filename); 33 | my $remote_exec_cmd = _mk_remote_exec_cmd($regexp, $file); 34 | 35 | for my $server (@$servers) { 36 | my $data = $self->remote_exec($server, $remote_exec_cmd); 37 | next unless $data; 38 | push @log, +{ 39 | server => $server, 40 | data => $data, 41 | }; 42 | } 43 | } 44 | \@log; 45 | } 46 | 47 | sub _mk_remote_exec_cmd { 48 | my ($regexp, $file) = @_; 49 | "test -e $file && /bin/egrep '$regexp' $file" 50 | } 51 | 52 | 1; 53 | 54 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/MySQLQuery.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::MySQLQuery; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | use Parallel::ForkManager; 6 | 7 | sub run { 8 | my ($self, $c) = @_; 9 | 10 | $self->execute($c); 11 | my $result = $self->over_threshold($c); 12 | $c->notify($result) if scalar(@$result); 13 | } 14 | 15 | sub execute { 16 | my ($self, $c) = @_; 17 | 18 | my $servers = $c->get_servers; 19 | my $password = $c->config->{password}; 20 | my $workers = $c->config->{workers} || 1; 21 | my $threshold = $c->config->{threshold} || 2; 22 | 23 | my $pm = Parallel::ForkManager->new($workers); 24 | 25 | for my $server (@$servers) { 26 | $pm->start and next; 27 | 28 | my $dbh = $c->db->dbh; 29 | 30 | my @logs = split /\n/, `mysql -ugame_r -h$server -p$password -e 'SHOW FULL PROCESSLIST'`; 31 | shift @logs; 32 | 33 | for my $log (@logs) { 34 | my @items = split /\t/, $log; 35 | if ($items[5] && $items[5] =~ /^[0-9]*$/ && $items[5] >= $threshold && $items[4] ne 'Sleep') { 36 | $dbh->do('insert into mysqlquery_threshold (server, log) values (?,?)', undef, $server, $log); 37 | } 38 | } 39 | $pm->finish; 40 | } 41 | 42 | $pm->wait_all_children; 43 | } 44 | 45 | sub over_threshold { 46 | my ($self, $c) = @_; 47 | 48 | my $dbh = $c->db->dbh; 49 | 50 | my $rows = $dbh->selectall_arrayref(q{ 51 | SELECT server, log 52 | FROM mysqlquery_threshold 53 | ORDER BY server 54 | }, 55 | +{ Slice => +{} }, 56 | ); 57 | $dbh->do('DELETE FROM mysqlquery_threshold'); 58 | $dbh->disconnect; 59 | 60 | $rows; 61 | } 62 | 63 | 1; 64 | 65 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/MySQLSlow.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::MySQLSlow; 2 | use strict; 3 | use warnings; 4 | use parent 'App::WatchCat::Agent'; 5 | use Path::Class; 6 | 7 | sub run { 8 | my ($self, $c) = @_; 9 | 10 | my $result = $self->execute($c); 11 | if (scalar(@$result)) { 12 | $c->notify($result); 13 | } 14 | } 15 | 16 | sub execute { 17 | my ($self, $c) = @_; 18 | 19 | my $servers = $c->config->{servers}; 20 | my $password = $c->config->{password}; 21 | my $slowlogfile = $c->config->{slowlogfile}; 22 | my $log_dir = $c->config->{log_dir}; 23 | my $mv_slowlogfile = file($log_dir, $c->date->strftime('mysqld-slow.log.%Y%m%d')); 24 | 25 | die "missing password..." unless $password; 26 | 27 | my @result; 28 | for my $server (@$servers) { 29 | eval { 30 | my $log = $self->remote_exec($server, "test -e $slowlogfile && mysqldumpslow $slowlogfile 2> /dev/null"); 31 | if ( $log !~ /^Count: 1 Time=0.00s \(0s\) Lock=0.00s \(0s\) Rows=0.0 \(0\), 0users\@0hosts/ ) { 32 | push @result, +{server => $server, log => $log}; 33 | } 34 | $self->remote_exec($server, "test -e $slowlogfile && mkdir -p $log_dir && mv $slowlogfile $mv_slowlogfile && mysqladmin -uroot -p$password flush-logs"); 35 | }; 36 | if ($@) { 37 | warn sprintf('remote_exec error: server: %s, msg: %s', $server, $@); 38 | } 39 | } 40 | 41 | \@result; 42 | } 43 | 44 | 1; 45 | 46 | -------------------------------------------------------------------------------- /lib/Komainu/Agent/Syslog.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Agent::Syslog; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Agent'; 5 | use Time::Seconds; 6 | use Digest::SHA1 qw(sha1_hex); 7 | 8 | sub run { 9 | my ($self, $c) = @_; 10 | 11 | $self->execute($c); 12 | 13 | if (my $result = $self->over_threshold($c)) { 14 | $c->notify( 15 | +{ 16 | logs => $result, 17 | count => scalar(@$result), 18 | service => $c->config->{service}, 19 | component => $c->config->{component}, 20 | } 21 | ); 22 | } 23 | } 24 | 25 | sub execute { 26 | my ($self, $c) = @_; 27 | 28 | my $servers = $c->config->{servers}; 29 | my $dbh = $c->db->dbh; 30 | my $date = $c->config->{yesterday} ? $c->date - ONE_DAY : $c->date; 31 | 32 | for my $filename (@{$c->config->{files}}) { 33 | 34 | my $file = $date->strftime($filename); 35 | my $remote_exec_cmd = _mk_remote_exec_cmd($c, $file); 36 | 37 | for my $server (@$servers) { 38 | 39 | my @logs = split /\n/, $self->remote_exec($server, $remote_exec_cmd); 40 | 41 | for my $line (@logs) { 42 | my $digest = sha1_hex($line); 43 | my $rows = $dbh->selectall_arrayref( 44 | q{ 45 | SELECT id 46 | FROM syslog 47 | WHERE 48 | role = ? 49 | AND service = ? 50 | AND component = ? 51 | AND server = ? 52 | AND digest = ? 53 | AND logged_on = ? 54 | AND notifyed = 1 55 | }, 56 | +{ Slice => +{} }, 57 | $c->role, $c->config->{service}, $c->config->{component}, $server, $digest, $c->today 58 | ); 59 | next if scalar @$rows; 60 | $dbh->do(qq{INSERT INTO syslog (role,service,component,server,digest,log,logged_on,notifyed) VALUES(?,?,?,?,?,?,?,0)}, undef, 61 | $c->role, $c->config->{service}, $c->config->{component}, $server, $digest, $line, $c->today, 62 | ); 63 | } 64 | } 65 | } 66 | } 67 | 68 | sub _mk_remote_exec_cmd { 69 | my ($c, $file) = @_; 70 | my $regexp = $c->config->{regexp}; 71 | "test -e $file && /bin/egrep '$regexp' $file" 72 | } 73 | 74 | sub over_threshold { 75 | my ($self, $c) = @_; 76 | 77 | my $dbh = $c->db->dbh; 78 | my $rows = $dbh->selectall_arrayref( 79 | q{ 80 | SELECT service, component, server, log, logged_on 81 | FROM syslog 82 | WHERE role = ? AND notifyed = 0 83 | }, 84 | +{ Slice => +{} }, 85 | $c->role, 86 | ); 87 | return unless scalar @$rows; 88 | 89 | $dbh->do(q{UPDATE syslog SET notifyed = 1 WHERE role = ? AND notifyed = 0}, undef, $c->role); 90 | 91 | $rows; 92 | } 93 | 94 | 1; 95 | 96 | -------------------------------------------------------------------------------- /lib/Komainu/Notify.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Notify; 2 | use strict; 3 | use warnings; 4 | 5 | sub new { 6 | my ($class, $options) = @_; 7 | bless $options, $class; 8 | } 9 | 10 | sub options { $_[0]->{options} } 11 | 12 | 1; 13 | 14 | -------------------------------------------------------------------------------- /lib/Komainu/Notify/Email.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Notify::Email; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Notify'; 5 | use Email::Sender::Transport::SMTP; 6 | use Email::MIME; 7 | use Email::Sender::Simple 'sendmail'; 8 | 9 | sub run { 10 | my ($self, $c, $result) = @_; 11 | 12 | my $body = $c->render($self->options->{tmpl}, +{result => $result}); 13 | my $transport = Email::Sender::Transport::SMTP->new( host => $self->options->{smtp} ); 14 | my $email = Email::MIME->create( 15 | header => [ 16 | From => $self->options->{mail_from}, 17 | To => $self->options->{mail_to}, 18 | Subject => $self->options->{subject}, 19 | ], 20 | attributes => { 21 | content_type => 'text/plain', 22 | charset => 'ISO-2022-JP', 23 | encoding => '7bit', 24 | }, 25 | body => $body, 26 | ); 27 | sendmail($email, { transport => $transport }); 28 | } 29 | 30 | 1; 31 | 32 | -------------------------------------------------------------------------------- /lib/Komainu/Notify/IRC.pm: -------------------------------------------------------------------------------- 1 | package Komainu::Notify::IRC; 2 | use strict; 3 | use warnings; 4 | use parent 'Komainu::Notify'; 5 | use AnyEvent::JSONRPC::Lite; 6 | 7 | sub run { 8 | my ($self, $c, $result) = @_; 9 | 10 | my $body = $c->render($self->options->{tmpl}, +{result => $result, staff => $self->options->{staff}}); 11 | my $irc = $self->options->{irc}; 12 | my $client = jsonrpc_client $irc->{host}, $irc->{port}; 13 | 14 | my $cnt=0; 15 | for my $line (split /\n/, $body) { 16 | $cnt++; 17 | my $res = $client->call( post => { msg => $line } )->recv; 18 | if ($cnt>=10) { 19 | $res = $client->call( post => { msg => 'too many error occured. check email please' } )->recv; 20 | $res = $client->call( post => { msg => $self->options->{staff}.': ^^' } )->recv; 21 | last; 22 | } 23 | } 24 | } 25 | 26 | 1; 27 | 28 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 1; 3 | 4 | BEGIN { use_ok 'Komainu' } 5 | -------------------------------------------------------------------------------- /t/Utils.pm: -------------------------------------------------------------------------------- 1 | package t::Utils; 2 | use strict; 3 | use warnings; 4 | use utf8; 5 | use lib qw(./t/ ./t/lib/); 6 | use Test::More; 7 | use Test::mysqld; 8 | use DBI; 9 | use Path::Class; 10 | 11 | sub import { 12 | my $caller = caller(0); 13 | 14 | for my $func (qw/ 15 | init_db 16 | /) { 17 | no strict 'refs'; ## no critic. 18 | *{$caller.'::'.$func} = \&$func; 19 | } 20 | 21 | strict->import; 22 | warnings->import; 23 | utf8->import; 24 | } 25 | 26 | sub init_db() { ## no critic. 27 | 28 | my $mysqld = Test::mysqld->new( 29 | my_cnf => { 30 | 'skip-networking' => '', 31 | } 32 | ) or plan skip_all => $Test::mysqld::errstr; 33 | 34 | my $dsn = $mysqld->dsn() . ';mysql_multi_statements=1'; 35 | my $dbh = DBI->connect($dsn, '','',{ RaiseError => 1, PrintError => 0, AutoCommit => 1 }); 36 | $dbh->do('create database komainu_test'); 37 | 38 | my $sql = "use komainu_test;\n"; 39 | $sql .= "set names utf8;\n"; 40 | $sql .= file('./docs/schema.sql')->slurp; 41 | $dbh->do($sql); 42 | 43 | $mysqld; 44 | } 45 | 46 | 1; 47 | 48 | -------------------------------------------------------------------------------- /t/agent/accesslog/_mk_remote_exec_cmd.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Accesslog; 4 | use Mock; 5 | 6 | my $mock = Mock->new(+{ 7 | config => +{ 8 | file => '/path/to/access_log.app.%Y%m%d_%H', 9 | regexp => '" 500 ', 10 | } 11 | }); 12 | 13 | is +Komainu::Agent::Accesslog::_mk_remote_exec_cmd($mock), q{test -e /path/to/access_log.app.20110707_00 && /bin/egrep '00:(52|51|50|49|48):' /path/to/access_log.app.20110707_00 | /bin/egrep '" 500 '}; 14 | 15 | done_testing; 16 | 17 | -------------------------------------------------------------------------------- /t/agent/accesslog/_normalize_host.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Accesslog; 4 | 5 | my $regexp = '^.+\.(app.sb.mbga-platform.jp|app.mbga-platform.jp)$'; 6 | 7 | is Komainu::Agent::Accesslog::_normalize_host('app.sb.mbga-platform.jp',$regexp), 'app.sb.mbga-platform.jp'; 8 | is Komainu::Agent::Accesslog::_normalize_host('app.mbga-platform.jp',$regexp), 'app.mbga-platform.jp'; 9 | 10 | is Komainu::Agent::Accesslog::_normalize_host('xxxxxx.app.sb.mbga-platform.jp',$regexp), 'app.sb.mbga-platform.jp'; 11 | is Komainu::Agent::Accesslog::_normalize_host('xxxxxx.app.mbga-platform.jp',$regexp), 'app.mbga-platform.jp'; 12 | 13 | is Komainu::Agent::Accesslog::_normalize_host('xxxxxx.xxxxxx.jp',$regexp), 'xxxxxx.xxxxxx.jp'; 14 | 15 | done_testing; 16 | 17 | -------------------------------------------------------------------------------- /t/agent/accesslog/_normalize_path.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Accesslog; 4 | 5 | my $regexp = '^(/api/restful/v1/[^/]+).+'; 6 | 7 | is Komainu::Agent::Accesslog::_normalize_path('/api/restful/v1/textdata/@app/@all', $regexp), '/api/restful/v1/textdata'; 8 | is Komainu::Agent::Accesslog::_normalize_path('/api/restful/v1/textdata/@app/@all?foo=bar', $regexp), '/api/restful/v1/textdata'; 9 | is Komainu::Agent::Accesslog::_normalize_path('/foo/bar/baz/@app/@all', $regexp), '/foo/bar/baz/@app/@all'; 10 | is Komainu::Agent::Accesslog::_normalize_path('/foo/bar/baz/?foo=bar', $regexp), '/foo/bar/baz/?foo=bar'; 11 | 12 | done_testing; 13 | 14 | -------------------------------------------------------------------------------- /t/agent/accesslog/_parse_accesslog.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Accesslog; 4 | 5 | 6 | my $log = Komainu::Agent::Accesslog::_parse_accesslog( 7 | '203.184.141.230 foo.example.com 80 [30/Jun/2011:11:57:35 +0900] "POST /foo/bar HTTP/1.0" 200 146 "Mozilla/5.0 (Windows NT 5.1; rv:5.0) Gecko/20100101 Firefox/5.0" "-" "-" "http://foo.example.com/foo/bar" "-" "-" "-" "-" 4' 8 | ); 9 | 10 | is_deeply $log, +{ 11 | ip => '203.184.141.230', 12 | host => 'foo.example.com', 13 | port => 80, 14 | date => '30/Jun/2011:11:57:35 +0900', 15 | method => 'POST', 16 | path => '/foo/bar', 17 | status => 200, 18 | useragent => "Mozilla/5.0 (Windows NT 5.1; rv:5.0) Gecko/20100101 Firefox/5.0", 19 | }; 20 | 21 | done_testing; 22 | 23 | -------------------------------------------------------------------------------- /t/agent/accesslog/_store.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Accesslog; 4 | use Mock; 5 | 6 | my $mysqld = init_db; 7 | my $mock = Mock->new(+{ 8 | mysqld => $mysqld, 9 | config => +{ 10 | role => 'test_role', 11 | service => 'service', 12 | component => 'api2', 13 | } 14 | }); 15 | my $dbh = $mock->db->dbh; 16 | 17 | Komainu::Agent::Accesslog::_store($mock, join("\t", 'host1','example.com','500','/bar/bal','GET'), 1); 18 | my $rows = $dbh->selectall_arrayref('select * from accesslog'); 19 | 20 | is_deeply $rows, [ 21 | [ 22 | '1', 23 | 'test_role', 24 | 'service', 25 | 'api2', 26 | 'example.com', 27 | 'host1', 28 | '500', 29 | '/bar/bal', 30 | 'GET', 31 | '2011-07-07 00:53:20', 32 | '1', 33 | '0f6ca374bab5306fd5939be9e447fbe3c90a7efc', 34 | ] 35 | ]; 36 | 37 | Komainu::Agent::Accesslog::_store($mock, join("\t", 'host2','example.com','500','/bar/bal','GET'), 10); 38 | $rows = $dbh->selectall_arrayref('select * from accesslog'); 39 | is_deeply $rows, [ 40 | [ 41 | '1', 42 | 'test_role', 43 | 'service', 44 | 'api2', 45 | 'example.com', 46 | 'host1', 47 | '500', 48 | '/bar/bal', 49 | 'GET', 50 | '2011-07-07 00:53:20', 51 | '1', 52 | '0f6ca374bab5306fd5939be9e447fbe3c90a7efc', 53 | ], 54 | [ 55 | '2', 56 | 'test_role', 57 | 'service', 58 | 'api2', 59 | 'example.com', 60 | 'host2', 61 | '500', 62 | '/bar/bal', 63 | 'GET', 64 | '2011-07-07 00:53:20', 65 | '10', 66 | '2f192704c5c5d67bdd387d22d7b89e46796eb086', 67 | ] 68 | ]; 69 | 70 | done_testing; 71 | 72 | -------------------------------------------------------------------------------- /t/agent/accesslog/_whitelist.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Mock; 4 | 5 | use Data::Dump qw/dump/; 6 | 7 | use Komainu::Agent::Accesslog; 8 | 9 | my $mock = Mock->new(+{ 10 | greptime => '10:(05|04|03|02|01):', 11 | config => +{ 12 | mail_group => 'accesslog_developersite', 13 | file => '/var/log/lighttpd/access_log.ds.%Y%m%d', 14 | regexp => '\" (500|404) ', 15 | service => 'common', 16 | component => 'developersite', 17 | whitelist => [qw{ 18 | /robots.txt 19 | /favicon.ico 20 | /favicon.gif 21 | /images/common/form_bg.png 22 | /pub/admin/common/h1_full.png 23 | /pub/admin/common/form_bg.png 24 | /pub/news/atom.xml 25 | }], 26 | whitelist_ua => +{ 27 | '^DoCoMo' => [qw{ 28 | /images/upload/ 29 | }], 30 | '^SoftBank' => [qw{ 31 | /images/upload/ 32 | }], 33 | '^KDDI' => [qw{ 34 | /images/upload/ 35 | }], 36 | '^Apple-PubSub' => [qw{ 37 | /pub/news/atom.xml 38 | }], 39 | }, 40 | agent => 'Accesslog', 41 | } 42 | }); 43 | 44 | 45 | subtest("test for _build_whitelist", sub { 46 | my $whitelist = Komainu::Agent::Accesslog::_build_whitelist($mock); 47 | is ( ref $whitelist, "Regexp", "return value is Regexp" ); 48 | 49 | ok ( "/robots.txt" =~ /$whitelist/, "matches ok 1"); 50 | ok ( "/pub/news/atom.xml" =~ /$whitelist/, "matches ok 1"); 51 | }); 52 | 53 | subtest("test for _build_whitelist_ua", sub { 54 | my $whitelist_ua = Komainu::Agent::Accesslog::_build_whitelist_ua($mock); 55 | is ( ref $whitelist_ua, "HASH", "return value is HashRef" ); 56 | 57 | is ( ref $_, "Regexp", "value are Regexp" ) for values %$whitelist_ua; 58 | }); 59 | 60 | subtest("test for _match_whitelists", sub { 61 | my $whitelist = Komainu::Agent::Accesslog::_build_whitelist($mock); 62 | my $whitelist_ua = Komainu::Agent::Accesslog::_build_whitelist_ua($mock); 63 | 64 | do { 65 | my $log = +{ 66 | useragent => "Mozilla/5.0 kazehakase/0.0.8", 67 | path => "/images/upload/mobile/0/0/0030e6cd8ae54d6263803e0ec2661290", 68 | }; 69 | ok ( ! Komainu::Agent::Accesslog::_match_whitelists($log, $whitelist, $whitelist_ua), "kazehakase with whitelisted path: not matches"); 70 | }; 71 | 72 | do { 73 | my $log = +{ 74 | useragent => "DoCoMo/2.0 P903iTV(c100;W24H15)", 75 | path => "/images/public/mobile/0/0/0030e6cd8ae54d6263803e0ec2661290", 76 | }; 77 | ok ( ! Komainu::Agent::Accesslog::_match_whitelists($log, $whitelist, $whitelist_ua), "docomo with non-whitelisted path: not matches"); 78 | }; 79 | 80 | do { 81 | my $log = +{ 82 | useragent => "DoCoMo/2.0 P903iTV(c100;W24H15)", 83 | path => "/images/upload/mobile/0/0/0030e6cd8ae54d6263803e0ec2661290", 84 | }; 85 | ok ( Komainu::Agent::Accesslog::_match_whitelists($log, $whitelist, $whitelist_ua), "docomo with whitelisted path: matches"); 86 | }; 87 | 88 | }); 89 | 90 | done_testing; 91 | -------------------------------------------------------------------------------- /t/agent/accesslog/execute.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Test::SharedFork; 4 | use Test::Mock::Guard qw/mock_guard/; 5 | use Komainu::Agent::Accesslog; 6 | use Mock; 7 | 8 | my $mysqld = init_db; 9 | my $mock = Mock->new(+{ 10 | mysqld => $mysqld, 11 | config => +{ 12 | role => 'test_role', 13 | service => 'service', 14 | component => 'api2', 15 | servers => [qw/host1 host2/], 16 | } 17 | }); 18 | my $dbh = $mock->db->dbh; 19 | 20 | my $mock_guard = mock_guard( 21 | 'Komainu::Agent::Accesslog', +{ 22 | _mk_remote_exec_cmd => sub { 23 | 'foo' 24 | }, 25 | remote_exec => sub { 26 | join "\n", 27 | '203.184.141.230 foo.example.com 80 [30/Jun/2011:11:57:35 +0900] "POST /foo/bar HTTP/1.0" 200 146 "Mozilla/5.0 (Windows NT 5.1; rv:5.0) Gecko/20100101 Firefox/5.0" "-" "-" "http://foo.example.com/foo/bar" "-" "-" "-" "-" 4"', 28 | '203.184.141.230 foo.example.com 80 [30/Jun/2011:11:57:35 +0900] "POST /hog/mog HTTP/1.0" 200 146 "Mozilla/5.0 (Windows NT 5.1; rv:5.0) Gecko/20100101 Firefox/5.0" "-" "-" "http://foo.example.com/hog/mog" "-" "-" "-" "-" 4"'; 29 | }, 30 | }, 31 | ); 32 | 33 | my $agent = Komainu::Agent::Accesslog->new; 34 | 35 | { 36 | $agent->execute($mock); 37 | 38 | my $rows = $dbh->selectall_arrayref('select * from accesslog'); 39 | note explain $rows; 40 | is_deeply $rows, [ 41 | [ 42 | '1', 43 | 'test_role', 44 | 'service', 45 | 'api2', 46 | 'foo.example.com', 47 | 'host1', 48 | '200', 49 | '/hog/mog', 50 | 'POST', 51 | '2011-07-07 00:53:20', 52 | '1', 53 | '07b85eb7ebff859706f1cbdd2ce5e9052df53a69', 54 | ], 55 | [ 56 | '2', 57 | 'test_role', 58 | 'service', 59 | 'api2', 60 | 'foo.example.com', 61 | 'host1', 62 | '200', 63 | '/foo/bar', 64 | 'POST', 65 | '2011-07-07 00:53:20', 66 | '1', 67 | 'ef16cab2593fe4fccbc8f1ac6827a02f6cd1a792', 68 | ], 69 | [ 70 | '3', 71 | 'test_role', 72 | 'service', 73 | 'api2', 74 | 'foo.example.com', 75 | 'host2', 76 | '200', 77 | '/foo/bar', 78 | 'POST', 79 | '2011-07-07 00:53:20', 80 | '1', 81 | '52e64b33ea3cc29bd68348ba9b06bd90b526fd0c', 82 | ], 83 | [ 84 | '4', 85 | 'test_role', 86 | 'service', 87 | 'api2', 88 | 'foo.example.com', 89 | 'host2', 90 | '200', 91 | '/hog/mog', 92 | 'POST', 93 | '2011-07-07 00:53:20', 94 | '1', 95 | '6502899e3112be5cd13d79c330b128742fa3652d', 96 | ] 97 | ]; 98 | } 99 | 100 | $dbh->do('delete from accesslog'); 101 | $dbh->commit; 102 | 103 | { 104 | $mock->{config}->{workers} = 2; 105 | $agent->execute($mock); 106 | 107 | my $rows = $dbh->selectall_arrayref('select role, server,host,status,path,method,count from accesslog order by server, path'); 108 | note explain $rows; 109 | is_deeply $rows, [ 110 | [ 111 | 'test_role', 112 | 'host1', 113 | 'foo.example.com', 114 | '200', 115 | '/foo/bar', 116 | 'POST', 117 | '1' 118 | ], 119 | [ 120 | 'test_role', 121 | 'host1', 122 | 'foo.example.com', 123 | '200', 124 | '/hog/mog', 125 | 'POST', 126 | '1' 127 | ], 128 | [ 129 | 'test_role', 130 | 'host2', 131 | 'foo.example.com', 132 | '200', 133 | '/foo/bar', 134 | 'POST', 135 | '1' 136 | ], 137 | [ 138 | 'test_role', 139 | 'host2', 140 | 'foo.example.com', 141 | '200', 142 | '/hog/mog', 143 | 'POST', 144 | '1' 145 | ] 146 | ]; 147 | } 148 | 149 | done_testing; 150 | 151 | -------------------------------------------------------------------------------- /t/agent/accesslog/over_threshold.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Test::Mock::Guard qw/mock_guard/; 4 | use Komainu::Agent::Accesslog; 5 | use Komainu::Agent; 6 | use Mock; 7 | 8 | my $mysqld = init_db; 9 | my $mock = Mock->new(+{ 10 | mysqld => $mysqld, 11 | config => +{ 12 | role => 'test_role', 13 | service => 'service', 14 | component => 'api2', 15 | } 16 | }); 17 | my $dbh = $mock->db->dbh; 18 | 19 | my $rows = [ 20 | [ 21 | '1', 22 | 'test_role', 23 | 'service', 24 | 'api2', 25 | 'example.com', 26 | 'host1', 27 | '500', 28 | '/path/to', 29 | 'GET', 30 | '2011-07-07 00:53:20', 31 | '1' 32 | ], 33 | [ 34 | '2', 35 | 'test_role', 36 | 'service', 37 | 'api2', 38 | 'example.com', 39 | 'host2', 40 | '500', 41 | '/path/to', 42 | 'GET', 43 | '2011-07-07 00:53:20', 44 | '2' 45 | ], 46 | ]; 47 | $dbh->do('insert into accesslog (id,role,service,component,host,server,status,path,method,logged_at,count) values (?,?,?,?,?,?,?,?,?,?,?)', undef, @{$_}) for @$rows; 48 | $dbh->commit; 49 | 50 | my $agent = Komainu::Agent::Accesslog->new; 51 | 52 | { 53 | my $rows = $agent->over_threshold($mock); 54 | note explain $rows; 55 | is_deeply $rows, [ 56 | { 57 | 'current_count' => '1', 58 | 'host' => 'example.com', 59 | 'method' => 'GET', 60 | 'old_count' => 0, 61 | 'path' => '/path/to', 62 | 'server' => 'host1', 63 | 'status' => '500', 64 | 'digest' => '', 65 | }, 66 | { 67 | 'current_count' => '2', 68 | 'host' => 'example.com', 69 | 'method' => 'GET', 70 | 'old_count' => 0, 71 | 'path' => '/path/to', 72 | 'server' => 'host2', 73 | 'status' => '500', 74 | 'digest' => '', 75 | } 76 | ]; 77 | } 78 | 79 | $rows = [ 80 | [ 81 | '3', 82 | 'test_role', 83 | 'service', 84 | 'api2', 85 | 'example.com', 86 | 'host1', 87 | '500', 88 | '/path/to', 89 | 'GET', 90 | '2011-07-07 00:58:20', 91 | '1' 92 | ], 93 | [ 94 | '4', 95 | 'test_role', 96 | 'service', 97 | 'api2', 98 | 'example.com', 99 | 'host2', 100 | '500', 101 | '/path/to', 102 | 'GET', 103 | '2011-07-07 00:58:20', 104 | '2' 105 | ], 106 | ]; 107 | 108 | $dbh->do('insert into accesslog (id,role,service,component,host,server,status,path,method,logged_at,count) values (?,?,?,?,?,?,?,?,?,?,?)', undef, @{$_}) for @$rows; 109 | 110 | { 111 | my $rows = $agent->over_threshold($mock); 112 | note explain $rows; 113 | is_deeply $rows, [ 114 | { 115 | 'current_count' => '1', 116 | 'host' => 'example.com', 117 | 'method' => 'GET', 118 | 'old_count' => 3, 119 | 'path' => '/path/to', 120 | 'server' => 'host1', 121 | 'status' => '500', 122 | 'digest' => '', 123 | }, 124 | { 125 | 'current_count' => '2', 126 | 'host' => 'example.com', 127 | 'method' => 'GET', 128 | 'old_count' => 3, 129 | 'path' => '/path/to', 130 | 'server' => 'host2', 131 | 'status' => '500', 132 | 'digest' => '', 133 | } 134 | ]; 135 | } 136 | 137 | { 138 | $mock->{config}->{threshold} = +{500 => 2}; 139 | my $rows = $agent->over_threshold($mock); 140 | note explain $rows; 141 | is_deeply $rows, [ 142 | { 143 | 'current_count' => '2', 144 | 'host' => 'example.com', 145 | 'method' => 'GET', 146 | 'old_count' => 3, 147 | 'path' => '/path/to', 148 | 'server' => 'host2', 149 | 'status' => '500', 150 | 'digest' => '', 151 | } 152 | ]; 153 | } 154 | 155 | done_testing; 156 | 157 | -------------------------------------------------------------------------------- /t/agent/deploy_log/logged.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::DeployLog; 4 | use Mock; 5 | 6 | my $mysqld = init_db; 7 | my $mock = Mock->new(+{mysqld => $mysqld, deploy_mode => 'start', service => 'sandbox', component => 'api2'}); 8 | my $dbh = $mock->db->dbh; 9 | $dbh->do('SET TIMESTAMP = 1302447600'); 10 | 11 | 12 | my $agent = Komainu::Agent::DeployLog->new; 13 | 14 | { 15 | $agent->logged($mock); 16 | $mock->{deploy_mode} = 'end'; 17 | $agent->logged($mock); 18 | 19 | my $rows = $dbh->selectall_arrayref('select * from deploy_log'); 20 | note explain $rows; 21 | is_deeply $rows, [ 22 | [ 23 | '1', 24 | 'sandbox', 25 | 'api2', 26 | '1302447600', 27 | '1302447600', 28 | ], 29 | ]; 30 | } 31 | 32 | { 33 | $mock->{deploy_mode} = 'start'; 34 | $agent->logged($mock); 35 | 36 | my $rows = $dbh->selectall_arrayref('select * from deploy_log'); 37 | note explain $rows; 38 | is_deeply $rows, [ 39 | [ 40 | '1', 41 | 'sandbox', 42 | 'api2', 43 | '1302447600', 44 | '1302447600', 45 | ], 46 | [ 47 | '2', 48 | 'sandbox', 49 | 'api2', 50 | '1302447600', 51 | undef, 52 | ], 53 | ]; 54 | } 55 | 56 | { 57 | $agent->logged($mock); 58 | $mock->{deploy_mode} = 'end'; 59 | $agent->logged($mock); 60 | 61 | my $rows = $dbh->selectall_arrayref('select * from deploy_log'); 62 | note explain $rows; 63 | is_deeply $rows, [ 64 | [ 65 | '1', 66 | 'sandbox', 67 | 'api2', 68 | '1302447600', 69 | '1302447600', 70 | ], 71 | [ 72 | '2', 73 | 'sandbox', 74 | 'api2', 75 | '1302447600', 76 | undef, 77 | ], 78 | [ 79 | '3', 80 | 'sandbox', 81 | 'api2', 82 | '1302447600', 83 | '1302447600', 84 | ], 85 | ]; 86 | } 87 | 88 | done_testing; 89 | 90 | -------------------------------------------------------------------------------- /t/agent/syslog/_mk_remote_exec_cmd.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Syslog; 4 | use Mock; 5 | 6 | my $mock = Mock->new(+{ 7 | config => +{ 8 | regexp => ' target ', 9 | } 10 | }); 11 | 12 | is +Komainu::Agent::Syslog::_mk_remote_exec_cmd($mock, '/path/to/file'), q{test -e /path/to/file && /bin/egrep ' target ' /path/to/file}; 13 | 14 | done_testing; 15 | 16 | -------------------------------------------------------------------------------- /t/agent/syslog/execute.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Test::Mock::Guard qw/mock_guard/; 4 | use Komainu::Agent::Syslog; 5 | use Komainu::Agent; 6 | use Mock; 7 | 8 | my $mysqld = init_db; 9 | my $mock = Mock->new(+{ 10 | mysqld => $mysqld, 11 | config => +{ 12 | service => 'service', 13 | component => 'api2', 14 | servers => [qw/host1 host2/], 15 | regexp => 'FATAL', 16 | files => ['/path/to/file/syslog', ], 17 | } 18 | }); 19 | my $dbh = $mock->db->dbh; 20 | 21 | my $mock_guard = mock_guard( 22 | 'Komainu::Agent', +{ 23 | remote_exec => sub { 24 | my ($self, $host, $cmd) = @_; 25 | ok $self; 26 | ok $host; 27 | ok $cmd; 28 | "log1\nlog2\nlog1"; 29 | }, 30 | }, 31 | ); 32 | 33 | my $agent = Komainu::Agent::Syslog->new; 34 | 35 | { 36 | $agent->execute($mock); 37 | 38 | my $rows = $dbh->selectall_arrayref('select * from syslog'); 39 | note explain $rows; 40 | is_deeply $rows, 41 | [ 42 | [ 43 | '1', 44 | 'test_role', 45 | 'service', 46 | 'api2', 47 | 'host1', 48 | 'f4f1b5fb935f19c3ed564c873a77041e633a2260', 49 | 'log1', 50 | '2011-07-07', 51 | '0' 52 | ], 53 | [ 54 | '2', 55 | 'test_role', 56 | 'service', 57 | 'api2', 58 | 'host1', 59 | '8272fbd4ea89b69b3ccf4f94a9578f957614acd7', 60 | 'log2', 61 | '2011-07-07', 62 | '0' 63 | ], 64 | [ 65 | '3', 66 | 'test_role', 67 | 'service', 68 | 'api2', 69 | 'host1', 70 | 'f4f1b5fb935f19c3ed564c873a77041e633a2260', 71 | 'log1', 72 | '2011-07-07', 73 | '0' 74 | ], 75 | [ 76 | '4', 77 | 'test_role', 78 | 'service', 79 | 'api2', 80 | 'host2', 81 | 'f4f1b5fb935f19c3ed564c873a77041e633a2260', 82 | 'log1', 83 | '2011-07-07', 84 | '0' 85 | ], 86 | [ 87 | '5', 88 | 'test_role', 89 | 'service', 90 | 'api2', 91 | 'host2', 92 | '8272fbd4ea89b69b3ccf4f94a9578f957614acd7', 93 | 'log2', 94 | '2011-07-07', 95 | '0' 96 | ], 97 | [ 98 | '6', 99 | 'test_role', 100 | 'service', 101 | 'api2', 102 | 'host2', 103 | 'f4f1b5fb935f19c3ed564c873a77041e633a2260', 104 | 'log1', 105 | '2011-07-07', 106 | '0' 107 | ] 108 | ]; 109 | } 110 | 111 | done_testing; 112 | 113 | -------------------------------------------------------------------------------- /t/agent/syslog/over_threshold.t: -------------------------------------------------------------------------------- 1 | use t::Utils; 2 | use Test::More; 3 | use Komainu::Agent::Syslog; 4 | use Mock; 5 | 6 | my $mysqld = init_db; 7 | my $mock = Mock->new(+{ 8 | mysqld => $mysqld, 9 | config => +{ 10 | service => 'service', 11 | component => 'api2', 12 | } 13 | }); 14 | my $dbh = $mock->db->dbh; 15 | 16 | my $rows = [ 17 | [ 18 | '1', 19 | 'test_role', 20 | 'service', 21 | 'api2', 22 | 'host1', 23 | 'log1', 24 | '2011-07-07', 25 | '0' 26 | ], 27 | [ 28 | '2', 29 | 'test_role', 30 | 'service', 31 | 'api2', 32 | 'host1', 33 | 'log2', 34 | '2011-07-07', 35 | '0' 36 | ], 37 | [ 38 | '3', 39 | 'test_role', 40 | 'service', 41 | 'api2', 42 | 'host2', 43 | 'log1', 44 | '2011-07-07', 45 | '0' 46 | ], 47 | [ 48 | '4', 49 | 'test_role', 50 | 'service', 51 | 'api2', 52 | 'host2', 53 | 'log2', 54 | '2011-07-07', 55 | '0' 56 | ] 57 | ]; 58 | $dbh->do('insert into syslog (id,role,service,component,server,log,logged_on,notifyed) values (?,?,?,?,?,?,?,?)', undef, @{$_}) for @$rows; 59 | 60 | my $agent = Komainu::Agent::Syslog->new; 61 | 62 | { 63 | my $rows = $agent->over_threshold($mock); 64 | note explain $rows; 65 | is_deeply $rows, [ 66 | { 67 | 'component' => 'api2', 68 | 'logged_on' => '2011-07-07', 69 | 'log' => 'log1', 70 | 'server' => 'host1', 71 | 'service' => 'service' 72 | }, 73 | { 74 | 'component' => 'api2', 75 | 'logged_on' => '2011-07-07', 76 | 'log' => 'log2', 77 | 'server' => 'host1', 78 | 'service' => 'service' 79 | }, 80 | { 81 | 'component' => 'api2', 82 | 'logged_on' => '2011-07-07', 83 | 'log' => 'log1', 84 | 'server' => 'host2', 85 | 'service' => 'service' 86 | }, 87 | { 88 | 'component' => 'api2', 89 | 'logged_on' => '2011-07-07', 90 | 'log' => 'log2', 91 | 'server' => 'host2', 92 | 'service' => 'service' 93 | } 94 | ]; 95 | $rows = $agent->over_threshold($mock); 96 | ok not $rows; 97 | } 98 | 99 | $dbh->do('update syslog set notifyed = 0 where id in (1,2,3)'); 100 | 101 | { 102 | my $rows = $agent->over_threshold($mock); 103 | note explain $rows; 104 | is_deeply $rows, [ 105 | { 106 | 'component' => 'api2', 107 | 'logged_on' => '2011-07-07', 108 | 'log' => 'log1', 109 | 'server' => 'host1', 110 | 'service' => 'service' 111 | }, 112 | { 113 | 'component' => 'api2', 114 | 'logged_on' => '2011-07-07', 115 | 'log' => 'log2', 116 | 'server' => 'host1', 117 | 'service' => 'service' 118 | }, 119 | { 120 | 'component' => 'api2', 121 | 'logged_on' => '2011-07-07', 122 | 'log' => 'log1', 123 | 'server' => 'host2', 124 | 'service' => 'service' 125 | }, 126 | ]; 127 | $rows = $agent->over_threshold($mock); 128 | ok not $rows; 129 | } 130 | 131 | done_testing; 132 | 133 | -------------------------------------------------------------------------------- /t/lib/Mock.pm: -------------------------------------------------------------------------------- 1 | package Mock; 2 | use strict; 3 | use warnings; 4 | use DBIx::Handler; 5 | use Time::Piece; 6 | 7 | sub new { 8 | my ($class, $opts) = @_; 9 | 10 | my $dt = gmtime(1310000000); 11 | bless { 12 | deploy_mode => '', 13 | service => '', 14 | component => '', 15 | db => '', 16 | mysqld => '', 17 | config => '', 18 | date => $dt, 19 | role => 'test_role', 20 | %$opts 21 | }, $class; 22 | } 23 | 24 | sub date { $_[0]->{date} } 25 | sub today { $_[0]->{date}->strftime('%Y-%m-%d') } 26 | sub now { $_[0]->{date}->strftime('%Y-%m-%d %H:%M:%S') } 27 | sub role { $_[0]->{role} } 28 | 29 | sub db { 30 | my $self = shift; 31 | $self->{db} ||= do { 32 | DBIx::Handler->new($self->{mysqld}->dsn(dbname => 'komainu_test'),'','',+{AutoCommit => 1,}); 33 | }; 34 | } 35 | 36 | sub config { $_[0]->{config} } 37 | 38 | 1; 39 | 40 | -------------------------------------------------------------------------------- /xt/01_perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval { 4 | require Test::Perl::Critic; 5 | Test::Perl::Critic->import( -profile => 'xt/perlcriticrc'); 6 | }; 7 | plan skip_all => "Test::Perl::Critic is not installed." if $@; 8 | all_critic_ok('lib'); 9 | -------------------------------------------------------------------------------- /xt/02_pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Pod 1.00"; 3 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 4 | all_pod_files_ok(); 5 | -------------------------------------------------------------------------------- /xt/perlcriticrc: -------------------------------------------------------------------------------- 1 | [TestingAndDebugging::ProhibitNoStrict] 2 | allow=refs 3 | 4 | [-Subroutines::ProhibitSubroutinePrototypes] 5 | 6 | --------------------------------------------------------------------------------