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