1package Ubic; 2{ 3 $Ubic::VERSION = '1.58'; 4} 5 6use strict; 7use warnings; 8 9# ABSTRACT: polymorphic service manager 10 11 12use POSIX qw(); 13use Carp; 14use IO::Handle; 15use Storable qw(freeze thaw); 16use Try::Tiny; 17use Scalar::Util qw(blessed); 18use Params::Validate qw(:all); 19 20use Ubic::Result qw(result); 21use Ubic::Multiservice::Dir; 22use Ubic::AccessGuard; 23use Ubic::Credentials; 24use Ubic::Persistent; 25use Ubic::AtomicFile; 26use Ubic::SingletonLock; 27use Ubic::Settings; 28 29our $SINGLETON; 30 31my $service_name_re = qr{^[\w-]+(?:\.[\w-]+)*$}; 32my $validate_service = { type => SCALAR, regex => $service_name_re }; 33 34# singleton constructor 35sub _obj { 36 my ($param) = validate_pos(@_, 1); 37 if (blessed($param)) { 38 return $param; 39 } 40 if ($param eq 'Ubic') { 41 # method called as a class method => singleton 42 $SINGLETON ||= Ubic->new({}); 43 return $SINGLETON; 44 } 45 die "Unknown argument '$param'"; 46} 47 48sub new { 49 my $class = shift; 50 my $options = validate(@_, { 51 service_dir => { type => SCALAR, optional => 1 }, 52 data_dir => { type => SCALAR, optional => 1 }, 53 }); 54 55 if (caller ne 'Ubic') { 56 warn "Using Ubic->new constructor is discouraged. Just call methods as class methods."; 57 } 58 59 for my $key (qw/ service_dir data_dir /) { 60 Ubic::Settings->$key($options->{ $key }) if defined $options->{$key}; 61 } 62 63 Ubic::Settings->check_settings; 64 65 my $self = {}; 66 $self->{data_dir} = Ubic::Settings->data_dir; 67 $self->{service_dir} = Ubic::Settings->service_dir; 68 69 $self->{status_dir} = "$self->{data_dir}/status"; 70 $self->{lock_dir} = "$self->{data_dir}/lock"; 71 $self->{tmp_dir} = "$self->{data_dir}/tmp"; 72 73 $self->{service_cache} = {}; 74 return bless $self => $class; 75} 76 77sub start($$) { 78 my $self = _obj(shift); 79 my ($name) = validate_pos(@_, $validate_service); 80 my $lock = $self->lock($name); 81 82 $self->enable($name); 83 my $result = $self->do_cmd($name, 'start'); 84 $self->set_cached_status($name, $result); 85 return $result; 86} 87 88sub stop($$) { 89 my $self = _obj(shift); 90 my ($name) = validate_pos(@_, $validate_service); 91 my $lock = $self->lock($name); 92 93 $self->disable($name); 94 95 # FIXME - 'stop' command can fail, in this case daemon will keep running. 96 # This is bad. 97 # We probably need to implement the same logic as when starting: 98 # retry stop attempts until actual status matches desired status. 99 my $result = $self->do_cmd($name, 'stop'); 100 return $result; 101} 102 103sub restart($$) { 104 my $self = _obj(shift); 105 my ($name) = validate_pos(@_, $validate_service); 106 my $lock = $self->lock($name); 107 108 $self->enable($name); 109 my $result = $self->do_cmd($name, 'stop'); 110 $result = $self->do_cmd($name, 'start'); 111 112 $self->set_cached_status($name, $result); 113 return result('restarted'); # FIXME - should return original status 114} 115 116sub try_restart($$) { 117 my $self = _obj(shift); 118 my ($name) = validate_pos(@_, $validate_service); 119 my $lock = $self->lock($name); 120 121 unless ($self->is_enabled($name)) { 122 return result('down'); 123 } 124 $self->do_cmd($name, 'stop'); 125 $self->do_cmd($name, 'start'); 126 return result('restarted'); 127} 128 129sub reload($$) { 130 my $self = _obj(shift); 131 my ($name) = validate_pos(@_, $validate_service); 132 my $lock = $self->lock($name); 133 134 unless ($self->is_enabled($name)) { 135 return result('down'); 136 } 137 138 # if reload isn't implemented, do nothing 139 # TODO - would it be better to execute reload as force-reload always? but it would be incompatible with LSB specification... 140 my $result = $self->do_cmd($name, 'reload'); 141 unless ($result->action eq 'reloaded') { 142 die $result; 143 } 144 return $result; 145} 146 147sub force_reload($$) { 148 my $self = _obj(shift); 149 my ($name) = validate_pos(@_, $validate_service); 150 my $lock = $self->lock($name); 151 152 unless ($self->is_enabled($name)) { 153 return result('down'); 154 } 155 156 my $result = $self->do_cmd($name, 'reload'); 157 return $result if $result->action eq 'reloaded'; 158 159 $self->try_restart($name); 160} 161 162sub status($$) { 163 my $self = _obj(shift); 164 my ($name) = validate_pos(@_, $validate_service); 165 my $lock = $self->lock($name); 166 167 return $self->do_cmd($name, 'status'); 168} 169 170sub enable($$) { 171 my $self = _obj(shift); 172 my ($name) = validate_pos(@_, $validate_service); 173 my $lock = $self->lock($name); 174 my $guard = $self->access_guard($name); 175 176 my $status_obj = $self->status_obj($name); 177 $status_obj->{status} = 'unknown'; 178 $status_obj->{enabled} = 1; 179 $status_obj->commit; 180 return result('unknown'); 181} 182 183sub is_enabled($$) { 184 my $self = _obj(shift); 185 my ($name) = validate_pos(@_, $validate_service); 186 187 die "Service '$name' not found" unless $self->root_service->has_service($name); 188 unless (-e $self->status_file($name)) { 189 return $self->service($name)->auto_start(); 190 } 191 192 my $status_obj = $self->status_obj_ro($name); 193 if ($status_obj->{enabled} or not exists $status_obj->{enabled}) { 194 return 1; 195 } 196 return; 197} 198 199sub disable($$) { 200 my $self = _obj(shift); 201 my ($name) = validate_pos(@_, $validate_service); 202 my $lock = $self->lock($name); 203 my $guard = $self->access_guard($name); 204 205 my $status_obj = $self->status_obj($name); 206 delete $status_obj->{status}; 207 $status_obj->{enabled} = 0; 208 $status_obj->commit; 209} 210 211 212sub cached_status($$) { 213 my ($self) = _obj(shift); 214 my ($name) = validate_pos(@_, $validate_service); 215 216 my $type; 217 if (not $self->is_enabled($name)) { 218 $type = 'disabled'; 219 } 220 elsif (-e $self->status_file($name)) { 221 $type = $self->status_obj_ro($name)->{status}; 222 } else { 223 $type = 'autostarting'; 224 } 225 return Ubic::Result::Class->new({ type => $type, cached => 1 }); 226} 227 228sub do_custom_command($$) { 229 my ($self) = _obj(shift); 230 my ($name, $command) = validate_pos(@_, $validate_service, 1); 231 232 # TODO - do all custom commands require locks? 233 # they can be distinguished in future by some custom_commands_ext method which will provide hash { command => properties }, i think... 234 my $lock = $self->lock($name); 235 236 # TODO - check custom_command presence by custom_commands() method first? 237 $self->do_sub(sub { 238 $self->service($name)->do_custom_command($command); # can custom commands require custom arguments? 239 }); 240} 241 242sub service($$) { 243 my $self = _obj(shift); 244 my ($name) = validate_pos(@_, $validate_service); 245 # this guarantees that : will be unambiguous separator in status filename (what??) 246 unless ($self->{service_cache}{$name}) { 247 # Service construction is a memory-leaking operation (because of package name randomization in Ubic::Multiservice::Dir), 248 # so we need to cache each service which we create. 249 $self->{service_cache}{$name} = $self->root_service->service($name); 250 } 251 return $self->{service_cache}{$name}; 252} 253 254sub has_service($$) { 255 my $self = _obj(shift); 256 my ($name) = validate_pos(@_, $validate_service); 257 # TODO - it would be safer to do this check without actual service construction 258 # but it would require cron-based script which maintains list of all services 259 return $self->root_service->has_service($name); 260} 261 262sub services($) { 263 my $self = _obj(shift); 264 return $self->root_service->services(); 265} 266 267sub service_names($) { 268 my $self = _obj(shift); 269 return $self->root_service->service_names(); 270} 271 272sub root_service($) { 273 my $self = _obj(shift); 274 unless (defined $self->{root}) { 275 $self->{root} = Ubic::Multiservice::Dir->new($self->{service_dir}, { protected => 1 }); 276 } 277 return $self->{root}; 278} 279 280sub compl_services($$) { 281 my $self = _obj(shift); 282 my $line = shift; 283 my @parts = split /\./, $line; 284 if ($line =~ /\.$/) { 285 push @parts, ''; 286 } 287 if (@parts == 0) { 288 return $self->service_names; 289 } 290 my $node = $self->root_service; 291 my $is_subservice = (@parts > 1); 292 while (@parts > 1) { 293 unless ($node->isa('Ubic::Multiservice')) { 294 return; 295 } 296 my $part = shift @parts; 297 return unless $node->has_service($part); # no such service 298 $node = $node->service($part); 299 } 300 301 my @variants = $node->service_names; 302 return 303 map { 304 ( $is_subservice ? $node->full_name.".".$_ : $_ ) 305 } 306 grep { 307 $_ =~ m{^\Q$parts[0]\E} 308 } 309 @variants; 310} 311 312sub set_cached_status($$$) { 313 my $self = _obj(shift); 314 my ($name, $status) = validate_pos(@_, $validate_service, 1); 315 my $guard = $self->access_guard($name); 316 317 if (blessed $status) { 318 croak "Wrong status param '$status'" unless $status->isa('Ubic::Result::Class'); 319 $status = $status->status; 320 } 321 my $lock = $self->lock($name); 322 323 if (-e $self->status_file($name) and $self->status_obj_ro($name)->{status} eq $status) { 324 # optimization - don't update status if nothing changed 325 return; 326 } 327 328 my $status_obj = $self->status_obj($name); 329 $status_obj->{status} = $status; 330 $status_obj->commit; 331} 332 333sub get_data_dir($) { 334 my $self = _obj(shift); 335 validate_pos(@_); 336 return $self->{data_dir}; 337} 338 339sub set_data_dir($$) { 340 my ($arg, $dir) = validate_pos(@_, 1, 1); 341 342 my $md = sub { 343 my $new_dir = shift; 344 mkdir $new_dir or die "mkdir $new_dir failed: $!" unless -d $new_dir; 345 }; 346 347 $md->($dir); 348 # FIXME - directory list is copy-pasted from Ubic::Admin::Setup 349 for my $subdir (qw[ 350 status simple-daemon simple-daemon/pid lock ubic-daemon tmp watchdog watchdog/lock watchdog/status 351 ]) { 352 $md->("$dir/$subdir"); 353 } 354 355 Ubic::Settings->data_dir($dir); 356 if ($SINGLETON) { 357 $SINGLETON->{lock_dir} = "$dir/lock"; 358 $SINGLETON->{status_dir} = "$dir/status"; 359 $SINGLETON->{tmp_dir} = "$dir/tmp"; 360 $SINGLETON->{data_dir} = $dir; 361 } 362} 363 364sub set_ubic_dir($$); 365*set_ubic_dir = \&set_data_dir; 366 367sub set_default_user($$) { 368 my ($arg, $user) = validate_pos(@_, 1, 1); 369 370 Ubic::Settings->default_user($user); 371} 372 373sub get_service_dir($) { 374 my $self = _obj(shift); 375 validate_pos(@_); 376 return $self->{service_dir}; 377} 378 379sub set_service_dir($$) { 380 my ($arg, $dir) = validate_pos(@_, 1, 1); 381 Ubic::Settings->service_dir($dir); 382 if ($SINGLETON) { 383 $SINGLETON->{service_dir} = $dir; 384 undef $SINGLETON->{root}; # force lazy regeneration 385 } 386} 387 388sub status_file($$) { 389 my $self = _obj(shift); 390 my ($name) = validate_pos(@_, $validate_service); 391 return "$self->{status_dir}/".$name; 392} 393 394sub status_obj($$) { 395 my $self = _obj(shift); 396 my ($name) = validate_pos(@_, $validate_service); 397 return Ubic::Persistent->new($self->status_file($name)); 398} 399 400sub status_obj_ro($$) { 401 my $self = _obj(shift); 402 my ($name) = validate_pos(@_, $validate_service); 403 return Ubic::Persistent->load($self->status_file($name)); 404} 405 406sub access_guard($$) { 407 my $self = _obj(shift); 408 my ($name) = validate_pos(@_, $validate_service); 409 return Ubic::AccessGuard->new( 410 Ubic::Credentials->new(service => $self->service($name)) 411 ); 412} 413 414sub lock($$) { 415 my ($self) = _obj(shift); 416 my ($name) = validate_pos(@_, $validate_service); 417 418 my $lock = do { 419 my $guard = $self->access_guard($name); 420 Ubic::SingletonLock->new($self->{lock_dir}."/".$name); 421 }; 422 return $lock; 423} 424 425sub do_sub($$) { 426 my ($self, $code) = @_; 427 my $result = try { 428 $code->(); 429 } catch { 430 die result($_); 431 }; 432 return result($result); 433} 434 435sub do_cmd($$$) { 436 my ($self, $name, $cmd) = @_; 437 $self->do_sub(sub { 438 my $service = $self->service($name); 439 440 my $creds = Ubic::Credentials->new( service => $service ); 441 442 if ($creds->eq(Ubic::Credentials->new)) { 443 # current credentials fit service expectations 444 return $service->$cmd(); 445 } 446 447 # setting just effective uid is not enough, because: 448 # - we can accidentally enter tainted mode, and service authors don't expect this 449 # - local administrator may want to allow everyone to write their own services, and leaving root as real uid is an obvious security breach 450 # (ubic will have to learn to compare service user with service file's owner for such policy to be safe, though - this is not implemented yet) 451 $self->forked_call(sub { 452 $creds->set(); 453 return $service->$cmd(); 454 }); 455 }); 456} 457 458sub forked_call { 459 my ($self, $callback) = @_; 460 my $tmp_file = $self->{tmp_dir}."/".time.".$$.".rand(1000000); 461 my $child; 462 unless ($child = fork) { 463 unless (defined $child) { 464 die "fork failed"; 465 } 466 my $result; 467 try { 468 $result = { ok => $callback->() }; 469 } 470 catch { 471 $result = { error => $_ }; 472 }; 473 474 try { 475 Ubic::AtomicFile::store( freeze($result) => $tmp_file ); 476 STDOUT->flush; 477 STDERR->flush; 478 POSIX::_exit(0); # don't allow to lock to be released - this process was forked from unknown environment, don't want to run unknown destructors 479 } 480 catch { 481 # probably tmp_file is not writable 482 warn $_; 483 POSIX::_exit(1); 484 }; 485 } 486 waitpid($child, 0); 487 unless (-e $tmp_file) { 488 die "temp file $tmp_file not found after fork"; 489 } 490 open my $fh, '<', $tmp_file or die "Can't read $tmp_file: $!"; 491 my $content = do { local $/; <$fh>; }; 492 close $fh or die "Can't close $tmp_file: $!"; 493 unlink $tmp_file; 494 my $result = thaw($content); 495 if ($result->{error}) { 496 die $result->{error}; 497 } 498 else { 499 return $result->{ok}; 500 } 501} 502 503 5041; 505 506__END__ 507 508=pod 509 510=head1 NAME 511 512Ubic - polymorphic service manager 513 514=head1 VERSION 515 516version 1.58 517 518=head1 SYNOPSIS 519 520 Configure ubic: 521 $ ubic-admin setup 522 523 Write the service config: 524 $ cat >/etc/ubic/service/foo.ini 525 [options] 526 bin = /usr/bin/foo.pl 527 528 Start your service: 529 $ ubic start foo 530 531 Enjoy your daemonized, monitored service. 532 533=head1 DESCRIPTION 534 535This module is a perl frontend to ubic services. 536 537It is a singleton OOP class. All of its methods should be invoked as class methods: 538 539 Ubic->start('foo'); 540 Ubic->stop('foo'); 541 my $status = Ubic->status('foo'); 542 543=head1 INTRODUCTION 544 545Ubic is a polymorphic service manager. 546 547Further directions: 548 549if you are looking for a general introduction to Ubic, see L<Ubic::Manual::Intro>; 550 551if you want to use ubic from the command line, see L<ubic>; 552 553if you want to manage ubic services from the perl scripts, read this POD; 554 555if you want to write your own service, see L<Ubic::Service> and other C<Ubic::Service::*> modules. 556 557=head1 CONSTRUCTOR 558 559=over 560 561=item B<< Ubic->new({ ... }) >> 562 563All methods in this package can be invoked as class methods, but sometimes you may need to override some status dirs. In this case you should construct your own C<Ubic> instance. 564 565Note that you can't create several instances in one process and have them work independently. So, this constructor is actually just a weird way to override service_dir and data_dir. 566 567Constructor options (all of them are optional): 568 569=over 570 571=item I<service_dir> 572 573Name of dir with service descriptions (which will be used to construct root C<Ubic::Multiservice::Dir> object). 574 575=item I<data_dir> 576 577Dir into which ubic stores all of its data (locks, status files, tmp files). 578 579=back 580 581=back 582 583=head1 LSB METHODS 584 585See L<LSB documentation|http://refspecs.freestandards.org/LSB_3.1.0/LSB-Core-generic/LSB-Core-generic/iniscrptact.html> for init-script method specifications. 586 587Following methods are trying to conform, except that all dashes in method names are replaced with underscores. 588 589These methods return the result objects, i.e., instances of the C<Ubic::Result::Class> class. 590 591=over 592 593=item B<start($name)> 594 595Start the service. 596 597=item B<stop($name)> 598 599Stop the service. 600 601=item B<restart($name)> 602 603Restart the service; start it if it's not running. 604 605=item B<try_restart($name)> 606 607Restart the service if it is enabled. 608 609=item B<reload($name)> 610 611Reload the service. 612 613This method will do reloading if the service implements C<reload()>; it will throw an exception otherwise. 614 615=item B<force_reload($name)> 616 617Reload the service if reloading is implemented, otherwise restart it. 618 619Does nothing if service is disabled. 620 621=item B<status($name)> 622 623Get the service status. 624 625=back 626 627=head1 OTHER METHODS 628 629=over 630 631=item B<enable($name)> 632 633Enable the service. 634 635Enabled service means that service B<should> be running. 636 637Watchdog will periodically check its status, attempt to restart it and mark it as I<broken> if it won't succeed. 638 639=item B<is_enabled($name)> 640 641Check whether the service is enabled. 642 643Returns true or false. 644 645=item B<disable($name)> 646 647Disable the service. 648 649Disabled service means that the service is ignored by ubic. 650 651Its state will no longer be checked by the watchdog, and C<ubic status> will report that the service is I<down>. 652 653=item B<cached_status($name)> 654 655Get cached status of the service. 656 657Unlike other methods, it can be invoked by any user. 658 659=item B<do_custom_command($name, $command)> 660 661Execute the custom command C<$command> for the given service. 662 663=item B<service($name)> 664 665Get service object by name. 666 667=item B<< has_service($name) >> 668 669Check whether the service named C<$name> exists. 670 671=item B<services()> 672 673Get the list of all services. 674 675=item B<service_names()> 676 677Get the list of all service names. 678 679=item B<root_service()> 680 681Get the root multiservice object. 682 683Root service doesn't have a name and returns all top-level services with C<services()> method. You can use it to traverse the whole service tree. 684 685=item B<compl_services($line)> 686 687Get the list of autocompletion variants for a given service prefix. 688 689=item B<set_cached_status($name, $status)> 690 691Write the new status into the service's status file. 692 693=item B<< get_data_dir() >> 694 695Get the data dir. 696 697=item B<< set_data_dir($dir) >> 698 699Set the data dir, creating it if necessary. 700 701Data dir is a directory with service statuses and locks. (See C<Ubic::Settings> for more details on how it's chosen). 702 703This setting will be propagated into subprocesses using environment, so the following code works: 704 705 Ubic->set_data_dir('tfiles/ubic'); 706 Ubic->set_service_dir('etc/ubic/service'); 707 system('ubic start some_service'); 708 system('ubic stop some_service'); 709 710=item B<< set_ubic_dir($dir) >> 711 712Deprecated. This method got renamed to C<set_data_dir()>. 713 714=item B<< set_default_user($user) >> 715 716Set default user for all services. 717 718This is a simple proxy for C<< Ubic::Settings->default_user($user) >>. 719 720=item B<< get_service_dir() >> 721 722Get the ubic services dir. 723 724=item B<< set_service_dir($dir) >> 725 726Set the ubic services dir. 727 728=back 729 730=head1 INTERNAL METHODS 731 732You shouldn't call these from a code which doesn't belong to core Ubic distribution. 733 734These methods can be changed or removed without further notice. 735 736=over 737 738=item B<status_file($name)> 739 740Get the status file name by a service's name. 741 742=item B<status_obj($name)> 743 744Get the status persistent object by a service's name. 745 746It's a bad idea to call this from any other class than C<Ubic>, but if you'll ever want to do this, at least don't forget to create C<Ubic::AccessGuard> first. 747 748=item B<status_obj_ro($name)> 749 750Get the readonly, nonlocked status persistent object (see L<Ubic::Persistent>) by a service's name. 751 752=item B<access_guard($name)> 753 754Get an access guard (L<Ubic::AccessGuard> object) for the given service. 755 756=item B<lock($name)> 757 758Acquire lock object for given service. 759 760You can lock one object twice from the same process, but not from different processes. 761 762=item B<< do_sub($code) >> 763 764Run any code and wrap any result or exception into a result object. 765 766=item B<< do_cmd($name, $cmd) >> 767 768Run C<$cmd> method from the service named C<$name> and wrap any result or exception in a result object. 769 770=item B<< forked_call($callback) >> 771 772Run a C<$callback> in a subprocess and return its return value. 773 774Interaction happens through a temporary file in C<< $ubic->{tmp_dir} >> dir. 775 776=back 777 778=head1 CONTRIBUTORS 779 780Andrei Mishchenko <druxa@yandex-team.ru> 781 782Yury Zavarin <yury.zavarin@gmail.com> 783 784Dmitry Yashin 785 786Christian Walde <walde.christian@googlemail.com> 787 788Ivan Bessarabov <ivan@bessarabov.ru> 789 790Oleg Komarov <komarov@cpan.org> 791 792Andrew Kirkpatrick <ubermonk@gmail.com> 793 794=head1 SEE ALSO 795 796Most Ubic-related links are collected on github wiki: L<http://github.com/berekuk/Ubic/wiki>. 797 798L<Daemon::Control> and L<Proc::Launcher> provide the start/stop/status style mechanisms for init scripts and apachectl-style commands. 799 800L<Server::Control> is an apachectl-style, heavyweight subclassable module for handling network daemons. 801 802L<ControlFreak> - process supervisor, similar to Ubic in its command-line interface. 803 804There are also L<App::Daemon>, L<App::Control> and L<Supervisor>. 805 806=head1 SUPPORT 807 808Our IRC channel is irc://irc.perl.org#ubic. 809 810There's also a mailing list at ubic-perl@googlegroups.com. Send an empty message to ubic-perl+subscribe@googlegroups.com to subscribe. 811 812=head1 AUTHOR 813 814Vyacheslav Matyukhin <mmcleric@yandex-team.ru> 815 816=head1 COPYRIGHT AND LICENSE 817 818This software is copyright (c) 2015 by Yandex LLC. 819 820This is free software; you can redistribute it and/or modify it under 821the same terms as the Perl 5 programming language system itself. 822 823=cut 824