lib/Clearquest/DBService.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: DBService.pm,v $
   4
   5 DB Service - Provide access to Clearquest database
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.2 $
  18
  19 =item Created
  20
  21 Monday, October 10, 2011  5:02:07 PM PDT
  22
  23 =item Modified
  24
  25 $Date: 2011/12/31 02:13:37 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides an interface to the Clearquest database over the network.
  32
  33 This library implements both the daemon portion of the server and the client
  34 API.
  35
  36 =head1 DESCRIPTION
  37
  38 The server allows both read and write access to a Clearquest database as defined
  39 in cqdservice.conf file. Note the username/password must be of a user who can
  40 write to the Clearquest database for write access to succeed.
  41
  42 A hash is passed into to the execute method, which the client should use to talk
  43 to the server, that describes relatively simple protocol to tell the server what
  44 action to perform. In both the read case and the read/write case a field named
  45 id should be defined that has a value of "<record>=<id>" (e.g.
  46 "defect=BUGDB00034429").
  47
  48 For the read case the rest of the keys are the names of the fields to retrieve
  49 with values that are undef'ed. For read/write, the rest of hash contains name
  50 value pairs of fields to set and their values.
  51
  52 Execute returns a status and a hash of name value pairs for the read case and an
  53 array of lines for any error messages for the read/write case.
  54
  55 =head1 ROUTINES
  56
  57 The following methods are available:
  58
  59 =cut
  60
  61 package Clearquest::DBService;
  62
  63 use strict;
  64 use warnings;
  65
  66 use Carp;
  67 use File::Basename;
  68 use FindBin;
  69 use IO::Socket;
  70 use Net::hostent;
  71 use POSIX ":sys_wait_h";
  72
  73 use DateUtils;
  74 use Display;
  75 use GetConfig;
  76
  77 # Seed options from config file
  78 my $config = $ENV{CQD_CONF} || dirname (__FILE__) . '/../../etc/cqdservice.conf';
  79
  80 croak "Unable to find config file $config" unless -r $config;
  81
  82 our %OPTS = GetConfig $config;
  83
  84 our $VERSION  = '$Revision: 1.2 $';
  85    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
  86
  87 # Override options if in the environment
  88 $OPTS{CQD_HOST}          = $ENV{CQD_HOST}
  89   if $ENV{CQD_HOST};
  90 $OPTS{CQD_PORT}          = $ENV{CQD_PORT}
  91   if $ENV{CQD_PORT};
  92 $OPTS{CQD_MULTITHREADED} = $ENV{CQD_MULTITHREADED}
  93   if defined $ENV{CQD_MULTITHREADED};
  94 $OPTS{CQD_DATABASE}      = $ENV{CQD_DATABASE}
  95   if $ENV{CQD_DATABASE};
  96 $OPTS{CQD_USERNAME}      = $ENV{CQD_USERNAME}
  97   if $ENV{CQD_USERNAME};
  98 $OPTS{CQD_PASSWORD}      = $ENV{CQD_PASSWORD}
  99   if $ENV{CQD_PASSWORD};
 100 $OPTS{CQD_DBSET}         = $ENV{CQD_DBSET}
 101   if $ENV{CQD_DBSET};
 102
 103 sub new () {
 104   my ($class) = @_;
 105
 106   my $cqdservice = bless {}, $class;
 107
 108   $cqdservice->{multithreaded} = $OPTS{CQD_MULTITHREADED};
 109
 110   return $cqdservice;
 111 } # new
 112
 113 sub _tag ($) {
 114   my ($self, $msg) = @_;
 115
 116   my $tag  = YMDHMS;
 117      $tag .= ' ';
 118      $tag .= $self->{pid} ? "[$self->{pid}] " : '';
 119
 120   return "$tag$msg";
 121 } # _tag
 122
 123  sub _verbose ($) {
 124   my ($self, $msg) = @_;
 125
 126   verbose $self->_tag ($msg);
 127
 128   return;
 129 } # _verbose
 130
 131 sub _debug ($) {
 132   my ($self, $msg) = @_;
 133
 134   debug $self->_tag ($msg);
 135
 136   return;
 137 } # _debug
 138
 139 sub _log ($) {
 140   my ($self, $msg) = @_;
 141
 142   display $self->_tag ($msg);
 143
 144   return;
 145 } # log
 146
 147 sub _funeral () {
 148   debug 'Entered _funeral';
 149
 150   while (my $childpid = waitpid (-1, WNOHANG) > 0) {
 151     my $status = $?;
 152
 153     debug "childpid: $childpid - status: $status";
 154
 155     if ($childpid != -1) {
 156       local $SIG{CHLD} = \&_funeral;
 157
 158       my $msg  = 'Child has died';
 159          $msg .= $status ? " with status $status" : '';
 160
 161       verbose "[$childpid] $msg"
 162         if $status;
 163     } else {
 164       debug "All children reaped";
 165     } # if
 166   } # while
 167
 168   return;
 169 } # _funeral
 170
 171 sub _endServer () {
 172   display "CQDService V$VERSION shutdown at " . localtime;
 173
 174   # Kill process group
 175   kill 'TERM', -$$;
 176
 177   # Wait for all children to die
 178   while (wait != -1) {
 179     # do nothing
 180   } # while
 181
 182   # Now that we are alone, we can simply exit
 183   exit;
 184 } # _endServer
 185
 186 sub _restartServer () {
 187   # Not sure what to do on a restart server
 188   display 'Entered _restartServer';
 189
 190   return;
 191 } # _restartServer
 192
 193 sub setMultithreaded ($) {
 194   my ($self, $value) = @_;
 195
 196   my $oldValue = $self->{multithreaded};
 197
 198   $self->{multithreaded} = $value;
 199
 200   return $oldValue;
 201 } # setMultithreaded
 202
 203 sub getMultithreaded () {
 204   my ($self) = @_;
 205
 206   return $self->{multithreaded};
 207 } # getMultithreaded
 208
 209 sub connectToServer (;$$) {
 210   my ($self, $host, $port) = @_;
 211
 212   $host ||= $OPTS{CQD_HOST};
 213   $port ||= $OPTS{CQD_PORT};
 214
 215   $self->{socket} = IO::Socket::INET->new (
 216     Proto       => 'tcp',
 217     PeerAddr    => $host,
 218     PeerPort    => $port,
 219   );
 220
 221   return unless $self->{socket};
 222
 223   $self->{socket}->autoflush;
 224
 225   $self->{host} = $host;
 226   $self->{port} = $port;
 227
 228   return $self->{socket} ? 1 : 0;
 229 } # connectToServer
 230
 231 sub disconnectFromServer () {
 232   my ($self) = @_;
 233
 234   if ($self->{socket}) {
 235    close $self->{socket};
 236
 237    undef $self->{socket};
 238   } # if
 239
 240   return;
 241 } # disconnectFromServer
 242
 243 # TODO: This function should not be internal and it should be overridable
 244 sub _serviceClient ($$) {
 245   my ($self, $host, $client) = @_;
 246
 247   $self->_verbose ("Serving requests from $host");
 248
 249   # Set autoflush for client
 250   $client->autoflush
 251     if $client;
 252
 253   # Input is simple and consists of the following:
 254   #
 255   # <recordType>=<ID>
 256   # <fieldname>=<fieldvalue>
 257   # <fieldname>+=<fieldvalue>
 258   # ...
 259   # end
 260   #
 261   # Notes: <ID> can be <ID_scope>. Also a += means append this fieldvalue to
 262   # the existing value for the field.
 263
 264   # First get record line
 265   my $line = <$client>;
 266
 267   if ($line) {
 268     chomp $line; chop $line if $line =~ /\r$/;
 269   } else {
 270     $self->_verbose ("Host $host went away!");
 271
 272     close $client;
 273
 274     return;
 275   } # if
 276
 277   if ($line =~ /stopserver/i) {
 278     if ($self->{server}) {
 279       $self->_verbose ("$host requested to stop server [$self->{server}]");
 280
 281       # Send server hangup signal
 282       kill 'HUP', $self->{server};
 283     } else {
 284       $self->_verbose ('Shutting down server');
 285
 286       print $client "CQDService Status: 0\n";
 287
 288       exit;
 289     } # if
 290   } # if
 291
 292   my ($record, $id) = split /=/, $line;
 293
 294   unless ($id) {
 295     $self->_verbose ('Garbled record line - rejected request');
 296
 297     close $client;
 298
 299     return;
 300   } # unless
 301
 302   $self->_verbose ("Client wishes to deal with $id");
 303
 304   my $scope;
 305
 306   if ($id =~ /_(\S+)/) {
 307     $scope = $1;
 308   } # if
 309
 310   $self->_debug ("$host wants $record:$id");
 311
 312   my ($read, %fields);
 313
 314   # Now read name/value pairs
 315   while () {
 316     # Read command from client
 317     $line = <$client>;
 318
 319     if ($line) {
 320       chomp $line; chop $line if $line =~ /\r$/;
 321     } else {
 322       $self->_verbose ("Host $host went away!");
 323
 324       close $client;
 325
 326       return;
 327     } # if
 328
 329     last if $line =~ /^end$/i;
 330
 331     # Collect name/values. Note if only names are requested then we will instead
 332     # return data.
 333     my ($name, $value) = split /=/, $line;
 334
 335     if ($value) {
 336       # Transform %0A's back to \n
 337       $value =~ s/\%0A/\n/g;
 338
 339       $self->_verbose ("Will set $name to $value");
 340     } else {
 341       $read = 1;
 342       $self->_verbose ("Will retrieve $name");
 343     } # if
 344
 345     $fields{$name} = $value;
 346   } # while
 347
 348   # Get record
 349   my $entity;
 350
 351   $self->_verbose ("Getting $record:$id");
 352
 353   eval { $entity = $self->{session}->GetEntity ($record, $id) };
 354
 355   unless ($entity) {
 356     print $client "Unable to GetEntity $record:$id\n";
 357
 358     close $client;
 359
 360     return;
 361   } # unless
 362
 363   if ($read) {
 364     print $client "$_@@" . $entity->GetFieldValue ($_)->GetValue . "\n"
 365       for (keys %fields);
 366     print $client "CQD Status: 0\n";
 367
 368     close $client;
 369
 370     return;
 371   } # if
 372
 373   # Edit record
 374   $self->_verbose ("Editing $id");
 375
 376   $entity->EditEntity ('Backend');
 377
 378   my $status;
 379
 380   for my $fieldName (keys %fields) {
 381     if ($fieldName =~ /(.+)\*$/) {
 382       my $newValue = delete $fields{$fieldName};
 383
 384       $fieldName = $1;
 385
 386       $fields{$fieldName} = $entity->GetFieldValue ($fieldName)->GetValue
 387                           . $newValue;
 388     } # if
 389
 390     $self->_verbose ("Setting $fieldName to $fields{$fieldName}");
 391
 392     $status = $entity->SetFieldValue ($fieldName, $fields{$fieldName});
 393
 394     if ($status ne '') {
 395       $self->_verbose ($status);
 396
 397       print $client "$status\n";
 398       print $client "CQD Status: 1\n";
 399
 400       close $client;
 401
 402       return;
 403     } # if
 404   } # for
 405
 406   $self->_verbose ("Validating $id");
 407
 408   $status = $entity->Validate;
 409
 410   if ($status eq '') {
 411     $self->_verbose ('Committing');
 412     $entity->Commit;
 413
 414     print $client "Successfully updated $id\n";
 415     print $client "CQD Status: 0\n";
 416   } else {
 417     $self->_verbose ('Reverting changes');
 418     $entity->Revert;
 419     print $client "$status\n";
 420     print $client "CQD Status: 1\n";
 421   } # if
 422
 423   close $client;
 424
 425   $self->_verbose ("Serviced requests from $host");
 426
 427   return;
 428 }  # _serviceClient
 429
 430 sub execute (%) {
 431   my ($self, %request) = @_;
 432
 433   $self->connectToServer or croak 'Unable to connect to CQD Service';
 434
 435   return (-1, 'Unable to talk to server')
 436     unless $self->{socket};
 437
 438   my ($status, @output) = (-1, ());
 439
 440   my $server = $self->{socket};
 441
 442   my $id = delete $request{id};
 443
 444   print $server "$id\n";
 445
 446   my $read;
 447
 448   for (keys %request) {
 449     if ($request{$_}) {
 450       print $server "$_=$request{$_}\n";
 451     } else {
 452       $read = 1;
 453       print $server "$_\n";
 454     } # if
 455   } # for
 456
 457   print $server "end\n";
 458
 459   my ($response, %output);
 460
 461   while (defined ($response = <$server>)) {
 462     if ($response =~ /CQD Status: (-*\d+)/) {
 463       $status = $1;
 464       last;
 465     } # if
 466
 467     if ($read) {
 468       chomp $response; chop $response if $response =~ /\r$/;
 469
 470       my ($field, $value) = split /\@\@/, $response;
 471
 472       $output{$field} = $value;
 473     } else {
 474       push @output, $response;
 475     } # if
 476   } # while
 477
 478   chomp @output unless $read;
 479
 480   $self->disconnectFromServer;
 481
 482   if ($status != 0 or $read == 0) {
 483     return ($status, @output);
 484   } else {
 485     return ($status, %output);
 486   } # if
 487 } # execute
 488
 489 sub startServer (;$$$$$) {
 490
 491   require 'Clearquest.pm';
 492
 493   my ($self, $port, $username, $password, $db, $dbset) = @_;
 494
 495   $port     ||= $OPTS{CQD_PORT};
 496   $username ||= $OPTS{CQD_USERNAME};
 497   $password ||= $OPTS{CQD_PASSWORD};
 498   $db       ||= $OPTS{CQD_DATABASE};
 499   $dbset    ||= $OPTS{CQD_DBSET};
 500
 501   # Create new socket to communicate to clients with
 502   $self->{socket} = IO::Socket::INET->new(
 503     Proto     => 'tcp',
 504     LocalPort => $port,
 505     Listen    => SOMAXCONN,
 506     Reuse     => 1
 507   );
 508
 509   error "Could not create socket - $!", 1
 510     unless $self->{socket};
 511
 512   # Connect to Clearquest database
 513   $self->{session} = CQSession::Build ();
 514
 515   verbose "Connecting to $username\@$db";
 516
 517   $self->{session}->UserLogon ($username, $password, $db, $dbset);
 518
 519   # Announce ourselves
 520   $self->_log ("CQD V$VERSION accepting clients at " . localtime);
 521
 522   # Now wait for an incoming request
 523   LOOP:
 524   my $client;
 525
 526   while ($client = $self->{socket}->accept) {
 527     my $hostinfo = gethostbyaddr $client->peeraddr;
 528     my $host     = $hostinfo ? $hostinfo->name : $client->peerhost;
 529
 530     $self->_verbose ("$host is requesting service");
 531
 532     if ($self->getMultithreaded) {
 533       $self->{server} = $$;
 534
 535       my $childpid;
 536
 537       $self->_debug ("Spawning child to handle request");
 538
 539       error "Can't fork: $!"
 540         unless defined ($childpid = fork);
 541
 542       if ($childpid) {
 543         $self->{pid} = $$;
 544
 545         $SIG{CHLD} = \&_funeral;
 546         $SIG{HUP}  = \&_endServer;
 547         $SIG{USR2} = \&_restartServer;
 548
 549         $self->_debug ("Parent produced child [$childpid]");
 550       } else {
 551         # In child process - ServiceClient
 552         $self->{pid} = $$;
 553
 554         $self->_debug ("Calling _serviceClient");
 555         $self->_serviceClient ($host, $client);
 556         $self->_debug ("Returned from _serviceClient - exiting...");
 557
 558         exit;
 559       } # if
 560     } else {
 561       $self->_serviceClient ($host, $client);
 562     } # if
 563   } # while
 564
 565   # This works but I really don't like it. The parent should have looped back to
 566   # the while statement thus waiting for the next client. But it doesn't seem to
 567   # do that. Instead, when multithreaded, the child exits above and then the
 568   # parent breaks out of the while loop. I'm not sure why this is happening.
 569   # This goto fixes this up but it's sooooo ugly!
 570   goto LOOP;
 571 } # startServer
 572
 573 1;
 574
 575 =pod
 576
 577 =head1 CONFIGURATION AND ENVIRONMENT
 578
 579 DEBUG: If set then $debug is set to this level.
 580
 581 VERBOSE: If set then $verbose is set to this level.
 582
 583 TRACE: If set then $trace is set to this level.
 584
 585 =head1 DEPENDENCIES
 586
 587 =head2 Perl Modules
 588
 589 L<Carp>
 590
 591 L<File::Basename|File::Basename>
 592
 593 L<FindBin>
 594
 595 L<IO::Socket|IO::Socket>
 596
 597 L<Net::hostent|Net::hostent>
 598
 599 L<POSIX>
 600
 601 =head2 ClearSCM Perl Modules
 602
 603 =begin man
 604
 605  DateUtils
 606  Display
 607  GetConfig
 608
 609 =end man
 610
 611 =begin html
 612
 613 <blockquote>
 614 <a href="http://clearscm.com/php/scm_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
 615 <a href="http://clearscm.com/php/scm_man.php?file=lib/Display.pm">Display</a><br>
 616 <a href="http://clearscm.com/php/scm_man.php?file=lib/GetConfig.pm">GetConf</a><br>
 617 </blockquote>
 618
 619 =end html
 620
 621 =head1 SEE ALSO
 622
 623 =head1 BUGS AND LIMITATIONS
 624
 625 There are no known bugs in this module.
 626
 627 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
 628
 629 =head1 LICENSE AND COPYRIGHT
 630
 631 Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
 632
 633 =cut