1#!/usr/bin/perl 2# 3# SixApart's Jabber Server 4# 5 6BEGIN { 7 $^P |= 0x01 if $ENV{TRACE_DJABBERD}; 8} 9 10use strict; 11use lib 'lib'; 12use FindBin qw($Bin); 13use Getopt::Long; 14 15use DJabberd; 16use DJabberd::Delivery::Local; 17use DJabberd::Delivery::S2S; 18use DJabberd::PresenceChecker::Local; 19use DJabberd::RosterStorage::SQLite; 20use DJabberd::Plugin::MUC; 21use DJabberd::Plugin::VCard::SQLite; 22my $daemonize; 23Getopt::Long::GetOptions( 24 'd|daemon' => \$daemonize, 25 ); 26 27$SixApart::LDAP_SERVER = "auth2.sfo.sixapart.com"; 28 29my $rs = DJabberd::RosterStorage::SixApart->new; 30$rs->set_config_database("$Bin/roster.sqlite"); 31$rs->finalize; 32 33my $vcard = DJabberd::Plugin::VCard::SQLite->new; 34$vcard->set_config_storage("$Bin/roster.sqlite"); 35$vcard->finalize; 36 37my $muc = DJabberd::Plugin::MUC->new; 38$muc->set_config_subdomain("conference"); 39$muc->finalize; 40 41my $vhost = DJabberd::VHost->new( 42 server_name => 'sixapart.com', 43 require_ssl => 1, 44 s2s => 1, 45 plugins => [ 46 DJabberd::Authen::SixApart->new, 47 $rs, 48 $vcard, 49 $muc, 50 DJabberd::Delivery::Local->new, 51 DJabberd::Delivery::S2S->new, 52 ], 53 ); 54 55my $server = DJabberd->new( 56 daemonize => $daemonize, 57 old_ssl => 1, 58 ); 59 60$server->add_vhost($vhost); 61$server->run; 62 63 64package DJabberd::Authen::SixApart; 65use strict; 66use base 'DJabberd::Authen'; 67use Net::LDAP; 68 69sub can_retrieve_cleartext { 0 } 70 71sub check_cleartext { 72 my ($self, $cb, %args) = @_; 73 my $user = $args{username}; 74 my $pass = $args{password}; 75 my $conn = $args{conn}; 76 77 unless ($user =~ /^\w+$/) { 78 $cb->reject; 79 return; 80 } 81 82 my $ldap = Net::LDAP->new( $SixApart::LDAP_SERVER ) or die "$@"; 83 my $dn = "uid=$user,ou=People,dc=sixapart,dc=com"; 84 my $msg = $ldap->bind($dn, password => $pass, version => 3); 85 if ($msg && !$msg->is_error) { 86 $cb->accept; 87 } else { 88 $cb->reject; 89 } 90} 91 92 93package DJabberd::RosterStorage::SixApart; 94use strict; 95use base 'DJabberd::RosterStorage::SQLite'; 96 97sub get_roster { 98 my ($self, $cb, $jid) = @_; 99 # cb can '->set_roster(Roster)' or decline 100 101 my $myself = lc $jid->node; 102 warn "SixApart loading roster for $myself ...\n"; 103 104 my $on_load_roster = sub { 105 my (undef, $roster) = @_; 106 107 my $pre_ct = $roster->items; 108 warn " $pre_ct roster items prior to population...\n"; 109 110 # see which employees already in roster 111 my %has; 112 foreach my $it ($roster->items) { 113 my $jid = $it->jid; 114 next unless $jid->as_bare_string =~ /^(\w+)\@sixapart\.com$/; 115 $has{lc $1} = $it; 116 } 117 118 # add missing employees to the roster 119 my $emps = _employees(); 120 foreach my $uid (keys %$emps) { 121 $uid = lc $uid; 122 next if $uid eq $myself; 123 124 my $emp = $emps->{$uid}; 125 my $ri = $has{$uid} || DJabberd::RosterItem->new(jid => "$uid\@sixapart.com", 126 name => ($emp->{displayName} || $emp->{cn}), 127 groups => ["SixApart"]); 128 129 130 $ri->subscription->set_from; 131 $ri->subscription->set_to; 132 $roster->add($ri); 133 } 134 135 my $post_ct = $roster->items; 136 warn " $post_ct roster items post population...\n"; 137 138 $cb->set_roster($roster); 139 }; 140 141 my $cb2 = DJabberd::Callback->new({set_roster => $on_load_roster, 142 decline => sub { $cb->decline }}); 143 $self->SUPER::get_roster($cb2, $jid); 144} 145 146my $last_emp; 147my $last_emp_time = 0; # unixtime of last ldap suck (ldap server is slow sometimes, so don't always poll) 148sub _employees { 149 my $now = time(); 150 151 # don't get new employees more often than once an hour.... :-) 152 if ($last_emp && $last_emp_time > $now - 3600) { 153 return $last_emp; 154 } 155 156 my $opts = "cn mailLocalAddress mail displayName"; 157 my @lines = `ldapsearch -H ldap://$SixApart::LDAP_SERVER -x -b ou=People,dc=SixApart,dc=com $opts`; 158 my $line_ct = @lines; 159 warn "Got employee lines from LDAP: $line_ct\n"; 160 if ($line_ct == 0) { 161 warn "zero employees: error=$?\n"; 162 if ($last_emp) { 163 warn " ... returning cached copy\n"; 164 return $last_emp; 165 } 166 } 167 168 my %info; # uid -> key -> value 169 my $curuid = undef; 170 foreach my $line (@lines) { 171 $line =~ s/^\#.*//; 172 if ($line =~ /^\s*$/) { 173 $curuid = undef; 174 next; 175 } 176 if ($line =~ /uid=(\w+)/) { 177 $curuid = $1; 178 } 179 next unless $curuid; 180 181 if ($line =~ /^(\w+): (.+)/) { 182 $info{$curuid}{$1} = $2; 183 } 184 } 185 186 delete $info{'tempaccount'}; 187 delete $info{'usability'}; 188 189 foreach my $uid (keys %info) { 190 delete $info{$uid} unless $info{$uid}{mailLocalAddress} || $info{$uid}{mail}; 191 } 192 193 $last_emp_time = $now; 194 return $last_emp = \%info; 195} 196 197sub load_roster_item { 198 my ($self, $jid, $contact_jid, $cb) = @_; 199 200 my $is_employee = sub { 201 my $jid = shift; 202 return $jid->domain eq "sixapart.com"; 203 }; 204 205 if ($is_employee->($jid) && $is_employee->($contact_jid)) { 206 my $both = DJabberd::Subscription->new; 207 $both->set_from; 208 $both->set_to; 209 my $rit = DJabberd::RosterItem->new(jid => $contact_jid, 210 subscription => $both); 211 $cb->set($rit); 212 return; 213 } 214 215 $self->SUPER::load_roster_item($jid, $contact_jid, $cb); 216} 217 218package DB; 219no strict 'refs'; 220no utf8; 221 222sub DB{}; 223sub sub { 224 # localize CALL_DEPTH so that we don't need to decrement it after the sub 225 # is called 226 local $DB::CALL_DEPTH = $DB::CALL_DEPTH+1; 227 #my @foo = @_; 228 my $fileline = ""; 229 if (ref $DB::sub eq "CODE") { 230 my @caller = caller; 231 my $pkg = $caller[0]; 232 my $line = $caller[2]; 233 $fileline = " called from $pkg, line $line"; 234 } 235 warn ("." x $DB::CALL_DEPTH . " ($DB::CALL_DEPTH) $DB::sub$fileline\n"); 236 237 # Call our subroutine. @_ gets passed on for us. 238 # by calling it last, we don't need to worry about "wantarray", etc 239 # by returning it like this, the caller's expectations are conveyed to 240 # the called routine 241 &{$DB::sub}; 242} 2431; 244