git.sur5r.net Git - bacula/bacula/blob - regress/scripts/regress-win32.pl

   1 #!/usr/bin/perl -w
   2
   3 =head1 NAME
   4
   5     regress-win32.pl -- Helper for Windows regression tests
   6
   7 =head2 DESCRIPTION
   8
   9     This perl script permits to run test Bacula Client Daemon on Windows.
  10     It allows to:
  11        - stop/start/upgrade the Bacula Client Daemon
  12        - compare to subtree with checksums, attribs and ACL
  13        - create test environments
  14
  15 =head2 USAGE
  16
  17   X:\> regress-win32.pl [-b basedir] [-i ip_address] [-p c:/bacula]
  18    or
  19   X:\> perl regress-win32.pl ...
  20
  21     -b|--base=path      Where to find regress and bacula directories
  22     -i|--ip=ip          Restrict access to this tool to this ip address
  23     -p|--prefix=path    Path to the windows installation
  24     -h|--help           Print this help
  25
  26 =head2 EXAMPLE
  27
  28     regress-win32.pl -b z:/git         # will find z:/git/regress z:/git/bacula
  29
  30     regress-win32.pl -i 192.168.0.1 -b z:
  31
  32 =head2 INSTALL
  33
  34     This perl script needs a Perl distribution on the Windows Client
  35     (http://strawberryperl.com)
  36
  37     You need to have the following subtree on x:
  38     x:/
  39       bacula/
  40       regress/
  41
  42    This script requires perl to work (http://strawberryperl.com), and by default
  43    it assumes that Bacula is installed in the standard location. Once it's
  44    started on the windows, you can do remote commands like:
  45     - start the service
  46     - stop the service
  47     - edit the bacula-fd.conf to change the director and password setting
  48     - install a new binary version (not tested, no plugin support)
  49     - create weird files and directories
  50     - create files with windows attributes
  51     - compare two directories (with md5)
  52
  53
  54    To test it, you can follow this procedure
  55    On the windows box:
  56     - install perl from http://strawberryperl.com on windows
  57     - copy or export regress directory somewhere on your windows
  58     - start the regress/scripts/regress-win32.pl (open it with perl.exe)
  59     - create c:/tmp (not sure it's mandatory)
  60     - make sure that the firewall is well configured or just disabled (needs
  61    bacula and 8091/tcp)
  62
  63    On Linux box:
  64     - edit config file to fill the following variables
  65
  66    WIN32_CLIENT="win2008-fd"
  67    # Client FQDN or IP address
  68    WIN32_ADDR="192.168.0.6"
  69    # File or Directory to backup.  This is put in the "File" directive
  70    #   in the FileSet
  71    WIN32_FILE="c:/tmp"
  72    # Port of Win32 client
  73    WIN32_PORT=9102
  74    # Win32 Client password
  75    WIN32_PASSWORD="xxx"
  76    # will be the ip address of the linux box
  77    WIN32_STORE_ADDR="192.168.0.1"
  78
  79     - type make setup
  80     - run ./tests/backup-bacula-test to be sure that everything is ok
  81     - start ./tests/win32-fd-test
  82
  83    I'm not very happy with this script, but it works :)
  84
  85 =cut
  86
  87 use strict;
  88 use HTTP::Daemon;
  89 use HTTP::Status;
  90 use HTTP::Response;
  91 use HTTP::Headers;
  92 use File::Copy;
  93 use Pod::Usage;
  94 use Cwd 'chdir';
  95 use File::Find;
  96 use Digest::MD5;
  97 use Getopt::Long ;
  98
  99 my $base = 'x:';
 100 my $src_ip = '';
 101 my $help;
 102 my $bacula_prefix="c:/Program Files/Bacula";
 103 my $conf = "C:/Documents and Settings/All Users/Application Data/Bacula";
 104 GetOptions("base=s"   => \$base,
 105            "help"     => \$help,
 106            "prefix=s" => \$bacula_prefix,
 107            "ip=s"     => \$src_ip);
 108
 109 if ($help) {
 110     pod2usage(-verbose => 2,
 111               -exitval => 0);
 112 }
 113
 114 if (! -d $bacula_prefix) {
 115     print "Could not find Bacula installation dir $bacula_prefix\n";
 116     print "Won't be able to upgrade the version or modify the configuration\n";
 117 }
 118
 119 if (-f "$bacula_prefix/bacula-fd.conf" and -f "$conf/bacula-fd.conf") {
 120     print "Unable to determine bacula-fd location $bacula_prefix or $conf ?\n";
 121
 122 } elsif (-f "$bacula_prefix/bacula-fd.conf") {
 123     $conf = $bacula_prefix;
 124 }
 125
 126 #if (! -d "$base/bacula" || ! -d "$base/regress") {
 127 #    pod2usage(-verbose => 2,
 128 #              -exitval => 1,
 129 #              -message => "Can't find bacula or regress dir on $base\n");
 130 #}
 131
 132 # stop the fd service
 133 sub stop_fd
 134 {
 135     return `net stop bacula-fd`;
 136 }
 137
 138 # copy binaries for a new fd
 139 sub install_fd
 140 {
 141     copy("$base/bacula/src/win32/release32/bacula-fd.exe",
 142          "c:/Program Files/bacula/bacula-fd.exe");
 143
 144     copy("$base/bacula/src/win32/release32/bacula.dll",
 145          "c:/Program Files/bacula/bacula.dll");
 146 }
 147
 148 # start the fd service
 149 sub start_fd
 150 {
 151     return `net start bacula-fd`;
 152 }
 153
 154 # initialize the weird directory for runscript test
 155 sub init_weird_runscript_test
 156 {
 157     my ($r) = shift;
 158
 159     if ($r->url !~ m!^/init_weird_runscript_test\?source=(\w:/[\w/]+)$!) {
 160         return "ERR\nIncorrect url\n";
 161     }
 162     my $source = $1;
 163
 164     if (!chdir($source)) {
 165         return "ERR\nCan't access to $source $!\n";
 166     }
 167
 168     if (-d "weird_runscript") {
 169         system("rmdir /Q /S weird_runscript");
 170     }
 171
 172     mkdir("weird_runscript");
 173     if (!chdir("weird_runscript")) {
 174         return "ERR\nCan't access to $source $!\n";
 175     }
 176
 177     open(FP, ">test.bat")                 or return "ERR\n";
 178     print FP "\@echo off\n";
 179     print FP "echo hello \%1\n";
 180     close(FP);
 181
 182     copy("test.bat", "test space.bat")    or return "ERR\n";
 183     copy("test.bat", "test2 space.bat")   or return "ERR\n";
 184     copy("test.bat", "testé.bat")         or return "ERR\n";
 185
 186     mkdir("dir space")                    or return "ERR\n";
 187     copy("test.bat", "dir space")         or return "ERR\n";
 188     copy("testé.bat","dir space")         or return "ERR\n";
 189     copy("test2 space.bat", "dir space")  or return "ERR\n";
 190
 191     mkdir("Évoilà")                       or return "ERR\n";
 192     copy("test.bat", "Évoilà")            or return "ERR\n";
 193     copy("testé.bat","Évoilà")            or return "ERR\n";
 194     copy("test2 space.bat", "Évoilà")     or return "ERR\n";
 195
 196     mkdir("Éwith space")                  or return "ERR\n";
 197     copy("test.bat", "Éwith space")       or return "ERR\n";
 198     copy("testé.bat","Éwith space")       or return "ERR\n";
 199     copy("test2 space.bat", "Éwith space") or return "ERR\n";
 200     return "OK\n";
 201 }
 202
 203 # init the Attrib test by creating some files and settings attributes
 204 sub init_attrib_test
 205 {
 206     my ($r) = shift;
 207
 208     if ($r->url !~ m!^/init_attrib_test\?source=(\w:/[\w/]+)$!) {
 209         return "ERR\nIncorrect url\n";
 210     }
 211
 212     my $source = $1;
 213
 214     if (!chdir($source)) {
 215         return "ERR\nCan't access to $source $!\n";
 216     }
 217
 218     # cleanup the old directory if any
 219     if (-d "attrib_test") {
 220         system("rmdir /Q /S attrib_test");
 221     }
 222
 223     mkdir("attrib_test");
 224     chdir("attrib_test");
 225
 226     mkdir("hidden");
 227     mkdir("hidden/something");
 228     system("attrib +H hidden");
 229
 230     mkdir("readonly");
 231     mkdir("readonly/something");
 232     system("attrib +R readonly");
 233
 234     mkdir("normal");
 235     mkdir("normal/something");
 236     system("attrib -R -H -S normal");
 237
 238     mkdir("system");
 239     mkdir("system/something");
 240     system("attrib +S system");
 241
 242     mkdir("readonly_hidden");
 243     mkdir("readonly_hidden/something");
 244     system("attrib +R +H readonly_hidden");
 245
 246     my $ret = `attrib /S /D`;
 247     $ret = strip_base($ret, $source);
 248
 249     return "OK\n$ret\n";
 250 }
 251
 252 sub md5sum
 253 {
 254     my $file = shift;
 255     open(FILE, $file) or return "Can't open $file $!";
 256     binmode(FILE);
 257     return Digest::MD5->new->addfile(*FILE)->hexdigest;
 258 }
 259
 260 # set $src and $dst before using Find call
 261 my ($src, $dst);
 262 my $error="";
 263 sub wanted
 264 {
 265     my $f = $File::Find::name;
 266     $f =~ s!^\Q$src\E/?!!i;
 267
 268     if (-f "$src/$f") {
 269         if (! -f "$dst/$f") {
 270             $error .= "$dst/$f is missing\n";
 271         } else {
 272             my $a = md5sum("$src/$f");
 273             my $b = md5sum("$dst/$f");
 274             if ($a ne $b) {
 275                 $error .= "$src/$f $a\n$dst/$f $b\n";
 276             }
 277         }
 278     }
 279 }
 280
 281 sub set_director_name
 282 {
 283     my ($r) = shift;
 284
 285     if ($r->url !~ m!^/set_director_name\?name=([\w\d\.\-]+);pass=([\w\d+]+)$!)
 286     {
 287         return "ERR\nIncorrect url\n";
 288     }
 289
 290     my ($name, $pass) = ($1, $2);
 291
 292     open(ORG, "$conf/bacula-fd.conf") or return "ERR\nORG $!\n";
 293     open(NEW, ">$conf/bacula-fd.conf.new") or return "ERR\nNEW $!\n";
 294
 295     my $in_dir=0;               # don't use monitoring section
 296     my $nb_dir="";
 297     while (my $l = <ORG>)
 298     {
 299         if ($l =~ /^\s*Director\s+{/i) {
 300             print NEW $l;
 301             $in_dir = 1;
 302         } elsif ($l =~ /^(\s*)Name\s*=/ and $in_dir) {
 303             print NEW "${1}Name=$name$nb_dir\n";
 304         } elsif ($l =~ /^(\s*)Password\s*=/ and $in_dir) {
 305             print NEW "${1}Password=$pass\n";
 306         } elsif ($l =~ /\s*}/ and $in_dir) {
 307             print NEW $l;
 308             $in_dir = 0;
 309             $nb_dir++;
 310         } else {
 311             print NEW $l;
 312         }
 313     }
 314
 315     close(ORG);
 316     close(NEW);
 317     move("$conf/bacula-fd.conf.new", "$conf/bacula-fd.conf")
 318         and return "OK\n";
 319
 320     return "ERR\n";
 321 }
 322
 323 # convert \ to / and strip the path
 324 sub strip_base
 325 {
 326     my ($data, $path) = @_;
 327     $data =~ s!\\!/!sg;
 328     $data =~ s!\Q$path!!sig;
 329     return $data;
 330 }
 331
 332 # Compare two directories, make checksums, compare attribs and ACLs
 333 sub compare
 334 {
 335     my ($r) = shift;
 336
 337     if ($r->url !~ m!^/compare\?source=(\w:/[\w/]+);dest=(\w:/[\w/]+)$!) {
 338         return "ERR\nIncorrect url\n";
 339     }
 340
 341     my ($source, $dest) = ($1, $2);
 342
 343     if (!Cwd::chdir($source)) {
 344         return "ERR\nCan't access to $source $!\n";
 345     }
 346
 347     my $src_attrib = `attrib /D /S`;
 348     $src_attrib = strip_base($src_attrib, $source);
 349
 350     if (!Cwd::chdir($dest)) {
 351         return "ERR\nCan't access to $dest $!\n";
 352     }
 353
 354     my $dest_attrib = `attrib /D /S`;
 355     $dest_attrib = strip_base($dest_attrib, $dest);
 356
 357     if (lc($src_attrib) ne lc($dest_attrib)) {
 358         return "ERR\n$src_attrib\n=========\n$dest_attrib\n";
 359     }
 360
 361     ($src, $dst, $error) = ($source, $dest, '');
 362     find(\&wanted, $source);
 363     if ($error) {
 364         return "ERR\n$error";
 365     } else {
 366         return "OK\n";
 367     }
 368 }
 369
 370 sub cleandir
 371 {
 372     my ($r) = shift;
 373
 374     if ($r->url !~ m!^/cleandir\?source=(\w:/[\w/]+)/restore$!) {
 375         return "ERR\nIncorrect url\n";
 376     }
 377
 378     my $source = $1;
 379
 380     if (! -d "$source/restore") {
 381         return "ERR\nIncorrect path\n";
 382     }
 383
 384     if (!chdir($source)) {
 385         return "ERR\nCan't access to $source $!\n";
 386     }
 387
 388     system("rmdir /Q /S restore");
 389
 390     return "OK\n";
 391 }
 392
 393 my $Registry;
 394 use Win32::TieRegistry qw/KEY_READ KEY_WRITE/;
 395
 396 sub add_registry_key
 397 {
 398     my ($r) = shift;
 399     my $ret="ERR";
 400     if ($r->url !~ m!^/add_registry_key\?key=(\w+);val=(\w+)$!) {
 401         return "ERR\nIncorrect url\n";
 402     }
 403     my ($k, $v) = ($1,$2);
 404
 405     my $key= new Win32::TieRegistry ("LMachine/SOFTWARE/",
 406                                      { Access=>KEY_READ()|KEY_WRITE(),
 407                                        Delimiter=>"/" })
 408         or return "ERR Can't open Registry\n";
 409     print join(",", keys( %{$key} )), "\n" ;
 410     my $newKey = $key->{"Bacula"};
 411     if ($newKey) {
 412         $newKey->{$k} = $v;
 413         $ret = "OK\n";
 414     } else {
 415         $ret = "ERR can't find Bacula key";
 416     }
 417
 418     undef $key;
 419     undef $newKey;
 420     return "$ret\n";
 421 }
 422
 423 sub del_registry_key
 424 {
 425     my ($r) = shift;
 426     my $ret="ERR";
 427     if ($r->url !~ m!^/del_registry_key\?key=(\w+)$!) {
 428         return "ERR\nIncorrect url\n";
 429     }
 430     my $k = $1;
 431
 432     my $key= new Win32::TieRegistry ("LMachine/Software/",
 433                                      { Access=>KEY_READ()|KEY_WRITE(),
 434                                        Delimiter=>"/" })
 435         or return "ERR Can't open Registry\n";
 436
 437     my $newKey = $key->{"Bacula"};
 438     if ($newKey) {
 439         delete $newKey->{$k};
 440         $ret = "OK\n";
 441     } else {
 442         $ret = "ERR can't find Bacula key";
 443     }
 444     undef $key;
 445     undef $newKey;
 446     return "$ret\n";
 447 }
 448
 449 sub get_registry_key
 450 {
 451     my ($r) = shift;
 452     my $ret = "ERR";
 453     if ($r->url !~ m!^/get_registry_key\?key=(\w+);val=(\w+)$!) {
 454         return "ERR\nIncorrect url\n";
 455     }
 456     my ($k, $v) = ($1, $2);
 457
 458     my $key= new Win32::TieRegistry ("LMachine/Software/",
 459                                      { Access=>KEY_READ()|KEY_WRITE(),
 460                                        Delimiter=>"/" })
 461         or return "ERR Can't open Registry\n";
 462
 463     my $newKey = $key->{"Bacula"};
 464     if ($newKey) {
 465         if ($newKey->{$k} eq $v) {
 466             $ret = "OK\n";
 467         } else {
 468             $ret = "ERR key=" . $newKey->{$k};
 469         }
 470     } else {
 471         $ret = "ERR can't find Bacula key";
 472     }
 473     undef $key;
 474     undef $newKey;
 475     return "$ret\n";
 476 }
 477
 478 # When adding an action, fill this hash with the right function
 479 my %action_list = (
 480     stop    => \&stop_fd,
 481     start   => \&start_fd,
 482     install => \&install_fd,
 483     compare => \&compare,
 484     init_attrib_test => \&init_attrib_test,
 485     init_weird_runscript_test => \&init_weird_runscript_test,
 486     set_director_name => \&set_director_name,
 487     cleandir => \&cleandir,
 488     add_registry_key => \&add_registry_key,
 489     del_registry_key => \&del_registry_key,
 490     get_registry_key => \&get_registry_key,
 491     quit => sub {  exit 0; },
 492     );
 493
 494 # handle client request
 495 sub handle_client
 496 {
 497     my ($c, $ip) = @_ ;
 498     my $action;
 499     my $r = $c->get_request ;
 500
 501     if (!$r) {
 502         $c->send_error(RC_FORBIDDEN) ;
 503         return;
 504     }
 505     if ($r->url->path !~ m!^/(\w+)!) {
 506         $c->send_error(RC_NOT_FOUND) ;
 507         return;
 508     }
 509     $action = $1;
 510
 511     if (($r->method eq 'GET')
 512         and $action_list{$action})
 513     {
 514         my $ret = $action_list{$action}($r);
 515         my $h = HTTP::Headers->new('Content-Type' => 'text/plain') ;
 516         my $r = HTTP::Response->new(HTTP::Status::RC_OK,
 517                                     'OK', $h, $ret) ;
 518
 519         $c->send_response($r) ;
 520     } else {
 521         $c->send_error(RC_NOT_FOUND) ;
 522     }
 523
 524     $c->close;
 525 }
 526
 527 my $d = HTTP::Daemon->new ( LocalPort =>  8091,
 528                             ReuseAddr => 1)
 529     || die "Error: Can't bind $!" ;
 530
 531 my $olddir = Cwd::cwd();
 532 while (1) {
 533     print "Starting daemon...\n";
 534     my $c = $d->accept ;
 535     my $ip = $c->peerhost;
 536     if (!$ip) {
 537         $c->send_error(RC_FORBIDDEN) ;
 538     } elsif ($src_ip && $ip ne $src_ip) {
 539         $c->send_error(RC_FORBIDDEN) ;
 540     } elsif ($c) {
 541         handle_client($c, $ip) ;
 542     } else {
 543         $c->send_error(RC_FORBIDDEN) ;
 544     }
 545     close($c) ;
 546     chdir($olddir);
 547 }