diff --git a/bs_copy/BSHTTP.pm b/bs_copy/BSHTTP.pm new file mode 100644 index 00000000..994a2238 --- /dev/null +++ b/bs_copy/BSHTTP.pm @@ -0,0 +1,401 @@ +# +# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program (see the file COPYING); if not, write to the +# Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA +# +################################################################ +# +# HTTP protocol functions. Also contains file/cpio sender/receiver. +# + +package BSHTTP; + +use Digest::MD5 (); + +use strict; + +sub gethead { + my ($h, $t) = @_; + + my ($field, $data); + for (split(/[\r\n]+/, $t)) { + next if $_ eq ''; + if (/^[ \t]/) { + next unless defined $field; + s/^\s*/ /; + $h->{$field} .= $_; + } else { + ($field, $data) = split(/\s*:\s*/, $_, 2); + $field =~ tr/A-Z/a-z/; + if ($h->{$field} && $h->{$field} ne '') { + $h->{$field} = $h->{$field}.','.$data; + } else { + $h->{$field} = $data; + } + } + } +} + +# +# read data from socket, do chunk decoding +# hdr: header data +# maxl = undef: read as much as you can +# exact = 1: read maxl data, maxl==undef -> read to eof; +# +sub read_data { + my ($hdr, $maxl, $exact) = @_; + + my $ret = ''; + local *S = $hdr->{'__socket'}; + if ($hdr->{'transfer-encoding'} && lc($hdr->{'transfer-encoding'}) eq 'chunked') { + my $cl = $hdr->{'__cl'} || 0; + if ($cl < 0) { + die("unexpected EOF\n") if $exact && defined($maxl) && length($ret) < $maxl; + return $ret; + } + my $qu = $hdr->{'__data'}; + while(1) { + if (defined($maxl) && $maxl <= $cl) { + while(length($qu) < $maxl) { + my $r = sysread(S, $qu, 8192, length($qu)); + die("unexpected EOF\n") unless $r; + } + $ret .= substr($qu, 0, $maxl); + $hdr->{'__cl'} = $cl - $maxl; + $hdr->{'__data'} = substr($qu, $maxl); + return $ret; + } + if ($cl) { + # no maxl or maxl > cl, read full cl + while(length($qu) < $cl) { + my $r = sysread(S, $qu, 8192, length($qu)); + die("unexpected EOF\n") unless $r; + } + $ret .= substr($qu, 0, $cl); + $qu = substr($qu, $cl); + $maxl -= $cl if defined $maxl; + $cl = 0; + if (!defined($maxl) && !$exact) { # no maxl, return every chunk + $hdr->{'__cl'} = $cl; + $hdr->{'__data'} = $qu; + return $ret; + } + } + while ($qu !~ /\r?\n/s) { + my $r = sysread(S, $qu, 8192, length($qu)); + die("unexpected EOF\n") unless $r; + } + if (substr($qu, 0, 1) eq "\n") { + $qu = substr($qu, 1); + next; + } + if (substr($qu, 0, 2) eq "\r\n") { + $qu = substr($qu, 2); + next; + } + die("bad CHUNK data: $qu\n") unless $qu =~ /^([0-9a-fA-F]+)/; + $cl = hex($1); + die if $cl < 0; + $qu =~ s/^.*?\r?\n//s; + if ($cl == 0) { + $hdr->{'__cl'} = -1; # mark EOF + die("unexpected EOF\n") if $exact && defined($maxl) && length($ret) < $maxl; + # read trailer + $qu = "\r\n$qu"; + while ($qu !~ /\n\r?\n/s) { + my $r = sysread(S, $qu, 8192, length($qu)); + die("unexpected EOF\n") unless $r; + } + $qu =~ /^(.*?)\n\r?\n/; + gethead($hdr, length($1) >= 2 ? substr($1, 2) : ''); + return $ret; + } + } + } else { + my $qu = $hdr->{'__data'}; + my $cl = $hdr->{'__cl'}; + $cl = $hdr->{'content-length'} unless defined $cl; + if (defined($cl) && (!defined($maxl) || $maxl > $cl)) { + die("unexpected EOF\n") if $exact && defined($maxl); + $maxl = $cl >= 0 ? $cl : 0; + } + while (!defined($maxl) || length($qu) < $maxl) { + my $m = ($maxl || 0) - length($qu); + $m = 8192 if $m < 8192; + my $r = sysread(S, $qu, $m, length($qu)); + if (!$r) { + die("unexpected EOF\n") if defined($cl) || ($exact && defined($maxl)); + $cl = $maxl = length($qu); + } + } + $cl -= $maxl if defined($cl); + $ret = substr($qu, 0, $maxl); + $hdr->{'__cl'} = $cl; + $hdr->{'__data'} = substr($qu, $maxl); + return $ret; + } +} + +sub str2hdr { + my ($str) = @_; + my $hdr = { + '__data' => $str, + '__cl' => length($str), + }; + return $hdr; +} + +sub fd2hdr { + my ($fd) = @_; + my $hdr = { + '__data' => '', + '__socket' => $fd, + '__cl' => -s *$fd, + }; + return $hdr; +} + +sub file_receiver { + my ($hdr, $param) = @_; + + die("file_receiver: no filename\n") unless defined $param->{'filename'}; + my $fn = $param->{'filename'}; + my $withmd5 = $param->{'withmd5'}; + local *F; + my $ctx; + $ctx = Digest::MD5->new if $withmd5; + open(F, '>', $fn) || die("$fn: $!\n"); + my $size = 0; + while(1) { + my $s = read_data($hdr, 8192); + last if $s eq ''; + (syswrite(F, $s) || 0) == length($s) || die("syswrite: $!\n"); + $size += length($s); + $ctx->add($s) if $ctx; + } + close(F) || die("close: $!\n"); + my $res = {size => $size}; + $res->{'md5'} = $ctx->hexdigest if $ctx; + return $res; +} + +sub cpio_receiver { + my ($hdr, $param) = @_; + my @res; + my $dn = $param->{'directory'}; + my $withmd5 = $param->{'withmd5'}; + local *F; + while(1) { + my $cpiohead = read_data($hdr, 110, 1); + die("cpio: not a 'SVR4 no CRC ascii' cpio\n") unless substr($cpiohead, 0, 6) eq '070701'; + my $mode = hex(substr($cpiohead, 14, 8)); + my $mtime = hex(substr($cpiohead, 46, 8)); + my $size = hex(substr($cpiohead, 54, 8)); + if ($size == 0xffffffff) { + # build service length extension + $cpiohead .= read_data($hdr, 16, 1); + $size = hex(substr($cpiohead, 62, 8)) * 4294967296. + hex(substr($cpiohead, 70, 8)); + substr($cpiohead, 62, 16) = ''; + } + my $nsize = hex(substr($cpiohead, 94, 8)); + die("ridiculous long filename\n") if $nsize > 8192; + my $nsizepad = $nsize; + $nsizepad += 4 - ($nsize + 2 & 3) if $nsize + 2 & 3; + my $name = read_data($hdr, $nsizepad, 1); + $name =~ s/\0.*//s; + $name =~ s/^\.\///s; + my $sizepad = $size; + $sizepad += 4 - ($size % 4) if $size % 4; + last if !$size && $name eq 'TRAILER!!!'; + if ($param->{'acceptsubdirs'} || $param->{'createsubdirs'}) { + die("cpio filename is illegal: $name\n") if "/$name/" =~ /\/\.{0,2}\//s; + } else { + die("cpio filename contains a '/': $name\n") if $name =~ /\//s; + } + die("cpio filename is '.' or '..'\n") if $name eq '.' || $name eq '..'; + my $ent = {'name' => $name, 'size' => $size, 'mtime' => $mtime, 'mode' => $mode}; + if ($param->{'accept'}) { + if (ref($param->{'accept'})) { + die("illegal file in cpio archive: $name\n") unless $param->{'accept'}->($param, $name, $ent); + } else { + die("illegal file in cpio archive: $name\n") unless $name =~ /$param->{'accept'}/; + } + } + if ($param->{'map'}) { + $ent->{'unmappedname'} = $name; + if (ref($param->{'map'})) { + $ent->{'name'} = $name = $param->{'map'}->($param, $name); + } else { + $ent->{'name'} = $name = "$param->{'map'}$name"; + } + } + if (!defined($name)) { + # skip entry + while ($sizepad) { + my $m = $sizepad > 8192 ? 8192 : $sizepad; + read_data($hdr, $m, 1); + $sizepad -= $m; + } + next; + } + push @res, $ent; + my $ctx; + $ctx = Digest::MD5->new if $withmd5; + if (defined($dn)) { + my $filename = "$dn/$name"; + if (($mode & 0xf000) == 0x4000 && $param->{'createsubdirs'}) { + die("directory has non-zero size\n") if $sizepad; + if (! -d $filename) { + unlink($filename) unless $param->{'no_unlink'}; + mkdir($filename) || die("mkdir $filename: $!\n"); + } + } else { + die("can only unpack plain files from cpio archive, file $name, mode was $mode\n") unless ($mode & 0xf000) == 0x8000; + unlink($filename) unless $param->{'no_unlink'}; + open(F, '>', $filename) || die("$filename: $!\n"); + } + } else { + $ent->{'data'} = ''; + } + while ($sizepad) { + my $m = $sizepad > 8192 ? 8192 : $sizepad; + my $data = read_data($hdr, $m, 1); + $sizepad -= $m; + $size -= $m; + $m += $size if $size < 0; + if (defined($dn)) { + (syswrite(F, $data, $m) || 0) == $m || die("syswrite: $!\n"); + } else { + $ent->{'data'} .= substr($data, 0, $m); + } + $ctx->add($size >= 0 ? $data : substr($data, 0, $m)) if $ctx; + } + if (defined($dn) && ($mode & 0xf000) != 0x4000) { + close(F) || die("close: $!\n"); + utime($mtime, $mtime, "$dn/$name"); + } + $ent->{'md5'} = $ctx->hexdigest if $ctx && ($mode & 0xf000) != 0x4000; + $param->{'cpiopostfile'}->($param, $ent) if $param->{'cpiopostfile'}; + } + return \@res; +} + +sub swrite { + my ($sock, $data) = @_; + local *S = $sock; + while (length($data)) { + my $l = syswrite(S, $data, length($data)); + die("socket write: $!\n") unless $l; + $data = substr($data, $l); + } +} + +sub cpio_sender { + my ($param, $sock) = @_; + + my $errors = ''; + local *F; + my $data; + for my $file (@{$param->{'cpiofiles'} || []}, {'__errors' => 1}) { + my @s; + if ($file->{'error'}) { + $errors .= "$file->{'name'}: $file->{'error'}\n"; + next; + } + if (exists $file->{'filename'}) { + if (ref($file->{'filename'})) { + *F = $file->{'filename'}; + } elsif (!open(F, '<', $file->{'filename'})) { + $errors .= "$file->{'name'}: $file->{'filename'}: $!\n"; + next; + } + @s = stat(F); + } else { + if ($file->{'__errors'}) { + next if $errors eq ''; + $file->{'data'} = $errors; + $file->{'name'} = ".errors"; + } + $s[7] = length($file->{'data'}); + $s[9] = time; + } + my $mode = $file->{'mode'} || 0x81a4; + $data = sprintf("07070100000000%08x000000000000000000000001", $mode); + if ($s[7] > 0xffffffff) { + # build service length extension + my $top = int($s[7] / 4294967296.); + $data .= sprintf("%08xffffffff%08x%08x", $s[9], $top, $s[7] - $top * 4294967296.); + } else { + $data .= sprintf("%08x%08x", $s[9], $s[7]); + } + $data .= "00000000000000000000000000000000"; + $data .= sprintf("%08x", length($file->{'name'}) + 1); + $data .= "00000000"; + $data .= "$file->{'name'}\0"; + $data .= substr("\0\0\0\0", (length($data) & 3)) if length($data) & 3; + if (exists $file->{'filename'}) { + my $l = $s[7]; + my $r = 0; + while(1) { + $r = sysread(F, $data, $l > 8192 ? 8192 : $l, length($data)) if $l; + $data .= substr("\0\0\0\0", ($s[7] % 4)) if $r == $l && ($s[7] % 4) != 0; + $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; + swrite($sock, $data); + $data = ''; + $l -= $r; + last unless $l; + } + die("internal error\n") if $l; + close F unless ref $file->{'filename'}; + } else { + $data .= $file->{'data'}; + $data .= substr("\0\0\0\0", (length($data) & 3)) if length($data) & 3; + $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; + swrite($sock, $data); + } + } + $data = "07070100000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000b00000000TRAILER!!!\0\0\0\0"; + $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; + swrite($sock, $data); + return ''; +} + +sub file_sender { + my ($param, $sock) = @_; + local *F; + + my $bytes = $param->{'bytes'}; + my $data; + if (ref($param->{'filename'})) { + *F = $param->{'filename'}; + } else { + open(F, '<', $param->{'filename'}) || die("$param->{'filename'}: $!\n") + } + while(1) { + last if defined($bytes) && !$bytes; + my $r = sysread(F, $data, 8192); + last unless $r; + if ($bytes) { + $data = substr($data, 0, $bytes) if length($data) > $bytes; + $bytes -= length($data); + } + $data = sprintf("%X\r\n", length($data)).$data."\r\n" if $param->{'chunked'}; + swrite($sock, $data); + } + close F unless ref $param->{'filename'}; + return ''; +} + +1; diff --git a/bs_copy/BSRPC.pm b/bs_copy/BSRPC.pm new file mode 100644 index 00000000..c3b3fac3 --- /dev/null +++ b/bs_copy/BSRPC.pm @@ -0,0 +1,354 @@ +# +# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program (see the file COPYING); if not, write to the +# Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA +# +################################################################ +# +# Run a HTTP query operation. Single thread only. +# + +package BSRPC; + +use Socket; +use XML::Structured; +use Symbol; +use MIME::Base64; +use Data::Dumper; + +use BSHTTP; + +use strict; + +our $useragent = 'BSRPC 0.9.1'; + +my %hostlookupcache; +my %cookiestore; # our session store to keep iChain fast +my $tossl; + +my $noproxy; + +sub import { + if (grep {$_ eq ':https'} @_) { + require BSSSL; + $tossl = \&BSSSL::tossl; + } +} + + +my $tcpproto = getprotobyname('tcp'); + +sub urlencode { + my $url = $_[0]; + $url =~ s/([\000-\040<>;\"#\?&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge; + return $url; +} + +sub createuri { + my ($param, @args) = @_; + my $uri = $param->{'uri'}; + if (!$param->{'verbatim_uri'} && $uri =~ /^(https?:\/\/[^\/]*\/)(.*)$/s) { + $uri = $1; + $uri .= BSRPC::urlencode($2); + } + if (@args) { + for (@args) { + $_ = urlencode($_); + s/%3D/=/; # convert first now escaped '=' back + } + if ($uri =~ /\?/) { + $uri .= '&'.join('&', @args); + } else { + $uri .= '?'.join('&', @args); + } + } + return $uri; +} + +sub useproxy { + my ($host, $noproxy) = @_; + + # strip leading and tailing whitespace + $noproxy =~ s/^\s+//; + $noproxy =~ s/\s+$//; + # noproxy is a list separated by commas and optional whitespace + for (split(/\s*,\s*/, $noproxy)) { + return 0 if $host =~ m/(^|\.)$_$/; + } + return 1; +} + +sub createreq { + my ($param, $uri, $proxy, $cookiestore, @xhdrs) = @_; + + my $act = $param->{'request'} || 'GET'; + if (exists($param->{'socket'})) { + my $req = "$act $uri HTTP/1.1\r\n".join("\r\n", @xhdrs)."\r\n\r\n"; + return ('', undef, undef, $req, undef); + } + my ($proxyauth, $proxytunnel); + die("bad uri: $uri\n") unless $uri =~ /^(https?):\/\/(?:([^\/\@]*)\@)?([^\/:]+)(:\d+)?(\/.*)$/; + my ($proto, $auth, $host, $port, $path) = ($1, $2, $3, $4, $5); + my $hostport = $port ? "$host$port" : $host; + undef $proxy if $proxy && defined($noproxy) && !useproxy($host, $noproxy); + if ($proxy) { + die("bad proxy uri: $proxy\n") unless "$proxy/" =~ /^(https?):\/\/(?:([^\/\@]*)\@)?([^\/:]+)(:\d+)?(\/.*)$/; + ($proto, $proxyauth, $host, $port) = ($1, $2, $3, $4); + $path = $uri unless $uri =~ /^https:/; + } + $port = substr($port || ($proto eq 'http' ? ":80" : ":443"), 1); + unshift @xhdrs, "Connection: close" unless $param->{'noclose'}; + unshift @xhdrs, "User-Agent: $useragent" unless !defined($useragent) || grep {/^user-agent:/si} @xhdrs; + unshift @xhdrs, "Host: $hostport" unless grep {/^host:/si} @xhdrs; + if (defined $auth) { + $auth =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; + unshift @xhdrs, "Authorization: Basic ".encode_base64($auth, ''); + } + if (defined $proxyauth) { + $proxyauth =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; + unshift @xhdrs, "Proxy-Authorization: Basic ".encode_base64($proxyauth, ''); + } + if ($proxy && $uri =~ /^https/) { + if ($hostport =~ /:\d+$/) { + $proxytunnel = "CONNECT $hostport HTTP/1.1\r\nHost: $hostport\r\n"; + } else { + $proxytunnel = "CONNECT $hostport:443 HTTP/1.1\r\nHost: $hostport:443\r\n"; + } + $proxytunnel .= shift(@xhdrs)."\r\n" if defined $proxyauth; + $proxytunnel .= "\r\n"; + } + if ($cookiestore && %$cookiestore) { + if ($uri =~ /((:?https?):\/\/(?:([^\/]*)\@)?(?:[^\/:]+)(?::\d+)?)(?:\/.*)$/) { + push @xhdrs, map {"Cookie: $_"} @{$cookiestore->{$1} || []}; + } + } + my $req = "$act $path HTTP/1.1\r\n".join("\r\n", @xhdrs)."\r\n\r\n"; + return ($proto, $host, $port, $req, $proxytunnel); +} + +# +# handled paramters: +# timeout +# uri +# data +# headers (array) +# chunked +# request +# verbatim_uri +# socket +# https +# continuation +# verbose +# sender +# async +# replyheaders +# receiver +# ignorestatus +# receiverarg +# maxredirects +# proxy +# + +sub rpc { + my ($uri, $xmlargs, @args) = @_; + + my $data = ''; + my @xhdrs; + my $chunked; + my $param = {'uri' => $uri}; + + if (ref($uri) eq 'HASH') { + $param = $uri; + my $timeout = $param->{'timeout'}; + if ($timeout) { + my %paramcopy = %$param; + delete $paramcopy{'timeout'}; + my $ans; + local $SIG{'ALRM'} = sub {alarm(0); die("rpc timeout\n");}; + eval { + eval { + alarm($timeout); + $ans = rpc(\%paramcopy, $xmlargs, @args); + }; + alarm(0); + die($@) if $@; + }; + die($@) if $@; + return $ans; + } + $uri = $param->{'uri'}; + $data = $param->{'data'}; + @xhdrs = @{$param->{'headers'} || []}; + $chunked = 1 if $param->{'chunked'}; + if (!defined($data) && $param->{'request'} && $param->{'request'} eq 'POST' && @args && grep {/^content-type:\sapplication\/x-www-form-urlencoded$/i} @xhdrs) { + for (@args) { + $_ = urlencode($_); + s/%3D/=/; # convert now escaped = back + } + $data = join('&', @args); + @args = (); + } + push @xhdrs, "Content-Length: ".length($data) if defined($data) && !ref($data) && !$chunked && !grep {/^content-length:/i} @xhdrs; + push @xhdrs, "Transfer-Encoding: chunked" if $chunked; + $data = '' unless defined $data; + } + $uri = createuri($param, @args); + my $proxy = $param->{'proxy'}; + my ($proto, $host, $port, $req, $proxytunnel) = createreq($param, $uri, $proxy, \%cookiestore, @xhdrs); + if ($proto eq 'https' || $proxytunnel) { + die("https not supported\n") unless $tossl || $param->{'https'}; + } + local *S; + if (exists($param->{'socket'})) { + *S = $param->{'socket'}; + } else { + if (!$hostlookupcache{$host}) { + my $hostaddr = inet_aton($host); + die("unknown host '$host'\n") unless $hostaddr; + $hostlookupcache{$host} = $hostaddr; + } + socket(S, PF_INET, SOCK_STREAM, $tcpproto) || die("socket: $!\n"); + setsockopt(S, SOL_SOCKET, SO_KEEPALIVE, pack("l",1)); + connect(S, sockaddr_in($port, $hostlookupcache{$host})) || die("connect to $host:$port: $!\n"); + if ($proxytunnel) { + BSHTTP::swrite(\*S, $proxytunnel); + my $ans = ''; + do { + die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans)); + } while ($ans !~ /\n\r?\n/s); + die("bad answer\n") unless $ans =~ s/^HTTP\/\d+?\.\d+?\s+?(\d+[^\r\n]*)/Status: $1/s; + my $status = $1; + die("proxy tunnel: CONNECT method failed: $status\n") unless $status =~ /^200[^\d]/; + } + ($param->{'https'} || $tossl)->(\*S, $param->{'ssl_keyfile'}, $param->{'ssl_certfile'}, 1) if $proto eq 'https' || $proxytunnel; + } + if (!$param->{'continuation'}) { + if ($param->{'verbose'}) { + print "> $_\n" for split("\r\n", $req); + #print "> $data\n" unless ref($data); + } + $req .= "$data" unless ref($data); + if ($param->{'sender'}) { + $param->{'sender'}->($param, \*S, $req); + } else { + while(1) { + BSHTTP::swrite(\*S, $req); + last unless ref $data; + $req = &$data($param, \*S); + if (!defined($req) || !length($req)) { + $req = $data = ''; + $req = "0\r\n\r\n" if $chunked; + next; + } + $req = sprintf("%X\r\n", length($req)).$req."\r\n" if $chunked; + } + } + if ($param->{'async'}) { + my $ret = {}; + $ret->{'uri'} = $uri; + my $fd = gensym; + *$fd = \*S; + $ret->{'socket'} = $fd; + $ret->{'async'} = 1; + $ret->{'continuation'} = 1; + $ret->{'request'} = $param->{'request'} || 'GET'; + $ret->{'verbose'} = $param->{'verbose'} if $param->{'verbose'}; + $ret->{'replyheaders'} = $param->{'replyheaders'} if $param->{'replyheaders'}; + $ret->{'receiver'} = $param->{'receiver'} if $param->{'receiver'}; + $ret->{$_} = $param->{$_} for grep {/^receiver:/} keys %$param; + $ret->{'receiverarg'} = $xmlargs if $xmlargs; + return $ret; + } + } + my $ans = ''; + do { + die("received truncated answer\n") if !sysread(S, $ans, 1024, length($ans)); + } while ($ans !~ /\n\r?\n/s); + die("bad answer\n") unless $ans =~ s/^HTTP\/\d+?\.\d+?\s+?(\d+[^\r\n]*)/Status: $1/s; + my $status = $1; + $ans =~ /^(.*?)\n\r?\n(.*)$/s; + my $headers = $1; + $ans = $2; + if ($param->{'verbose'}) { + print "< $_\n" for split(/\r?\n/, $headers); + } + my %headers; + BSHTTP::gethead(\%headers, $headers); + if ($status =~ /^200[^\d]/) { + undef $status; + } elsif ($status =~ /^302[^\d]/) { + # XXX: should we do the redirect if $param->{'ignorestatus'} is defined? + close S; + die("error: no redirects allowed\n") unless defined $param->{'maxredirects'}; + die("error: status 302 but no 'location' header found\n") unless exists $headers{'location'}; + die("error: max number of redirects reached\n") if $param->{'maxredirects'} < 1; + my %myparam = %$param; + $myparam{'uri'} = $headers{'location'}; + $myparam{'maxredirects'} = $param->{'maxredirects'} - 1; + return rpc(\%myparam, $xmlargs, @args); + } else { + #if ($param->{'verbose'}) { + # 1 while sysread(S, $ans, 1024, length($ans)); + # print "< $ans\n"; + #} + if ($status =~ /^(\d+) +(.*?)$/) { + die("$1 remote error: $2\n") unless $param->{'ignorestatus'}; + } else { + die("remote error: $status\n") unless $param->{'ignorestatus'}; + } + } + if ($headers{'set-cookie'} && $param->{'uri'}) { + my @cookie = split(',', $headers{'set-cookie'}); + s/;.*// for @cookie; + if ($param->{'uri'} =~ /((:?https?):\/\/(?:([^\/]*)\@)?(?:[^\/:]+)(?::\d+)?)(?:\/.*)$/) { + my %cookie = map {$_ => 1} @cookie; + push @cookie, grep {!$cookie{$_}} @{$cookiestore{$1} || []}; + splice(@cookie, 10) if @cookie > 10; + $cookiestore{$1} = \@cookie; + } + } + if (($param->{'request'} || '') eq 'HEAD') { + close S; + ${$param->{'replyheaders'}} = \%headers if $param->{'replyheaders'}; + return \%headers; + } + $headers{'__socket'} = \*S; + $headers{'__data'} = $ans; + my $receiver; + $receiver = $param->{'receiver:'.lc($headers{'content-type'} || '')}; + $receiver ||= $param->{'receiver'}; + $xmlargs ||= $param->{'receiverarg'}; + if ($receiver) { + $ans = $receiver->(\%headers, $param, $xmlargs); + $xmlargs = undef; + } else { + $ans = BSHTTP::read_data(\%headers, undef, 1); + } + close S; + delete $headers{'__socket'}; + delete $headers{'__data'}; + ${$param->{'replyheaders'}} = \%headers if $param->{'replyheaders'}; + #if ($param->{'verbose'}) { + # print "< $ans\n"; + #} + if ($xmlargs) { + die("answer is not xml\n") if $ans !~ /<.*?>/s; + my $res = XMLin($xmlargs, $ans); + return $res; + } + return $ans; +} + +1; diff --git a/bs_copy/BSSSL.pm b/bs_copy/BSSSL.pm new file mode 100644 index 00000000..8b5ec5d3 --- /dev/null +++ b/bs_copy/BSSSL.pm @@ -0,0 +1,140 @@ +# +# Copyright (c) 2007 Michael Schroeder, Novell Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program (see the file COPYING); if not, write to the +# Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA +# +################################################################ +# +# SSL Socket wrapper. Like Net::SSLeay::Handle, but can tie +# inplace and also supports servers. Plus, it uses the more useful +# Net::SSLeay::read instead of Net::SSLeay::ssl_read_all. +# + +package BSSSL; + +use Socket; +use Net::SSLeay; + +use strict; + +my $sslctx; + +sub initctx { + my ($keyfile, $certfile) = @_; + Net::SSLeay::load_error_strings(); + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::randomize(); + $sslctx = Net::SSLeay::CTX_new() or die("CTX_new failed!\n"); + Net::SSLeay::CTX_set_options($sslctx, &Net::SSLeay::OP_ALL); + if ($keyfile) { + Net::SSLeay::CTX_use_RSAPrivateKey_file($sslctx, $keyfile, &Net::SSLeay::FILETYPE_PEM) || die("RSAPrivateKey $keyfile failed\n"); + } + if ($certfile) { + Net::SSLeay::CTX_use_certificate_file($sslctx, $certfile, &Net::SSLeay::FILETYPE_PEM) || die("certificate $keyfile failed\n"); + } +} + +sub freectx { + Net::SSLeay::CTX_free($sslctx); + undef $sslctx; +} + +sub tossl { + local *S = $_[0]; + tie(*S, 'BSSSL', @_); +} + +sub TIEHANDLE { + my ($self, $socket, $keyfile, $certfile, $forceconnect) = @_; + + initctx() unless $sslctx; + my $ssl = Net::SSLeay::new($sslctx) or die("SSL_new failed\n"); + Net::SSLeay::set_fd($ssl, fileno($socket)); + if ($keyfile) { + Net::SSLeay::use_RSAPrivateKey_file($ssl, $keyfile, &Net::SSLeay::FILETYPE_PEM) || die("RSAPrivateKey $keyfile failed\n"); + } + if ($certfile) { + Net::SSLeay::use_certificate_file($ssl, $certfile, &Net::SSLeay::FILETYPE_PEM) || die("certificate $certfile failed\n"); + } + if (defined($keyfile) && !$forceconnect) { + Net::SSLeay::accept($ssl) == 1 || die("SSL_accept\n"); + } else { + Net::SSLeay::connect($ssl) || die("SSL_connect"); + } + return bless [$ssl, $socket]; +} + +sub PRINT { + my $sslr = shift; + my $r = 0; + for my $msg (@_) { + next unless defined $msg; + $r = Net::SSLeay::write($sslr->[0], $msg) or last; + } + return $r; +} + +sub READLINE { + my ($sslr) = @_; + return Net::SSLeay::ssl_read_until($sslr->[0]); +} + +sub READ { + my ($sslr, undef, $len, $offset) = @_; + my $buf = \$_[1]; + my $r = Net::SSLeay::read($sslr->[0], $len); + return undef unless defined $r; + return length($$buf = $r) unless defined $offset; + my $bl = length($$buf); + $$buf .= chr(0) x ($offset - $bl) if $offset > $bl; + substr($$buf, $offset) = $r; + return length($r); +} + +sub WRITE { + my ($sslr, $buf, $len, $offset) = @_; + return $len unless $len; + return Net::SSLeay::write($sslr->[0], substr($buf, $offset || 0, $len)) ? $len : undef; +} + +sub FILENO { + my ($sslr) = @_; + return Net::SSLeay::get_fd($sslr->[0]); +} + +sub CLOSE { + my ($sslr) = @_; + if (tied($sslr->[1]) && tied($sslr->[1]) eq $sslr) { + untie($sslr->[1]); + close($sslr->[1]); + } else { + Net::SSLeay::free($sslr->[0]); + undef $sslr->[0]; + } + undef $sslr->[1]; +} + +sub UNTIE { + my ($sslr) = @_; + Net::SSLeay::free($sslr->[0]); + undef $sslr->[0]; +} + +sub DESTROY { + my ($sslr) = @_; + UNTIE($sslr) if $sslr && $sslr->[0]; +} + +1; diff --git a/bs_copy/BSUtil.pm b/bs_copy/BSUtil.pm new file mode 100644 index 00000000..915c1b9e --- /dev/null +++ b/bs_copy/BSUtil.pm @@ -0,0 +1,593 @@ +# +# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program (see the file COPYING); if not, write to the +# Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA +# +################################################################ +# +# collection of useful functions +# + +package BSUtil; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw{writexml writestr readxml readstr ls mkdir_p xfork str2utf8 data2utf8 str2utf8xml data2utf8xml}; + +use XML::Structured; +use POSIX; +use Fcntl qw(:DEFAULT :flock); +use Encode; +use Storable (); +use IO::Handle; + +use strict; + +our $fdatasync_before_rename; + +sub set_fdatasync_before_rename { + $fdatasync_before_rename = 1; + if (!defined(&File::Sync::fdatasync_fd)) { + eval { + require File::Sync; + }; + warn($@) if $@; + *File::Sync::fdatasync_fd = sub {} unless defined &File::Sync::fdatasync_fd; + } +} + +sub do_fdatasync { + my ($fd) = @_; + set_fdatasync_before_rename() unless defined &File::Sync::fdatasync_fd; + File::Sync::fdatasync_fd($fd); +} + +sub writexml { + my ($fn, $fnf, $dd, $dtd) = @_; + my $d = XMLout($dtd, $dd); + local *F; + open(F, '>', $fn) || die("$fn: $!\n"); + (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); + do_fdatasync(fileno(F)) if defined($fnf) && $fdatasync_before_rename; + close(F) || die("$fn close: $!\n"); + return unless defined $fnf; + $! = 0; + rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); +} + +sub writestr { + my ($fn, $fnf, $d) = @_; + local *F; + open(F, '>', $fn) || die("$fn: $!\n"); + if (length($d)) { + (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); + } + do_fdatasync(fileno(F)) if defined($fnf) && $fdatasync_before_rename; + close(F) || die("$fn close: $!\n"); + return unless defined $fnf; + rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); +} + +sub appendstr { + my ($fn, $d) = @_; + local *F; + open(F, '>>', $fn) || die("$fn: $!\n"); + if (length($d)) { + (syswrite(F, $d) || 0) == length($d) || die("$fn write: $!\n"); + } + close(F) || die("$fn close: $!\n"); +} + +sub readstr { + my ($fn, $nonfatal) = @_; + local *F; + if (!open(F, '<', $fn)) { + die("$fn: $!\n") unless $nonfatal; + return undef; + } + my $d = ''; + 1 while sysread(F, $d, 8192, length($d)); + close F; + return $d; +} + +sub readxml { + my ($fn, $dtd, $nonfatal) = @_; + my $d = readstr($fn, $nonfatal); + return $d unless defined $d; + if ($d !~ /<.*?>/s) { + die("$fn: not xml\n") unless $nonfatal; + return undef; + } + return XMLin($dtd, $d) unless $nonfatal; + eval { $d = XMLin($dtd, $d); }; + return $@ ? undef : $d; +} + +sub fromxml { + my ($d, $dtd, $nonfatal) = @_; + return XMLin($dtd, $d) unless $nonfatal; + eval { $d = XMLin($dtd, $d); }; + return $@ ? undef : $d; +} + +sub toxml { + my ($d, $dtd) = @_; + return XMLout($dtd, $d); +} + +sub touch($) { + my ($file) = @_; + if (-e $file) { + utime(time, time, $file); + } else { + # create new file, mtime is anyway current + local *F; + open(F, '>>', $file) || die("$file: $!\n"); + close(F) || die("$file close: $!\n"); + } +} + +sub ls { + local *D; + opendir(D, $_[0]) || return (); + my @r = grep {$_ ne '.' && $_ ne '..'} readdir(D); + closedir D; + return @r; +} + +sub mkdir_p { + my ($dir) = @_; + + return 1 if -d $dir; + my $pdir; + if ($dir =~ /^(.+)\//) { + $pdir = $1; + mkdir_p($pdir) || return undef; + } + while (!mkdir($dir, 0777)) { + my $e = $!; + return 1 if -d $dir; + if (defined($pdir) && ! -d $pdir) { + mkdir_p($pdir) || return undef; + next; + } + $! = $e; + warn("mkdir: $dir: $!\n"); + return undef; + } + return 1; +} + +# calls mkdir_p and changes ownership of the created directory to the +# supplied user and group if provided. +sub mkdir_p_chown { + my ($dir, $user, $group) = @_; + + if (!(-d $dir)) { + mkdir_p($dir) || return undef; + } + return 1 unless defined($user) || defined($group); + + $user = -1 unless defined $user; + $group = -1 unless defined $group; + + if ($user !~ /^-?\d+$/ && !($user = getpwnam($user))) { + warn "user $user unknown\n"; return undef + } + if ($group !~ /^-?\d+$/ && !($group = getgrnam($group))) { + warn "group $group unknown\n"; return undef + } + + my @s = stat($dir); + if ($s[4] != $user || $s[5] != $group) { + if (!chown $user, $group, $dir) { + warn "failed to chown $dir to $user:$group\n"; return undef; + } + } + return 1; +} + +sub drop_privs_to { + my ($user, $group) = @_; + + if (defined($group)) { + $group = getgrnam($group) unless $group =~ /^\d+$/; + die("unknown group\n") unless defined $group; + if ($) != $group || $( != $group) { + ($), $() = ($group, $group); + die("setgid: $!\n") if $) != $group; + } + } + if (defined($user)) { + $user = getpwnam($user) unless $user =~ /^\d+$/; + die("unknown user\n") unless defined $user; + if ($> != $user || $< != $user) { + ($>, $<) = ($user, $user); + die("setuid: $!\n") if $> != $user; + } + } +} + +sub cleandir { + my ($dir) = @_; + + my $ret = 1; + return 1 unless -d $dir; + for my $c (ls($dir)) { + if (! -l "$dir/$c" && -d _) { + cleandir("$dir/$c"); + $ret = undef unless rmdir("$dir/$c"); + } else { + $ret = undef unless unlink("$dir/$c"); + } + } + return $ret; +} + +sub linktree { + my ($from, $to) = @_; + return unless -d $from; + mkdir_p($to); + my @todo = sort(ls($from)); + while (@todo) { + my $f = shift @todo; + if (! -l "$from/$f" && -d _) { + mkdir_p("$to/$f"); + unshift @todo, map {"$f/$_"} ls("$from/$f"); + } else { + link("$from/$f", "$to/$f") || die("link $from/$f $to/$f: $!\n"); + } + } +} + +sub treeinfo { + my ($dir) = @_; + my @info; + my @todo = sort(ls($dir)); + while (@todo) { + my $f = shift @todo; + my @s = lstat("$dir/$f"); + next unless @s; + if (-d _) { + push @info, "$f"; + unshift @todo, map {"$f/$_"} ls("$dir/$f"); + } else { + push @info, "$f $s[9]/$s[7]/$s[1]"; + } + } + return \@info; +} + +sub xfork { + my $pid; + while (1) { + $pid = fork(); + last if defined $pid; + die("fork: $!\n") if $! != POSIX::EAGAIN; + sleep(5); + } + return $pid; +} + +sub cp { + my ($from, $to, $tof) = @_; + local *F; + local *T; + open(F, '<', $from) || die("$from: $!\n"); + open(T, '>', $to) || die("$to: $!\n"); + my $buf; + while (sysread(F, $buf, 8192)) { + (syswrite(T, $buf) || 0) == length($buf) || die("$to write: $!\n"); + } + close(F); + close(T) || die("$to: $!\n"); + if (defined($tof)) { + rename($to, $tof) || die("rename $to $tof: $!\n"); + } +} + +sub checkutf8 { + my ($oct) = @_; + Encode::_utf8_off($oct); + return 1 unless defined $oct; + return 1 unless $oct =~ /[\200-\377]/; + eval { + Encode::_utf8_on($oct); + encode('UTF-8', $oct, Encode::FB_CROAK); + }; + return $@ ? 0 : 1; +} + +sub str2utf8 { + my ($oct) = @_; + return $oct unless defined $oct; + return $oct unless $oct =~ /[^\011\012\015\040-\176]/s; + eval { + Encode::_utf8_on($oct); + $oct = encode('UTF-8', $oct, Encode::FB_CROAK); + }; + if ($@) { + # assume iso-8859-1 + eval { + Encode::_utf8_off($oct); + $oct = encode('UTF-8', $oct, Encode::FB_CROAK); + }; + if ($@) { + Encode::_utf8_on($oct); + $oct = encode('UTF-8', $oct, Encode::FB_XMLCREF); + } + } + Encode::_utf8_off($oct); # just in case... + return $oct; +} + +sub data2utf8 { + my ($d) = @_; + if (ref($d) eq 'ARRAY') { + for my $dd (@$d) { + if (ref($dd) eq '') { + $dd = str2utf8($dd); + } else { + data2utf8($dd); + } + } + } elsif (ref($d) eq 'HASH') { + for my $dd (keys %$d) { + if (ref($d->{$dd}) eq '') { + $d->{$dd} = str2utf8($d->{$dd}); + } else { + data2utf8($d->{$dd}); + } + } + } +} + +sub str2utf8xml { + my ($oct) = @_; + return $oct unless defined $oct; + return $oct unless $oct =~ /[^\011\012\015\040-\176]/s; + $oct = str2utf8($oct); + Encode::_utf8_on($oct); + # xml does not accept all utf8 chars, escape the illegal + $oct =~ s/([\000-\010\013\014\016-\037\177])/sprintf("&#x%x;",ord($1))/sge; + $oct =~ s/([\x{d800}-\x{dfff}\x{fffe}\x{ffff}])/sprintf("&#x%x;",ord($1))/sge; + Encode::_utf8_off($oct); + return $oct; +} + +sub data2utf8xml { + my ($d) = @_; + if (ref($d) eq 'ARRAY') { + for my $dd (@$d) { + if (ref($dd) eq '') { + $dd = str2utf8xml($dd); + } else { + data2utf8xml($dd); + } + } + } elsif (ref($d) eq 'HASH') { + for my $dd (keys %$d) { + if (ref($d->{$dd}) eq '') { + $d->{$dd} = str2utf8xml($d->{$dd}); + } else { + data2utf8xml($d->{$dd}); + } + } + } +} + +sub waituntilgone { + my ($fn, $timeout) = @_; + while (1) { + return 1 unless -e $fn; + return 0 if defined($timeout) && $timeout <= 0; + select(undef, undef, undef, .1); + $timeout -= .1 if defined $timeout; + } +} + +sub lockopen { + my ($fg, $op, $fn, $nonfatal) = @_; + + local *F = $fg; + while (1) { + if (!open(F, $op, $fn)) { + return undef if $nonfatal; + die("$fn: $!\n"); + } + flock(F, LOCK_EX) || die("flock $fn: $!\n"); + my @s = stat(F); + return 1 if @s && $s[3]; + close F; + } +} + +sub lockcheck { + my ($op, $fn) = @_; + local *F; + while (1) { + if (!open(F, $op, $fn)) { + return -1; + } + if (!flock(F, LOCK_EX | LOCK_NB)) { + close(F); + return 0; + } + my @s = stat(F); + close F; + return 1 if @s && $s[3]; + } +} + +sub lockopenxml { + my ($fg, $op, $fn, $dtd, $nonfatal) = @_; + if (!lockopen($fg, $op, $fn, $nonfatal)) { + die("$fn: $!\n") unless $nonfatal; + return undef; + } + my $d = readxml($fn, $dtd, $nonfatal); + if (!$d) { + local *F = $fg; + close F; + } + return $d; +} + +sub lockcreatexml { + my ($fg, $fn, $fnf, $dd, $dtd) = @_; + + local *F = $fg; + writexml($fn, undef, $dd, $dtd); + open(F, '<', $fn) || die("$fn: $!\n"); + flock(F, LOCK_EX | LOCK_NB) || die("lock: $!\n"); + if (!link($fn, $fnf)) { + unlink($fn); + close F; + return undef; + } + unlink($fn); + return 1; +} + +sub isotime { + my ($t) = @_; + my @lt = localtime($t || time()); + return sprintf "%04d-%02d-%02d %02d:%02d:%02d", $lt[5] + 1900, $lt[4] + 1, @lt[3,2,1,0]; +} + +# XXX: does that really belong here? +# +# Algorithm: +# each enable/disable has a score: +# +1 if it's a disable +# +2 if the arch matches +# +4 if the repo matches +# +sub enabled { + my ($repoid, $disen, $default, $arch) = @_; + + # filter matching elements, check for shortcuts + return $default unless $disen; + my @dis = grep { (!defined($_->{'arch'}) || $_->{'arch'} eq $arch) && + (!defined($_->{'repository'}) || $_->{'repository'} eq $repoid) + } @{$disen->{'disable'} || []}; + return 1 if !@dis && $default; + my @ena = grep { (!defined($_->{'arch'}) || $_->{'arch'} eq $arch) && + (!defined($_->{'repository'}) || $_->{'repository'} eq $repoid) + } @{$disen->{'enable'} || []}; + return @dis ? 0 : $default unless @ena; + return @ena ? 1 : $default unless @dis; + + # have @dis and @ena, need to do score thing... + my $disscore = 0; + for (@dis) { + my $score = 1; + $score += 2 if defined($_->{'arch'}); + $score += 4 if defined($_->{'repository'}); + if ($score > $disscore) { + return 0 if $score == 7; # can't max this! + $disscore = $score; + } + } + my $enascore = 0; + for (@ena) { + my $score = 0; + $score += 2 if defined($_->{'arch'}); + $score += 4 if defined($_->{'repository'}); + if ($score > $enascore) { + return 1 if $enascore == 6; # can't max this! + $enascore = $score; + } + } + return $enascore > $disscore ? 1 : 0; +} + +sub store { + my ($fn, $fnf, $dd) = @_; + if ($fdatasync_before_rename && defined($fnf)) { + local *F; + open(F, '>', $fn) || die("$fn: $!\n"); + if (!Storable::nstore_fd($dd, \*F)) { + die("nstore_fd $fn: $!\n"); + } + (\*F)->flush(); + do_fdatasync(fileno(F)); + close(F) || die("$fn close: $!\n"); + } else { + if (!Storable::nstore($dd, $fn)) { + die("nstore $fn: $!\n"); + } + } + return unless defined $fnf; + $! = 0; + rename($fn, $fnf) || die("rename $fn $fnf: $!\n"); +} + +sub retrieve { + my ($fn, $nonfatal) = @_; + my $dd; + if (!$nonfatal) { + $dd = ref($fn) ? Storable::fd_retrieve($fn) : Storable::retrieve($fn); + die("retrieve $fn: $!\n") unless $dd; + } else { + eval { + $dd = ref($fn) ? Storable::fd_retrieve($fn) : Storable::retrieve($fn); + }; + if (!$dd && $nonfatal == 2) { + if ($@) { + warn($@); + } else { + warn("retrieve $fn: $!\n"); + } + } + } + return $dd; +} + +sub ping { + my ($pingfile) = @_; + local *F; + if (sysopen(F, $pingfile, POSIX::O_WRONLY|POSIX::O_NONBLOCK)) { + syswrite(F, 'x'); + close(F); + } +} + +sub restartexit { + my ($arg, $name, $runfile, $pingfile) = @_; + return unless $arg; + if ($arg eq '--stop' || $arg eq '--exit') { + if (!(-e "$runfile.lock") || lockcheck('>>', "$runfile.lock")) { + print "$name not running.\n"; + exit 0; + } + print "exiting $name...\n"; + BSUtil::touch("$runfile.exit"); + ping($pingfile) if $pingfile; + BSUtil::waituntilgone("$runfile.exit"); + exit(0); + } + if ($ARGV[0] eq '--restart') { + die("$name not running.\n") if !(-e "$runfile.lock") || BSUtil::lockcheck('>>', "$runfile.lock"); + print "restarting $name...\n"; + BSUtil::touch("$runfile.restart"); + ping($pingfile) if $pingfile; + BSUtil::waituntilgone("$runfile.restart"); + exit(0); + } +} + +1; diff --git a/bs_copy/BSXML.pm b/bs_copy/BSXML.pm new file mode 100644 index 00000000..c9e10fab --- /dev/null +++ b/bs_copy/BSXML.pm @@ -0,0 +1,1671 @@ +# +# Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc. +# Copyright (c) 2008 Adrian Schroeter, Novell Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program (see the file COPYING); if not, write to the +# Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA +# +################################################################ +# +# XML templates for the BuildService. See XML/Structured. +# + +package BSXML; + +use strict; + +# +# an explained example entry of this file +# +#our $pack = [ creates space +# 'package' => +# 'name', +# 'project', +# [], before the [] all strings become attributes to +# 'title', from here on all strings become children like +# 'description', +# [[ 'person' => creates children, the [[ ]] syntax allows any number of them including zero +# 'role', again role and userid attributes, both are required +# 'userid', +# ]], this block describes a construct +# @flags, copies in the block of possible flag definitions +# [ $repo ], refers to the repository construct and allows again any number of them (0-X) +#]; closes the child with + +our $repo = [ + 'repository' => + 'name', + 'rebuild', + 'block', + 'linkedbuild', + [[ 'releasetarget' => + 'project', + 'repository', + 'trigger', + ]], + [[ 'path' => + 'project', + 'repository', + ]], + [ 'hostsystem' => + 'project', + 'repository', + ], + [ 'base' => # expanded repo only! + 'project', + 'repository', + ], + [ 'arch' ], + 'status', +]; + +our @disableenable = ( + [[ 'disable' => + 'arch', + 'repository', + ]], + [[ 'enable' => + 'arch', + 'repository', + ]], +); + +our @flags = ( + [ 'lock' => @disableenable ], + [ 'build' => @disableenable ], + [ 'publish' => @disableenable ], + [ 'debuginfo' => @disableenable ], + [ 'useforbuild' => @disableenable ], + [ 'binarydownload' => @disableenable ], + [ 'sourceaccess' => @disableenable ], + [ 'access' => @disableenable ], +); + +our @roles = ( + [[ 'person' => + 'role', + 'userid', + ]], + [[ 'group' => + 'role', + 'groupid', + ]], +); + +our $download = [ + 'download' => + 'baseurl', + 'metafile', + 'mtype', + 'arch', +]; + +our $maintenance = [ + 'maintenance' => + [[ 'maintains' => + 'project', + ]], +]; + +our $proj = [ + 'project' => + 'name', + 'kind', + [], + 'title', + 'description', + [[ 'link' => + 'project', + ]], + 'remoteurl', + 'remoteproject', + 'mountproject', + [ 'devel', => + 'project', + ], + @roles, + [ $download ], + $maintenance, + @flags, + [ $repo ], +]; + +our $pack = [ + 'package' => + 'name', + 'project', + [], + 'title', + 'description', + [ 'devel', => + 'project', + 'package', + ], + @roles, + @disableenable, + @flags, + 'url', + 'bcntsynctag', +]; + +our $packinfo = [ + 'info' => + 'repository', + 'name', + 'file', + 'error', + [ 'dep' ], + [ 'prereq' ], + [ 'imagetype' ], # kiwi + [ 'imagearch' ], # kiwi + 'nodbgpkgs', # kiwi + 'nosrcpkgs', # kiwi + [[ 'path' => + 'project', + 'repository', + ]], + [[ 'extrasource' => + 'project', + 'package', + 'srcmd5', + 'file', + ]], +]; + +our $linked = [ + 'linked' => + 'project', + 'package', +]; + +our $aggregatelist = [ + 'aggregatelist' => + [[ 'aggregate' => + 'project', + [], + 'nosources', + [ 'package' ], + [ 'binary' ], + [[ 'repository' => + 'target', + 'source', + ]], + ]], +]; + +# former: kernel - 123 - 1 123: incident +# now: sec-123 - 1 -1 +our $patchinfo = [ + 'patchinfo' => + 'incident', # optional, gets replaced on with updateinfoid on release + 'version', # optional, defaults to 1 + [], + [ 'package' ],# optional + [ 'binary' ], # optional + [[ 'releasetarget' => # optional + 'project', + 'repository', + ]], + [[ 'issue' => + 'tracker', + 'id', + 'documented', + [], + '_content', + ]], + 'category', + 'rating', + 'name', # optional, old patchinfo name which will become part of incident string + 'summary', + 'description', + 'swampid', # obsolete + 'packager', + 'stopped', + 'zypp_restart_needed', + 'reboot_needed', + 'relogin_needed', +]; + +our $channel = [ + 'channel' => + [ 'product' => + 'project', + 'name', + ], + [[ 'target' => + 'project', + 'repository', + 'tag', # optional + ]], + [[ 'binaries' => + 'project', + 'repository', + 'arch', + [[ 'binary' => + 'name', + 'binaryarch', + 'project', + 'repository', + 'package', + 'arch', + 'supportstatus', + ]], + ]], +]; + +our $projpack = [ + 'projpack' => + 'repoid', + [[ 'project' => + 'name', + 'kind', + [], + 'title', + 'description', + 'config', + 'patternmd5', + [[ 'link' => + 'project', + ]], + 'remoteurl', + 'remoteproject', + @flags, + @roles, + [ $repo ], + [ $download ], + [[ 'package' => + 'name', + 'rev', + 'srcmd5', # commit id + 'versrel', + 'verifymd5', # tree id + 'originproject', + 'revtime', + 'constraintsmd5', # md5sum of constraints file in srcmd5 + [ $linked ], + 'error', + [ $packinfo ], + $aggregatelist, + $patchinfo, + $channel, + @flags, + 'bcntsynctag', + ]], + 'missingpackages', + ]], + [[ 'remotemap' => + 'project', + 'root', + 'remoteurl', + 'remoteproject', + 'remoteroot', + 'partition', + 'proto', # project data not included + [], + 'config', + @flags, + @roles, + [ $repo ], + 'error', + ]], +]; + +our $linkinfo = [ + 'linkinfo' => + # information from link + 'project', + 'package', + 'rev', + 'srcmd5', + 'baserev', + 'missingok', + # expanded / unexpanded srcmd5 + 'xsrcmd5', + 'lsrcmd5', + 'error', + 'lastworking', + [ $linked ], +]; + +our $serviceinfo = [ + 'serviceinfo' => + # information in case a source service is part of package + 'code', # can be "running", "failed", "succeeded" + 'xsrcmd5', + 'lsrcmd5', + [], + 'error', # contains error message (with new lines) in case of error +]; + +our $dir = [ + 'directory' => + 'name', + 'count', # obsolete, the API sets this for some requests + 'rev', + 'vrev', + 'srcmd5', + 'tproject', # obsolete, use linkinfo + 'tpackage', # obsolete, use linkinfo + 'trev', # obsolete, use linkinfo + 'tsrcmd5', # obsolete, use linkinfo + 'lsrcmd5', # obsolete, use linkinfo + 'error', + 'xsrcmd5', # obsolete, use linkinfo + $linkinfo, + $serviceinfo, + [[ 'entry' => + 'name', + 'md5', + 'size', + 'mtime', + 'error', + 'id', + 'originproject', # for package listing + ]] +]; + +our $fileinfo = [ + 'fileinfo' => + 'filename', + [], + 'name', + 'epoch', + 'version', + 'release', + 'arch', + 'source', + 'summary', + 'description', + 'size', + 'mtime', + [ 'provides' ], + [ 'requires' ], + [ 'prerequires' ], + [ 'conflicts' ], + [ 'obsoletes' ], + [ 'recommends' ], + [ 'supplements' ], + [ 'suggests' ], + [ 'enhances' ], + + [[ 'provides_ext' => + 'dep', + [[ 'requiredby' => + 'name', + 'epoch', + 'version', + 'release', + 'arch', + 'project', + 'repository', + ]], + ]], + [[ 'requires_ext' => + 'dep', + [[ 'providedby' => + 'name', + 'epoch', + 'version', + 'release', + 'arch', + 'project', + 'repository', + ]], + ]], +]; + +our $sourceinfo = [ + 'sourceinfo' => + 'package', + 'rev', + 'vrev', + 'srcmd5', + 'lsrcmd5', + 'verifymd5', + [], + 'filename', + 'error', + 'originproject', + [ $linked ], + 'revtime', + 'changesmd5', + + 'name', + 'version', + 'release', + [ 'subpacks' ], + [ 'deps' ], + [ 'prereqs' ], + [ 'exclarch' ], + [ 'badarch' ], +]; + +our $sourceinfolist = [ + 'sourceinfolist' => + [ $sourceinfo ], +]; + +our $buildinfo = [ + 'buildinfo' => + 'project', + 'repository', + 'package', + 'srcserver', + 'reposerver', + 'downloadurl', + [], + 'job', + 'arch', + 'hostarch', # for cross build + 'error', + 'srcmd5', + 'verifymd5', + 'rev', + 'disturl', + 'reason', # just for the explain string of a build reason + 'needed', # number of blocked + 'revtime', # time of last commit + 'readytime', + 'specfile', # obsolete + 'file', + 'versrel', + 'bcnt', + 'release', + 'debuginfo', + 'constraintsmd5', + [ 'prjconfconstraint' ], + [ 'subpack' ], + [ 'imagetype' ], # kiwi + 'nodbgpkgs', # kiwi + 'nosrcpkgs', # kiwi + [ 'dep' ], + [[ 'bdep' => + 'name', + 'preinstall', + 'vminstall', + 'cbpreinstall', + 'cbinstall', + 'runscripts', + 'notmeta', + 'noinstall', + + 'epoch', + 'version', + 'release', + 'arch', + 'project', + 'repository', + 'repoarch', + 'binary', + 'package', + 'srcmd5', + ]], + [ 'pdep' ], # obsolete + [[ 'path' => + 'project', + 'repository', + 'server', + ]], + [[ 'syspath' => + 'project', + 'repository', + 'server', + ]], + 'expanddebug', + 'followupfile', # for two-stage builds + 'masterdispatched', # dispatched through a master dispatcher +]; + +our $jobstatus = [ + 'jobstatus' => + 'code', + 'result', # succeeded, failed or unchanged + 'details', + [], + 'starttime', + 'endtime', + 'workerid', + 'hostarch', + + 'uri', # uri to reach worker + + 'arch', # our architecture + 'job', # our jobname + 'jobid', # md5 of job info file +]; + +our $buildreason = [ + 'reason' => + [], + 'explain', # Readable reason + 'time', # unix time from start build + 'oldsource', # last build source md5 sum, if a source change was the reason + [[ 'packagechange' => # list changed files which are used for building + 'change', # kind of change (content/meta change, additional file or removed file) + 'key', # file name + ]], +]; + +our $buildstatus = [ + 'status' => + 'package', + 'code', + 'status', # obsolete, now code + 'error', # obsolete, now details + [], + 'details', + + 'workerid', # last build data + 'hostarch', + 'readytime', + 'starttime', + 'endtime', + + 'job', # internal, job when building + + 'uri', # obsolete + 'arch', # obsolete +]; + +our $builddepinfo = [ + 'builddepinfo' => + [[ 'package' => + 'name', + [], + 'source', + [ 'pkgdep' ], + [ 'subpkg' ], + ]], + [[ 'cycle' => + [ 'package' ], + ]], +]; + +our $event = [ + 'event' => + 'type', + [], + 'project', + 'repository', + 'arch', + 'package', + 'job', + 'due', +]; + +our $events = [ + 'events' => + 'next', + 'sync', + [ $event ], +]; + +our $revision = [ + 'revision' => + 'rev', + 'vrev', + [], + 'srcmd5', + 'version', + 'time', + 'user', + 'comment', + 'requestid', +]; + +our $revision_acceptinfo = [ + @$revision, + [ 'acceptinfo' => + 'rev', + 'srcmd5', + 'osrcmd5', + 'xsrcmd5', + 'oxsrcmd5', + ], +]; + +our $revisionlist = [ + 'revisionlist' => + [ $revision ] +]; + +our $buildhist = [ + 'buildhistory' => + [[ 'entry' => + 'rev', + 'srcmd5', + 'versrel', + 'bcnt', + 'time', + ]], +]; + +our $binaryversionlist = [ + 'binaryversionlist' => + [[ 'binary' => + 'name', # should be filename instead. sigh. + 'sizek', + 'error', + 'hdrmd5', + 'metamd5', + 'leadsigmd5', + ]], +]; + +our $packagebinaryversionlist = [ + 'packagebinaryversionlist' => + [[ 'binaryversionlist' => + 'package', + 'code', + [[ 'binary' => + 'name', + 'sizek', + 'error', + 'hdrmd5', + 'metamd5', + 'leadsigmd5', + ]], + ]], +]; + +our $worker = [ + 'worker' => + 'hostarch', + 'ip', + 'port', + 'workerid', + [ 'buildarch' ], + [ 'hostlabel' ], + 'sandbox', + [ 'linux' => + [], + 'version', + 'flavor' + ], + [ 'hardware' => + [ 'cpu' => + [ 'flag' ], + ], + 'processors', + 'memory', # in MBytes + 'swap', # in MBytes + 'disk', # in MBytes + ], + 'owner', + 'tellnojob', + + 'job', # set when worker is busy + 'arch', # set when worker is busy + 'jobid', # set when worker is busy + 'reposerver', # set when worker is busy and job was masterdispatched +]; + +our $packstatuslist = [ + 'packstatuslist' => + 'project', + 'repository', + 'arch', + [[ 'packstatus' => + 'name', + 'status', + 'error', + ]], + [[ 'packstatussummary' => + 'status', + 'count', + ]], +]; + +our $linkpatch = [ + '' => + [ 'add' => + 'name', + 'type', + 'after', + 'popt', + 'dir', + ], + [ 'apply' => + 'name', + ], + [ 'delete' => + 'name', + ], + 'branch', + 'topadd', +]; + +our $link = [ + 'link' => + 'project', + 'package', + 'rev', + 'vrev', + 'cicount', + 'baserev', + 'missingok', + [ 'patches' => + [ $linkpatch ], + ], +]; + +our $workerstatus = [ + 'workerstatus' => + 'clients', + [[ 'idle' => + 'uri', + 'workerid', + 'hostarch', + ]], + [[ 'building' => + 'uri', + 'workerid', + 'hostarch', + 'project', + 'repository', + 'package', + 'arch', + 'starttime', + ]], + [[ 'waiting', => + 'arch', + 'jobs', + ]], + [[ 'blocked', => + 'arch', + 'jobs', + ]], + [[ 'buildavg', => + 'arch', + 'buildavg', + ]], + [[ 'partition' => + 'name', + [[ 'daemon' => + 'type', # scheduler/dispatcher/signer/publisher/warden + 'arch', # scheduler only + 'state', + 'starttime', + [ 'queue' => # scheduler only + 'high', + 'med', + 'low', + 'next', + ], + ]], + ]], +]; + +our $workerstate = [ + 'workerstate' => + 'state', + 'nextstate', # for exit/restart + 'jobid', +]; + +our $jobhistlay = [ + 'package', + 'rev', + 'srcmd5', + 'versrel', + 'bcnt', + 'readytime', + 'starttime', + 'endtime', + 'code', + 'uri', + 'workerid', + 'hostarch', + 'reason', + 'verifymd5', +]; + +our $jobhist = [ + 'jobhist' => + @$jobhistlay, +]; + +our $jobhistlist = [ + 'jobhistlist' => + [ $jobhist ], +]; + +our $ajaxstatus = [ + 'ajaxstatus' => + [[ 'watcher' => + 'filename', + 'state', + [[ 'job' => + 'id', + 'ev', + 'fd', + 'peer', + 'request', + ]], + ]], + [[ 'rpc' => + 'uri', + 'state', + 'ev', + 'fd', + [[ 'job' => + 'id', + 'ev', + 'fd', + 'peer', + 'starttime', + 'request', + ]], + ]], + [[ 'serialize' => + 'filename', + [[ 'job' => + 'id', + 'ev', + 'fd', + 'peer', + 'request', + ]], + ]], +]; + +our $serverstatus = [ + 'serverstatus' => + [[ 'job' => + 'id', + 'starttime', + 'pid', + 'peer', + 'request', + 'group', + ]], +]; + +##################### new api stuff + +our $binarylist = [ + 'binarylist' => + 'package', + [[ 'binary' => + 'filename', + 'size', + 'mtime', + ]], +]; + +our $summary = [ + 'summary' => + [[ 'statuscount' => + 'code', + 'count', + ]], +]; + +our $schedulerstats = [ + 'stats' => + 'lastchecked', + 'checktime', + 'lastfinished', + 'lastpublished', +]; + +our $result = [ + 'result' => + 'project', + 'repository', + 'arch', + 'code', # pra state, can be "unknown", "broken", "scheduling", "blocked", "building", "finished", "publishing", "published" or "unpublished" + 'state', # old name of 'code', to be removed + 'details', + 'dirty', # marked for re-scheduling if element exists, state might not be correct anymore + [ $buildstatus ], + [ $binarylist ], + $summary, + $schedulerstats, +]; + +our $resultlist = [ + 'resultlist' => + 'state', + 'retryafter', + [ $result ], +]; + +our $opstatus = [ + 'status' => + 'code', + 'origin', + [], + 'summary', + 'details', + [[ 'data' => + 'name', + '_content', + ]], + [ 'exception' => + 'type', + 'message', + [ 'backtrace' => + [ 'line' ], + ], + ], +]; + +my $rpm_entry = [ + 'rpm:entry' => + 'kind', + 'name', + 'epoch', + 'ver', + 'rel', + 'flags', +]; + +our $pattern = [ + 'pattern' => + 'xmlns', # obsolete, moved to patterns + 'xmlns:rpm', # obsolete, moved to patterns + [], + 'name', + 'arch', + [[ 'version' => + 'epoch', + 'ver', + 'rel', + ]], + [[ 'summary' => + 'lang', + '_content', + ]], + [[ 'description' => + 'lang', + '_content', + ]], + 'default', + 'uservisible', + [[ 'category' => + 'lang', + '_content', + ]], + 'icon', + 'script', + [ 'rpm:provides' => [ $rpm_entry ], ], + [ 'rpm:conflicts' => [ $rpm_entry ], ], + [ 'rpm:obsoletes' => [ $rpm_entry ], ], + [ 'rpm:requires' => [ $rpm_entry ], ], + [ 'rpm:suggests' => [ $rpm_entry ], ], + [ 'rpm:enhances' => [ $rpm_entry ], ], + [ 'rpm:supplements' => [ $rpm_entry ], ], + [ 'rpm:recommends' => [ $rpm_entry ], ], +]; + +our $patterns = [ + 'patterns' => + 'count', + 'xmlns', + 'xmlns:rpm', + [], + [ $pattern ], +]; + +our $ymp = [ + 'metapackage' => + 'xmlns:os', + 'xmlns', + [], + [[ 'group' => + 'recommended', + 'distversion', + [], + 'name', + 'summary', + 'description', + 'remainSubscribed', + [ 'repositories' => + [[ 'repository' => + 'recommended', + 'format', + 'producturi', + [], + 'name', + 'summary', + 'description', + 'url', + ]], + ], + [ 'software' => + [[ 'item' => + 'type', + 'recommended', + 'architectures', + 'action', + [], + 'name', + 'summary', + 'description', + ]], + ], + ]], +]; + +our $binary_id = [ + 'binary' => + 'name', + 'project', + 'package', + 'repository', + 'version', + 'release', + 'arch', + 'filename', + 'filepath', + 'baseproject', + 'type', +]; + +our $pattern_id = [ + 'pattern' => + 'name', + 'project', + 'repository', + 'arch', + 'filename', + 'filepath', + 'baseproject', + 'type', +]; + +our $request = [ + 'request' => + 'id', + 'type', # obsolete, still here to handle OBS pre-1.5 requests + 'key', # cache key, not really in request + 'retryafter', # timed out waiting for a key change + [[ 'action' => + 'type', # currently submit, delete, change_devel, add_role, maintenance_release, maintenance_incident, set_bugowner + [ 'source' => + 'project', + 'package', + 'rev', # belongs to package attribute + 'repository', # for merge request + ], + [ 'target' => + 'project', + 'package', + 'releaseproject', # for incident request + 'repository', # for release and delete request + ], + [ 'person' => + 'name', + 'role', + ], + [ 'group' => + 'name', + 'role', + ], + [ 'options' => + [], + 'sourceupdate', # can be cleanup, update or noupdate + 'updatelink', # can be true or false + ], + [ 'acceptinfo' => + 'rev', + 'srcmd5', + 'osrcmd5', + 'xsrcmd5', + 'oxsrcmd5', + ], + ]], + [ 'submit' => # this is old style, obsolete by request, but still supported + [ 'source' => + 'project', + 'package', + 'rev', + ], + [ 'target' => + 'project', + 'package', + ], + ], + [ 'state' => + 'name', + 'who', + 'when', + 'superseded_by', # set when state.name is "superseded" + [], + 'comment', + ], + [[ 'review' => + 'state', # review state (new/accepted or declined) + 'by_user', # this user shall review it + 'by_group', # one of this groupd shall review it + # either user or group must be used, never both + 'by_project', # any maintainer of this project can review it + 'by_package', # any maintainer of this package can review it (requires by_project) + 'who', # this user has reviewed it + 'when', + [], + 'comment', + ]], + [[ 'history' => + 'name', + 'who', + 'when', + 'superseded_by', + [], + 'comment', + ]], + 'accept_at', + 'title', + 'description', +]; + +our $repositorystate = [ + 'repositorystate' => + [ 'blocked' ], +]; + +our $collection = [ + 'collection' => + 'matches', + 'limited', + [ $request ], + [ $proj ], + [ $pack ], + [ $binary_id ], + [ $pattern_id ], + [ 'value' ], +]; + +our $quota = [ + 'quota' => + 'packages', + [[ 'project' => + 'name', + 'packages', + ]], +]; + +our $schedulerinfo = [ + 'schedulerinfo' => + 'arch', + 'started', + 'time', + [], + 'slept', + 'notready', + [ 'queue' => + 'high', + 'med', + 'low', + 'next', + ], + 'projects', + 'repositories', + [[ 'worst' => + 'project', + 'repository', + 'packages', + 'time', + ]], + 'buildavg', + 'avg', + 'variance', +]; + +our $person = [ + 'person' => + 'login', + 'email', + 'realname', + 'state', + [ 'globalrole' ], + [ 'watchlist' => + [[ 'project' => + 'name', + ]], + ], +]; + +our $comps = [ + 'comps' => + [[ 'group' => + [], + 'id', + [[ 'description' => + 'xml:lang', + '_content', + ]], + [[ 'name' => + 'xml:lang', + '_content', + ]], + [ 'packagelist' => + [[ 'packagereq' => + 'type', + '_content', + ]], + ], + ]], +]; + +our $dispatchprios = [ + 'dispatchprios' => + [[ 'prio' => + 'project', + 'repository', + 'arch', + 'adjust', + ]], +]; + +# list of used services for a package or project +our $services = [ + 'services' => + [[ 'service' => + 'name', + 'mode', # "localonly" is skipping this service on server side, "trylocal" is trying to merge changes directly in local files, "disabled" is just skipping it + [[ 'param' => + 'name', + '_content' + ]], + ]], +]; + +# service type definitions +our $servicetype = [ + 'service' => + 'name', + 'hidden', # "true" to suppress it from service list in GUIs + [], + 'summary', + 'description', + [[ 'parameter' => + 'name', + [], + 'description', + 'required', # don't run without this parameter + 'allowmultiple', # This parameter can be used multiple times + [ 'allowedvalue' ], # list of possible values + ]], +]; + +our $servicelist = [ + 'servicelist' => + [ $servicetype ], +]; + +our $updateinfoitem = [ + 'update' => + 'from', + 'status', + 'type', + 'version', + [], + 'id', + 'title', + 'severity', + 'release', + [ 'issued' => + 'date', + ], + [ 'updated' => + 'date', + ], + 'reboot_suggested', + [ 'references' => + [[ 'reference' => + 'href', + 'id', + 'title', + 'type', + ]], + ], + 'description', + [ 'pkglist', + [[ 'collection' => + 'short', + [], + 'name', + [[ 'package' => + 'name', + 'epoch', + 'version', + 'release', + 'arch', + 'src', + 'supportstatus', + [], + 'filename', + [ 'sum' => # obsolete? + 'type', + '_content', + ], + 'reboot_suggested', + 'restart_suggested', + 'relogin_suggested', + ]], + ]], + ], +]; + +our $updateinfo = [ + 'updates' => + 'xmlns', + [ $updateinfoitem ], +]; + +our $deltapackage = [ + 'newpackage' => + 'name', + 'epoch', + 'version', + 'release', + 'arch', + [[ 'delta' => + 'oldepoch', + 'oldversion', + 'oldrelease', + [], + 'filename', + 'sequence', + 'size', + [ 'checksum' => + 'type', + '_content', + ], + ]], +]; + +our $deltainfo = [ + 'deltainfo' => + [ $deltapackage ], +]; + +our $prestodelta = [ + 'prestodelta' => + [ $deltapackage ], +]; + +our $sourcediff = [ + 'sourcediff' => + 'key', + [ 'old' => + 'project', + 'package', + 'rev', + 'srcmd5', + ], + [ 'new' => + 'project', + 'package', + 'rev', + 'srcmd5', + ], + [ 'files' => + [[ 'file' => + 'state', # added, deleted, changed + [ 'old' => + 'name', + 'md5', + 'size', + 'mtime', + ], + [ 'new' => + 'name', + 'md5', + 'size', + 'mtime', + ], + [ 'diff' => + 'binary', + 'lines', + 'shown', + '_content', + ], + ]], + ], + [ 'issues' => + [[ 'issue' => + 'state', + 'tracker', + 'name', + 'label', + 'url', + ]] + ], +]; + +our $configuration = [ + 'configuration' => + [], + 'title', #webui only + 'description', #webui only + 'name', #obsname + 'anonymous', + 'registration', + 'default_access_disabled', + 'allow_user_to_create_home_project', + 'multiaction_notify_support', + 'disallow_group_creation', + 'change_password', + 'cleanup_after_days', + 'hide_private_options', + 'gravatar', + 'enforce_project_keys', + 'download_on_demand', + 'download_url', + 'ymp_url', + 'errbit_url', + 'bugzilla_url', + 'http_proxy', + 'no_proxy', + 'admin_email', + 'theme', + 'cleanup_empty_projects', + 'disable_publish_for_branches', + [ 'schedulers' => + [ 'arch' ], + ], +]; + +our $issue_trackers = [ + 'issue-trackers' => + [[ 'issue-tracker' => + [], + 'name', + 'description', + 'kind', + 'label', + 'enable-fetch', + 'regex', + 'user', +# 'password', commented out on purpose, should not reach backend + 'show-url', + 'url', + 'issues-updated', + ]], +]; + +our $appdataitem = [ + 'application' => + [ 'id' => + 'type', + '_content' + ], + 'pkgname', + 'name', + 'summary', + [ 'icon' => + 'type', + [], + 'name', + [[ 'filecontent' => + 'file', + '_content' + ]], + ], + [ 'appcategories' => + [ 'appcategory' ] + ], + [ 'mimetypes' => + [ 'mimetype' ] + ], + [ 'keywords' => + [ 'keyword' ] + ], + [ 'url' => + 'type', + '_content' + ] +]; + +our $appdata = [ + 'applications' => + 'version', + [ $appdataitem ] +]; + +our $attribute = [ + 'attribute' => + 'namespace', + 'name', + 'binary', + [ 'value' ], + [[ 'issue' => + 'name', + 'tracker' + ]], +]; + +our $attributes = [ + 'attributes' => + [ $attribute ], +]; + +our $size = [ + 'size' => + 'unit', + [], + '_content', +]; + +our $time = [ + 'time' => + 'unit', + [], + '_content', +]; + +# define constraints for build jobs in packages or projects. +our @constraint = ( + [[ 'hostlabel' => + 'exclude', # true or false. default is false. + [], + '_content' # workers might get labels defined by admin, for example for benchmarking. + ]], + [ 'sandbox' => + 'exclude', # true or false. default is false. + [], + '_content' # xen/kvm/zvm/lxc/emulator/chroot/secure + ], + [ 'linux' => + [ 'version' => + [], + 'max' , + 'min' , + ], + 'flavor', + ], + [ 'hardware' => + [ 'cpu' => + [ 'flag' ], + ], + 'processors', + [ 'disk' => $size ], + [ 'memory' => $size ], + [ 'physicalmemory' => $size ], + ] +); +our $constraints = [ + 'constraints' => + @constraint, + [[ 'overwrite' => + [ 'conditions' => + [ 'arch' ], + [ 'package' ], + ], + @constraint, + ]] +]; + +our $buildstatistics = [ + 'buildstatistics' => + [ 'disk' => + [ 'usage' => + [ 'size' => + 'unit', + [], + '_content', + ], + 'io_requests', + 'io_sectors', + ], + ], + [ 'memory' => + [ 'usage' => $size ], + ], + [ 'times' => + [ 'total' => $time ], + [ 'preinstall' => $time ], + [ 'install' => $time ], + [ 'main' => $time ], + [ 'download' => $time ], + ], + [ 'download' => + [], + $size, + 'binaries', + 'cachehits', + 'preinstallimage', + ], +]; + +our $notifications = [ + 'notifications' => + 'next', + 'sync', + [[ 'notification' => + 'type', + 'time', + [[ 'data' => + 'key', + '_content', + ]], + ]], +]; + +our $frozenlinks = [ + 'frozenlinks' => + [[ 'frozenlink' => + 'project', + [[ 'package' => + 'name', + 'srcmd5', + 'vrev', + ]], + ]], +]; + +1; diff --git a/bs_copy/XML/Structured.pm b/bs_copy/XML/Structured.pm new file mode 100644 index 00000000..40a3c794 --- /dev/null +++ b/bs_copy/XML/Structured.pm @@ -0,0 +1,532 @@ + +package XML::Structured; + +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(XMLin XMLinfile XMLout); +$VERSION = '1.0'; + +use XML::Parser; +use Encode; + +use strict; + +our $bytes; + +sub import { + $bytes = 1 if grep {$_ eq ':bytes'} @_; + __PACKAGE__->export_to_level(1, grep {$_ ne ':bytes'} @_); +} + +sub _workin { + my ($how, $out, $ain, @in) = @_; + my @how = @$how; + my $am = shift @how; + + my %known = map {ref($_) ? (!@$_ ? () : (ref($_->[0]) ? $_->[0]->[0] : $_->[0] => $_)) : ($_=> $_)} @how; + for my $a (keys %$ain) { + die("unknown attribute: $a\n") unless $known{$a}; + if (ref($known{$a})) { + die("attribute '$a' must be element\n") if @{$known{$a}} > 1 || ref($known{$a}->[0]); + push @{$out->{$a}}, $ain->{$a}; + } else { + die("attribute '$a' must be singleton\n") if exists $out->{$a}; + $out->{$a} = $ain->{$a}; + Encode::_utf8_off($out->{$a}) if $bytes; + } + } + while (@in) { + my ($e, $v) = splice(@in, 0, 2); + my $ke = $known{$e}; + if ($e eq '0') { + next if $v =~ /^\s*$/s; + die("element '$am' contains content\n") unless $known{'_content'}; + Encode::_utf8_off($v) if $bytes; + $v =~ s/\s+$/ /s; + $v =~ s/^\s+/ /s; + if (exists $out->{'_content'}) { + $out->{'_content'} =~ s/ $//s if $v =~ /^ /s; + $out->{'_content'} .= $v; + } else { + $out->{'_content'} = $v; + } + next; + } + if (!$ke && $known{''}) { + $ke = $known{''}; + $v = [{}, $e, $v]; + $e = ''; + } + die("unknown element: $e\n") unless $ke; + if (!ref($ke)) { + push @$v, '0', '' if @$v == 1; + die("element '$e' contains attributes @{[keys %{$v->[0]}]}\n") if %{$v->[0]}; + die("element '$e' has subelements\n") if $v->[1] ne '0'; + die("element '$e' must be singleton\n") if exists $out->{$e}; + Encode::_utf8_off($v->[2]) if $bytes; + $out->{$e} = $v->[2]; + } elsif (@$ke == 1 && !ref($ke->[0])) { + push @$v, '0', '' if @$v == 1; + die("element '$e' contains attributes\n") if %{$v->[0]}; + die("element '$e' has subelements\n") if $v->[1] ne '0'; + Encode::_utf8_off($v->[2]) if $bytes; + push @{$out->{$e}}, $v->[2]; + } else { + if (@$ke == 1) { + push @{$out->{$e}}, {}; + _workin($ke->[0], $out->{$e}->[-1], @$v); + } else { + die("element '$e' must be singleton\n") if exists $out->{$e}; + $out->{$e} = {}; + _workin($ke, $out->{$e}, @$v); + } + } + } + if (exists $out->{'_content'}) { + $out->{'_content'} =~ s/^ //s; + $out->{'_content'} =~ s/ $//s; + } +} + +sub _escape { + my ($d) = @_; + $d =~ s/&/&/sg; + $d =~ s//>/sg; + $d =~ s/"/"/sg; + return $d; +} + +sub _workout { + my ($how, $d, $indent) = @_; + my @how = @$how; + my $am = _escape(shift @how); + my $ret = "$indent<$am"; + my $inelem; + my %d2 = %$d; + my $gotel = 0; + if ($am eq '') { + $ret = ''; + $gotel = $inelem = 1; + $indent = substr($indent, 2); + } + for my $e (@how) { + if (!$inelem && !ref($e) && $e ne '_content') { + next unless exists $d2{$e}; + $ret .= _escape(" $e=").'"'._escape($d2{$e}).'"'; + delete $d2{$e}; + next; + } + $inelem = 1; + next if ref($e) && !@$e; # magic inelem marker + my $en = $e; + $en = $en->[0] if ref($en); + $en = $en->[0] if ref($en); + next unless exists $d2{$en}; + my $ee = _escape($en); + if (!ref($e) && $e eq '_content' && !$gotel) { + $gotel = 2; # special marker to strip indent + $ret .= ">"._escape($d2{$e})."\n"; + delete $d2{$e}; + next; + } + $ret .= ">\n" unless $gotel; + $gotel = 1; + if (!ref($e)) { + die("'$e' must be scalar\n") if ref($d2{$e}); + if ($e eq '_content') { + my $c = $d2{$e}; + $ret .= "$indent "._escape("$c\n"); + delete $d2{$e}; + next; + } + if (defined($d2{$e})) { + $ret .= "$indent <$ee>"._escape($d2{$e})."\n"; + } else { + $ret .= "$indent <$ee/>\n"; + } + delete $d2{$e}; + next; + } elsif (@$e == 1 && !ref($e->[0])) { + die("'$en' must be array\n") unless UNIVERSAL::isa($d2{$en}, 'ARRAY'); + for my $se (@{$d2{$en}}) { + $ret .= "$indent <$ee>"._escape($se)."\n"; + } + delete $d2{$en}; + } elsif (@$e == 1) { + die("'$en' must be array\n") unless UNIVERSAL::isa($d2{$en}, 'ARRAY'); + for my $se (@{$d2{$en}}) { + die("'$en' must be array of hashes\n") unless UNIVERSAL::isa($se, 'HASH'); + $ret .= _workout($e->[0], $se, "$indent "); + } + delete $d2{$en}; + } else { + die("'$en' must be hash\n") unless UNIVERSAL::isa($d2{$en}, 'HASH'); + $ret .= _workout($e, $d2{$en}, "$indent "); + delete $d2{$en}; + } + } + die("excess hash entries: ".join(', ', sort keys %d2)."\n") if %d2; + if ($gotel == 2 && $ret =~ s/\n$//s) { + $ret .= "\n" unless $am eq ''; + } elsif ($gotel) { + $ret .= "$indent\n" unless $am eq ''; + } else { + $ret .= " />\n"; + } + return $ret; +} + +package XML::Structured::saxparser; + +sub new { + return bless []; +} + +sub start_document { + my ($self) = @_; + $self->[0] = []; +} + +sub start_element { + my ($self, $e) = @_; + my %as = map {$_->{'Name'} => $_->{'Value'}} values %{$e->{'Attributes'} || {}}; + push @{$self->[0]}, $e->{'Name'}, [ $self->[0], \%as ]; + $self->[0] = $self->[0]->[-1]; +} + +sub end_element { + my ($self) = @_; + $self->[0] = shift @{$self->[0]}; +} + +sub characters { + my ($self, $c) = @_; + + my $cl = $self->[0]; + if (@$cl > 2 && $cl->[-2] eq '0') { + $cl->[-1] .= $c->{'Data'}; + } else { + push @$cl, '0' => $c->{'Data'}; + } +} + +sub end_document { + my ($self) = @_; + return $self->[0]; +} + +package XML::Structured; + +my $xmlinparser; + +sub _xmlparser { + my ($str) = @_; + my $p = new XML::Parser(Style => 'Tree'); + return $p->parse($str); +} + +sub _saxparser { + my ($str) = @_; + my $handler = new XML::Structured::saxparser; + my $sp = XML::SAX::ParserFactory->parser('Handler' => $handler); + if (ref(\$str) eq 'GLOB' || UNIVERSAL::isa($str, 'IO::Handle')) { + return $sp->parse_file($str); + } + return $sp->parse_string($str); +} + +sub _chooseparser { + eval { require XML::SAX; }; + my $saxok; + if (!$@) { + $saxok = 1; + my $parsers = XML::SAX->parsers(); + return \&_saxparser if $parsers && @$parsers && (@$parsers > 1 || $parsers->[0]->{'Name'} ne 'XML::SAX::PurePerl'); + } + eval { require XML::Parser; }; + return \&_xmlparser unless $@; + return \&_saxparser if $saxok; + die("XML::Structured needs either XML::SAX or XML::Parser\n"); +} + +sub XMLin { + my ($dtd, $str) = @_; + $xmlinparser = _chooseparser() unless defined $xmlinparser; + my $d = $xmlinparser->($str); + my $out = {}; + $d = ['', [{}, @$d]] if $dtd->[0] eq ''; + die("document element must be '$dtd->[0]', was '$d->[0]'\n") if $d->[0] ne $dtd->[0]; + _workin($dtd, $out, @{$d->[1]}); + return $out; +} + +sub XMLinfile { + my ($dtd, $fn) = @_; + local *F; + open(F, '<', $fn) || die("$fn: $!\n"); + my $out = XMLin($dtd, *F); + close F; + return $out; +} + +sub XMLout { + my ($dtd, $d) = @_; + die("parameter is not a hash\n") unless UNIVERSAL::isa($d, 'HASH'); + if ($dtd->[0] eq '') { + die("excess hash elements\n") if keys %$d > 1; + for my $el (@$dtd) { + return _workout($el, $d->{$el->[0]}, '') if ref($el) && $d->{$el->[0]}; + } + die("no match for alternative\n"); + } + return _workout($dtd, $d, ''); +} + +1; + +__END__ + +=head1 NAME + +XML::Structured - simple conversion API from XML to perl structures and back + +=head1 SYNOPSIS + + use XML::Structured; + + $dtd = [ + 'element' => + 'attribute1', + 'attribute2', + [], + 'element1', + [ 'element2' ], + [ 'element3' => + ... + ], + [[ 'element4' => + ... + ]], + ]; + + $hashref = XMLin($dtd, $xmlstring); + $hashref = XMLinfile($dtd, $filename_or_glob); + $xmlstring = XMLout($dtd, $hashref); + +=head1 DESCRIPTION + +The XML::Structured module provides a way to convert xml data into +a predefined perl data structure and back to xml. Unlike with modules +like XML::Simple it is an error if the xml data does not match +the provided skeleton (the "dtd"). Another advantage is that the +order of the attributes and elements is taken from the dtd when +converting back to xml. + +=head2 XMLin() + +The XMLin() function takes the dtd and a string as arguments and +returns a hash reference containing the data. + +=head2 XMLinfile() + +This function works like C, but takes a filename or a +file descriptor glob as second argument. + +=head2 XMLout() + +C provides the reverse operation to C, it takes +a dtd and a hash reference as arguments and returns an XML string. + +=head1 The DTD + +The dtd parameter specifies the structure of the allowed xml data. +It consists of nested perl arrays. + +=head2 simple attributes and elements + +The very simple example for a dtd is: + + $dtd = [ 'user' => + 'login', + 'password', + ]; + +This dtd will accept/create XML like: + + + +XMLin doesn't care if "login" or "password" are attributes or +elements, so + + + foo + bar + + +is also valid input (but doesn't get re-created by C). + +=head2 multiple elements of the same name + +If an element may appear multiple times, it must be declared as +an array in the dtd: + + $dtd = [ 'user' => + 'login', + [ 'favorite_fruits' ], + ]; + +XMLin will create an array reference as value in this case, even if +the xml data contains only one element. Valid XML looks like: + + + apple + peach + + +As attributes may not appear multiple times, XMLout will create +elements for this case. Note also that all attributes must come +before the first element, thus the first array in the dtd ends +the attribute list. As an example, the following dtd + + $dtd = [ 'user' => + 'login', + [ 'favorite_fruits' ], + 'password', + ]; + +will create xml like: + + + apple + peach + bar + + +"login" is translated to an attribute and "password" to an element. + +You can use an empty array reference to force the end of the attribute +list, e.g.: + + $dtd = [ 'user' => + [], + 'login', + 'password', + ]; + +will translate to + + + foo + bar + + +instead of + + + +=head2 sub-elements + +sub-elements are elements that also contain attributes or other +elements. They are specified in the dtd as arrays with more than +one element. Here is an example: + + $dtd = [ 'user' => + 'login', + [ 'address' => + 'street', + 'city', + ], + ]; + +Valid xml for this dtd looks like: + + +
+ + +It is sometimes useful to specify such dtds in multiple steps: + + $addressdtd = [ 'address' => + 'street', + 'city', + ]; + + $dtd = [ 'user' => + 'login', + $addressdtd, + ]; + +=head2 multiple sub-elements with the same name + +As with simple elements, one can allow sub-elements to occur multiple +times. C creates an array of hash references in this case. +The dtd specification uses an array reference to an array for this +case, for example: + + $dtd = [ 'user' => + 'login', + [[ 'address' => + 'street', + 'city', + ]], + ]; +Or, with the $addressdtd definition used in the previous example: + + $dtd = [ 'user' => + 'login', + [ $addressdtd ], + ]; + +Accepted XML is: + + +
+
+ + +=head2 the _content pseudo-element + +All of the non-whitespace parts between elements get collected +into a single "_content" element. As example, + + +
hello +
world + + +would set the _content element to C (the dtd must allow +a _content element, of course). If the dtd is + + $dtd = [ 'user' => + 'login', + [ $addressdtd ], + '_content', + ]; + +the xml string created by XMLout() will be: + + +
+
+ hello world + + +The exact input cannot be re-created, as the positions and the +fragmentation of the content data is lost. + +=head1 SEE ALSO + +B requires either L or L. + +=head1 COPYRIGHT + +Copyright 2006 Michael Schroeder Emls@suse.deE + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/bs_mirrorfull b/bs_mirrorfull new file mode 100755 index 00000000..ccae1799 --- /dev/null +++ b/bs_mirrorfull @@ -0,0 +1,75 @@ +#!/usr/bin/perl -w + +use lib 'bs_copy'; +use BSUtil; +use BSRPC ':https'; +use BSXML; +use BSHTTP; + +use strict; + +my $nodebug; + +while (@ARGV) { + if ($ARGV[0] eq '--nodebug') { + $nodebug = 1; + } elsif ($ARGV[0] eq '--') { + shift @ARGV; + last; + } elsif ($ARGV[0] =~ /^-/) { + die("unknown option $ARGV[0]\n"); + } else { + last; + } + shift @ARGV; +} + +die("uasge: bs_mirrorfull url dir\n") unless @ARGV == 2; +my ($url, $dir) = @ARGV; +$url =~ s/\/$//; + +print "receiving tree state\n"; +my $bvl = BSRPC::rpc("$url/_repository", $BSXML::binaryversionlist, "view=binaryversions", "nometa=1"); +my @localbins = grep {/^[0-9a-f]{32}-.+\.rpm$/} ls($dir); +my %localbins = map {$_ => 1} @localbins; +my %remotebins; +for my $bv (@{$bvl->{'binary'} || []}) { + next unless $bv->{'name'} =~ /\.rpm$/; + next if $nodebug && $bv->{'name'} =~ /-debug(?:info|source|info-32bit)\.rpm$/; + $remotebins{"$bv->{'hdrmd5'}-$bv->{'name'}"} = $bv; +} +my @todelete = grep {!$remotebins{$_}} sort keys %localbins; +my @todownload = grep {!$localbins{$_}} sort keys %remotebins; +if (@todelete) { + print "deleting ".@todelete." old packages\n"; + for my $bin (@todelete) { + unlink("$dir/$bin") || die("unlink: $!\n"); + } +} +if (@todownload) { + print "downloading ".@todownload." new packages\n"; + my $todo = @todownload; + my $did = 0; + while (@todownload) { + my @fetch = splice(@todownload, 0, 50); + my @args; + for (@fetch) { + die unless /^[0-9a-f]{32}-(.+)\.rpm$/; + push @args, "binary=$1"; + } + my $param = { + 'uri' => "$url/_repository", + 'directory' => $dir, + 'map' => sub { + my ($param, $name) = @_; + return undef unless $name =~ /^(.+)-([0-9a-f]{32})$/; + return "$2-$1.rpm"; + }, + 'receiver' => \&BSHTTP::cpio_receiver, + }; + BSRPC::rpc($param, undef, 'view=cpioheaders', @args); + $did += @fetch; + print "$did/$todo\n"; + } +} +print "done, we now have ".(keys %remotebins)." packages.\n";