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