1package DJabberd::Stanza::SASL;
2use strict;
3use warnings;
4use base qw(DJabberd::Stanza);
5
6use MIME::Base64 qw/encode_base64 decode_base64/;
7
8sub on_recv_from_server { die "unimplemented" }
9
10## TODO:
11## check number of auth failures, force deconnection, bad for t time §7.3.5 policy-violation
12## Provide hooks for Authen:: modules to return details about errors:
13## - credentials-expired
14## - account-disabled
15## - invalid-authzid
16## - temporary-auth-failure
17## these hooks should probably additions to parameters taken by GetPassword, CheckClearText
18## right now all these errors results in not-authorized being returned
19
20sub on_recv_from_client {
21    my $self = shift;
22
23    return $self->handle_abort(@_)
24        if $self->element_name eq 'abort';
25
26    return $self->handle_response(@_)
27        if $self->element_name eq 'response';
28
29    return $self->handle_auth(@_)
30        if $self->element_name eq 'auth';
31}
32
33## supports §7.3.4, §7.4.1
34## handles: <abort xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>
35sub handle_abort {
36    my ($self, $conn) = @_;
37
38    $self->send_failure("aborted" => $conn);
39    return;
40}
41
42sub handle_response {
43    my $self = shift;
44    my ($conn) = @_;
45
46    my $sasl = $conn->sasl
47        or return $self->send_failure("malformed-request" => $conn);
48
49    if (my $error = $sasl->error) {
50        return $self->send_failure("not-authorized" => $conn);
51    }
52    if (! $sasl->need_step) {
53        $conn->log->info("sasl negotiation unexpected end");
54        return $self->send_failure("malformed-request" => $conn);
55    }
56
57    my $response = $self->first_child;
58    $response = $self->decode($response);
59    $conn->log->info("Got the response $response");
60
61    $sasl->server_step(
62        $response => sub { $self->send_reply($conn->{sasl}, shift() => $conn) },
63    );
64}
65
66sub handle_auth {
67    my ($self, $conn) = @_;
68
69    my $fallback = sub {
70        $self->send_failure("invalid-mechanism" => $conn);
71    };
72
73    my $vhost = $conn->vhost
74        or die "There is no vhost";
75
76    my $saslmgr;
77    $vhost->run_hook_chain( phase => "GetSASLManager",
78                            args  => [ conn => $conn ],
79                            methods => {
80                                get => sub {
81                                     (undef, $saslmgr) = @_;
82                                },
83                            },
84                            fallback => $fallback,
85    );
86    die "no SASL" unless $saslmgr;
87
88    ## TODO: §7.4.4.  encryption-required
89    my $mechanism = $self->attr("{}mechanism");
90    return $self->send_failure("invalid-mechanism" => $conn)
91        unless $saslmgr->is_mechanism_supported($mechanism);
92
93    ## we don't support it for now
94    my $opts = { no_integrity => 1 };
95    $saslmgr->mechanism($mechanism);
96    my $sasl_conn = $saslmgr->server_new("xmpp", $vhost->server_name, $opts);
97    $conn->{sasl} = $sasl_conn;
98
99    my $init = $self->first_child;
100    if (!$init or $init eq '=') {
101        $init = '';
102    }
103    else {
104        $init = $self->decode($init);
105    }
106
107    $sasl_conn->server_start(
108        $init => sub { $self->send_reply($conn->{sasl}, shift() => $conn) },
109    );
110}
111
112sub send_challenge {
113    my $self = shift;
114    my ($challenge, $conn) = @_;
115
116    $conn->log->debug("Sending Challenge: $challenge");
117    my $enc_challenge = $self->encode($challenge);
118    my $xml = "<challenge xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>$enc_challenge</challenge>";
119    $conn->xmllog->info($xml);
120    $conn->write(\$xml);
121}
122
123sub send_failure {
124    my $self = shift;
125    my ($error, $conn) = @_;
126    $conn->log->debug("Sending error: $error");
127    my $xml = <<EOF;
128<failure xmlns='urn:ietf:params:xml:ns:xmpp-sasl'><$error/></failure>
129EOF
130    $conn->xmllog->info($xml);
131    $conn->write(\$xml);
132    return;
133}
134
135sub ack_success {
136    my $self = shift;
137    my ($sasl_conn, $challenge, $conn) = @_;
138
139    my $username = $sasl_conn->answer('username') || $sasl_conn->answer('user');
140    my $sname = $conn->vhost->name;
141    unless ($username && $sname) {
142        $conn->log->error("Couldn't bind to a jid, declining.");
143        $self->send_failure("not-authorized" => $conn);
144        return;
145    }
146    my $authenticated_jid = "$username\@$sname";
147    $sasl_conn->set_authenticated_jid($authenticated_jid);
148
149    my $xml;
150    if (defined $challenge) {
151        my $enc = $challenge ? $self->encode($challenge) : "=";
152        $xml = "<success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>$enc</success>";
153    }
154    else {
155        $xml = "<success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>";
156    }
157    $conn->xmllog->info($xml);
158    $conn->write(\$xml);
159    if (($sasl_conn->property('ssf') || 0) > 0) {
160        $conn->log->info("SASL: Securing socket");
161        $conn->log->warn("This will probably NOT work");
162        $sasl_conn->securesocket($conn);
163    }
164    else {
165        $conn->log->info("SASL: Not securing socket");
166    }
167    $conn->restart_stream;
168}
169
170sub encode {
171    my $self = shift;
172    my $str  = shift;
173    return encode_base64($str, '');
174}
175
176sub decode {
177    my $self = shift;
178    my $str  = shift;
179    return decode_base64($str);
180}
181
182sub send_reply {
183    my $self = shift;
184    my ($sasl_conn, $challenge, $conn) = @_;
185
186    if (my $error = $sasl_conn->error) {
187        $self->send_failure("not-authorized" => $conn);
188    }
189    elsif ($sasl_conn->is_success) {
190        $self->ack_success($sasl_conn, $challenge => $conn);
191    }
192    else {
193        $self->send_challenge($challenge => $conn);
194    }
195    return;
196}
197
1981;
199