home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _58234310b6f81fde18d31099d5fd71e4 < prev    next >
Encoding:
Text File  |  2004-06-01  |  15.0 KB  |  520 lines
  1. package PPM::Repository::PPM3Server;
  2.  
  3. use strict;
  4. use SOAP::Lite 0.51;
  5. use Data::Dumper;
  6. use File::Basename qw(basename);
  7. use Digest::MD5 ();
  8.  
  9. use PPM::Config;
  10. use PPM::Sysinfo;
  11. use PPM::Result qw(Ok Error Warning List);
  12. use PPM::PPD;
  13.  
  14. use base qw(PPM::Repository);
  15. our $VERSION = '3.06';
  16. our $PROTOCOL_VERSION = 3;
  17.  
  18. #==============================================================================
  19. # Note: the server exports this interface:
  20. #   describe('language', 'package name');
  21. #   getppd('language', 'package name');
  22. #   search('language', 'query', 'case-insensitive');
  23. #   uptodate('language', 'package name', 'osd-version');
  24. #   ppm_protocol();
  25. #
  26. # Note: definition of package_entity:
  27. #   package_entity {
  28. #    repository_url
  29. #       target_type
  30. #       target_name
  31. #       package_name
  32. #       package_version
  33. #   }
  34. #
  35. # This part of the interface is for profile management:
  36. #   profile_create('name');
  37. #   profile_delete('name');
  38. #   profile_save('name', package_entity(s));
  39. #   profile_info('name');
  40. #   profile_target_rename('name', 'oldtarget', 'newtarget');
  41. #   profile_rename('oldname', 'newname'); # XXX: emulated on client-side!
  42. #
  43. # This part is for profile tracking:
  44. #   installed(package_entity);
  45. #   removed(package_entity);
  46. #   upgraded(package_entity);
  47. #==============================================================================
  48.  
  49. sub init {
  50.     my $o = shift;
  51.     my $file = PPM::Config::get_license_file();
  52.  
  53.     $o->{licfile} = $file;
  54.     $o->{mtime} = 0;
  55.     $o->{license} = undef;
  56.  
  57.     1;
  58. }
  59.  
  60. sub check_license {
  61.     my $o = $_[0];
  62.     my $file = $o->{licfile};
  63.  
  64.     # Reset state unless the license file exists
  65.     goto &init unless -f $file;
  66.  
  67.     # Used the cached license unless the license file has changed on disk
  68.     my $f_mtime = ((stat($file))[9]);
  69.     my $l_mtime = $o->{mtime};
  70.     return unless ($f_mtime > $l_mtime or $file ne $o->{liclast});
  71.  
  72.     # Update the cache from the disk
  73.     if (open (my $LICENSE, $file)) {
  74.     $o->{mtime}   = $f_mtime;
  75.     $o->{license} = do { local $/; <$LICENSE> };
  76.     $o->{liclast} = $file;
  77.     close ($LICENSE) or die "can't close license file $file: $!";
  78.     }
  79. }
  80.  
  81. sub search {
  82.     my $o = shift;
  83.     my $target = shift;
  84.     my $query = shift;
  85.     my $casei = shift;
  86.  
  87.     # Get all my arguments together:
  88.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  89.     my @headers = $o->mkheaders(target => $target);
  90.     my $response = eval {
  91.     $o->{client}->search($target_t, $query, $casei, @headers)->result;
  92.     };
  93.     my $err = $o->errors($response);
  94.     return $err unless $err->ok;
  95.  
  96.     my @results;
  97.     for my $res (@{$response->{'results'}}) {
  98.     my $h = {
  99.             name => $res->[0], 
  100.             version => $res->[1],
  101.             abstract => $res->[2],
  102.         };
  103.         my $ppd = PPM::Repository::PPM3Server::PPD->new($h, 0);
  104.     @$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
  105.     push @results, $ppd;
  106.     }
  107.     List(@results);
  108. }
  109.  
  110. sub describe {
  111.     my $o = shift;
  112.     my $target = shift;
  113.     my $pkg = shift;
  114.  
  115.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  116.     my @headers = $o->mkheaders(target => $target);
  117.     my $response = eval {
  118.     $o->{client}->describe($target_t, $pkg, @headers)->result;
  119.     };
  120.     my $err = $o->errors($response);
  121.     return $err unless $err->ok;
  122.  
  123.     my $ppd = PPM::Repository::PPM3Server::PPD->new($response->{'results'}, 1);
  124.     @$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
  125.     Ok($ppd);
  126. }
  127.  
  128. sub getppd_obj {
  129.     my $o = shift;
  130.     my $target = shift;
  131.     my $pkg = shift;
  132.     my $ppd_txt = $o->getppd($target, $pkg);
  133.     return $ppd_txt unless $ppd_txt->ok;
  134.     my $obj = PPM::PPD::->new($ppd_txt->result, $o, $pkg);
  135.     $obj->{from} = 'repository';
  136.     Ok($obj);
  137. }
  138.  
  139. sub getppd {
  140.     my $o = shift;
  141.     my $target = shift;
  142.     my $pkg = shift;
  143.  
  144.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  145.     my @headers = $o->mkheaders(target => $target);
  146.     my $response = eval {
  147.     $o->{client}->getppd($target_t, $pkg, @headers)->result;
  148.     };
  149.     my $err = $o->errors($response);
  150.     return $err unless $err->ok;
  151.     Ok($response->{'results'});
  152. }
  153.  
  154. sub uptodate {
  155.     my $o = shift;
  156.     my $target = shift;
  157.     my $pkg = shift;
  158.     my $version = shift;
  159.  
  160.     my $target_t = $target->config_get("TARGET_TYPE")->result;
  161.     my @headers = $o->mkheaders(target => $target);
  162.     my $response = eval {
  163.     # call the more efficient uptodate2 method.
  164.     $o->{client}->uptodate2($target_t, $pkg, $version, @headers)->result;
  165.     };
  166.     my $err = $o->errors($response);
  167.     return $err unless $err->ok;
  168.     List($response->{results}[0], $response->{results}[1]{version});
  169. #    # If the status is false (it's out of date) return the version on the
  170. #    # server as the new version.
  171. #    my $newversion = '';
  172. #    unless ($response->{'results'}) {
  173. #    my $ppd = $o->describe($target, $pkg)->result;
  174. #    $newversion = $ppd->version;
  175. #    }
  176. #    List($response->{'results'}, $newversion);
  177. }
  178.  
  179. sub batch {
  180.     my $o = shift;
  181.     # The batch() method was introduced in PPM protocol version 303.
  182.     return $o->SUPER::batch(@_) unless $o->protocol >= 303;
  183.     my $targ = shift;
  184.     my @tasks = @_;
  185.     my $targ_t = $targ->config_get("TARGET_TYPE")->result;
  186.  
  187.     # Every task needs the target as the first argument, so add it.
  188.     for my $task (@tasks) {
  189.     splice @$task, 1, 0, $targ_t;
  190.     }
  191.     my @headers = $o->mkheaders($targ => $targ);
  192.     my $response = eval {
  193.     $o->{client}->batch($targ_t, @tasks, @headers)->result;
  194.     };
  195.     my $err = $o->errors($response);
  196.     return $err unless $err->ok;
  197.     my @responses = @{$response->{results}};
  198.     for my $i (0 .. $#tasks) {
  199.     my $resp = $responses[$i];
  200.     my $meth = $tasks[$i][0];
  201.     my $err = $o->errors($resp);
  202.     if ($err->ok) {
  203.         my $clean_method = "cleanup_$meth";
  204.         $responses[$i] = $o->can($clean_method)
  205.         ? $o->$clean_method($resp->{results})
  206.         : Ok($resp->{results});
  207.     }
  208.     else {
  209.         $responses[$i] = $err;
  210.     }
  211.     }
  212.     List(@responses);
  213. }
  214.  
  215. #=============================================================================
  216. # Cleanup functions for the batch() method.
  217. #=============================================================================
  218. sub cleanup_uptodate2 {
  219.     my ($o, $result) = @_;
  220.     my $ppd = PPM::Repository::PPM3Server::PPD->new($result->[1], 0);
  221.     @$ppd{qw(rep id from)} = ($o, $ppd->name, 'repository');
  222.     $result->[1] = $ppd;
  223.     Ok($result);
  224. }
  225.  
  226. #=============================================================================
  227. # Profiles
  228. #=============================================================================
  229. sub profile_list {
  230.     my $o = shift;
  231.     my @headers = $o->mkheaders;
  232.     my $response = eval {
  233.     $o->{client}->profile_list(@headers)->result;
  234.     };
  235.     my $err = $o->errors($response);
  236.     return $err unless $err->ok;
  237.  
  238.     my @profiles = @{$response->{'results'}};
  239.     List(@profiles);
  240. }
  241.  
  242. sub profile_add {
  243.     my $o = shift;
  244.     my $name = shift;
  245.     my @headers = $o->mkheaders;
  246.     my $response = eval {
  247.     $o->{client}->profile_create($name, @headers)->result;
  248.     };
  249.     my $err = $o->errors($response,"profile_create");
  250.     return $err unless $err->ok;
  251.     Ok();
  252. }
  253.  
  254. sub profile_del {
  255.     my $o = shift;
  256.     my $name = shift;
  257.     my @headers = $o->mkheaders;
  258.     my $response = eval {
  259.     $o->{client}->profile_delete($name, @headers)->result;
  260.     };
  261.     my $err = $o->errors($response,"profile_delete");
  262.     return $err unless $err->ok;
  263.     Ok();
  264. }
  265.  
  266. sub profile_save {
  267.     my $o = shift;
  268.     my $name = shift;
  269.     my @entries = @_;
  270.     my @headers = $o->mkheaders;
  271.     my $response = eval {
  272.     $o->{client}->profile_save($name, \@entries, @headers)->result;
  273.     };
  274.     my $err = $o->errors($response);
  275.     return $err unless $err->ok;
  276.     Ok();
  277. }
  278.  
  279. sub profile_info {
  280.     my $o = shift;
  281.     my $name = shift;
  282.     my @headers = $o->mkheaders;
  283.     my $response = eval {
  284.     $o->{client}->profile_info($name, @headers)->result;
  285.     };
  286.     my $err = $o->errors($response);
  287.     return $err unless $err->ok;
  288.     my $entries = $response->{'results'};
  289.     List(@$entries);
  290. }
  291.  
  292. sub profile_target_rename {
  293.     my $o = shift;
  294.     my $profile = shift;
  295.     my $oldname = shift;
  296.     my $newname = shift;
  297.     my @headers = $o->mkheaders;
  298.     my $response = eval {
  299.     my @args = ($profile, $oldname, $newname);
  300.     $o->{client}->profile_target_rename(@args, @headers)->result;
  301.     };
  302.     my $err = $o->errors($response);
  303.     return $err unless $err->ok;
  304.     Ok();
  305. }
  306.  
  307. # This is a bit of a temporary hack: the server doesn't actually expose a
  308. # profile_rename() method, so I emulate it by retrieving the doomed profile,
  309. # saving it as the new profile, and deleting the other. I suspect this will be
  310. # moved over to the server in future, because it can be lightening-fast if
  311. # done directly in the database.
  312. sub profile_rename {
  313.     my $o = shift;
  314.     my $oldprof = shift;
  315.     my $newprof = shift;
  316.  
  317.     # Retrieve the old profile:
  318.     my $info = $o->profile_info($oldprof);
  319.     return $info unless $info->ok;
  320.  
  321.     # Delete the new one, but don't croak if it returns an error. This allows
  322.     # us to rename over old profiles.
  323.     my $purge = $o->profile_del($newprof);
  324.  
  325.     # Create the new one:
  326.     my $new = $o->profile_add($newprof);
  327.     return $new unless $new->ok;
  328.  
  329.     # Save the new one:
  330.     my $save = $o->profile_save($newprof, $info->result_l);
  331.     return $save unless $save->ok;
  332.  
  333.     # Delete the old one:
  334.     my $del = $o->profile_del($oldprof);
  335.     return $del unless $del->ok;
  336.  
  337.     Ok();
  338. }
  339.  
  340. #=============================================================================
  341. # Profile Tracking:
  342. #=============================================================================
  343. sub installed {
  344.     my $o = shift;
  345.     my $profile = shift;
  346.     my @l = @_;
  347.     my @headers = $o->mkheaders;
  348.     my $response = eval {
  349.     $o->{client}->profile_pkgs_installed($profile, \@l, @headers)->result;
  350.     };
  351.     $o->errors($response);
  352. }
  353.  
  354. sub upgraded {
  355.     my $o = shift;
  356.     my $profile = shift;
  357.     my @l = @_;
  358.     my @headers = $o->mkheaders;
  359.     my $response = eval {
  360.     $o->{client}->profile_pkgs_upgraded($profile, \@l, @headers)->result;
  361.     };
  362.     $o->errors($response);
  363. }
  364.  
  365. sub removed {
  366.     my $o = shift;
  367.     my $profile = shift;
  368.     my @l = @_;
  369.     my @headers = $o->mkheaders;
  370.     my $response = eval {
  371.     $o->{client}->profile_pkgs_removed($profile, \@l, @headers)->result;
  372.     };
  373.     $o->errors($response);
  374. }
  375.  
  376. # Calculate a hash of the current user, plus the host and the install time.
  377. # This is useful for tracking how many "users" are using each installation.
  378. my $userhash = PPM::Sysinfo::generate_user_key();
  379. my $insthash = PPM::Sysinfo::inst_key();
  380.  
  381. # This little helper builds SOAP Headers we can use to send along with the
  382. # SOAP request. The license and other information is sent along with it.
  383. sub mkheaders {
  384.     my $o = shift;
  385.     my %args = @_;
  386.     my @headers;
  387.  
  388.     # By checking the license each time, we can auto-detect new licenses
  389.     # without a re-start of PPM:
  390.     $o->check_license;
  391.     push @headers, SOAP::Header->name('license', $o->{license});
  392.  
  393.     # Push on the ID of this installation of PPM:
  394.     push @headers, SOAP::Header->name('ppm_install_id', $insthash);
  395.  
  396.     # Push on a hash of the current user plus hostname & install time. Note
  397.     # that we specifically don't want to use all the same elements that went
  398.     # into the install_id of this host (hostname, insttime, os, ip_addr). We
  399.     # want to have each user get a unique string, but to munge enough extra
  400.     # uniqueness that the usernames can't be guessed just by a simple
  401.     # dictionary attack against someone sniffing the MD5 keys.
  402.     push @headers, SOAP::Header->name('user_hash', $userhash);
  403.  
  404.     # Push on the client's protocol version and "real" version:
  405.     push @headers, SOAP::Header->name('client_version', $VERSION);
  406.     push @headers, SOAP::Header->name('ppm_protocol',
  407.                       $PROTOCOL_VERSION);
  408.  
  409.     # This information has to be grabbed from the piece of software actually
  410.     # interacting with the user. Currently, there's no way to do that cleanly.
  411.     push @headers, SOAP::Header->name('useragent', 'PPM');
  412.     push @headers, SOAP::Header->name('useragent_vers', '3.0');
  413.  
  414.     # Push on target-specific stuff:
  415.     for my $k (keys %args) {
  416.     if ($k eq 'target') {
  417.         my $t = $args{$k};
  418.         push(@headers,
  419.              SOAP::Header->name('archname',
  420.                     $t->config_get("ARCHITECTURE")->result),
  421.          SOAP::Header->name('os', $t->config_get("OSVALUE")->result),
  422.          SOAP::Header->name('osvers',
  423.                      $t->config_get("OSVERSION")->result),
  424.         );
  425.     }
  426.     }
  427.     @headers;
  428. }
  429.  
  430. sub type_printable { "PPMServer 3.0" }
  431.  
  432. sub errors {
  433.     my $o = shift;
  434.     my $response = shift;
  435.  
  436.     # assuming that method name here and method name on server are usually
  437.     # equivalent.  if not, use an optional second argument to supply method
  438.     # name.
  439.     my $method = shift || (split '::', (caller(1))[3])[-1];
  440.  
  441.     if ($@) {
  442.     chomp $@;
  443.     return PPM::Repository::Result::->new("$method exception: $@.",
  444.                           $o->location,
  445.                              );
  446.     }
  447.     elsif (not defined $response) {
  448.     return
  449.       PPM::Repository::Result::->new(
  450.           "$method returned undefined results.",
  451.           $o->location,
  452.       );
  453.     }
  454.     elsif ($response->{'status'} != 0) {
  455.     return PPM::Repository::Result::->new($response->{'message'},
  456.                           $o->location,
  457.                           $response->{'status'}
  458.                          );
  459.     }
  460.     Ok();
  461. }
  462.  
  463. package PPM::Repository::PPM3Server::PPD;
  464. our @ISA = qw(PPM::PPD);
  465.  
  466. sub new {
  467.     my $this = shift;
  468.     my $class = ref($this) || $this;
  469.     my $self = bless {}, $class;
  470.     my $server_ppd = shift;
  471.     my $complete = shift;
  472.  
  473.     $self->{is_complete} = $complete;
  474.  
  475.     # Author:  "authorname (authoremail)"
  476.     if (defined $server_ppd->{'authorname'}) {
  477.         $self->{parsed}{AUTHOR} = $server_ppd->{'authorname'};
  478.         if (defined $server_ppd->{'authoremail'}) {
  479.             $self->{parsed}{AUTHOR} .= " ($server_ppd->{'authoremail'})";
  480.         }
  481.     }
  482.     
  483.     # Name, title, version, abstract:
  484.     for my $field (qw(title abstract version name)) {
  485.     $self->{parsed}{"\U$field"} = $server_ppd->{$field};
  486.     }
  487.  
  488.     # Implementations:
  489.     for my $impl (@{$server_ppd->{implementation}}) {
  490.     my $i = bless { ARCHITECTURE => $impl },
  491.               'PPM::Repository::PPM3Server::PPD::Implementation';
  492.     push @{$self->{parsed}{IMPLEMENTATION}}, $i;
  493.  
  494.     # Dependencies:
  495.     for my $dep (@{$server_ppd->{dependency}}) {
  496.         my $dep = bless { NAME => $dep->{name},
  497.                   VERSION => $dep->{version} },
  498.                 'PPM::Repository::PPM3Server::PPD::Dependency';
  499.         push @{$i->{DEPENDENCY}}, $dep;
  500.     }
  501.     }
  502.     return $self;
  503. }
  504.  
  505. sub version {
  506.     my $o = shift;
  507.     $o->version_osd;
  508. }
  509.  
  510. package PPM::Repository::PPM3Server::PPD::Implementation;
  511. our @ISA = qw(PPM::PPD::Implementation);
  512.  
  513. package PPM::Repository::PPM3Server::PPD::Dependency;
  514. our @ISA = qw(PPM::PPD::Dependency);
  515.  
  516. sub version {
  517.     my $o = shift;
  518.     $o->version_osd;
  519. }
  520.