1package DJabberd::SASL::Manager::AuthenSASL;
2
3use strict;
4use warnings;
5
6use base qw/DJabberd::SASL::ManagerBase/;
7use DJabberd::SASL::Connection::AuthenSASL;
8
9use Authen::SASL ('Perl');
10
11sub server_new {
12    my $obj = shift;
13    my $conn = $obj->{impl}->server_new(@_);
14    return DJabberd::SASL::Connection::AuthenSASL->new($conn);
15}
16
17sub is_mechanism_supported {
18    my $sasl      = shift;
19    my $mechanism = shift;
20
21    ## FIXME We might want to check that what's declared in the config
22    ## is supported in Authen::SASL
23    my $plugin = $sasl->{__sasl_plugin};
24    return $plugin->mechanisms->{uc $mechanism};
25    return 1;
26}
27
28sub manager_implementation {
29    my $mgr  = shift;
30    my $conn = shift;
31
32    my $plugin = $mgr->plugin;
33    my $vhost  = $conn->vhost or die "missing vhost";
34
35    my $mechanisms = $plugin->mechanisms_str;
36    my $saslmgr    = Authen::SASL->new(
37        mechanism => $mechanisms,
38        callback  => {
39            checkpass => sub {
40                my $sasl = shift;
41                my $args = shift;
42                my $cb   = shift;
43
44                my $user = $args->{user};
45                my $pass = $args->{pass};
46
47                if ($vhost->are_hooks("CheckCleartext")) {
48                    $vhost->run_hook_chain(
49                        phase   => "CheckCleartext",
50                        args    => [ username => $user, password => $pass ],
51                        methods => {
52                            accept => sub { $cb->(1) },
53                            reject => sub { $cb->(0) },
54                        },
55                    );
56                }
57            },
58            getsecret => sub {
59                my $sasl = shift;
60                my $args = shift;
61                my $cb   = shift;
62
63                my $user = $args->{user};
64
65                if ($vhost->are_hooks("GetPassword")) {
66                    $vhost->run_hook_chain(
67                        phase   => "GetPassword",
68                        args    => [ username => $user, ],
69                        methods => {
70                            set => sub {
71                                my (undef, $good_password) = @_;
72                                $cb->($good_password);
73                            },
74                        },
75                    );
76                }
77            },
78        },
79    );
80    return $saslmgr;
81}
82
831;
84