#!/usr/bin/perl # # SixApart's Jabber Server # BEGIN { $^P |= 0x01 if $ENV{TRACE_DJABBERD}; } use strict; use lib 'lib'; use FindBin qw($Bin); use Getopt::Long; use DJabberd; use DJabberd::Delivery::Local; use DJabberd::Delivery::S2S; use DJabberd::PresenceChecker::Local; use DJabberd::RosterStorage::SQLite; use DJabberd::Plugin::MUC; use DJabberd::Plugin::VCard::SQLite; my $daemonize; Getopt::Long::GetOptions( 'd|daemon' => \$daemonize, ); $SixApart::LDAP_SERVER = "auth2.sfo.sixapart.com"; my $rs = DJabberd::RosterStorage::SixApart->new; $rs->set_config_database("$Bin/roster.sqlite"); $rs->finalize; my $vcard = DJabberd::Plugin::VCard::SQLite->new; $vcard->set_config_storage("$Bin/roster.sqlite"); $vcard->finalize; my $muc = DJabberd::Plugin::MUC->new; $muc->set_config_subdomain("conference"); $muc->finalize; my $vhost = DJabberd::VHost->new( server_name => 'sixapart.com', require_ssl => 1, s2s => 1, plugins => [ DJabberd::Authen::SixApart->new, $rs, $vcard, $muc, DJabberd::Delivery::Local->new, DJabberd::Delivery::S2S->new, ], ); my $server = DJabberd->new( daemonize => $daemonize, old_ssl => 1, ); $server->add_vhost($vhost); $server->run; package DJabberd::Authen::SixApart; use strict; use base 'DJabberd::Authen'; use Net::LDAP; sub can_retrieve_cleartext { 0 } sub check_cleartext { my ($self, $cb, %args) = @_; my $user = $args{username}; my $pass = $args{password}; my $conn = $args{conn}; unless ($user =~ /^\w+$/) { $cb->reject; return; } my $ldap = Net::LDAP->new( $SixApart::LDAP_SERVER ) or die "$@"; my $dn = "uid=$user,ou=People,dc=sixapart,dc=com"; my $msg = $ldap->bind($dn, password => $pass, version => 3); if ($msg && !$msg->is_error) { $cb->accept; } else { $cb->reject; } } package DJabberd::RosterStorage::SixApart; use strict; use base 'DJabberd::RosterStorage::SQLite'; sub get_roster { my ($self, $cb, $jid) = @_; # cb can '->set_roster(Roster)' or decline my $myself = lc $jid->node; warn "SixApart loading roster for $myself ...\n"; my $on_load_roster = sub { my (undef, $roster) = @_; my $pre_ct = $roster->items; warn " $pre_ct roster items prior to population...\n"; # see which employees already in roster my %has; foreach my $it ($roster->items) { my $jid = $it->jid; next unless $jid->as_bare_string =~ /^(\w+)\@sixapart\.com$/; $has{lc $1} = $it; } # add missing employees to the roster my $emps = _employees(); foreach my $uid (keys %$emps) { $uid = lc $uid; next if $uid eq $myself; my $emp = $emps->{$uid}; my $ri = $has{$uid} || DJabberd::RosterItem->new(jid => "$uid\@sixapart.com", name => ($emp->{displayName} || $emp->{cn}), groups => ["SixApart"]); $ri->subscription->set_from; $ri->subscription->set_to; $roster->add($ri); } my $post_ct = $roster->items; warn " $post_ct roster items post population...\n"; $cb->set_roster($roster); }; my $cb2 = DJabberd::Callback->new({set_roster => $on_load_roster, decline => sub { $cb->decline }}); $self->SUPER::get_roster($cb2, $jid); } my $last_emp; my $last_emp_time = 0; # unixtime of last ldap suck (ldap server is slow sometimes, so don't always poll) sub _employees { my $now = time(); # don't get new employees more often than once an hour.... :-) if ($last_emp && $last_emp_time > $now - 3600) { return $last_emp; } my $opts = "cn mailLocalAddress mail displayName"; my @lines = `ldapsearch -H ldap://$SixApart::LDAP_SERVER -x -b ou=People,dc=SixApart,dc=com $opts`; my $line_ct = @lines; warn "Got employee lines from LDAP: $line_ct\n"; if ($line_ct == 0) { warn "zero employees: error=$?\n"; if ($last_emp) { warn " ... returning cached copy\n"; return $last_emp; } } my %info; # uid -> key -> value my $curuid = undef; foreach my $line (@lines) { $line =~ s/^\#.*//; if ($line =~ /^\s*$/) { $curuid = undef; next; } if ($line =~ /uid=(\w+)/) { $curuid = $1; } next unless $curuid; if ($line =~ /^(\w+): (.+)/) { $info{$curuid}{$1} = $2; } } delete $info{'tempaccount'}; delete $info{'usability'}; foreach my $uid (keys %info) { delete $info{$uid} unless $info{$uid}{mailLocalAddress} || $info{$uid}{mail}; } $last_emp_time = $now; return $last_emp = \%info; } sub load_roster_item { my ($self, $jid, $contact_jid, $cb) = @_; my $is_employee = sub { my $jid = shift; return $jid->domain eq "sixapart.com"; }; if ($is_employee->($jid) && $is_employee->($contact_jid)) { my $both = DJabberd::Subscription->new; $both->set_from; $both->set_to; my $rit = DJabberd::RosterItem->new(jid => $contact_jid, subscription => $both); $cb->set($rit); return; } $self->SUPER::load_roster_item($jid, $contact_jid, $cb); } package DB; no strict 'refs'; no utf8; sub DB{}; sub sub { # localize CALL_DEPTH so that we don't need to decrement it after the sub # is called local $DB::CALL_DEPTH = $DB::CALL_DEPTH+1; #my @foo = @_; my $fileline = ""; if (ref $DB::sub eq "CODE") { my @caller = caller; my $pkg = $caller[0]; my $line = $caller[2]; $fileline = " called from $pkg, line $line"; } warn ("." x $DB::CALL_DEPTH . " ($DB::CALL_DEPTH) $DB::sub$fileline\n"); # Call our subroutine. @_ gets passed on for us. # by calling it last, we don't need to worry about "wantarray", etc # by returning it like this, the caller's expectations are conveyed to # the called routine &{$DB::sub}; } 1;