kanla-1.4/0000755000014500017510000000000012232511602011723 5ustar michaelstaffkanla-1.4/default.cfg0000644000014500017510000000125512147453516014051 0ustar michaelstaff# vim:tabstop=4:shiftwidth=4:expandtab # # kanla configuration file (apache-style) # see http://kanla.zekjur.net/docs/ # kanla uses jabber (XMPP) to alert you about any problem it detects. # You can configure multiple accounts for redundancy. # It is currently unspecified how messages are distributed across accounts. jid = "kanla@example.invalid" password = "kV9eJ4LZ9KRYOCec5W2witq" # Jabber ID(s) which should receive alerts. # Specify one jabber ID per line. # For redundancy, use jabber IDs on different servers. send_alerts_to = <
{toc-title}
kanla-1.4/inc/0000755000014500017510000000000012232511602012474 5ustar michaelstaffkanla-1.4/inc/Module/0000755000014500017510000000000012232511602013721 5ustar michaelstaffkanla-1.4/inc/Module/Install.pm0000644000014500017510000003013512232511601015666 0ustar michaelstaff#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. kanla-1.4/inc/Module/Install/0000755000014500017510000000000012232511602015327 5ustar michaelstaffkanla-1.4/inc/Module/Install/Scripts.pm0000644000014500017510000000101112232511601017304 0ustar michaelstaff#line 1 package Module::Install::Scripts; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die("Cannot find script '$_'"); } } } 1; kanla-1.4/inc/Module/Install/Metadata.pm0000644000014500017510000004327712232511601017421 0ustar michaelstaff#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; kanla-1.4/inc/Module/Install/Fetch.pm0000644000014500017510000000462712232511601016726 0ustar michaelstaff#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; kanla-1.4/inc/Module/Install/Win32.pm0000644000014500017510000000340312232511601016566 0ustar michaelstaff#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; kanla-1.4/inc/Module/Install/WriteAll.pm0000644000014500017510000000237612232511601017417 0ustar michaelstaff#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; kanla-1.4/inc/Module/Install/Share.pm0000644000014500017510000000464312232511601016735 0ustar michaelstaff#line 1 package Module::Install::Share; use strict; use Module::Install::Base (); use File::Find (); use ExtUtils::Manifest (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_share { my $self = shift; my $dir = @_ ? pop : 'share'; my $type = @_ ? shift : 'dist'; unless ( defined $type and $type eq 'module' or $type eq 'dist' ) { die "Illegal or invalid share dir type '$type'"; } unless ( defined $dir and -d $dir ) { require Carp; Carp::croak("Illegal or missing directory install_share param: '$dir'"); } # Split by type my $S = ($^O eq 'MSWin32') ? "\\" : "\/"; my $root; if ( $type eq 'dist' ) { die "Too many parameters to install_share" if @_; # Set up the install $root = "\$(INST_LIB)${S}auto${S}share${S}dist${S}\$(DISTNAME)"; } else { my $module = Module::Install::_CLASS($_[0]); unless ( defined $module ) { die "Missing or invalid module name '$_[0]'"; } $module =~ s/::/-/g; $root = "\$(INST_LIB)${S}auto${S}share${S}module${S}$module"; } my $manifest = -r 'MANIFEST' ? ExtUtils::Manifest::maniread() : undef; my $skip_checker = $ExtUtils::Manifest::VERSION >= 1.54 ? ExtUtils::Manifest::maniskip() : ExtUtils::Manifest::_maniskip(); my $postamble = ''; my $perm_dir = eval($ExtUtils::MakeMaker::VERSION) >= 6.52 ? '$(PERM_DIR)' : 755; File::Find::find({ no_chdir => 1, wanted => sub { my $path = File::Spec->abs2rel($_, $dir); if (-d $_) { return if $skip_checker->($File::Find::name); $postamble .=<<"END"; \t\$(NOECHO) \$(MKPATH) "$root${S}$path" \t\$(NOECHO) \$(CHMOD) $perm_dir "$root${S}$path" END } else { return if ref $manifest && !exists $manifest->{$File::Find::name}; return if $skip_checker->($File::Find::name); $postamble .=<<"END"; \t\$(NOECHO) \$(CP) "$dir${S}$path" "$root${S}$path" END } }, }, $dir); # Set up the install $self->postamble(<<"END_MAKEFILE"); config :: $postamble END_MAKEFILE # The above appears to behave incorrectly when used with old versions # of ExtUtils::Install (known-bad on RHEL 3, with 5.8.0) # So when we need to install a share directory, make sure we add a # dependency on a moderately new version of ExtUtils::MakeMaker. $self->build_requires( 'ExtUtils::MakeMaker' => '6.11' ); # 99% of the time we don't want to index a shared dir $self->no_index( directory => $dir ); } 1; __END__ #line 154 kanla-1.4/inc/Module/Install/Can.pm0000644000014500017510000000615712232511601016376 0ustar michaelstaff#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 kanla-1.4/inc/Module/Install/Makefile.pm0000644000014500017510000002743712232511601017416 0ustar michaelstaff#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 kanla-1.4/inc/Module/Install/Base.pm0000644000014500017510000000214712232511601016542 0ustar michaelstaff#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 kanla-1.4/docs/0000755000014500017510000000000012232511602012653 5ustar michaelstaffkanla-1.4/docs/installing-rhel.html0000644000014500017510000003462112125551463016655 0ustar michaelstaffInstalling kanla on Red Hat Enterprise Linux

This document explains how to install kanla on RHEL 6.4.

The instructions should also work for any other rpm-based distribution.

1. Install EPEL

Many dependencies of kanla are available for RHEL in the EPEL repository.

Visit http://mirror.de.leaseweb.net/epel/6/i386/repoview/epel-release.html and install the epel-release rpm.

2. Check that kanla is still not available

We are working on getting kanla available via EPEL.

Despite our best efforts, this document might be outdated, so run yum search kanla before continuing.

3. Installing dependencies not in EPEL

wget http://kanla.zekjur.net/downloads/rpm/perl-AnyEvent-HTTP-2.15-1.el6.noarch.rpm
wget http://kanla.zekjur.net/downloads/rpm/perl-AnyEvent-XMPP-0.54-2.el6.noarch.rpm
wget http://kanla.zekjur.net/downloads/rpm/perl-Object-Event-1.23-5.el6.noarch.rpm
yum install perl-AnyEvent-XMPP-0.54-2.el6.noarch.rpm
yum install perl-Object-Event-1.23-5.el6.noarch.rpm
yum install perl-AnyEvent-HTTP-2.15-1.el6.noarch.rpm

You can help by getting these two packages from Fedora to EPEL :-).

4. Install the kanla RPM

wget http://kanla.zekjur.net/downloads/rpm/kanla-1.2-1.el6.noarch.rpm
yum install kanla-1.2-1.el6.noarch.rpm

Note that there currently is no init script in the RPM. If you can provide one, please go ahead. I personally lost motivation after realizing the lack of start-stop-daemon in RHEL.

kanla-1.4/docs/userguide.html0000644000014500017510000016477012215126031015553 0ustar michaelstaffThe kanla User Guide

kanla is a daemon which periodically checks whether your website, mail server, etc. are still up and running.

In case a health check fails, kanla will notify you via jabber (XMPP).

Focus of kanla lies on being light-weight, being simple, using a sane configuration file, being well-documented.

1. Introduction

Many people run personal websites or websites of their pet projects. Except for professional sysadmins, none of those I asked ran any kind of software to notify them about failures. Since nobody disagreed with me about the idea being helpful, this suggests that existing software is too complex, complicated to setup, under-documented or for some other reason undesirable.

I myself wanted to be notified — by software, not by users — when http://i3wm.org is not reachable anymore. However, the software I looked at could not be configured to verify the actual page contents (as opposed to only the HTTP status) and did not even support IPv6 (come on, it’s 2013).

My conclusion was that writing a simple program myself would be faster than trying to re-implement plugins for existing monitoring/alerting software in such a way that I’d be happy with them.

kanla is the fruit of this effort. It is intentionally simple and focuses on small-scale alerting. This means it will NOT generate uptime statistics, or execute certain actions when some condition is met, or handle pager alerts and on-call schedules. Instead, it verifies what you describe and whenever something is wrong, it sends you a message via jabber (XMPP).

1.1. Terminology

kanla instance

A process of the kanla binary, running with precisely one configuration. You can have multiple instances running and each instance usually has several plugins running.

plugin

A small program which verifies that things are good. For example, the "http" plugin retrieves websites and verifies their content. If anything goes wrong you will get an alert.

alert

The message which kanla sends to you when things go wrong.

2. Installation

To install kanla, you should by all means use your distribution’s package management system.

It is intentional that there is no instruction for installing from source.

If there is no package for your distribution, consider making one. The Debian packaging serves as reference packaging.

2.1. Locations

kanla itself should be installed as /usr/bin/kanla.

kanla ships with a number of plugins. To find the plugin location for your system, use:

perl -MFile::ShareDir -E 'say File::ShareDir::dist_dir("kanla")'

Custom plugins can be placed in /usr/local/share/kanla/ or /usr/local/lib/kanla/, depending on whether they are binary files or scripts.

A plugin is just an executable file (implemented in any language, but preferably Perl) which produces output in a certain format on stderr when things go wrong. Plugins are identified by their file name, e.g. "http".

Configuration files are placed in /etc/kanla/ with the default configuration file being named default.cfg. This file — by default — includes every .cfg file in /etc/kanla/default.d/ which is where you will find example configurations for every plugin.

3. Configuration

The main kanla configuration file is called /etc/kanla/default.cfg. It contains the jabber (XMPP) account configuration, the default alert destination (e.g. your jabber id) and includes /etc/kanla/default.d/*.cfg.

After modifying the jabber (XMPP) account configuration, you need to enable at least one plugin by removing the comment signs (#) in front of every line of its configuration file. The provided files serve as a minimum useful example (while this documentation poses a reference) and will not change often so you can modify them without being bothered by config file conflicts on upgrades.

It goes without saying that configuration files are encoded as UTF-8 and UTF-8 is supported throughout kanla.

Note SysVinit will not directly report error messages when (re)starting kanla. Ensure kanla is running by checking service kanla status and/or look at /var/log/kanla.log for error messages

3.1. Quick example

A minimum useful kanla configuration:

<jabber>
    jid      = "kanla@example.com"
    password = "kV9eJ4LZ9KRYOCec5W2witq"
</jabber>

send_alerts_to = <<EOT
michael@example.com
EOT

<monitor i3wm website>
    plugin = http
    url    = "http://www.i3wm.org/"
    url    = "http://i3wm.org/"
</monitor>

3.2. Jabber configuration

Jabber configuration is done with one (or multiple) jabber block(s). Each block needs to have at least the jid and password attribute. The following attributes can be configured:

jid

The jabber id of this account, e.g. kanla@example.com.

password

The password for this account.

host

The hostname of the jabber server to which to connect to. It is normally NOT necessary to specify this, but some networks actively break SRV record resolution.

port

The port of the jabber server, if non-standard.

Simple jabber example:

<jabber>
    jid      = "kanla@example.com"
    password = "kV9eJ4LZ9KRYOCec5W2witq"
</jabber>

Complex jabber example:

<jabber>
    jid      = "kanla@example.com"
    password = "kV9eJ4LZ9KRYOCec5W2witq"
</jabber>

<jabber>
    jid      = "kanla@example.net"
    password = "kV9eJ4LZ9KRYOCec5W2witq"
    host     = "jabber.example.net"
    port     = 5222
</jabber>

There is no default value for this option, therefore you have to configure this.

Note kanla will send an XEP-0199 ping to the server every 60 seconds. If the server does not reply within 60 seconds, the connection is considered dead and will be reconnected.

3.3. Main configuration

3.3.1. send_alerts_to

A list of jabber ids (line-separated) to which alerts will be sent. This can be overwritten on a per-plugin basis. Please use the heredoc syntax, otherwise extending this list will not work (a limitation of the Config::General module).

send_alerts_to example:

send_alerts_to = <<EOT
michael@example.com
stefan@example.com
EOT

There is no default value for this option, therefore you have to configure this.

Note

In order to maximize redundancy, you can (and should) use multiple jabber ids. Of course, they should not use the same infrastructure, so use two different jabber servers and clients (if possible).

In case you are using Android, consider using Google Talk (built-in) and Xabber (supports XEP-0184 message receipts) with a non-google account.

3.4. Plugin configuration

There are some configuration directives which are valid for every plugin. These directives are:

plugin

Specifies which plugin should be used. This is simply the base filename of the plugin, e.g. "http".

send_alerts_to

Overwrites the main configuration’s send_alerts_to for this plugin, see [send_alerts_to]. Using variables, you can also amend instead of overwrite, see [variables].

interval

Controls how often the plugin verifies that things are good. This configuration directive is merely a convention, that is, plugins don’t have to use it (e.g. in case the plugin needs a more detailed interval configuration), but it is strongly recommended.

3.5. Plugin: http

The http plugin periodically retrieves the specified URL(s) and sends alerts if the HTTP status is not 200 or anything else went wrong during retrieval.

3.5.1. URL

The URL of the site to retrieve. This can be anything which the AnyEvent::HTTP module accepts. In addition it allows to embed username and password for HTTP basic access authentication. The standard URI syntax is used, e.g. http://user:pass@www.i3wm.org/.

You can specify this configuration directive multiple times.

Full URL example:

<monitor i3wm website>
    plugin = http
    url    = "http://www.i3wm.org/"
</monitor>

There is no default value for this option, therefore you have to configure this.

You can specify multiple URLs:

Multiple URL example:

<monitor i3wm website>
    plugin = http
    url    = http://www.i3wm.org/
    url    = http://www.i3-wm.org/
</monitor>

3.5.2. Family

The address family (IPv4, IPv6 or both) which should be used when retrieving the URL(s).

The default is to try both IPv4 and IPv6.

Full family example:

<monitor i3wm website>
    plugin = http
    family = ipv4 | ipv6
    url    = "http://www.i3wm.org/"
</monitor>

<monitor slashdot>
    plugin = http
    # slashdot doesn’t even support IPv6…
    family = ipv4
    url    = "http://slashdot.org/"
</monitor>
Note The absence of a AAAA DNS record is treated as an error (to catch DNS misconfiguration problems). Therefore, if your site is IPv4-only, you need to explicitly configure that. This is intentional — it’s 2013, your site should really be dual-stacked by now.

3.5.3. Body

You can make kanla verify the page it received via HTTP actually contains expected content. That is, sometimes webservers fail even though they return the HTTP 200 status, for example because a poorly written PHP script could not establish a database connection.

You can specify this option multiple times, all specified checks need to pass.

You can either specify a Perl regular expression (e.g. /foo/, it MUST be enclosed in forward slashes) or a custom verification function (MUST start with "sub {"), see the example below. Functions will be called with the full HTTP body string as first argument.

This option has no default value, meaning no checks on the body are performed.

Full body example:

<monitor i3wm website>
    plugin = http
    url    = "http://www.i3wm.org/"

    # Check for the intro text.
    body   = "/tiling window manager/"

    # Check for version 4.x in the page.
    body   = <<EOT
/4.\d<\/span>/
EOT
</monitor>

<monitor i3wm website>
    plugin = http
    url    = "http://www.i3wm.org/"

    # Stupid check for the length of the returned page.
    # Only good for demonstration purposes.
    # Note how variables need to be escaped because
    # otherwise they are interpolated.
    body   = <<EOT
sub {
    my (\$body) = @_;
    return (length(\$body) == 5137);
}
EOT
</monitor>

3.6. Plugin: smtp

The smtp plugin periodically connects to an SMTP server and sends alerts if the server does not send the SMTP greeting (220 …) within 20 seconds after connecting or anything else went wrong on the DNS/TCP level.

3.6.1. Host

The host (may include a port) of the smtp server to check. Every syntax which AnyEvent::Socket’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats).

You can specify this configuration directive multiple times.

Full Host example:

<monitor i3 smtp>
    plugin = smtp
    host   = infra.in.zekjur.net
</monitor>

<monitor i3 smtp>
    plugin = smtp
    family = ipv6
    host   = "[2001:4d88:100e:1::2]:submission"
</monitor>

3.6.2. Family

See [http-family].

3.6.3. Timeout

The timeout (in seconds) for each connection attempt (via TCP) and for receiving the greeting.

The default value is a timeout 20 seconds. This means it is okay if the TCP connection can be established after 9 seconds and the SMTP greeting is read after another 9 seconds.

Full timeout example:

<monitor i3 smtp>
    plugin   = smtp

    # Gee, we could really use some newer hardware.
    # Until then, cut the server some slack:
    # Check only every 5 minutes,
    # wait up to 60 seconds for connections
    # and for reading the greeting.
    timeout  = 60
    interval = 300

    host     = infra.in.zekjur.net
</monitor>

3.7. Plugin: irc

The irc plugin periodically logs onto an IRC network and sends alerts if the server does not let you log in properly (it looks for the "001" IRC message) or anything else went wrong on the DNS/TCP level.

3.7.1. ircd

The host (may include a port) of the IRC server to check. Every syntax which AnyEvent::Socket’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats).

Full ircd example:

<monitor TWiCEiRC>
    plugin = irc
    ircd   = irc.twice-irc.de
</monitor>

3.7.2. Family

See [http-family].

3.7.3. Timeout

See [smtp-timeout].

3.8. Plugin: git

The git plugin periodically checks whether the specified git URL works correctly (by receiving the current HEAD revision) and sends alerts if anything comes back which does not look like a git HEAD revision or anything else went wrong on the DNS/TCP level.

3.8.1. url

A git URL of the git-daemon to check. Every syntax which AnyEvent::Socket’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats).

Full url example:

<monitor i3 git>
    plugin = git
    url    = git://code.i3wm.org/i3
</monitor>

3.8.2. Family

See [http-family].

3.8.3. Timeout

See [smtp-timeout].

3.9. Plugin: redis

The redis plugin periodically connects to a redis server and sends alerts if the server does not respond to a PING command (with +PONG) or anything else went wrong on the DNS/TCP level.

3.9.1. Host

The host (may include a port) of the redis server to check. Every syntax which AnyEvent::Socket’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats).

You can specify this configuration directive multiple times.

Full Host example:

<monitor my redis>
    plugin = redis
    host   = localhost:6379
</monitor>

3.9.2. Family

See [http-family]. Make sure to use family = ipv4 here as long as redis does not support IPv6.

4. Config recipes

4.1. Variables

When configuring many hosts which are alike, variables might come in handy. kanla enables Config::General::Interpolated, so you can use variables by refering to configuration directives with a dollar sign prefixed, e.g. $send_alerts_to evaluates to the contents of the send_alerts_to directive.

You are not confined to the directives which actually exist, but you can use any key/value pair you want. To avoid troubles, you should prefix your own directives with an underscore. kanla will never implement directives starting with an underscore.

Amending send_alerts_to:

# michael@example.com gets ALL the alerts!
send_alerts_to = <<EOT
michael@example.com
EOT

<monitor i3wm website>
    plugin         = http
    url            = "http://www.i3wm.org/"

    # Additionally, alert stefan@example.com.
    send_alerts_to = <<EOT
    $send_alerts_to
    stefan@example.com
    EOT
</monitor>

Monitor multiple trac instances (/etc/kanla/default.cfg):

_trac_url = "bugs.i3wm.org"
include "default.d/http-trac.cfg"

_trac_url = "trac.edgewall.org"
include "default.d/http-trac.cfg"

Monitor multiple trac instances (/etc/kanla/default.d/http-trac.cfg):

<monitor trac at $_trac_url>
    plugin = http
    url    = $_trac_url
# TODO: content matching
</monitor>

5. Technical details

5.1. Message receipts

kanla supports jabber’s XEP-0184 message receipts. With message receipts, delivery of a message is confirmed end-to-end, that is, kanla can be sure your device received its message. More importantly, when your device does not confirm the message, kanla will retry (after 30 seconds) to send the message, until your device confirms the message.

You will immediately notice this feature when you configure multiple jabber accounts. In that case, kanla will try to deliver alerts using one jabber account first, and if that fails, it retries with the second one. In case you have more than two accounts, this is repeated until your device confirmed the message or there are no accounts left.

For send_alerts_to destinations which do not support XEP-0184, kanla will immediately send alerts from all jabber accounts. This leads to a storm of alerts on your device, but this is intended to keep things simple. Lobby your jabber client vendor to implement XEP-0184, it’s simple enough.

5.2. Jabber presences

Let’s assume you configure michael@example.com via send_alerts_to and you are connected as michael@example.com on your computer and on your smartphone. Jabber calls each of these connections a presence.

When sending an alert to michael@example.com, kanla will chose the presence with the highest priority. In case multiple presences have the same priority, one of them will be arbitrarily chosen.

By changing the priority in your jabber client(s), you can therefore influence where alerts should go.

5.3. Writing plugins

The recommended way to write plugins is to write them in Perl and use the Perl module Kanla::Plugin. This module sets up some useful imports, the signal_error function, configuration parsing and a main timer. The only thing you have to write yourself is a function called run, which will be invoked regularly.

Additionally, if the service you are monitoring works in a banner-like way (e.g. you connect, possibly write some data, then read some data), you can use Kanla::Plugin::Banner. This module establishes a connection when you call banner_connect and takes care of everything: resolving the host, connecting to the resolved addresses, raising errors on timeouts.

For an example of using these modules, check the “git” plugin.

Of course, plugins can be implemented in any language. See the next section for details.

5.4. Plugin interface

Plugins are executable files which run for an indefinite amount of time. When they exit, regardless of their exit status, they will be restarted after 2 seconds.

On stdin, plugins get their configuration. The plugin’s stdout and stderr is not interpreted by kanla.

On file descriptor 3, plugins send alerts, formatted as JSON.

5.4.1. Example configuration input

The configuration for plugins is dumped by Config::General.

Here is the http plugin’s example configuration as sent to the plugin via stdin:

Example configuration input:

plugin   http
family   ipv4
url   http://slashdot.org/

Given that the config is generated by Config::General, it is of course the best idea to use that module to read the configuration, too. However, this is not required and, especially if you are using a different language than Perl, parsing this key/value format using regular expressions should work fine.

5.4.2. Example alert output

Each message is represented by a JSON hash. Currently, only two keys are defined:

severity

The severity of the message. Note that kanla currently ignores this.

message

A free text message which will be sent to the configured send_alerts_to destination. Make this as helpful as possible, but keep it as verbose as necessary.

Example alert JSON output:

{
 "severity": "critical",
 "message": "This will be sent via Jabber"
}
kanla-1.4/docs/installing-rhel.txt0000644000014500017510000000344612125551457016534 0ustar michaelstaffInstalling kanla on Red Hat Enterprise Linux ============================================ Michael Stapelberg March 2013 This document explains how to install kanla on RHEL 6.4. The instructions should also work for any other rpm-based distribution. == Install EPEL Many dependencies of kanla are available for RHEL in the EPEL repository. Visit http://mirror.de.leaseweb.net/epel/6/i386/repoview/epel-release.html and install the epel-release rpm. == Check that kanla is still not available We are working on getting kanla available via EPEL. Despite our best efforts, this document might be outdated, so run +yum search kanla+ before continuing. == Installing dependencies not in EPEL ----------------------------------------------------------------------------------- wget http://kanla.zekjur.net/downloads/rpm/perl-AnyEvent-HTTP-2.15-1.el6.noarch.rpm wget http://kanla.zekjur.net/downloads/rpm/perl-AnyEvent-XMPP-0.54-2.el6.noarch.rpm wget http://kanla.zekjur.net/downloads/rpm/perl-Object-Event-1.23-5.el6.noarch.rpm yum install perl-AnyEvent-XMPP-0.54-2.el6.noarch.rpm yum install perl-Object-Event-1.23-5.el6.noarch.rpm yum install perl-AnyEvent-HTTP-2.15-1.el6.noarch.rpm ----------------------------------------------------------------------------------- You can help by getting these two packages from Fedora to EPEL :-). == Install the kanla RPM --------------------------------------------------------------------- wget http://kanla.zekjur.net/downloads/rpm/kanla-1.2-1.el6.noarch.rpm yum install kanla-1.2-1.el6.noarch.rpm --------------------------------------------------------------------- Note that there currently is no init script in the RPM. If you can provide one, please go ahead. I personally lost motivation after realizing the lack of start-stop-daemon in RHEL. kanla-1.4/docs/contributions.txt0000644000014500017510000000574212161656765016353 0ustar michaelstaffContributing to kanla ===================== Michael Stapelberg March 2013 Thank you for your interest in contributing to kanla. == Ways to contribute 1. Package kanla for your distribution. By creating and/or maintaining a package for your operating system of choice, you are helping kanla and the users of your operating system. We believe that using the existing infrastructure is much better than people installing software from third parties. 2. Send a well-written, detailed bug report. When you notice a bug, chances are that other people ran into it, too, or will run into it in the future. Many people don’t bother to report bugs, though. By sending a good bug report, you are thereby doing all users who are affected by this bug a big favor. 3. Send a documentation fix/improvement. Software is only as useful as its documentation (unless you like reading the source). Since one of kanla’s focus points is good documentation, improvements (making things more clear or easier to understand) and corrections are always very welcome. 4. Send a patch. Of course, as with all FOSS software, we appreciate patches. In case you are fixing a bug, please let others know what bug you are working on by posting a short message in the corresponding bug report. In case you are implementing a feature, please check back with us whether the feature makes sense and fits kanla’s philosophy before you spend any time on it. == Patches === Getting the source Our source code lives in a git repository. The "master" branch (what you get when just cloning the repository) is intended to be always stable and this is where you should develop. You can clone the git repository using +git clone git://github.com/kanla/kanla.git+ === Coding standard To ensure that kanla is formatted in a consistent way, we use perltidy, a program to automatically format Perl source code. To enable a quick and fruitful code review, please use perltidy on your code before submitting your patch. ///////////////////////////////////////////////// TODO: sollen wir diesen hook nutzen? https://github.com/mlawren/githook-perltidy //////////////////////////////////////////////// === Testsuite To ensure that code changes don’t (re-)introduce bugs, we have a testsuite, which you should run periodically while developing (using +make test+). In case you are implementing a new feature, a testcase for this feature is very welcome (but currently not a hard requirement). Be aware though, that unless the feature is very hard to test, it will not be committed without a testcase. This means that when you don’t write a testcase, someone else will have to. So to get your feature merged quickly, it would be best if you could write the testcase. === Sending your changes Please send a pull request on github in order to get your changes merged into the official kanla source tree. //////////////////////////////////////////////////// TODO: mailing liste einrichten /////////////////////////////////////////////////// kanla-1.4/docs/installing-wheezy.html0000644000014500017510000003166212147471421017237 0ustar michaelstaffInstalling kanla on Debian 7.0 wheezy

This document explains how to install kanla on Debian 7.0 wheezy.

Note that Debian 6.0 squeeze does not contain the necessary dependencies, so we do not support it.

In case you would like to use kanla with Debian 7.0 wheezy through wheezy-backports, please file a Debian wishlist bugreport against the kanla package.

The instructions should also work for any other deb-based distribution.

1. Use Debian testing?

In Debian testing, you can just apt-get install kanla

2. Install the kanla deb

In case you cannot use Debian testing, you may follow these steps:

apt-get install gdebi-core
wget http://kanla.zekjur.net/downloads/deb/kanla_1.3-1_all.deb
gdebi kanla_1.3-1_all.deb
kanla-1.4/docs/contributions.html0000644000014500017510000003715512215126030016454 0ustar michaelstaffContributing to kanla

Thank you for your interest in contributing to kanla.

1. Ways to contribute

  1. Package kanla for your distribution. By creating and/or maintaining a package for your operating system of choice, you are helping kanla and the users of your operating system. We believe that using the existing infrastructure is much better than people installing software from third parties.

  2. Send a well-written, detailed bug report. When you notice a bug, chances are that other people ran into it, too, or will run into it in the future. Many people don’t bother to report bugs, though. By sending a good bug report, you are thereby doing all users who are affected by this bug a big favor.

  3. Send a documentation fix/improvement. Software is only as useful as its documentation (unless you like reading the source). Since one of kanla’s focus points is good documentation, improvements (making things more clear or easier to understand) and corrections are always very welcome.

  4. Send a patch. Of course, as with all FOSS software, we appreciate patches. In case you are fixing a bug, please let others know what bug you are working on by posting a short message in the corresponding bug report. In case you are implementing a feature, please check back with us whether the feature makes sense and fits kanla’s philosophy before you spend any time on it.

2. Patches

2.1. Getting the source

Our source code lives in a git repository. The "master" branch (what you get when just cloning the repository) is intended to be always stable and this is where you should develop.

You can clone the git repository using git clone git://github.com/kanla/kanla.git

2.2. Coding standard

To ensure that kanla is formatted in a consistent way, we use perltidy, a program to automatically format Perl source code.

To enable a quick and fruitful code review, please use perltidy on your code before submitting your patch.

2.3. Testsuite

To ensure that code changes don’t (re-)introduce bugs, we have a testsuite, which you should run periodically while developing (using make test).

In case you are implementing a new feature, a testcase for this feature is very welcome (but currently not a hard requirement). Be aware though, that unless the feature is very hard to test, it will not be committed without a testcase. This means that when you don’t write a testcase, someone else will have to. So to get your feature merged quickly, it would be best if you could write the testcase.

2.4. Sending your changes

Please send a pull request on github in order to get your changes merged into the official kanla source tree.

kanla-1.4/docs/userguide.txt0000644000014500017510000005365712204457170015440 0ustar michaelstaffThe kanla User Guide ==================== Michael Stapelberg March 2013 kanla is a daemon which periodically checks whether your website, mail server, etc. are still up and running. In case a health check fails, kanla will notify you via jabber (XMPP). Focus of kanla lies on being light-weight, being simple, using a sane configuration file, being well-documented. == Introduction Many people run personal websites or websites of their pet projects. Except for professional sysadmins, none of those I asked ran any kind of software to notify them about failures. Since nobody disagreed with me about the idea being helpful, this suggests that existing software is too complex, complicated to setup, under-documented or for some other reason undesirable. I myself wanted to be notified -- by software, not by users -- when http://i3wm.org is not reachable anymore. However, the software I looked at could not be configured to verify the actual page contents (as opposed to only the HTTP status) and did not even support IPv6 (come on, it’s 2013). My conclusion was that writing a simple program myself would be faster than trying to re-implement plugins for existing monitoring/alerting software in such a way that I’d be happy with them. kanla is the fruit of this effort. It is intentionally simple and focuses on small-scale alerting. This means it will *NOT* generate uptime statistics, or execute certain actions when some condition is met, or handle pager alerts and on-call schedules. Instead, it verifies what you describe and whenever something is wrong, it sends you a message via jabber (XMPP). === Terminology kanla instance:: A process of the +kanla+ binary, running with precisely one configuration. You can have multiple instances running and each instance usually has several plugins running. plugin:: A small program which verifies that things are good. For example, the "http" plugin retrieves websites and verifies their content. If anything goes wrong you will get an alert. alert:: The message which kanla sends to you when things go wrong. == Installation To install kanla, you should by all means use your distribution’s package management system. It is intentional that there is no instruction for installing from source. If there is no package for your distribution, consider making one. The Debian packaging serves as reference packaging. === Locations kanla itself should be installed as +/usr/bin/kanla+. kanla ships with a number of plugins. To find the plugin location for your system, use: ----------------------------------------------------------------- perl -MFile::ShareDir -E 'say File::ShareDir::dist_dir("kanla")' ----------------------------------------------------------------- Custom plugins can be placed in +/usr/local/share/kanla/+ or +/usr/local/lib/kanla/+, depending on whether they are binary files or scripts. A plugin is just an executable file (implemented in any language, but preferably Perl) which produces output in a certain format on stderr when things go wrong. Plugins are identified by their file name, e.g. "http". Configuration files are placed in +/etc/kanla/+ with the default configuration file being named +default.cfg+. This file -- by default -- includes every +.cfg+ file in +/etc/kanla/default.d/+ which is where you will find example configurations for every plugin. == Configuration The main kanla configuration file is called +/etc/kanla/default.cfg+. It contains the jabber (XMPP) account configuration, the default alert destination (e.g. your jabber id) and includes +/etc/kanla/default.d/*.cfg+. After modifying the jabber (XMPP) account configuration, you need to enable at least one plugin by removing the comment signs (+#+) in front of every line of its configuration file. The provided files serve as a minimum useful example (while this documentation poses a reference) and will not change often so you can modify them without being bothered by config file conflicts on upgrades. It goes without saying that configuration files are encoded as UTF-8 and UTF-8 is supported throughout kanla. [NOTE] SysVinit will not directly report error messages when (re)starting kanla. Ensure kanla is running by checking +service kanla status+ and/or look at +/var/log/kanla.log+ for error messages === Quick example *A minimum useful kanla configuration*: -------------------------------------------------------------------------------- jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = < plugin = http url = "http://www.i3wm.org/" url = "http://i3wm.org/" -------------------------------------------------------------------------------- === Jabber configuration Jabber configuration is done with one (or multiple) jabber block(s). Each block needs to have at least the jid and password attribute. The following attributes can be configured: jid:: The jabber id of this account, e.g. +kanla@example.com+. password:: The password for this account. host:: The hostname of the jabber server to which to connect to. It is normally *NOT* necessary to specify this, but some networks actively break SRV record resolution. port:: The port of the jabber server, if non-standard. *Simple jabber example*: -------------------------------------------------------------------------------- jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" -------------------------------------------------------------------------------- *Complex jabber example*: -------------------------------------------------------------------------------- jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" jid = "kanla@example.net" password = "kV9eJ4LZ9KRYOCec5W2witq" host = "jabber.example.net" port = 5222 -------------------------------------------------------------------------------- There is no default value for this option, therefore *you have to configure this*. [NOTE] kanla will send an http://xmpp.org/extensions/xep-0199.html[XEP-0199] ping to the server every 60 seconds. If the server does not reply within 60 seconds, the connection is considered dead and will be reconnected. === Main configuration ==== send_alerts_to [[send_alerts_to]] A list of jabber ids (line-separated) to which alerts will be sent. This can be overwritten on a per-plugin basis. Please use the heredoc syntax, otherwise extending this list will not work (a limitation of the http://metacpan.org/module/Config::General[Config::General] module). *send_alerts_to example*: -------------------------------------------------------------------------------- send_alerts_to = <>. Using variables, you can also amend instead of overwrite, see <>. interval:: Controls how often the plugin verifies that things are good. This configuration directive is merely a convention, that is, plugins don’t *have to* use it (e.g. in case the plugin needs a more detailed interval configuration), but it is strongly recommended. === Plugin: http The http plugin periodically retrieves the specified URL(s) and sends alerts if the HTTP status is not 200 or anything else went wrong during retrieval. ==== URL The URL of the site to retrieve. This can be anything which the http://metacpan.org/module/AnyEvent::HTTP[AnyEvent::HTTP] module accepts. In addition it allows to embed username and password for HTTP basic access authentication. The http://tools.ietf.org/html/rfc3986#section-3.2[standard URI syntax] is used, e.g. +http://user:pass@www.i3wm.org/+. You can specify this configuration directive multiple times. *Full URL example*: -------------------------------------------------------------------------------- plugin = http url = "http://www.i3wm.org/" -------------------------------------------------------------------------------- There is no default value for this option, therefore *you have to configure this*. You can specify multiple URLs: *Multiple URL example*: -------------------------------------------------------------------------------- plugin = http url = http://www.i3wm.org/ url = http://www.i3-wm.org/ -------------------------------------------------------------------------------- ==== Family [[http-family]] The address family (IPv4, IPv6 or both) which should be used when retrieving the URL(s). The default is to try both IPv4 and IPv6. *Full family example*: -------------------------------------------------------------------------------- plugin = http family = ipv4 | ipv6 url = "http://www.i3wm.org/" plugin = http # slashdot doesn’t even support IPv6… family = ipv4 url = "http://slashdot.org/" -------------------------------------------------------------------------------- [NOTE] The absence of a AAAA DNS record is treated as an error (to catch DNS misconfiguration problems). Therefore, if your site is IPv4-only, you need to explicitly configure that. This is intentional -- it’s 2013, your site should really be dual-stacked by now. ==== Body [[http-body]] You can make kanla verify the page it received via HTTP actually contains expected content. That is, sometimes webservers fail even though they return the HTTP 200 status, for example because a poorly written PHP script could not establish a database connection. You can specify this option multiple times, all specified checks need to pass. You can either specify a http://perldoc.perl.org/perlre.html[Perl regular expression] (e.g. +/foo/+, it *MUST* be enclosed in forward slashes) or a custom verification function (*MUST* start with "sub {"), see the example below. Functions will be called with the full HTTP body string as first argument. This option has no default value, meaning no checks on the body are performed. *Full body example*: -------------------------------------------------------------------------------- plugin = http url = "http://www.i3wm.org/" # Check for the intro text. body = "/tiling window manager/" # Check for version 4.x in the page. body = </ EOT plugin = http url = "http://www.i3wm.org/" # Stupid check for the length of the returned page. # Only good for demonstration purposes. # Note how variables need to be escaped because # otherwise they are interpolated. body = < -------------------------------------------------------------------------------- === Plugin: smtp The smtp plugin periodically connects to an SMTP server and sends alerts if the server does not send the SMTP greeting (220 …) within 20 seconds after connecting or anything else went wrong on the DNS/TCP level. ==== Host The host (may include a port) of the smtp server to check. Every syntax which https://metacpan.org/module/AnyEvent::Socket[AnyEvent::Socket]’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats). You can specify this configuration directive multiple times. *Full Host example*: -------------------------------------------------------------------------------- plugin = smtp host = infra.in.zekjur.net plugin = smtp family = ipv6 host = "[2001:4d88:100e:1::2]:submission" -------------------------------------------------------------------------------- ==== Family See <>. ==== Timeout [[smtp-timeout]] The timeout (in seconds) for each connection attempt (via TCP) and for receiving the greeting. The default value is a timeout 20 seconds. This means it is okay if the TCP connection can be established after 9 seconds and the SMTP greeting is read after another 9 seconds. *Full timeout example*: -------------------------------------------------------------------------------- plugin = smtp # Gee, we could really use some newer hardware. # Until then, cut the server some slack: # Check only every 5 minutes, # wait up to 60 seconds for connections # and for reading the greeting. timeout = 60 interval = 300 host = infra.in.zekjur.net -------------------------------------------------------------------------------- === Plugin: irc The irc plugin periodically logs onto an IRC network and sends alerts if the server does not let you log in properly (it looks for the "001" IRC message) or anything else went wrong on the DNS/TCP level. ==== ircd The host (may include a port) of the IRC server to check. Every syntax which https://metacpan.org/module/AnyEvent::Socket[AnyEvent::Socket]’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats). *Full ircd example*: -------------------------------------------------------------------------------- plugin = irc ircd = irc.twice-irc.de -------------------------------------------------------------------------------- ==== Family See <>. ==== Timeout See <>. === Plugin: git The git plugin periodically checks whether the specified git URL works correctly (by receiving the current HEAD revision) and sends alerts if anything comes back which does not look like a git HEAD revision or anything else went wrong on the DNS/TCP level. ==== url A git URL of the git-daemon to check. Every syntax which https://metacpan.org/module/AnyEvent::Socket[AnyEvent::Socket]’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats). *Full url example*: -------------------------------------------------------------------------------- plugin = git url = git://code.i3wm.org/i3 -------------------------------------------------------------------------------- ==== Family See <>. ==== Timeout See <>. === Plugin: redis The redis plugin periodically connects to a redis server and sends alerts if the server does not respond to a PING command (with `+PONG`) or anything else went wrong on the DNS/TCP level. ==== Host The host (may include a port) of the redis server to check. Every syntax which https://metacpan.org/module/AnyEvent::Socket[AnyEvent::Socket]’s parse_hostport function understands is accepted (this covers all common IPv4 and IPv6 formats). You can specify this configuration directive multiple times. *Full Host example*: -------------------------------------------------------------------------------- plugin = redis host = localhost:6379 -------------------------------------------------------------------------------- ==== Family See <>. Make sure to use `family = ipv4` here as long as redis does not support IPv6. == Config recipes === Variables [[variables]] When configuring many hosts which are alike, variables might come in handy. kanla enables http://metacpan.org/module/Config::General::Interpolated[Config::General::Interpolated], so you can use variables by refering to configuration directives with a dollar sign prefixed, e.g. +$send_alerts_to+ evaluates to the contents of the send_alerts_to directive. You are not confined to the directives which actually exist, but you can use any key/value pair you want. To avoid troubles, you should prefix your own directives with an underscore. kanla will never implement directives starting with an underscore. *Amending send_alerts_to*: -------------------------------------------------------------------------------- # michael@example.com gets ALL the alerts! send_alerts_to = < plugin = http url = "http://www.i3wm.org/" # Additionally, alert stefan@example.com. send_alerts_to = < -------------------------------------------------------------------------------- *Monitor multiple trac instances* (+/etc/kanla/default.cfg+): -------------------------------------------------------------------------------- _trac_url = "bugs.i3wm.org" include "default.d/http-trac.cfg" _trac_url = "trac.edgewall.org" include "default.d/http-trac.cfg" -------------------------------------------------------------------------------- *Monitor multiple trac instances* (+/etc/kanla/default.d/http-trac.cfg+): -------------------------------------------------------------------------------- plugin = http url = $_trac_url # TODO: content matching -------------------------------------------------------------------------------- == Technical details === Message receipts kanla supports jabber’s http://xmpp.org/extensions/xep-0184.html[XEP-0184] message receipts. With message receipts, delivery of a message is confirmed end-to-end, that is, kanla can be sure your device received its message. More importantly, when your device does not confirm the message, kanla will retry (after 30 seconds) to send the message, until your device confirms the message. You will immediately notice this feature when you configure multiple jabber accounts. In that case, kanla will try to deliver alerts using one jabber account first, and if that fails, it retries with the second one. In case you have more than two accounts, this is repeated until your device confirmed the message or there are no accounts left. For +send_alerts_to+ destinations which do not support XEP-0184, kanla will immediately send alerts from all jabber accounts. This leads to a storm of alerts on your device, but this is intended to keep things simple. Lobby your jabber client vendor to implement XEP-0184, it’s simple enough. === Jabber presences Let’s assume you configure +michael@example.com+ via +send_alerts_to+ and you are connected as +michael@example.com+ on your computer and on your smartphone. Jabber calls each of these connections a presence. When sending an alert to +michael@example.com+, kanla will chose the presence with the highest priority. In case multiple presences have the same priority, one of them will be arbitrarily chosen. By changing the priority in your jabber client(s), you can therefore influence where alerts should go. === Writing plugins The recommended way to write plugins is to write them in Perl and use the Perl module +Kanla::Plugin+. This module sets up some useful imports, the signal_error function, configuration parsing and a main timer. The only thing you have to write yourself is a function called +run+, which will be invoked regularly. Additionally, if the service you are monitoring works in a banner-like way (e.g. you connect, possibly write some data, then read some data), you can use +Kanla::Plugin::Banner+. This module establishes a connection when you call +banner_connect+ and takes care of everything: resolving the host, connecting to the resolved addresses, raising errors on timeouts. For an example of using these modules, check the “git” plugin. Of course, plugins can be implemented in any language. See the next section for details. === Plugin interface Plugins are executable files which run for an indefinite amount of time. When they exit, regardless of their exit status, they will be restarted after 2 seconds. On stdin, plugins get their configuration. The plugin’s stdout and stderr is not interpreted by kanla. On file descriptor 3, plugins send alerts, formatted as JSON. ==== Example configuration input The configuration for plugins is dumped by +Config::General+. Here is the http plugin’s example configuration as sent to the plugin via stdin: *Example configuration input*: ------------------------------------------- plugin http family ipv4 url http://slashdot.org/ ------------------------------------------- Given that the config is generated by +Config::General+, it is of course the best idea to use that module to read the configuration, too. However, this is not required and, especially if you are using a different language than Perl, parsing this key/value format using regular expressions should work fine. ==== Example alert output Each message is represented by a JSON hash. Currently, only two keys are defined: severity:: The severity of the message. Note that kanla currently ignores this. message:: A free text message which will be sent to the configured send_alerts_to destination. Make this as helpful as possible, but keep it as verbose as necessary. *Example alert JSON output*: ------------------------------------------- { "severity": "critical", "message": "This will be sent via Jabber" } ------------------------------------------- kanla-1.4/docs/installing-wheezy.txt0000644000014500017510000000166112147471367017117 0ustar michaelstaffInstalling kanla on Debian 7.0 wheezy ===================================== Michael Stapelberg May 2013 This document explains how to install kanla on Debian 7.0 wheezy. Note that Debian 6.0 squeeze does not contain the necessary dependencies, so we do not support it. In case you would like to use kanla with Debian 7.0 wheezy through wheezy-backports, please file a Debian wishlist bugreport against the kanla package. The instructions should also work for any other deb-based distribution. == Use Debian testing? In Debian testing, you can just +apt-get install kanla+ == Install the kanla deb In case you cannot use Debian testing, you may follow these steps: -------------------------------------------------------------- apt-get install gdebi-core wget http://kanla.zekjur.net/downloads/deb/kanla_1.3-1_all.deb gdebi kanla_1.3-1_all.deb -------------------------------------------------------------- kanla-1.4/lib/0000755000014500017510000000000012232511602012471 5ustar michaelstaffkanla-1.4/lib/Kanla/0000755000014500017510000000000012232511602013517 5ustar michaelstaffkanla-1.4/lib/Kanla/Plugin.pm0000644000014500017510000000617212232511305015321 0ustar michaelstaff# -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- # vim:ts=4:sw=4:expandtab package Kanla::Plugin; use strict; use warnings; use utf8; use v5.10; # libanyevent-perl use AnyEvent; # libconfig-general-perl use Config::General; # libjson-xs-perl use JSON::XS; # core use IO::Handle; use Exporter (); our @EXPORT = qw( signal_error $conf ); our $conf; # see http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/ our $VERSION = "1.4"; $VERSION = eval $VERSION; # This will be set to a true value # after initialization is complete, # so that multiple callers can # "use Kanla::Plugin" # and all of them actually work :). # (We do read STDIN for example, # which can only be done once.) my $initialized; my $errorfh; my $main_timer; sub signal_error { my ($severity, $message) = @_; say $errorfh encode_json({ severity => $severity, message => $message }); } sub import { my ($class, %args) = @_; say "kanla::plugin import"; say "second!" if (defined($conf)); my $pkg = caller; # Enable 5.10 features, # strict, # warnings, # utf8 # for the caller. feature->import(":5.10"); strict->import; warnings->import; utf8->import; # Setup the error fd if (!$initialized) { $errorfh = IO::Handle->new_from_fd(3, 'w'); $errorfh->autoflush(1); # Parse the configuration my $config_str; { local $/; $config_str = ; } do { $conf = Config::General->new( -String => $config_str, # open all files in utf-8 mode -UTF8 => 1, # normalize yes, on, 1, true and no, off, 0, false to 1 resp. 0 -AutoTrue => 1, # case-insensitive key names by lowercasing everything -LowerCaseNames => 1, # provide the ->array, ->hash, etc. methods -ExtendedAccess => 1, -FlagBits => { family => { ipv4 => 1, ipv6 => 1, }, }, ); if (!$conf->exists('family')) { $config_str .= <<'EOT'; family = ipv4 | ipv6 EOT } } until ($conf->exists('family')); # TODO: parse interval from config my $interval = 60; # Periodically run the check, but don’t wait for the first $interval seconds to # pass, but run it right now, too. my $run; $run = sub { # XXX ->can also resolves in @ISA die 'plugins must implement "sub run"' unless $run = $pkg->can("run"); goto $run; }; $main_timer = AnyEvent->timer( after => 0, interval => $interval, cb => $run, ); $initialized = 1; } @_ = ($class); goto \&Exporter::import; } END { AnyEvent->condvar->recv; } 1 kanla-1.4/lib/Kanla/Plugin/0000755000014500017510000000000012232511602014755 5ustar michaelstaffkanla-1.4/lib/Kanla/Plugin/Banner.pm0000644000014500017510000001350712232511314016526 0ustar michaelstaff# -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- # vim:ts=4:sw=4:expandtab package Kanla::Plugin::Banner; use strict; use warnings; use utf8; use v5.10; use Kanla::Plugin; # libanyevent-perl use AnyEvent; use AnyEvent::Handle; use AnyEvent::Socket; use Socket qw(SOCK_STREAM); use Exporter qw(import); our @EXPORT = qw( banner_connect banner_disconnect ); # see http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/ our $VERSION = "1.4"; $VERSION = eval $VERSION; # Filled in banner_connect(). my $timeout = 0; =head1 NAME Kanla::Plugin::Banner - Useful functions for banner-based plugins =head1 SYNOPSIS use Kanla::Plugin; use Kanla::Plugin::Banner; sub run { banner_connect( host => 'irc.twice-irc.de', default_service => 'ircd', cb => sub { my ($handle, $timeout) = @_; $handle->push_write("NICK kanla\r\n"); $handle->push_write("USER kanla kanla kanla :kanla\r\n"); my @read_line; @read_line = ( line => sub { my ($handle, $line) = @_; if ($line !~ /^:[^ ]+ 001 /) { $handle->push_read(@read_line); return; } # We successfully signed on. undef $timeout; $handle->push_write("QUIT\r\n"); banner_disconnect($handle); }); $handle->push_read(@read_line); }); } =head1 METHODS =cut sub _banner_connect { my ($ip, $service, $cb) = @_; tcp_connect $ip, $service, sub { my ($fh) = @_; if (!$fh) { signal_error( 'critical', "Connecting to $ip on port $service failed: $!" ); return; } my $t; $t = AnyEvent->timer( after => $timeout, cb => sub { signal_error( 'critical', # XXX: It is unfortunate that this # error message is so sparse. # we should refactor the code to # allow for better errors here. "Timeout ($timeout s) on [$ip]:$service" ); }); my $handle; # avoid direct assignment so on_eof has it in scope. $handle = AnyEvent::Handle->new( fh => $fh, on_error => sub { signal_error( 'critical', "TCP read error on [$ip]:$service: " . $_[2]); undef $t; $_[0]->destroy; }, on_eof => sub { $handle->destroy; # destroy handle signal_error( 'critical', "TCP EOF on [$ip]:$service" ); undef $t; }); $cb->($handle, $t, $ip, $service); }; } =head2 banner_connect Connects to the given address (parsed by C's parse_hostport) using the configured address families. The caller provides a callback, which will be called after the connection was established. In case there was an error (DNS name could not be resolved, connection was refused/timed out, etc.), the callback will B be called, but an alert will be signaled. The callback will be called with an C and an C timer (timeouts). The timeout is initialized to the configured value (plugin configuration) or 20s if left unconfigured. This example connects to one of Google's SMTP servers and waits for the SMTP greeting. It does not resolve MX records, but that's not the point of the example: banner_connect( host => 'aspmx.l.google.com', default_service => 'smtp', cb => sub { my ($handle, $timeout) = @_; $handle->push_read(line => sub { my ($handle, $line) = @_; undef $timeout; if ($line !~ /^220 /) { signal_error('critical', 'Invalid greeting'); } }); }); =cut sub banner_connect { my %args = @_; $timeout = ($conf->exists('timeout') ? $conf->value('timeout') : 20); # Ensure timeout is an int and > 0. $timeout += 0; $timeout ||= 1; my ($host, $service) = parse_hostport($args{'host'}, $args{'default_service'}); my $resolved_cb = sub { # family is either A or AAAA my $family = shift; if (@_ == 0) { signal_error( 'critical', "Cannot resolve $args{'host'} ($family) DNS record" ); return; } for my $record (@_) { my ($service, $host) = AnyEvent::Socket::unpack_sockaddr($record->[3]); _banner_connect(format_address($host), $service, $args{'cb'}); } }; if ($conf->obj('family')->value('ipv4')) { AnyEvent::Socket::resolve_sockaddr( $host, $service, "tcp", 4, SOCK_STREAM, sub { $resolved_cb->('A', @_) }); } if ($conf->obj('family')->value('ipv6')) { AnyEvent::Socket::resolve_sockaddr( $host, $service, "tcp", 6, SOCK_STREAM, sub { $resolved_cb->('AAAA', @_) }); } } =head2 banner_disconnect($handle) Properly disconnects the specified C. =cut sub banner_disconnect { my ($handle) = @_; $handle->on_drain( sub { shutdown $handle->{fh}, 1; $handle->destroy; undef $handle; }); } 1 kanla-1.4/lib/Kanla.pm0000644000014500017510000003645412232511273014075 0ustar michaelstaff# -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- package Kanla; use strict; use warnings; use utf8; use v5.10; # libanyevent-xmpp-perl use AnyEvent::XMPP::Client; use AnyEvent::XMPP::Ext::Disco; use AnyEvent::XMPP::Ext::Ping; use AnyEvent::XMPP::Ext::VCard; use AnyEvent::XMPP::Ext::Version; # ::Receipts was added in AnyEvent::XMPP 0.54. # kanla works fine without, # but it’s nice to have. # Therefore, load it and fall back if that fails. my $use_receipts = eval { require AnyEvent::XMPP::Ext::Receipts; AnyEvent::XMPP::Ext::Receipts->import(); 1; }; # libfile-sharedir-perl use File::ShareDir qw(dist_dir); # libanyevent-perl use AnyEvent; use AnyEvent::Util; use AnyEvent::Handle; # libconfig-general-perl use Config::General; # libjson-xs-perl use JSON::XS; # core use Cwd qw(abs_path); use Carp; use Data::Dumper; use File::Basename qw(basename); # see http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/ our $VERSION = "1.4"; $VERSION = eval $VERSION; binmode STDOUT, ':utf8'; binmode STDERR, ':utf8'; my $conf; my $xmpp; # Messages which were produced while no XMPP connection was established (yet). # They will be sent when a connection is established. my @queued_messages; # Returns the path # to the specified plugin # by first checking dist_dir('kanla'), # then 'plugins/', # just like the configuration # is searched in /etc/kanla, # then in '.'. sub plugin_path { my ($plugin) = @_; # The custom plugin dir # takes precedence. for my $dir (qw(share lib)) { my $path = "/usr/local/$dir/kanla/$plugin"; return $path if -e $path; } my $dist_dir; # We eval because # dist_dir dies # when the dir does not exist. eval { $dist_dir = dist_dir('kanla'); }; if (defined($dist_dir)) { return "$dist_dir/$plugin" if -e "$dist_dir/$plugin"; } # NB: This does not imply # that the plugin exists. return "plugins/$plugin"; } sub start_plugin { my ($plugin, $name) = @_; # Save the config for this plugin to string, # we will feed it to the plugin via stdin below. my $config = $conf->obj('monitor')->obj($name); my $config_str = $config->save_string(); my @dest; if ($config->exists('send_alerts_to')) { @dest = split("\n", $config->value('send_alerts_to')); } else { @dest = split("\n", $conf->value('send_alerts_to')); } say qq|[$plugin/instance "$name"] starting…|; my ($pr, $pw) = AnyEvent::Util::portable_pipe; fcntl($pr, AnyEvent::F_SETFD, AnyEvent::FD_CLOEXEC); my $w; $w = AnyEvent::Handle->new( fh => $pr, on_error => sub { my ($hdl, $fatal, $msg) = @_; say STDERR qq|[$plugin/instance "$name"] error reading from stderr: $msg|; # Restart the plugin, # so that you can just kill plugins # after changing their code. # # The delay of 2 seconds avoids # spamming the user with errors # when a plugin exits immediately. my $t; $t = AnyEvent->timer( after => 2, cb => sub { start_plugin($plugin, $name); undef $t; }); $w->destroy; }); my @start_request; @start_request = ( json => sub { my ($hdl, $hashref) = @_; handle_stderr_msg(basename($plugin), \@dest, $hashref); $hdl->push_read(@start_request); }); $w->push_read(@start_request); my $cv = run_cmd [ plugin_path($plugin) ], # feed the config on stdin '<', \$config_str, # stdout goes to /dev/null for now. '>', '/dev/null', # TODO: proxy stderr into our log so that one can easily spot plugin failures '3>', $pw; $cv->cb( sub { my $status = shift->recv; say STDERR qq|[$plugin/instance "$name"] exited with exit code $status|; }); } sub xmpp_empty_queue { my @leftover; for my $entry (@queued_messages) { my ($jid, $message) = @$entry; # Find the account, # if unsuccessful, # no account # is connected. my $account = $xmpp->find_account_for_dest_jid($jid); if (!defined($account) || !defined($account->connection)) { push @leftover, $entry; next; } my $presence = $xmpp->get_priority_presence_for_jid($jid); if (!defined($presence)) { say "[XMPP] No presence found for $jid, skipping"; push @leftover, $entry; next; } # NB: We cannot use $xmpp->send_message here because # that will make the JID a bare JID and use its own # conversation tracking technique. $account->connection->send_message( $presence->jid, 'chat', undef, body => $message ); } @queued_messages = @leftover; } sub handle_stderr_msg { my ($module, $dest, $data) = @_; if (!exists($data->{severity}) || !exists($data->{message})) { say STDERR "Malformed JSON output from module $module (missing severity or messages property)."; return; } if ($data->{severity} eq 'critical') { say "relaying: " . $data->{message}; for my $jid (@$dest) { push @queued_messages, [ $jid, $data->{message} ]; } xmpp_empty_queue(); } } sub run { my %args = @_; $args{configfile} //= 'default.cfg'; $conf = Config::General->new( # XXX: Not sure if '.' is a good idea. It makes development easier. -ConfigPath => [ '/etc/kanla', '.' ], -ConfigFile => $args{configfile}, # open all files in utf-8 mode -UTF8 => 1, # normalize yes, on, 1, true and no, off, 0, false to 1 resp. 0 -AutoTrue => 1, # case-insensitive key names by lowercasing everything -LowerCaseNames => 1, # include files relative to the location -IncludeRelative => 1, # allow glob patterns in include statements -IncludeGlob => 1, # allow including the same file multiple times, # since we might have different variables set. -IncludeAgain => 1, # allow "include " -UseApacheInclude => 1, # provide the ->array, ->hash, etc. methods -ExtendedAccess => 1, # interpolate config options when referred to as $foobar -InterPolateVars => 1, ); say 'FYI: Configuration was read from the following files:'; say ' ' . abs_path($_) for $conf->files; # sanity check: are there any plugins configured? if (!defined($conf->keys('monitor')) || scalar $conf->keys('monitor') == 0) { say STDERR 'Your configuration does not contain any blocks.'; say STDERR 'Without these blocks, running this program does not make sense.'; exit 1; } # also: are there any jabber accounts configured? if (!$conf->exists('jabber')) { say STDERR 'Your configuration does not contain any blocks.'; say STDERR 'Without these blocks, running this program does not make sense.'; exit 1; } # Collect all jabber IDs # to add them to our roster # and allow subscription requests. my @all_jids; my $sat_global; if ($conf->exists('send_alerts_to')) { # Remember that there is a global send_alerts_to directive, # so that we can throw errors # when a module does not have its own # and there is no global send_alerts_to. $sat_global = 1; @all_jids = (@all_jids, split("\n", $conf->value('send_alerts_to'))); } my $plugin_cfgs = $conf->obj('monitor'); for my $name ($conf->keys('monitor')) { my $plugin_cfg = $plugin_cfgs->obj($name); if (ref $plugin_cfg eq 'ARRAY') { say STDERR "ERROR: You have two blocks with name “$name”."; say STDERR "ERROR: This is not supported. Please rename one of the blocks."; exit 1; } if (!$plugin_cfg->exists('send_alerts_to')) { if (!$sat_global) { say STDERR "The block is missing the send_alerts_to directive"; exit 1; } next; } @all_jids = (@all_jids, split("\n", $plugin_cfg->value('send_alerts_to'))); } # An AnyEvent->timer which will send @queued_messages. We need that because we # need to wait for presence updates to finish before we can determine an # inidividual user’s presence with the highest priority. While it would be # easier to send to a bare JID, we also need full JIDs for message receipts. my $queued_timer; $xmpp = AnyEvent::XMPP::Client->new(); my @accounts; if (!$conf->is_array('jabber')) { @accounts = ({ $conf->hash('jabber') }); } else { @accounts = $conf->array('jabber'); } for my $account (@accounts) { $xmpp->add_account( $account->{jid}, $account->{password}, $account->{host}, $account->{port}, { initial_presence => undef }); } my $ping = AnyEvent::XMPP::Ext::Ping->new(); $xmpp->add_extension($ping); # Sends a ping request every 60 seconds. If the server does not respond within # another 60 seconds, reconnect. $ping->auto_timeout(60); # We are a good jabber citizen and mark this client as a bot. my $disco = AnyEvent::XMPP::Ext::Disco->new(); $xmpp->add_extension($disco); $disco->set_identity('client', 'bot'); # Advertise VCard support for a nice real name plus an avatar later. my $vcard = AnyEvent::XMPP::Ext::VCard->new(); $disco->enable_feature($vcard->disco_feature); my $version = AnyEvent::XMPP::Ext::Version->new(); $version->set_name("kanla"); $version->set_version("0.1"); $version->set_os("Linux"); $xmpp->add_extension($version); $disco->enable_feature($version->disco_feature); if ($use_receipts) { my $receipts = AnyEvent::XMPP::Ext::Receipts->new(disco => $disco, debug => 1); $xmpp->add_extension($receipts); } else { say STDERR "WARNING: XEP-0184 message receipts are not available because AnyEvent::XMPP is too old."; } $xmpp->set_presence(undef, 'okay (17:32:00, 2012-10-09)', 11); $xmpp->reg_cb( stream_ready => sub { my ($cl, $account) = @_; $vcard->hook_on($account->connection(), 1); }, connected => sub { my ($self, $account) = @_; say "connected, adding contacts"; # TODO: vcard avatar should be our logo as soon as we got one :) $vcard->store( $account->connection(), { NICKNAME => 'kanla', FN => 'kanla', }, sub { my ($error) = @_; if ($error) { say "[XMPP] VCard upload failed: " . $error->string; } }); for my $jid (@all_jids) { $account->connection()->get_roster()->new_contact( $jid, undef, undef, sub { my ($contact, $err) = @_; if (defined($contact)) { say "Added $jid, sending presence subscription"; $contact->send_subscribe(); } else { say "Error adding $jid: $err"; } }); } }, presence_update => sub { my ($cl, $account, $roster, $contact, $old_presence, $new_presence) = @_; return if defined($queued_timer); $queued_timer = AnyEvent->timer( # We wait 5 seconds for the presence updates to trickle in. On very # slow uplinks, that might be too short, but then again, monitoring # will likely not work very well anyways in that situation. after => 5, cb => sub { xmpp_empty_queue(); undef $queued_timer; }); }, contact_request_subscribe => sub { my ($cl, $acc, $roster, $contact) = @_; # Ignore subscription requests from people who are not in # @all_jids. return unless (scalar grep { $_ eq $contact->jid } @all_jids) > 0; # Acknowledge everything else. say "Acknowledging subscription request from " . $contact->jid; $contact->send_subscribed; $contact->send_subscribe; }, disconnect => sub { my ($self, $account, $host, $port, $message) = @_; say "[XMPP] Disconnected: $message"; # Try to reconnect, if necessary. $xmpp->update_connections(); }, error => sub { my ($self, $account, $error) = @_; # TODO: we might want to handle presence errors in a special way. # in case of a 404 they probably mean the user has a typo in his jid. say "[XMPP] Error: " . $error->string(); # Try to reconnect, if necessary. $xmpp->update_connections(); }, ); $xmpp->start; # Start all the monitoring modules, # read their stderr, relay errors to XMPP. for my $name ($conf->keys('monitor')) { my $plugin_cfg = $plugin_cfgs->obj($name); my $plugin = $plugin_cfg->value('plugin'); # TODO: handle send_alerts_to per plugin if (!defined($plugin) || $plugin eq '') { say STDERR qq|Invalid block: 'plugin' not specified for "$name"|; next; } my $path = plugin_path($plugin); if (!-e $path) { say STDERR qq|Invalid block: plugin "$plugin" not found|; next; } if (!-X $path) { say STDERR qq|Invalid block: plugin "$plugin" not executable (try chmod +x?)|; next; } start_plugin($plugin, $name); } } 1 __END__ =encoding utf-8 =head1 NAME kanla - small-scale alerting daemon =head1 DESCRIPTION kanla is a daemon which peridiocally checks whether your website, mail server, etc. are still up and running. In case a health check fails, kanla will notify you via jabber (XMPP). Focus of kanla lies on being light-weight, being simple, using a sane configuration file, being well-documented. =head1 DOCUMENTATION kanla's documentation can be found at http://kanla.zekjur.net/docs/ We have decided to use asciidoc for kanla, and to not maintain both POD and asciidoc, the POD documentation is intentionally sparse. =head1 VERSION Version 1.4 =head1 AUTHOR Michael Stapelberg, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2012-2013 Michael Stapelberg. This program is free software; you can redistribute it and/or modify it under the terms of the BSD license. =cut # vim:ts=4:sw=4:expandtab kanla-1.4/LICENSE0000644000014500017510000000273612057632527012757 0ustar michaelstaffCopyright © 2012, Michael Stapelberg and contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Michael Stapelberg nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY Michael Stapelberg ''AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Michael Stapelberg BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. kanla-1.4/.perltidyrc0000644000014500017510000000007312060736116014115 0ustar michaelstaff-pt=2 -ci=4 -i=4 -nolc -ce -sot -sct -baao -bar -boc -nbbc kanla-1.4/t/0000755000014500017510000000000012232511602012166 5ustar michaelstaffkanla-1.4/t/001-load.t0000644000014500017510000000012112042773403013572 0ustar michaelstaff#!perl use Test::More; use strict; use warnings; use_ok 'Kanla'; done_testing; kanla-1.4/t/002-plugin-api.t0000644000014500017510000000403112122077023014717 0ustar michaelstaff#!perl # vim:ts=4:sw=4:expandtab # core use Test::More; use File::Temp qw(tempfile); use IO::Handle; use POSIX qw(setsid); # libtest-mockmodule-perl use Test::MockModule; use strict; use warnings; use AnyEvent::XMPP; use Kanla; setsid(); # Provide a configuration file my ($fh, $filename) = tempfile(UNLINK => 1); $fh->autoflush(1); binmode($fh, ':utf8'); say $fh <<'EOT'; # kanla testcase config file jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = "testJID@example.com" plugin = fail EOT Kanla::run(configfile => $filename); my $cv = AnyEvent->condvar; # Mock a lot of AnyEvent::XMPP modules # to ensure that messages from plugins # are actually sent over the wire # (in case we had a proper account configured). my $mock_conn = Test::MockModule->new('AnyEvent::XMPP::Connection'); $mock_conn->mock('send_message', sub { my ($self, $jid, $type, $unused, %args) = @_; is($args{body}, 'Hello, this is the "fail" plugin. If you read this message, your setup seems to be working :-).', 'message relayed untouched'); # Terminate this test successfully $cv->send(1) }); my $conn = AnyEvent::XMPP::Connection->new(); my $mock_account = Test::MockModule->new('AnyEvent::XMPP::IM::Account'); $mock_account->mock('connection', sub { $conn }); my $account = AnyEvent::XMPP::IM::Account->new(); my $mock_presence = Test::MockModule->new('AnyEvent::XMPP::IM::Presence'); $mock_presence->mock('jid', sub { 'michael@stapelberg.de' }); my $mock_xmpp = Test::MockModule->new('AnyEvent::XMPP::Client'); $mock_xmpp->mock('find_account_for_dest_jid', sub { $account }); $mock_xmpp->mock('get_priority_presence_for_jid', sub { AnyEvent::XMPP::IM::Presence->new() }); # Timeout this test after 1s my $timeout = AnyEvent->timer(after => 1, cb => sub { $cv->send() }); my $retval = $cv->recv; ok($retval, 'mocked send_message was called'); done_testing; # Kill all child processes, # otherwise a 'prove' process hangs. $SIG{TERM} = sub { }; kill('TERM', 0); kanla-1.4/t/003-send-alerts-to.t0000644000014500017510000001135712217422022015523 0ustar michaelstaff#!perl # vim:ts=4:sw=4:expandtab # core use Test::More; use File::Temp qw(tempfile); use IO::Handle; use POSIX qw(setsid); # libtest-mockmodule-perl use Test::MockModule; use strict; use warnings; use AnyEvent::XMPP; use Kanla; setsid(); sub test_send_alerts_to { my ($config, $expected) = @_; my $num_jids = scalar @$expected; # Provide a configuration file my ($fh, $filename) = tempfile(UNLINK => 1); $fh->autoflush(1); binmode($fh, ':utf8'); say $fh $config; Kanla::run(configfile => $filename); my $cv = AnyEvent->condvar; # Mock a lot of AnyEvent::XMPP modules # to ensure that messages from plugins # are actually sent over the wire # (in case we had a proper account configured). my $mock_conn = Test::MockModule->new('AnyEvent::XMPP::Connection'); $mock_conn->mock( 'send_message', sub { my ($self, $jid, $type, $unused, %args) = @_; ok((scalar grep { $_ eq $jid } @$expected) > 0, 'JID expected'); @$expected = grep { $_ ne $jid } @$expected; is( $args{body}, 'Hello, this is the "fail" plugin. If you read this message, your setup seems to be working :-).', 'message relayed untouched' ); # Terminate this test successfully, # if @$expected is empty now # (meaning all JIDs were messaged). $cv->send(scalar @$expected == 0); }); my $conn = AnyEvent::XMPP::Connection->new(); my $mock_account = Test::MockModule->new('AnyEvent::XMPP::IM::Account'); $mock_account->mock('connection', sub { $conn }); my $account = AnyEvent::XMPP::IM::Account->new(); my $mockjid; my $mock_presence = Test::MockModule->new('AnyEvent::XMPP::IM::Presence'); $mock_presence->mock('jid', sub { $mockjid }); my $mock_xmpp = Test::MockModule->new('AnyEvent::XMPP::Client'); $mock_xmpp->mock('find_account_for_dest_jid', sub { $account }); $mock_xmpp->mock( 'get_priority_presence_for_jid', sub { my ($self, $jid) = @_; $mockjid = $jid; AnyEvent::XMPP::IM::Presence->new(); }); # Timeout this test after 1s my $timeout = AnyEvent->timer(after => 1, cb => sub { $cv->send(1) }); for (1 .. $num_jids) { last if ($cv->recv); } } ################################################################################ # First test with send_alerts_to on global scope ################################################################################ my $config = <<'EOCONF'; # kanla testcase config file jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = "testJID@example.com" plugin = fail EOCONF test_send_alerts_to($config, ['testJID@example.com']); ################################################################################ # Then test with send_alerts_to overwritten # on module level ################################################################################ $config = <<'EOCONF'; # kanla testcase config file jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = "testJID@example.com" send_alerts_to = "overwritten@example.com" plugin = fail EOCONF test_send_alerts_to($config, ['overwritten@example.com']); ################################################################################ # Test with multiple destination JIDs ################################################################################ $config = <<'EOCONF'; # kanla testcase config file jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = < plugin = fail EOCONF test_send_alerts_to( $config, [ 'testJID@example.com', 'test2@example.com', ]); ################################################################################ # Test with amended multiple JIDs ################################################################################ $config = <<'EOCONF'; # kanla testcase config file jid = "kanla@example.com" password = "kV9eJ4LZ9KRYOCec5W2witq" send_alerts_to = < send_alerts_to = < EOCONF test_send_alerts_to( $config, [ 'testJID@example.com', 'test2@example.com', 'amended@example.com', ]); done_testing; # Kill all child processes, # otherwise a 'prove' process hangs. $SIG{TERM} = sub { }; kill('TERM', 0); kanla-1.4/t/005-http.t0000644000014500017510000002430412204457170013647 0ustar michaelstaff#!perl # vim:ts=4:sw=4:expandtab # core use Test::More; use Test::Deep; use File::Temp qw(tempfile); use IO::Handle; use POSIX qw(setsid); use Data::Dumper; use strict; use warnings; use utf8; use Kanla; # libanyevent-perl use AnyEvent; use AnyEvent::Util; use AnyEvent::Socket; setsid(); # This is a simplified version of Kanla.pm’s start_plugin. sub test_plugin { my ($plugin, $config, $num_msgs, $expected) = @_; my ($pr, $pw) = AnyEvent::Util::portable_pipe; fcntl($pr, AnyEvent::F_SETFD, AnyEvent::FD_CLOEXEC); my $w; $w = AnyEvent::Handle->new( fh => $pr, on_error => sub { my ($hdl, $fatal, $msg) = @_; diag("error reading from stderr: $msg"); $w->destroy; }); my @messages; my $test_cv = AnyEvent->condvar; my @start_request; @start_request = ( json => sub { my ($hdl, $hashref) = @_; push @messages, $hashref; if (scalar @messages == $num_msgs) { $test_cv->send(1); } $hdl->push_read(@start_request); }); $w->push_read(@start_request); my $cv = run_cmd ["plugins/$plugin"], # feed the config on stdin '<', \$config, # stdout goes to /dev/null for now. '>', '/dev/null', # TODO: proxy stderr into our log so that one can easily spot plugin failures '3>', $pw; $cv->cb( sub { my $status = shift->recv; diag("exited with exit code $status"); $test_cv->send(0); }); # Timeout this test after 2s, # plugins have a timeout of 1s. my $timeout = AnyEvent->timer( after => 2, cb => sub { diag('plugin timeout (2s)'); $test_cv->send(0); }); $test_cv->recv; cmp_deeply(\@messages, $expected, 'plugin messages match expectation'); } sub serve { my ($content) = @_; my $host; tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; syswrite( $fh, $content, ); close($fh); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); return $host; } sub serve_and_close_connections { my $host; tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; shutdown($fh, 2); close($fh); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); return $host; } sub serve_with_basic_authentication { my $host; tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; my $handle; $handle = AnyEvent::Handle->new( fh => $fh, on_eof => sub { $handle->destroy; }); $handle->push_read( line => "\015\012\015\012", sub { my ($handle, $headers) = @_; # i.e. ilove:kanla if ($headers =~ /Authorization: Basic aWxvdmU6a2FubGE=/) { $handle->push_write( "HTTP/1.0 200 OK\r\nContent-Length: 16\r\n\r\nYes, yes you do." ); } else { $handle->push_write( "HTTP/1.0 401 Unauthorized\r\nContent-Length: 19\r\n\r\nYou are not worthy." ); } }); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); return $host; } my $check_ipv4_unauthorized = { 'severity' => 'critical', 'message' => re(qr#^HTTP reply 401 for http://localhost:[0-9]+ \(127.0.0.1\)#), }; my $check_ipv4_fail = { 'severity' => 'critical', 'message' => re(qr#^HTTP reply 59\d for http://localhost:[0-9]+ \(127.0.0.1\)#), }; my $check_ipv6_fail = { 'severity' => 'critical', 'message' => re(qr#^HTTP reply 59\d for http://localhost:[0-9]+ \(::1\)#), }; ################################################################################ # Bind to a port, # but immediately close incoming connections. # Verify that the plugin fails # with the appropriate message. ################################################################################ my $host = serve_and_close_connections(); my $config = <timer( after => 10, cb => sub { syswrite($fh, "timeout exceeded.\r\n"); undef $t; }); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); $config = < 'critical', 'message' => re( qr#^HTTP body of http://localhost:[0-9]+ \(127.0.0.1\) does not match regexp /Latest release: \\d/# ), }, $check_ipv6_fail, )); ################################################################################ # Bind to a port, # send correct greeting, # and correct message in body. # Verify that the plugin # does not fail. ################################################################################ $host = serve("HTTP/1.0 200 OK\r\nContent-Length: 17\r\n\r\nLatest release: 3"); $config = < 'critical', 'message' => re( qr#^HTTP body of http://localhost:[0-9]+ \(127.0.0.1\) does not match regexp /this regex should fail/# ), }, $check_ipv6_fail )); ################################################################################ # Bind to a port, # and check http basic authorization header. # Verify that the plugin # fails with incorrect credentials. ################################################################################ $host = serve_with_basic_authentication(); $config = <new( fh => $pr, on_error => sub { my ($hdl, $fatal, $msg) = @_; diag("error reading from stderr: $msg"); $w->destroy; }); my @messages; my $test_cv = AnyEvent->condvar; my @start_request; @start_request = ( json => sub { my ($hdl, $hashref) = @_; push @messages, $hashref; if (scalar @messages == $num_msgs) { $test_cv->send(1); } $hdl->push_read(@start_request); }); $w->push_read(@start_request); my $cv = run_cmd ["plugins/$plugin"], # feed the config on stdin '<', \$config, # stdout goes to /dev/null for now. '>', '/dev/null', # TODO: proxy stderr into our log so that one can easily spot plugin failures '3>', $pw; $cv->cb( sub { my $status = shift->recv; diag("exited with exit code $status"); $test_cv->send(0); }); # Timeout this test after 2s, # plugins have a timeout of 1s. my $timeout = AnyEvent->timer( after => 2, cb => sub { diag('plugin timeout (2s)'); $test_cv->send(0); }); $test_cv->recv; cmp_deeply(\@messages, $expected, 'plugin messages match expectation'); } ################################################################################ # Bind to a port, # but immediately close incoming connections. # Verify that the plugin fails # with the appropriate message. ################################################################################ my $host; tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; shutdown($fh, 2); close($fh); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); my $config = < 'critical', 'message' => re(qr/^TCP read error on \[127.0.0.1\]:[0-9]+: /), }, { 'severity' => 'critical', 'message' => re( qr/^Connecting to ::1 on port [0-9]+ failed: Connection refused/ ), }, )); ################################################################################ # Bind to a port, # but don’t send anything. # Verify that the plugin fails # with the appropriate message. ################################################################################ tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; my $t; $t = AnyEvent->timer( after => 10, cb => sub { syswrite($fh, "timeout exceeded.\r\n"); undef $t; }); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); $config = < 'critical', 'message' => re( qr/^Timeout \(1 s\) on \[127\.0\.0\.1\]:[0-9]+/ ), }, { 'severity' => 'critical', 'message' => re( qr/^Connecting to ::1 on port [0-9]+ failed: Connection refused/ ), }, )); ################################################################################ # Bind to a port, # but send a wrong greeting. # Verify that the plugin fails # with the appropriate message. ################################################################################ tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; syswrite( $fh, "PROPRIETARY SERVICE READY. SEND CLEARTEXT PASSWORDS NOW!\r\n" ); close($fh); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); $config = < 'critical', 'message' => re( qr/^Protocol error on \[127\.0\.0\.1\]:[0-9]+: Wrong greeting received. Expected '220 …', got 'PROPR…'/ ), }, { 'severity' => 'critical', 'message' => re( qr/^Connecting to ::1 on port [0-9]+ failed: Connection refused/ ), }, )); ################################################################################ # Bind to a port, # send correct greeting. # Verify that the plugin # does not fail. ################################################################################ tcp_server( "127.0.0.1", undef, sub { my ($fh, $host, $port) = @_; syswrite( $fh, "220 fake smtp ready\r\n", ); close($fh); }, sub { my ($fh, $thishost, $thisport) = @_; $host = "localhost:$thisport"; return undef; }); $config = < 'critical', 'message' => re( qr/^Connecting to ::1 on port [0-9]+ failed: Connection refused/ ), }, )); done_testing; # Kill all child processes, # otherwise a 'prove' process hangs. $SIG{TERM} = sub { }; kill('TERM', 0); kanla-1.4/MANIFEST0000644000014500017510000000155212147467452013101 0ustar michaelstaff.perltidyrc asciidoc-toc.css asciidoc.conf Changes default.cfg default.d/fail.cfg default.d/http-example.cfg docs/contributions.html docs/contributions.txt docs/installing-rhel.html docs/installing-rhel.txt docs/installing-wheezy.html docs/installing-wheezy.txt docs/userguide.html docs/userguide.txt inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Scripts.pm inc/Module/Install/Share.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm kanla-logo.svg lib/Kanla.pm lib/Kanla/Plugin.pm lib/Kanla/Plugin/Banner.pm LICENSE Makefile.PL MANIFEST This list of files META.yml plugins/fail plugins/git plugins/http plugins/irc plugins/smtp script/kanla t/001-load.t t/002-plugin-api.t t/003-send-alerts-to.t t/004-smtp.t t/005-http.t kanla-1.4/kanla-logo.svg0000644000014500017510000001256212053231113014473 0ustar michaelstaff image/svg+xml kanla kanla-1.4/script/0000755000014500017510000000000012232511602013227 5ustar michaelstaffkanla-1.4/script/kanla0000755000014500017510000000342512232511322014246 0ustar michaelstaff#!/usr/bin/env perl # vim:ts=4:sw=4:expandtab use strict; use warnings; use utf8; use v5.10; use lib qw(lib); use Kanla; use AnyEvent; use Getopt::Long; use Pod::Usage; use POSIX qw(setsid); binmode STDOUT, ':utf8'; binmode STDERR, ':utf8'; my $configfile; GetOptions( 'configfile=s' => \$configfile, 'help' => sub { pod2usage({ -verbose => 1, -exitval => 0, }) }, 'version' => sub { say "kanla $Kanla::VERSION © 2012-2013 Michael Stapelberg and contributors"; exit 0; }, ); # Open a new session # so that init scripts # can kill kanla plus all plugins # by using kill -$(pidof kanla) setsid(); Kanla::run( configfile => $configfile ); # Run forever. AnyEvent->condvar->recv; =head1 NAME kanla - small-scale alerting daemon =head1 SYNOPSIS kanla [--configfile=path] =head1 DESCRIPTION kanla is a daemon which peridiocally checks whether your website, mail server, etc. are still up and running. In case a health check fails, kanla will notify you via jabber (XMPP). Focus of kanla lies on being light-weight, being simple, using a sane configuration file, being well-documented. =head1 OPTIONS =over =item B<--configfile=path> Use path instead of /etc/kanla/default.cfg as configuration file. =back =head1 DOCUMENTATION kanla's documentation can be found at http://kanla.zekjur.net/docs/ We have decided to use asciidoc for kanla, and to not maintain both POD and asciidoc, the POD documentation is intentionally sparse. =head1 VERSION Version 1.4 =head1 AUTHOR Michael Stapelberg, C<< >> =head1 LICENSE AND COPYRIGHT Copyright 2012-2013 Michael Stapelberg. This program is free software; you can redistribute it and/or modify it under the terms of the BSD license. =cut kanla-1.4/plugins/0000755000014500017510000000000012232511602013404 5ustar michaelstaffkanla-1.4/plugins/fail0000755000014500017510000000242512042773403014260 0ustar michaelstaff#!/usr/bin/env perl # vim:ts=4:sw=4:expandtab use strict; use warnings; use v5.10; # libanyevent-perl use AnyEvent; # libjson-xs-perl use JSON::XS; # libconfig-general-perl use Config::General; # core use Carp; use Data::Dumper; use IO::Handle; my $errorfh = IO::Handle->new_from_fd(3, 'w'); $errorfh->autoflush(1); # reads in the whole STDIN sub slurp { local $/; ; } my $config_str = slurp(); say "config = *$config_str*"; my $conf = Config::General->new( -String => $config_str, # open all files in utf-8 mode -UTF8 => 1, # normalize yes, on, 1, true and no, off, 0, false to 1 resp. 0 -AutoTrue => 1, # case-insensitive key names by lowercasing everything -LowerCaseNames => 1, # provide the ->array, ->hash, etc. methods -ExtendedAccess => 1, ); my $interval = 60; # Disable buffering. $| = 1; sub signal_error { my ($severity, $message) = @_; say $errorfh encode_json({ severity => $severity, message => $message }); } my $main_timer; $main_timer = AnyEvent->timer( after => 0, interval => $interval, cb => sub { signal_error('critical', 'Hello, this is the "fail" plugin. If you read this message, your setup seems to be working :-).'); }); # Run forever. AnyEvent->condvar->recv; kanla-1.4/plugins/irc0000755000014500017510000000420312104252151014105 0ustar michaelstaff#!/usr/bin/env perl # -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- # vim:ts=4:sw=4:expandtab # To make development easier. use lib qw(lib); use Kanla::Plugin; use Kanla::Plugin::Banner; my @ircds; if (!$conf->is_array('ircd')) { @ircds = ($conf->value('ircd')); } else { @ircds = $conf->array('ircd'); } # Unless the user specified something else, # we use 45 s instead of the default # since IRC uses timeouts # e.g. for ident checking. if (!$conf->exists('timeout')) { $conf->value('timeout', 45); } sub run { for my $ircd (@ircds) { # Connect to each configured server. banner_connect( host => $ircd, default_service => 'ircd', cb => sub { my ($handle, $timeout) = @_; # To avoid # "nickname already in use" # we generate a sufficiently random nick. # Downside: # This might make kanla health checks # look like IRC spam bots. # Then again, # the network operator(s) # should know about any kanla instances. my $suffix = ''; for (1 .. 6) { $suffix .= chr(ord('A') + rand(ord('Z') - ord('A'))); } $handle->push_write("NICK kanla-$suffix\r\n"); $handle->push_write("USER kanla kanla kanla :kanla\r\n"); my @read_line; @read_line = ( line => sub { my ($handle, $line) = @_; if ($line !~ /^:[^ ]+ 001 /) { $handle->push_read(@read_line); return; } # We successfully signed on. undef $timeout; $handle->push_write( "QUIT :kanla is configured to health-check this server\r\n" ); banner_disconnect($handle); }); $handle->push_read(@read_line); }); } } kanla-1.4/plugins/http0000755000014500017510000001310712204457170014323 0ustar michaelstaff#!/usr/bin/env perl # -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- # To make development easier. use lib qw(lib); use Kanla::Plugin; # libanyevent-http-perl use AnyEvent::HTTP; # libanyevent-perl use AnyEvent; use AnyEvent::Socket; use AnyEvent::DNS; # core use MIME::Base64; # The regexes are ripped out of AnyEvent::HTTP. # They were modified to extract username and password. # It returns the hostname, # if present, username:password or an empty string otherwise, # a clean version of the given URL for errror reports and logging. sub parse_url { my ($url) = @_; my ($uscheme, $uauthority, $upath, $query, $fragment) = $url =~ m|^ ([^:]+): # scheme (?:// # // is used in http ([^/?\#]*) # user, pass, hostname, port )? ([^?\#]*) # path (\?[^\#]*)? # query (\#.*)? # fragment $|x; my ($user_pass, $hostname, $port) = $uauthority =~ /^(?: (.*)\@ )? ([^\@:]+) ( : (\d+) )?$/x or die "Unparsable URL"; $query //= ''; $fragment //= ''; $port //= ''; my $clean_url = $uscheme . '://' . $hostname . $port . $upath . $query . $fragment; # TODO: error out in a way which the main process understands return ($hostname, $user_pass, $clean_url); } my @urls; if (!$conf->is_array('url')) { @urls = ($conf->value('url')); } else { @urls = $conf->array('url'); } my @body; if ($conf->exists('body')) { if (!$conf->is_array('body')) { @body = ($conf->value('body')); } else { @body = $conf->array('body'); } # Convert strings to regular expressions or coderefs, depending on # their content. for my $idx (0 .. @body - 1) { my $body = $body[$idx]; if (my ($re) = ($body =~ m,^/(.*)/$,)) { $body[$idx] = [ $body, qr/$re/ ]; } elsif ($body =~ /^sub/) { $body[$idx] = [ $body, eval $body ]; } else { die "Invalid “body” value: $body"; } } } my $timeout = ($conf->exists('timeout') ? $conf->value('timeout') : 10); # Ensure timeout is an int and > 0. $timeout += 0; $timeout ||= 1; sub verify_availability { my ($ip, $url) = @_; my (undef, $user_pass, $clean_url) = parse_url($url); $user_pass = 'Basic ' . encode_base64($user_pass) if defined($user_pass); http_get( $clean_url, # This timeout is for each individual stage, # e.g. for connecting, # for waiting for a response, # etc. # It is not a global timeout. timeout => $timeout, headers => { # TODO: configurable User-Agent 'User-Agent' => 'kanla', 'Authorization' => $user_pass, }, tcp_connect => sub { my (undef, $port, $connect_cb, $prepare_cb) = @_; # Wrap around tcp_connect, # replacing the host # with our resolved one. AnyEvent::Socket::tcp_connect($ip, $port, $connect_cb, $prepare_cb); }, sub { my ($body, $hdr) = @_; # HTTP 4xx is Client Errors, # HTTP 5xx is Server Errors. if ($hdr->{Status} =~ /^[4-5]/) { signal_error( 'critical', 'HTTP reply ' . $hdr->{Status} . " for $clean_url ($ip)" ); return; } # Perform body checks, if any. if (@body > 0) { for my $elm (@body) { my ($input, $check) = @$elm; if (ref $check eq 'Regexp') { if ($body !~ $check) { signal_error( 'critical', "HTTP body of $clean_url ($ip) does not match regexp $input" ); } } else { if (!$check->($body)) { signal_error( 'critical', "HTTP body of $clean_url ($ip) does not match code $input" ); } } } } }); } sub resolved { # family is either A or AAAA my $family = shift; my $hostname = shift; my $url = shift; if (@_ == 0) { signal_error( 'critical', "Cannot resolve $family DNS record for $hostname" ); return; } for my $ip (@_) { verify_availability($ip, $url); } } sub run { for my $url (@urls) { # XXX: We re-resolve all the time because it is assumed that you are # using a local caching nameserver, which is a good idea anyways and # allows us to correctly pick up new addresses once the old ones # expire. # Since AnyEvent::HTTP offers no way to specify whether we want to # access the website via IPv4 or IPv6, we need to resolve the hostname # on our own and specifically connect to the resolved IP address. my ($host) = parse_url($url); if ($conf->obj('family')->value('ipv4')) { AnyEvent::DNS::a $host, sub { resolved('A', $host, $url, @_) }; } if ($conf->obj('family')->value('ipv6')) { AnyEvent::DNS::aaaa $host, sub { resolved('AAAA', $host, $url, @_) }; } } } # Run forever. AnyEvent->condvar->recv; # vim:ts=4:sw=4:expandtab kanla-1.4/plugins/smtp0000755000014500017510000000274612043334443014334 0ustar michaelstaff#!/usr/bin/env perl # vim:ts=4:sw=4:expandtab use lib qw(lib); use Kanla::Plugin; use Kanla::Plugin::Banner; my @hosts; if (!$conf->is_array('host')) { @hosts = ($conf->value('host')); } else { @hosts = $conf->array('host'); } my $interval = 60; sub run { for my $host (@hosts) { banner_connect( host => $host, default_service => 'smtp', cb => sub { my ($handle, $timeout, $ip, $service) = @_; $handle->push_read( line => sub { my ($handle, $line) = @_; # cancel timeout undef $timeout; if ($line =~ /^220 /) { # SMTP greeting received, # everything fine. # Close the connection. $handle->push_write("QUIT\r\n"); banner_disconnect($handle); return; } # Wrong greeting received. my $ellipsized = substr($line, 0, 5); $ellipsized .= "…" if length($line) > 5; signal_error( 'critical', "Protocol error on [$ip]:$service: Wrong greeting received. Expected '220 …', got '$ellipsized'" ); }); }); } } kanla-1.4/plugins/git0000755000014500017510000000414012043474254014127 0ustar michaelstaff#!/usr/bin/env perl # -*- Mode: CPerl; # cperl-indent-level: 4; # cperl-continued-statement-offset: 4; # cperl-indent-parens-as-block: t; # cperl-tabs-always-indent: t; # cperl-indent-subs-specially: nil; # -*- # vim:ts=4:sw=4:expandtab # To make development easier. use lib qw(lib); use Kanla::Plugin; use Kanla::Plugin::Banner; my @urls; if (!$conf->is_array('url')) { @urls = ($conf->value('url')); } else { @urls = $conf->array('url'); } sub run { for my $url (@urls) { # This is ripped out of AnyEvent::HTTP. # If the code sucks, # we’d have to replace AnyEvent::HTTP, # and that’s not going to happen # due to the scope of the project. # Therefore, this fragment is # good enough by definition :). my ($uscheme, $uauthority, $upath, $query, undef) = # ignore fragment $url =~ m|^([^:]+):(?://([^/?#]*))?([^?#]*)(?:(\?[^#]*))?(?:#(.*))?$|; $uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x or die "Unparsable URL"; my $host = lc $1; # Connect to each configured server. banner_connect( host => $host, default_service => 'git', cb => sub { my ($handle, $timeout) = @_; my $pktline = sprintf( "%04xgit-upload-pack %s\0host=%s\0", 0, $upath, $host ); substr($pktline, 0, 4) = sprintf("%04x", length($pktline)); $handle->push_write($pktline); $handle->push_read( line => "\x0", sub { my ($handle, $line) = @_; if ($line !~ /^[0-9a-f]+ HEAD$/) { signal_error( 'critical', 'Protocol error: expected git sha-id, got ' . $line ); } undef $timeout; banner_disconnect($handle); }); }); } } kanla-1.4/Makefile.PL0000644000014500017510000000366012143524627013716 0ustar michaelstaffuse inc::Module::Install; use Cwd; name 'kanla'; all_from 'lib/Kanla.pm'; author 'Michael Stapelberg'; requires 'AnyEvent'; requires 'AnyEvent::Util'; requires 'AnyEvent::Handle'; requires 'AnyEvent::XMPP::Client'; requires 'AnyEvent::XMPP::Ext::Disco'; requires 'AnyEvent::XMPP::Ext::Ping'; requires 'AnyEvent::XMPP::Ext::VCard'; requires 'AnyEvent::XMPP::Ext::Version'; requires 'JSON::XS'; requires 'Config::General' => '2.50'; requires 'File::ShareDir'; # plugin requirements requires 'AnyEvent::HTTP' => '1.5'; requires 'AnyEvent::Socket'; requires 'AnyEvent::DNS'; # test requirements test_requires 'Test::MockModule'; test_requires 'Test::Deep'; install_script 'kanla'; # Install plugins/ into a distribution-shared directory install_share('dist', 'plugins'); ################################################################################ # We generate make targets for every file in docs/ # so users can use 'make docs' # to generate docs/*.html from docs/*.txt ################################################################################ my @docs = ; my $alldocfiles = join ' ', map { substr($_, 0, length() - 4) . '.html' } @docs; my $postamble = ''; my $cwd = getcwd(); for my $file (@docs) { my $htmlfile = $file; $htmlfile =~ s/\.txt$/.html/; $postamble .= < $htmlfile EOT } postamble < >>' - 'Michael Stapelberg' build_requires: ExtUtils::MakeMaker: 6.59 Test::Deep: 0 Test::MockModule: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: kanla no_index: directory: - inc - plugins - t requires: AnyEvent: 0 AnyEvent::DNS: 0 AnyEvent::HTTP: 1.5 AnyEvent::Handle: 0 AnyEvent::Socket: 0 AnyEvent::Util: 0 AnyEvent::XMPP::Client: 0 AnyEvent::XMPP::Ext::Disco: 0 AnyEvent::XMPP::Ext::Ping: 0 AnyEvent::XMPP::Ext::VCard: 0 AnyEvent::XMPP::Ext::Version: 0 Config::General: 2.50 File::ShareDir: 0 JSON::XS: 0 perl: 5.10.0 resources: license: http://opensource.org/licenses/bsd-license.php version: 1.4 kanla-1.4/asciidoc-toc.css0000644000014500017510000000015712037061221015001 0ustar michaelstafful.toc { list-style-type: none; margin-left: 0; padding-left: 0; } ul.toc ul.toc { padding-left: 0.5em; } kanla-1.4/Changes0000644000014500017510000000146212232511564013230 0ustar michaelstaffRevision history for kanla: 1.4 Fri, 25 Oct 2013 17:49:59 +0200 - make Kanla::Plugin work reliably with newer Perl versions - add redis plugin - http plugin: implement basic auth - avoid using smartmatch since it is experimental in Perl ≥ 5.18 1.3 Thu, 23 May 2013 19:57:28 +0200 - remove debug => 1 to remove errors when XML::Twig is missing - add "fail" plugin to the default config - install configfiles with permission 640 - use kanla@example.invalid instead of example.com in the default config 1.2 Sat, 30 Mar 2013 12:26:46 +0100 - Improve error message when having two blocks with the same name - Switch from MergeDuplicateOptions to manually adding defaults. This fixes specifying multiple URLs. 1.1 Tue, 19 Mar 2013 15:39:00 +0100 - Initial release. kanla-1.4/default.d/0000755000014500017510000000000012232511602013571 5ustar michaelstaffkanla-1.4/default.d/http-example.cfg0000644000014500017510000000021012057632527016672 0ustar michaelstaff# vim:tabstop=4:shiftwidth=4:expandtab # # plugin = http # # url = "http://kanla.zekjur.net/" # kanla-1.4/default.d/fail.cfg0000644000014500017510000000035612156662554015213 0ustar michaelstaff# vim:tabstop=4:shiftwidth=4:expandtab # The fail-plugin will periodically send you an error. # This can be used to verify your xmpp-setup. # If everything works you can just remove this file. plugin = fail