File Coverage

blib/lib/Net/Scan/SSH/Server/SupportedAuth.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::Scan::SSH::Server::SupportedAuth;

use strict;
use warnings;
use Carp;

our $VERSION = '0.02';

use Net::SSH::Perl::Kex;
use Net::SSH::Perl::Auth;
our %AUTH_IF;
while (my ($a, $b) = each %Net::SSH::Perl::Auth::AUTH) {
    $AUTH_IF{ lc($a) } = 1<<$b;
}
$AUTH_IF{publickey} = $AUTH_IF{rsa}; # alias
our @EXPORT_OK   = qw(%AUTH_IF);
our %EXPORT_TAGS = ( flag => [qw(%AUTH_IF)] );

BEGIN {
    my $debug_flag = $ENV{SMART_COMMENTS} || $ENV{SMART_COMMENT} || $ENV{SMART_DEBUG} || $ENV{SC};
    if ($debug_flag) {
        my @p = map { '#'x$_ } ($debug_flag =~ /([345])\s*/g);
        use UNIVERSAL::require;
        Smart::Comments->use(@p);
    }
}

sub new {
    my($class, %opt) = @_;

    my $self =  bless {
        server   => {
            host => '127.0.0.1',
            port => '22',
        },
        _version => 0, # 2.0 or 1.99 or 1.5
        _result  => {
            1 => 0,
            2 => 0,
        },
        _scanned => 0,
    }, $class;

    $self->{server}{$_} = $opt{$_} for grep { $opt{$_} } keys %{$self->{server}};
    ### host, port: $self->{server}{host}, $self->{server}{port}

    return $self;
}

sub scan {
    my $self = shift;

    $self->{_scanned} = 1;

    $self->_sshconnect2();
    $self->_sshconnect1() if $self->{_version} < 2;

    ### scan: $self->{_result}
    return $self->{_result};
}

sub scan_as_hash {
    my $self = shift;
    $self->scan unless $self->{_scanned};
    ### dump: $self->{_result}

    my $result;
    for my $v (2,1) {
        $result->{$v}{password}  = ($self->{_result}{$v} & $AUTH_IF{password}) ? 1 : 0;
        $result->{$v}{publickey} = ($self->{_result}{$v} & $AUTH_IF{rsa})      ? 1 : 0;
    }
    ### scan: $result
    return $result;
}

sub _sshconnect2 {
    my $self = shift;

    ### ssh2 connect
    my $ssh;
    eval {
        $ssh = Net::SSH::Perl->new(
            $self->{server}{host},
            port        => $self->{server}{port},
            protocol    => 2,
            compression => 0,
            debug       => 0,
           ) or return;
    };
    if ($@) {
        ### ssh2 connect error: $@
        return;
    }

    my $v = $self->_protocol_version( $ssh->server_version_string );
    ### _version: $v
    $self->{_version} = $v if $v;

    return if $self->{_version} < 1.5; # server supports 1 only

    my @authlist;
    {
        # override to get auth list.
        package Net::SSH::Perl::AuthMgr;
        no warnings 'redefine', 'once';

        local *auth_failure = sub {
            my $amgr = shift;
            my($packet) = @_;
            my $authlist = $packet->get_str;
            $packet->{data}->{offset} -= length($authlist)+4;

            $amgr->{__authlist} = [ split /,/, $authlist ];

            $amgr->{_done} = 1;
        };
        local *auth_list = sub {
            my $amgr = shift;
            $amgr->authenticate;
            return @{ $amgr->{__authlist} };
        };

        my $kex      = Net::SSH::Perl::Kex->new($ssh);
        $kex->exchange;
        my $amgr     = Net::SSH::Perl::AuthMgr->new($ssh);
        @authlist = $amgr->auth_list;
    }

    for my $a (@authlist) {
        ### authlist: $a
        if ($a eq 'publickey') {
            $self->{_result}{2} |= $AUTH_IF{rsa};
        } elsif ($a eq 'password') {
            $self->{_result}{2} |= $AUTH_IF{password};
        }
    }
    ### ssh2 result: $self->{_result}
}

sub _sshconnect1 {
    my $self = shift;

    ### ssh1 connect
    my $ssh;
    eval {
        $ssh = Net::SSH::Perl->new(
            $self->{server}{host},
            port        => $self->{server}{port},
            protocol    => 1,
            compression => 0,
            debug       => 0,
           ) or return;
    };
    if ($@) {
        ### ssh1 connect error: $@
        return;
    }

    my $v = $self->_protocol_version( $ssh->server_version_string );
    ### _version: $v
    $self->{_version} = $v if $v;

    my($protocol_flags, $supported_ciphers, $supported_auth);
    {
        # copy from Net::SSH::Perl::SSH1#_login
        use Net::SSH::Perl::Constants qw( :protocol :msg :hosts );
        my $packet = Net::SSH::Perl::Packet->read_expect($ssh, SSH_SMSG_PUBLIC_KEY);
        my $check_bytes = $packet->bytes(0, 8, "");

        my %keys;
        for my $which (qw( public host )) {
            $keys{$which}            = Net::SSH::Perl::Key::RSA1->new;
            $keys{$which}{rsa}{bits} = $packet->get_int32;
            $keys{$which}{rsa}{e}    = $packet->get_mp_int;
            $keys{$which}{rsa}{n}    = $packet->get_mp_int;
        }

        $protocol_flags    = $packet->get_int32;
        $supported_ciphers = $packet->get_int32;
        $supported_auth    = $packet->get_int32;
    }

    $self->{_result}{1} = $supported_auth;
}

sub _protocol_version {
    my $self = shift;
    ### _protocol_version: $_[0]
    return $_[0] =~ /^SSH-([\d.]+)/ ? $1 : 0;
}

sub dump {
    my $self = shift;
    $self->scan unless $self->{_scanned};
    ### dump: $self->{_result}

    return sprintf(
        '{"1":{"password":%d,"publickey":%d},"2":{"password":%d,"publickey":%d}}',
        $self->{_result}{1} & $AUTH_IF{password} ? 1 : 0,
        $self->{_result}{1} & $AUTH_IF{rsa}      ? 1 : 0,
        $self->{_result}{2} & $AUTH_IF{password} ? 1 : 0,
        $self->{_result}{2} & $AUTH_IF{rsa}      ? 1 : 0,
       );
}

1;

__END__