home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Netrunner 2004 October
/
NETRUNNER0410.ISO
/
regular
/
ActivePerl-5.8.4.810-MSWin32-x86.msi
/
_58234310b6f81fde18d31099d5fd71e4
< prev
next >
Wrap
Text File
|
2004-06-01
|
15KB
|
520 lines
package PPM::Repository::PPM3Server;
use strict;
use SOAP::Lite 0.51;
use Data::Dumper;
use File::Basename qw(basename);
use Digest::MD5 ();
use PPM::Config;
use PPM::Sysinfo;
use PPM::Result qw(Ok Error Warning List);
use PPM::PPD;
use base qw(PPM::Repository);
our $VERSION = '3.06';
our $PROTOCOL_VERSION = 3;
#==============================================================================
# Note: the server exports this interface:
# describe('language', 'package name');
# getppd('language', 'package name');
# search('language', 'query', 'case-insensitive');
# uptodate('language', 'package name', 'osd-version');
# ppm_protocol();
#
# Note: definition of package_entity:
# package_entity {
# repository_url
# target_type
# target_name
# package_name
# package_version
# }
#
# This part of the interface is for profile management:
# profile_create('name');
# profile_delete('name');
# profile_save('name', package_entity(s));
# profile_info('name');
# profile_target_rename('name', 'oldtarget', 'newtarget');
# profile_rename('oldname', 'newname'); # XXX: emulated on client-side!
#
# This part is for profile tracking:
# installed(package_entity);
# removed(package_entity);
# upgraded(package_entity);
#==============================================================================
sub init {
my $o = shift;
my $file = PPM::Config::get_license_file();
$o->{licfile} = $file;
$o->{mtime} = 0;
$o->{license} = undef;
1;
}
sub check_license {
my $o = $_[0];
my $file = $o->{licfile};
# Reset state unless the license file exists
goto &init unless -f $file;
# Used the cached license unless the license file has changed on disk
my $f_mtime = ((stat($file))[9]);
my $l_mtime = $o->{mtime};
return unless ($f_mtime > $l_mtime or $file ne $o->{liclast});
# Update the cache from the disk
if (open (my $LICENSE, $file)) {
$o->{mtime} = $f_mtime;
$o->{license} = do { local $/; <$LICENSE> };
$o->{liclast} = $file;
close ($LICENSE) or die "can't close license file $file: $!";
}
}
sub search {
my $o = shift;
my $target = shift;
my $query = shift;
my $casei = shift;
# Get all my arguments together:
my $target_t = $target->config_get("TARGET_TYPE")->result;
my @headers = $o->mkheaders(target => $target);
my $response = eval {
$o->{client}->search($target_t, $query, $casei, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
my @results;
for my $res (@{$response->{'results'}}) {
my $h = {
name => $res->[0],
version => $res->[1],
abstract => $res->[2],
};
my $ppd = PPM::Repository::PPM3Server::PPD->new($h, 0);
@$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
push @results, $ppd;
}
List(@results);
}
sub describe {
my $o = shift;
my $target = shift;
my $pkg = shift;
my $target_t = $target->config_get("TARGET_TYPE")->result;
my @headers = $o->mkheaders(target => $target);
my $response = eval {
$o->{client}->describe($target_t, $pkg, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
my $ppd = PPM::Repository::PPM3Server::PPD->new($response->{'results'}, 1);
@$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
Ok($ppd);
}
sub getppd_obj {
my $o = shift;
my $target = shift;
my $pkg = shift;
my $ppd_txt = $o->getppd($target, $pkg);
return $ppd_txt unless $ppd_txt->ok;
my $obj = PPM::PPD::->new($ppd_txt->result, $o, $pkg);
$obj->{from} = 'repository';
Ok($obj);
}
sub getppd {
my $o = shift;
my $target = shift;
my $pkg = shift;
my $target_t = $target->config_get("TARGET_TYPE")->result;
my @headers = $o->mkheaders(target => $target);
my $response = eval {
$o->{client}->getppd($target_t, $pkg, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
Ok($response->{'results'});
}
sub uptodate {
my $o = shift;
my $target = shift;
my $pkg = shift;
my $version = shift;
my $target_t = $target->config_get("TARGET_TYPE")->result;
my @headers = $o->mkheaders(target => $target);
my $response = eval {
# call the more efficient uptodate2 method.
$o->{client}->uptodate2($target_t, $pkg, $version, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
List($response->{results}[0], $response->{results}[1]{version});
# # If the status is false (it's out of date) return the version on the
# # server as the new version.
# my $newversion = '';
# unless ($response->{'results'}) {
# my $ppd = $o->describe($target, $pkg)->result;
# $newversion = $ppd->version;
# }
# List($response->{'results'}, $newversion);
}
sub batch {
my $o = shift;
# The batch() method was introduced in PPM protocol version 303.
return $o->SUPER::batch(@_) unless $o->protocol >= 303;
my $targ = shift;
my @tasks = @_;
my $targ_t = $targ->config_get("TARGET_TYPE")->result;
# Every task needs the target as the first argument, so add it.
for my $task (@tasks) {
splice @$task, 1, 0, $targ_t;
}
my @headers = $o->mkheaders($targ => $targ);
my $response = eval {
$o->{client}->batch($targ_t, @tasks, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
my @responses = @{$response->{results}};
for my $i (0 .. $#tasks) {
my $resp = $responses[$i];
my $meth = $tasks[$i][0];
my $err = $o->errors($resp);
if ($err->ok) {
my $clean_method = "cleanup_$meth";
$responses[$i] = $o->can($clean_method)
? $o->$clean_method($resp->{results})
: Ok($resp->{results});
}
else {
$responses[$i] = $err;
}
}
List(@responses);
}
#=============================================================================
# Cleanup functions for the batch() method.
#=============================================================================
sub cleanup_uptodate2 {
my ($o, $result) = @_;
my $ppd = PPM::Repository::PPM3Server::PPD->new($result->[1], 0);
@$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
$result->[1] = $ppd;
Ok($result);
}
#=============================================================================
# Profiles
#=============================================================================
sub profile_list {
my $o = shift;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_list(@headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
my @profiles = @{$response->{'results'}};
List(@profiles);
}
sub profile_add {
my $o = shift;
my $name = shift;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_create($name, @headers)->result;
};
my $err = $o->errors($response,"profile_create");
return $err unless $err->ok;
Ok();
}
sub profile_del {
my $o = shift;
my $name = shift;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_delete($name, @headers)->result;
};
my $err = $o->errors($response,"profile_delete");
return $err unless $err->ok;
Ok();
}
sub profile_save {
my $o = shift;
my $name = shift;
my @entries = @_;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_save($name, \@entries, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
Ok();
}
sub profile_info {
my $o = shift;
my $name = shift;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_info($name, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
my $entries = $response->{'results'};
List(@$entries);
}
sub profile_target_rename {
my $o = shift;
my $profile = shift;
my $oldname = shift;
my $newname = shift;
my @headers = $o->mkheaders;
my $response = eval {
my @args = ($profile, $oldname, $newname);
$o->{client}->profile_target_rename(@args, @headers)->result;
};
my $err = $o->errors($response);
return $err unless $err->ok;
Ok();
}
# This is a bit of a temporary hack: the server doesn't actually expose a
# profile_rename() method, so I emulate it by retrieving the doomed profile,
# saving it as the new profile, and deleting the other. I suspect this will be
# moved over to the server in future, because it can be lightening-fast if
# done directly in the database.
sub profile_rename {
my $o = shift;
my $oldprof = shift;
my $newprof = shift;
# Retrieve the old profile:
my $info = $o->profile_info($oldprof);
return $info unless $info->ok;
# Delete the new one, but don't croak if it returns an error. This allows
# us to rename over old profiles.
my $purge = $o->profile_del($newprof);
# Create the new one:
my $new = $o->profile_add($newprof);
return $new unless $new->ok;
# Save the new one:
my $save = $o->profile_save($newprof, $info->result_l);
return $save unless $save->ok;
# Delete the old one:
my $del = $o->profile_del($oldprof);
return $del unless $del->ok;
Ok();
}
#=============================================================================
# Profile Tracking:
#=============================================================================
sub installed {
my $o = shift;
my $profile = shift;
my @l = @_;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_pkgs_installed($profile, \@l, @headers)->result;
};
$o->errors($response);
}
sub upgraded {
my $o = shift;
my $profile = shift;
my @l = @_;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_pkgs_upgraded($profile, \@l, @headers)->result;
};
$o->errors($response);
}
sub removed {
my $o = shift;
my $profile = shift;
my @l = @_;
my @headers = $o->mkheaders;
my $response = eval {
$o->{client}->profile_pkgs_removed($profile, \@l, @headers)->result;
};
$o->errors($response);
}
# Calculate a hash of the current user, plus the host and the install time.
# This is useful for tracking how many "users" are using each installation.
my $userhash = PPM::Sysinfo::generate_user_key();
my $insthash = PPM::Sysinfo::inst_key();
# This little helper builds SOAP Headers we can use to send along with the
# SOAP request. The license and other information is sent along with it.
sub mkheaders {
my $o = shift;
my %args = @_;
my @headers;
# By checking the license each time, we can auto-detect new licenses
# without a re-start of PPM:
$o->check_license;
push @headers, SOAP::Header->name('license', $o->{license});
# Push on the ID of this installation of PPM:
push @headers, SOAP::Header->name('ppm_install_id', $insthash);
# Push on a hash of the current user plus hostname & install time. Note
# that we specifically don't want to use all the same elements that went
# into the install_id of this host (hostname, insttime, os, ip_addr). We
# want to have each user get a unique string, but to munge enough extra
# uniqueness that the usernames can't be guessed just by a simple
# dictionary attack against someone sniffing the MD5 keys.
push @headers, SOAP::Header->name('user_hash', $userhash);
# Push on the client's protocol version and "real" version:
push @headers, SOAP::Header->name('client_version', $VERSION);
push @headers, SOAP::Header->name('ppm_protocol',
$PROTOCOL_VERSION);
# This information has to be grabbed from the piece of software actually
# interacting with the user. Currently, there's no way to do that cleanly.
push @headers, SOAP::Header->name('useragent', 'PPM');
push @headers, SOAP::Header->name('useragent_vers', '3.0');
# Push on target-specific stuff:
for my $k (keys %args) {
if ($k eq 'target') {
my $t = $args{$k};
push(@headers,
SOAP::Header->name('archname',
$t->config_get("ARCHITECTURE")->result),
SOAP::Header->name('os', $t->config_get("OSVALUE")->result),
SOAP::Header->name('osvers',
$t->config_get("OSVERSION")->result),
);
}
}
@headers;
}
sub type_printable { "PPMServer 3.0" }
sub errors {
my $o = shift;
my $response = shift;
# assuming that method name here and method name on server are usually
# equivalent. if not, use an optional second argument to supply method
# name.
my $method = shift || (split '::', (caller(1))[3])[-1];
if ($@) {
chomp $@;
return PPM::Repository::Result::->new("$method exception: $@.",
$o->location,
);
}
elsif (not defined $response) {
return
PPM::Repository::Result::->new(
"$method returned undefined results.",
$o->location,
);
}
elsif ($response->{'status'} != 0) {
return PPM::Repository::Result::->new($response->{'message'},
$o->location,
$response->{'status'}
);
}
Ok();
}
package PPM::Repository::PPM3Server::PPD;
our @ISA = qw(PPM::PPD);
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = bless {}, $class;
my $server_ppd = shift;
my $complete = shift;
$self->{is_complete} = $complete;
# Author: "authorname (authoremail)"
if (defined $server_ppd->{'authorname'}) {
$self->{parsed}{AUTHOR} = $server_ppd->{'authorname'};
if (defined $server_ppd->{'authoremail'}) {
$self->{parsed}{AUTHOR} .= " ($server_ppd->{'authoremail'})";
}
}
# Name, title, version, abstract:
for my $field (qw(title abstract version name)) {
$self->{parsed}{"\U$field"} = $server_ppd->{$field};
}
# Implementations:
for my $impl (@{$server_ppd->{implementation}}) {
my $i = bless { ARCHITECTURE => $impl },
'PPM::Repository::PPM3Server::PPD::Implementation';
push @{$self->{parsed}{IMPLEMENTATION}}, $i;
# Dependencies:
for my $dep (@{$server_ppd->{dependency}}) {
my $dep = bless { NAME => $dep->{name},
VERSION => $dep->{version} },
'PPM::Repository::PPM3Server::PPD::Dependency';
push @{$i->{DEPENDENCY}}, $dep;
}
}
return $self;
}
sub version {
my $o = shift;
$o->version_osd;
}
package PPM::Repository::PPM3Server::PPD::Implementation;
our @ISA = qw(PPM::PPD::Implementation);
package PPM::Repository::PPM3Server::PPD::Dependency;
our @ISA = qw(PPM::PPD::Dependency);
sub version {
my $o = shift;
$o->version_osd;
}