view release on metacpan or  search on metacpan

lib/Net/SSH/Any/Backend/Net_SSH2.pm  view on Meta::CPAN

do {
    local ($@, $SIG{__DIE__});
    for my $c (keys %C) {
        if (defined (my $v = eval "Net::SSH2::LIBSSH2_$c()")) {
            $C{$c} = $v;
        }
    }
};

sub __copy_error {
    my ($any, $code) = @_;
    my $ssh2 = $any->{be_ssh2}
        or die "internal error: __copy_error called, but there is no ssh2 object";
    my ($error, $error_name, $error_msg) = $ssh2->error;
    $error or die "internal error: __copy_error called, but there is no error";
    $error_msg ||= $error_name;

    if ($error == $C{ERROR_EAGAIN}) {
        # most libssh2 functions can't recover from an EAGAIN error
        # leaving the connection in a broken state. We catch that case
        # marking the connection as lost. Note that the functions that
        # can recover, return LIBSSH2_ERROR_EAGAIN but leave the
        # internal error field as 0
        $any->_set_error(SSHA_CONNECTION_ERROR,
                         "connection lost: internal libssh2 error, unhandled EAGAIN, $error_msg");
    }
    else {
        $any->_set_error($code || SSHA_CHANNEL_ERROR, $error_msg);
    }
    return;
}

sub __check_host_key {
    my $any = shift;
    my $ssh2 = $any->{be_ssh2} or croak "internal error: be_ssh2 is not set";
    my $be_opts = $any->{be_opts};

    my $hostkey_method = $ssh2->can('remote_hostkey');
    unless ($hostkey_method) {
        carp "The version of Net::SSH2 installed ($Net::SSH2::VERSION) doesn't support " .
            "checking the host key against a known_hosts file. This script is exposed to ".
                "man-in-the-middle atacks!!!";
        return 1;
    }

    my ($key, $type) = $hostkey_method->($ssh2);

    my $known_hosts_path = $be_opts->{known_hosts_path};
    unless (defined $known_hosts_path) {
        my $config_dir;
        if ($windows) {
            $any->_load_module('Win32') or return;
            my $appdata = Win32::GetFolderPath(Win32::CSIDL_APPDATA());
            unless (defined $appdata) {
                $any->_set_error(SSHA_CONNECTION_ERROR, "unable to determine directory for user application data");
                return;
            }
            $config_dir = File::Spec->join($appdata, 'libnet-ssh-any-perl');
        }
        else {
            my $home = (getpwuid $>)[7];
            $home = $ENV{HOME} unless defined $home;
            unless (defined $home) {
                $any->_set_error(SSHA_CONNECTION_ERROR, "unable to determine user home directory");
                return;
            }
            $config_dir = File::Spec->join($home, '.ssh');
        }
        unless (-d $config_dir or mkdir $config_dir, 0700) {
            $any->_set_error(SSHA_CONNECTION_ERROR, "unable to create directory '$config_dir': $^E");
            return;
        }
        $known_hosts_path = File::Spec->join($config_dir, 'known_hosts');
    }

    $debug and $debug & 1024 and _debug "reading known host keys from '$known_hosts_path'";

    local ($@, $SIG{__DIE__});

    my $kh = $ssh2->known_hosts;
    my $ok = eval { $kh->readfile($known_hosts_path) };
    unless (defined $ok) {
        $debug and $debug & 1024 and _debug "unable to read known hosts file: " . $ssh2->error;
        if ($ssh2->error == $C{ERROR_FILE}) {
            if (-f $known_hosts_path) {
                $any->_set_error(SSHA_CONNECTION_ERROR, "unable to read known_hosts file at '$known_hosts_path'");
                return;
            }
            # a non-existent file is not an error, continue...
        }
        else {
            $any->_set_error(SSHA_CONNECTION_ERROR,
                             "Unable to parse known_hosts file at '$known_hosts_path': ". ($ssh2->error)[2]);
            return;
        }
    }

    if ($debug and $debug & 1024) {
        _debug "remote key is of type $type";
        _debug_hexdump("key", $key);
    }

    my $key_type = ( $C{KNOWNHOST_TYPE_PLAIN} |
                     $C{KNOWNHOST_KEYENC_RAW} |
                     (($type + 1) << $C{KNOWNHOST_KEY_SHIFT}) );

    my $check = $kh->check($be_opts->{host}, $be_opts->{port}, $key, $key_type);

    if ($check == $C{KNOWNHOST_CHECK_MATCH}) {
        $debug and $debug & 1024 and _debug("host key matched");
        return 1;
    }
    elsif ($check == $C{KNOWNHOST_CHECK_MISMATCH}) {
        $debug and $debug & 1024 and _debug("host key found but did not match");
        $any->_set_error(SSHA_CONNECTION_ERROR, "The host key for '$be_opts->{host}' has changed");
        return;
    }
    elsif ($check == $C{KNOWNHOST_CHECK_NOTFOUND}) {
        $debug and $debug & 1024 and _debug("host key not found in known_hosts");
        if ($be_opts->{strict_host_key_checking}) {
            $any->_set_error(SSHA_CONNECTION_ERROR, "the authenticity of host '$be_opts->{host}' can't be established");

lib/Net/SSH/Any/Backend/Net_SSH2.pm  view on Meta::CPAN

}

sub _validate_backend_opts {
    my ($any, %be_opts) = @_;
    my $mod_ver = do { no warnings; 0 + $Net::SSH2::VERSION };
    if ($mod_ver < 0.59) {
        $any->_set_error(SSHA_CONNECTION_ERROR,
                         "The version of Net::SSH2 available ($Net::SSH2::VERSION) is too old. ".
                         "0.59 or later required");
        return;
    }

    my @lib_ver = Net::SSH2::version();
    $debug and $debug & 1024 and _debug "libssh2 version $lib_ver[2]";
    if ($lib_ver[1] < 0x010500) {
        $any->_set_error(SSHA_CONNECTION_ERROR,
                         "Net::SSH2 was compiled against an old unsupported version of libssh2 ($lib_ver[2])");
        return;
    }

    my $ssh2 = $any->{be_ssh2} = Net::SSH2->new;
    unless ($ssh2) {
        $any->_set_error(SSHA_CONNECTION_ERROR, "Unable to create Net::SSH2 object");
        return;
    }
    $debug and $debug & 2048 and $ssh2->trace(~0); #~$C{TRACE_TRANS});

    $ssh2->timeout(1000 * ($be_opts{timeout} // $be_opts{io_timeout}));

    if ($be_opts{compress}) {
        if (defined(my $flag_method = $ssh2->can('flag'))) {
            $debug and $debug & 1024 and _debug "enabling compression";
            $flag_method->($ssh2, $C{FLAG_COMPRESS}, 1);
        }
    }

    $any->{be_opts} = \%be_opts;
    1;
}

sub _connect {
    my $any = shift;
    my $ssh2 = $any->{be_ssh2} or return;
    my $be_opts = $any->{be_opts};
    my $socket = IO::Socket::INET->new(PeerHost => $be_opts->{host},
                                       PeerPort => ($be_opts->{port} || 22),
                                       ($be_opts->{timeout} ? (Timeout => $be_opts->{timeout}) : ()));
    if ($socket) {
        $socket->sockopt(SO_LINGER, pack(SS => 0, 0));
        $socket->sockopt(SO_KEEPALIVE, 1);
    }
    unless ($socket and $ssh2->connect($socket)) {
        return $any->_set_error(SSHA_CONNECTION_ERROR, "Unable to connect to remote host");
    }
    $debug and $debug & 1024 and _debug 'COMP_SC: ' . $ssh2->method('COMP_SC') . ' COMP_CS: ' .$ssh2->method('COMP_CS');

    __check_host_key($any) or return;

    my %aa;
    $aa{username} = _first_defined($be_opts->{user},
                                   eval { (getpwuid $<)[0] },
                                   eval { getlogin() });
    $aa{password} = $be_opts->{password} if defined $be_opts->{password};
    $aa{passphrase} = $be_opts->{passphrase} if defined $be_opts->{passphrase};
    if (defined (my $private = $be_opts->{key_path})) {
        unless (-f $private) {
            $any->_set_error(SSHA_CONNECTION_ERROR, "Private key '$private' does not exist on file system");
            return;
        }
        my $public = $private.".pub";
        unless (-f $public) {
            $any->_set_error(SSHA_CONNECTION_ERROR, "Public key '$public' does not exist on file system");
            return;
        }
        $aa{privatekey} = $private;
        $aa{publickey}  = $public;
    }
    # TODO: use default user keys on ~/.ssh/id_dsa and ~/.ssh/id_rsa

    $debug and $debug & 1024 and _debug_dump "Net::SSH2 authentication args", \%aa;

    $ssh2->auth(%aa, interact => !$be_opts->{batch_mode});
    unless ($ssh2->auth_ok) {
        $any->_set_error(SSHA_CONNECTION_ERROR, "Authentication failed");
        return;
    }

    $any->{be_fileno} = fileno $ssh2->sock;
    $debug and $debug & 1024 and _debug("SSH socket file descriptor: $any->{be_fileno}");
    $any->{be_select_bm} = '';
    vec ($any->{be_select_bm}, $any->{be_fileno}, 1) = 1;
    1;
}

# those are the operations that can be safely carried on in a
# non-blocking fashion:
my %non_blocking_method = (read => 1);

sub _channel_do {
    my $any = shift;
    my $channel = shift;
    my $blocking = shift;
    my $method = shift;
    if ($any->error == SSHA_CONNECTION_ERROR) {
        $debug and $debug & 1024 and _debug "skipping $channel->$method call because connection is broken";
        return
    }
    my $ssh2 = $any->{be_ssh2};
    $blocking ||= !$non_blocking_method{$method};
    $ssh2->blocking($blocking);

    $debug and $debug & 1024 and _debug "calling $channel->$method with ", scalar(@_), " args";

    my $time_limit = time + $any->{io_timeout};
    while (1) {
        my $rc = $channel->$method(@_);
        $debug and $debug & 1024 and _debug "$channel->$method rc: ", $rc;
        return $rc if defined $rc;
        my ($error, $error_name, $error_msg) = $ssh2->error;
        # We assume Net::SSH2 masked a LIBSSH2_ERROR_EAGAIN if
        # both $rc and $ssh->error are unset