├── .travis.yml ├── Changes ├── MANIFEST.SKIP ├── Makefile.PL ├── README.mkd ├── bin ├── stf ├── stf-recover-object-disk ├── stf-repair-cluster ├── stf-repair-degraded-objects └── stf-worker ├── carton.lock ├── cpanfile ├── etc ├── admin.psgi ├── admin │ └── profiles.pl ├── config.pl ├── config_test.pl ├── container.pl ├── dispatcher.psgi ├── gettext │ ├── en.po │ └── ja.po └── storage.psgi ├── ext ├── STF-Migrator │ ├── Makefile.PL │ ├── bin │ │ └── stf-recover-storage │ └── lib │ │ └── STF │ │ ├── Migrator.pm │ │ └── Migrator │ │ └── Worker.pm └── STF-Stress │ └── lib │ └── STF │ └── Stress.pm ├── lib ├── STF.pm └── STF │ ├── API │ ├── Bucket.pm │ ├── Config.pm │ ├── DeletedObject.pm │ ├── Entity.pm │ ├── Notification.pm │ ├── Notification │ │ ├── Email.pm │ │ └── Ikachan.pm │ ├── NotificationRule.pm │ ├── Object.pm │ ├── ObjectMeta.pm │ ├── Queue.pm │ ├── Queue │ │ ├── Q4M.pm │ │ ├── Redis.pm │ │ ├── Resque.pm │ │ └── Schwartz.pm │ ├── Storage.pm │ ├── StorageCluster.pm │ ├── StorageMeta.pm │ ├── Throttler.pm │ ├── WithDBI.pm │ └── WorkerInstances.pm │ ├── AdminWeb.pm │ ├── AdminWeb │ ├── Context.pm │ ├── Controller.pm │ ├── Controller │ │ ├── Bucket.pm │ │ ├── Cluster.pm │ │ ├── Config.pm │ │ ├── Object.pm │ │ ├── Root.pm │ │ ├── Storage.pm │ │ └── Worker.pm │ ├── Renderer.pm │ └── View │ │ └── Xslate.pm │ ├── CLI.pm │ ├── CLI │ ├── Base.pm │ ├── Enqueue.pm │ ├── Health.pm │ ├── Object.pm │ └── Storage.pm │ ├── Constants.pm │ ├── Container.pm │ ├── Context.pm │ ├── DFV.pm │ ├── Dispatcher.pm │ ├── Environment.pm │ ├── Log.pm │ ├── Storage.pm │ ├── Test.pm │ ├── Trace │ └── SQLite.pm │ ├── Trait │ ├── WithCache.pm │ ├── WithContainer.pm │ └── WithDBI.pm │ ├── Utils.pm │ └── Worker │ ├── AdaptiveDegrader.pm │ ├── AdaptiveThrottler.pm │ ├── Base.pm │ ├── ContinuousRepair.pm │ ├── DeleteBucket.pm │ ├── DeleteObject.pm │ ├── Drone.pm │ ├── Loop.pm │ ├── Loop │ ├── Periodic.pm │ ├── Q4M.pm │ ├── Redis.pm │ ├── Resque.pm │ └── Schwartz.pm │ ├── Notify.pm │ ├── RepairObject.pm │ ├── RepairStorage.pm │ ├── Replicate.pm │ ├── StatsCollector.pm │ └── StorageHealth.pm ├── misc ├── apache-dispatcher-proxy.sample.conf ├── apache-storage-proxy.sample.conf ├── nginx.sample.conf ├── stf-1.x-to-2.x.sql ├── stf.sql ├── stf_q4m.sql └── stf_schwartz.sql ├── public └── assets │ ├── css │ ├── bootstrap-responsive.css │ ├── bootstrap-responsive.min.css │ ├── bootstrap.css │ └── bootstrap.min.css │ ├── img │ ├── ajax-loader.gif │ ├── glyphicons-halflings-white.png │ └── glyphicons-halflings.png │ └── js │ ├── bootstrap.js │ ├── bootstrap.min.js │ └── jquery-1.9.1.min.js ├── script ├── stf-dispatcher └── stf-storage ├── t ├── 000_compile.t ├── 001_basic.t ├── 002_bucket.t ├── 003_object.t ├── 004_entity.t ├── 005_dispatcher.t ├── 006_backend.t ├── 007_storage.t ├── 008_notify.t ├── 010_write_during_cluster_read_only.t ├── 100_container.t ├── 200_repair.t ├── 203_storage_health.t ├── 206_notification.t ├── 299_drone.t ├── 300_failed_storage.t ├── 301_downed_storage.t ├── 302_deleted_content.t ├── 303_crashed_storage.t ├── 304_repair_storage.t ├── dispatcher.psgi ├── lib │ └── App │ │ └── Prove │ │ └── Plugin │ │ ├── RedirectLog.pm │ │ ├── SchemaUpdater.pm │ │ ├── StartBackend.pm │ │ ├── StartDatabase.pm │ │ ├── StartMemcached.pm │ │ └── StartRedis.pm └── proverc └── templates ├── bucket ├── add.html.tx ├── list.html.tx └── view.html.tx ├── cluster ├── add.html.tx ├── edit.html.tx ├── heading.tx ├── list.html.tx ├── storage_free.html.tx └── view.html.tx ├── config ├── notification.html.tx ├── worker.html.tx └── worker_list.html.tx ├── inc └── layout.tx ├── not_found.html.tx ├── object ├── create.html.tx ├── edit.html.tx ├── heading.tx ├── index.html.tx └── view.html.tx ├── root └── index.html.tx └── storage ├── add.html.tx ├── edit.html.tx ├── entities.html.tx ├── heading.tx └── list.html.tx /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | before_install: perlbrew -f install-cpanm 3 | perl: 4 | - "5.20" 5 | - "5.18" 6 | - "5.16" 7 | - "5.14" 8 | - "5.12" 9 | env: 10 | - STF_QUEUE_TYPE=Schwartz 11 | - STF_QUEUE_TYPE=Resque 12 | - STF_QUEUE_TYPE=Redis 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Changes 2 | ======= 3 | 4 | 2.00 - Oct 12, 2012 5 | * Storages are now grouped into Storage Clusters. You need at least 6 | 3 storages per cluster. When a write occurs, you must be able to 7 | write to at least 3 storages in order for the write to be successful. 8 | If a write to a cluster fails, other clusters are tried until success. 9 | A PUT operation returns failure if and only if writes to all clusters 10 | fail. 11 | * Worker Drones are now able to self-balance the number of workers that 12 | each drone is supposed to spawn. You can set the global number of 13 | worker instances by setting variables in the 'config' table in the 14 | database. 15 | * Workers can now be throttled. 16 | * Admin interface now allows you to set some global config variables 17 | without having to muck with the database. 18 | * Repairs can now take place without having to delete the entities in 19 | the targeted storage. Previously we blindly assumed that the 20 | storage was inaccessible and therefore all entities are lost, so 21 | you could only delete the (logical) entities there. 22 | Now you can choose to specify "needs repair" which will assume that 23 | the target is READABLE but not writable for repair, so you can 24 | basically keep entities that are intact, or you can choose to set 25 | "crashed (needs repair)", which will skip checking for entities 26 | in that storage, and will simply migrate away what it can. 27 | * ObjectHealth worker is now deprecated. 28 | * RecoverCrash worker is now deprecated. 29 | * RetireStorage worker is now deprecated. 30 | * Added stf-recover-object-disk, a tool to recover objects directly 31 | from a file on disk. 32 | * Added stf-repair-cluster, a tool to manually repair objects in a 33 | cluster. 34 | * Added stf-repair-degraded-objects, a tool to selectively look for 35 | objects that have less than 3 entities and put them into the 36 | repair queue. 37 | * Added support for Redis and Resque message queues. 38 | * Removed STF::Migrator and STF::Stress under ext/ (actually, they probably 39 | don't work right now, anyway) 40 | * Output generated with STF_DEBUG is now much better thanks to 41 | Log::Minimal 42 | * Fixed a bug in the Q4M worker that caused jobs at the very end of the 43 | loop to be lost. 44 | * Fixed cache mechanism in various places either to make fetches 45 | faster or to forcefully update necessary fields. 46 | * Fixed 32-bit support by using Bit::Vector et al. 47 | * Removed unecessary Perl module dependency. 48 | * Changed to use Mouse as the class builder. 49 | * Changed to check for object sizes upon repair. -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \bRCS\b 2 | \bCVS\b 3 | ,v$ 4 | \B\.svn\b 5 | 6 | ^MANIFEST\. 7 | ^Makefile$ 8 | ^blib/ 9 | ^MakeMaker-\d 10 | 11 | ~$ 12 | \.old$ 13 | ^#.*#$ 14 | ^\.# 15 | 16 | \.travis\.yml -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use 5.12.0; 3 | use ExtUtils::MakeMaker; 4 | use Config (); 5 | 6 | # The additional \n helps to fool Module::Install 7 | sub MY::test_via_harness { "\tprove --lib --rc=t/proverc t\n" } 8 | 9 | my $mysql = `which mysql`; 10 | chomp $mysql; 11 | $mysql ||= '(null)'; 12 | my $mysqladmin = `which mysqladmin`; 13 | chomp $mysqladmin; 14 | $mysqladmin ||= '(null)'; 15 | 16 | print < "STF", 38 | VERSION_FROM => 'lib/STF.pm', 39 | LICENSE => "artistic_2", 40 | AUTHOR => 'Daisuke Maki C<< >>', 41 | PREREQ_PM => { 42 | 'Cache::Memcached::Fast' => 0, 43 | 'Data::Page' => 0, 44 | 'Data::FormValidator' => 0, 45 | 'Data::Localize' => 0, 46 | 'Digest::MurmurHash' => 0, 47 | 'DBI' => 0, 48 | 'DBD::mysql' => 0, 49 | 'DBIx::DSN::Resolver::Cached' => '0.04', 50 | 'Email::MIME' => 0, 51 | 'Email::Send' => 0, 52 | 'Furl' => '0.38', 53 | 'HTML::FillInForm::Lite' => 0, 54 | 'HTTP::Parser::XS' => 0, 55 | 'IPC::SysV' => 0, 56 | 'Log::Minimal' => '0.14', 57 | 'Math::Round' => 0, 58 | 'Mojolicious' => '3.84', 59 | 'Mouse' => '1.05', 60 | 'Net::SNMP' => 0, 61 | 'Plack' => '1.0013', 62 | 'Plack::Middleware::ReverseProxy' => 0, 63 | 'Plack::Middleware::Session' => 0, 64 | 'Plack::Middleware::Static' => 0, 65 | 'Plack::Request' => 0, 66 | 'Plack::Session' => 0, 67 | 'Parallel::ForkManager' => '0.7.9', 68 | 'Parallel::Scoreboard' => '0.03', 69 | 'Router::Simple' => 0, 70 | 'SQL::Maker' => 0, 71 | 'Scope::Guard' => 0, 72 | 'Starlet' => 0, 73 | 'String::Urandom' => 0, 74 | 'Task::Weaken' => 0, 75 | 'Text::MultiMarkdown' => 0, 76 | 'Text::Xslate' => '1.6001', 77 | 'YAML' => 0, 78 | 'STF::Dispatcher::PSGI' => '1.09', 79 | # Add this requirement if the environment asks for it 80 | ( $queue_type eq 'Schwartz' ? ( 'TheSchwartz' => 0 ): () ), 81 | ( $queue_type eq 'Redis' ? ( 'Redis' => 0 ): () ), 82 | ( $queue_type eq 'Resque' ? ( 'Resque' => 0 ): () ), 83 | ( $Config::Config{use64bitint} ? () : ("Bit::Vector" => 0, "Math::BigInt" => 0) ), 84 | }, 85 | BUILD_REQUIRES => { 86 | # For tests 87 | 'App::Prove' => 0, 88 | 'Proc::Guard' => 0, 89 | 'Test::TCP' => 0, 90 | 'Test::mysqld' => 0, 91 | 'Test::MockTime' => 0, 92 | 'Plack::Middleware::Reproxy' => '0.00002', 93 | }, 94 | clean => { 95 | FILES => 't/*.log t/store* trace.db', 96 | } 97 | ); 98 | 99 | -------------------------------------------------------------------------------- /README.mkd: -------------------------------------------------------------------------------- 1 | # STF - Scalable, Simple Distributed Object Storage 2 | 3 | STF is a distributed object store (similar to MogileFS), which allows you to store billions of files on commodity hardware/software stack. It was developed at livedoor Inc, initially as sets of Apache modules, then eventually was ported to a native PSGI application. 4 | 5 | Among other things, it currently handles traffic for one of Japan's busiest blogging service, chugging 400Mbps of datas. 6 | 7 | STF is built on top of long trusted software like Apache (or nginx), Perl, Q4M (or TheSchwartz, Resque, Redis), MySQL, and Memcached, with open protocols so it's easy to maintain. 8 | 9 | ======= 10 | 11 | ## UPGRADING 12 | 13 | ### DATABASE SCHEMA 14 | 15 | If you were running STF 1.x, you must change your database schema: 16 | 17 | # IT IS HIGHLY RECOMMENDED THAT YOU TEST THIS BEFORE 18 | # RUNNING IT AGAINST A PRODUCTION DATABASE 19 | # -- you've been warned 20 | 21 | mysql stf ... < misc/stf-1.x-to-2.x.sql 22 | 23 | ### WORKER SELF-BALANCING 24 | 25 | Since version 2.00, STF workers control the number of instances that should 26 | be fork+exec'ed on each drone: e.g. if you had 3 drones, and you set the 27 | config variable stf.drone.RepairObject.instances to 20, drones will spawn 28 | 6, 6, and 8 RepairObject workers. 29 | 30 | Thus the old setting in your config.pl will no longer be respected. 31 | 32 | ### CLUSTERED STORAGE 33 | 34 | Since version 2.00, STF requires that you setup your storage in "clusters". 35 | 36 | First you need to create clusters, and add storages to it. You can set this 37 | via the new admin interface, or by manual operation. 38 | 39 | INSERT INTO storage_cluster ...; 40 | UPDATE storage SET cluster_id = ... WHERE id = ...; 41 | 42 | There is no constraint from the system as to how many storages you should put 43 | in a cluster, but in order to keep your data safe, you MUST have at least 44 | three storages per cluster. You also should have at least two clusters, but 45 | three or more is recommended. 46 | 47 | ## Travis CI 48 | 49 | [![Build Status](https://secure.travis-ci.org/stf-storage/stf.png?branch=master)](http://travis-ci.org/stf-storage/stf) 50 | 51 | ## Get STF 52 | 53 | git clone git://github.com/stf-storage/stf.git 54 | cd stf 55 | cpanm --installdeps . 56 | 57 | ## Setup 58 | 59 | Please read http://stf-storage.github.com/setup.html 60 | 61 | ## Very simple usage via lwp-request 62 | 63 | # create a bucket 64 | lwp-request -m PUT http://stf-host/bucket 65 | Please enter content (text/plain) to be PUTed: 66 | # (Press Ctrl+D here so you don't send any content) 67 | 68 | # create an object 69 | lwp-request -m PUT http://stf-host/bucket/object 70 | Please enter content (text/plain) to be PUTed: 71 | # Type in random stuff here to be sent to the server 72 | 73 | # get the object 74 | lwp-request http://stf-host/bucket/object 75 | 76 | # delete the object 77 | lwp-request -m DELETE http://stf-host/bucket/object 78 | 79 | ## See Also 80 | 81 | * Web site - http://stf-storage.github.com 82 | * Deploy STF on dotCloud - https://github.com/stf-storage/stf-on-dotcloud 83 | * STF::Dispatcher::PSGI - https://github.com/stf-storage/stf-dispatcher-psgi 84 | * Net::STF::Client - https://github.com/stf-storage/net-stf-client -------------------------------------------------------------------------------- /bin/stf: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use lib "lib"; 4 | use STF::Environment; 5 | use STF::CLI; 6 | 7 | my $c = STF::CLI->new; 8 | $c->run( @ARGV ); -------------------------------------------------------------------------------- /bin/stf-recover-object-disk: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use STF::Context; 4 | use Cwd (); 5 | use File::Spec; 6 | use Getopt::Long; 7 | 8 | main() unless caller(); 9 | 10 | sub main () { 11 | my %opts; 12 | if (! GetOptions(\%opts, "object_id=s", "root=s", "force!")) { 13 | exit 1; 14 | } 15 | 16 | my $object_id = $opts{object_id}; 17 | if (! $object_id) { 18 | die "--object_id is required\n"; 19 | } 20 | 21 | my $force = $opts{force}; 22 | my $root = $opts{root} || Cwd::cwd(); 23 | 24 | my $cxt = STF::Context->bootstrap; 25 | my $cnt = $cxt->container; 26 | my $object_api = $cnt->get('API::Object'); 27 | my $object = $object_api->lookup( $object_id ); 28 | if (! $object) { 29 | die "Could not find object $object_id\n"; 30 | } 31 | 32 | my $path = File::Spec->catfile( $root, $object->{internal_name} ); 33 | if (!-f $path) { 34 | die "Could not find entity $path for $object_id\n"; 35 | } 36 | 37 | # found it! 38 | open my $fh, '<', $path or 39 | die "Could not open file $path: $!\n"; 40 | 41 | # check sizes 42 | my $size = -s $fh; 43 | if ($size != $object->{size}) { 44 | if (! $force) { 45 | die "File size for object $object_id does not match (wanted = $object->{size}, actual = $size). Will not proceed without --force\n"; 46 | } 47 | } 48 | 49 | # store this in a writable storage, anywhere. 50 | my $cluster_api = $cnt->get('API::StorageCluster'); 51 | my @clusters = $cluster_api->load_candidates_for( $object_id ); 52 | foreach my $cluster (@clusters) { 53 | my $ok = $cluster_api->store({ 54 | cluster => $cluster, 55 | object_id => $object_id, 56 | content => $fh, 57 | minimum => 2, 58 | force => 1, 59 | }); 60 | if ($ok) { 61 | $cluster_api->register_for_object( { 62 | cluster_id => $cluster->{id}, 63 | object_id => $object_id 64 | }); 65 | last; 66 | } 67 | } 68 | 69 | $cnt->get('API::Queue')->enqueue(repair_obejct => $object_id); 70 | } 71 | 72 | __END__ 73 | 74 | =head1 NAME 75 | 76 | stf-recover-object-disk - Recover An Object From Disk 77 | 78 | =head1 SYNOPSIS 79 | 80 | stf-recover-object-disk 81 | --root=[/path/to/root] \ 82 | --object_id=[id] 83 | 84 | =head1 DESCRIPTION 85 | 86 | C is useful when 87 | 88 | =over 4 89 | 90 | =item 1. Your object entry is still in tact in the database 91 | 92 | =item 2. ...but your entities have gone missing 93 | 94 | This may happen if you left your workers down for too long, or you didn't 95 | properly repair your storages when crashes happened. 96 | 97 | =item 3. ...but your hard disk contents are still mostly intact 98 | 99 | Perhaps you experienced a storage crash, but you were able to recover the 100 | hard disk via a raid rebuild. 101 | 102 | =back 103 | 104 | =cut 105 | -------------------------------------------------------------------------------- /bin/stf-repair-degraded-objects: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use Parallel::ForkManager; 4 | use STF::Context; 5 | use STF::Constants qw(STF_DEBUG); 6 | use STF::Log; 7 | 8 | our $DBNAME = "DB::Slave"; # XXX Make it configurable later 9 | 10 | main() unless caller(); 11 | 12 | sub main { 13 | my $cxt = STF::Context->bootstrap; 14 | my $pfm = Parallel::ForkManager->new(10); 15 | my $c = $cxt->container; 16 | my $guard = $c->new_scope(); 17 | my $dbh = $c->get($DBNAME); 18 | my $limit = 500; 19 | my $min_object_id = 0; 20 | my $max_object_id = 0; 21 | my $sth = $dbh->prepare(<= ? AND status = 1 ORDER BY id ASC LIMIT $limit,1 23 | EOSQL 24 | 25 | local $dbh->{InactiveDestroy} = 1; 26 | while ( defined $max_object_id ) { 27 | ($max_object_id) = $dbh->selectrow_array($sth, undef, $min_object_id); 28 | 29 | if (! defined $max_object_id) { 30 | last; 31 | } 32 | 33 | if ($pfm->start) { 34 | if ($min_object_id eq $max_object_id) { 35 | last; 36 | } 37 | $min_object_id = $max_object_id; 38 | next; 39 | } 40 | 41 | eval { 42 | process($cxt, $min_object_id, $max_object_id); 43 | }; 44 | if ($@) { 45 | critf("Error while processing %s -> %s: %s", $min_object_id, $max_object_id, $@); 46 | } 47 | $pfm->finish; 48 | } 49 | 50 | $pfm->wait_all_children; 51 | } 52 | 53 | sub process { 54 | my ($cxt, $min_object_id, $max_object_id) = @_; 55 | 56 | $0 = "$0 worker $min_object_id -> $max_object_id"; 57 | 58 | if (STF_DEBUG) { 59 | debugf( "Processing objects between %s to %s", $min_object_id, $max_object_id ); 60 | } 61 | 62 | my $c = $cxt->container; 63 | my $guard = $c->new_scope(1); 64 | my $dbh = $c->get($DBNAME); 65 | my $q_api = $c->get('API::Queue'); 66 | 67 | local $dbh->{InactiveDestroy} = 1; 68 | 69 | my $object_id; 70 | my $count_sth = $dbh->prepare(<prepare(<= ? AND id < ? AND status = 1 ORDER BY id ASC 79 | EOSQL 80 | my $rv = $sth->execute( $min_object_id, $max_object_id ); 81 | $sth->bind_columns( \($object_id) ); 82 | while( $sth->fetchrow_arrayref ) { 83 | my ($count) = $dbh->selectrow_array($count_sth, undef, $object_id); 84 | 85 | if ($count == 0) { 86 | critf( "Object %s has no entities... broken, or deleted. Skipping.", $object_id ); 87 | next; 88 | } 89 | 90 | if ($count < 3) { 91 | if (STF_DEBUG) { 92 | debugf( "Object %s needs at least 3 entities (have %d). Sending to repair", $object_id, $count ); 93 | } 94 | $q_api->enqueue( repair_object => "NP:$object_id" ); 95 | } 96 | } 97 | } 98 | 99 | 1; 100 | -------------------------------------------------------------------------------- /bin/stf-worker: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use lib "lib"; 4 | use STF::Environment; 5 | use STF::Worker::Drone; 6 | my $drone = STF::Worker::Drone->bootstrap(); 7 | $drone->run; -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | #!perl 2 | requires 'Cache::Memcached::Fast' => 0; 3 | requires 'Data::Page' => 0; 4 | requires 'Data::FormValidator' => 0; 5 | requires 'Data::Localize' => 0; 6 | requires 'Digest::MurmurHash' => 0; 7 | requires 'DBI' => 0; 8 | requires 'DBIx::DSN::Resolver::Cached' => '0.04'; 9 | requires 'DBD::mysql' => 0; 10 | requires 'Email::MIME' => 0; 11 | requires 'Email::Send' => 0; 12 | requires 'File::RotateLogs' => '0.02'; 13 | requires 'Furl' => '0.38'; 14 | requires 'HTML::FillInForm::Lite' => 0; 15 | requires 'HTTP::Parser::XS' => 0; 16 | requires 'IPC::SysV' => 0; 17 | requires 'Log::Minimal' => '0.14'; 18 | requires 'Math::Round' => 0; 19 | requires 'Mojolicious' => '3.85'; 20 | requires 'Mouse' => 0; 21 | requires 'Module::Build' => '0.4003'; 22 | requires 'Net::SNMP' => 0; 23 | requires 'Plack' => '1.0013'; 24 | requires 'Plack::Middleware::AxsLog' => '0.10'; 25 | requires 'Plack::Middleware::ReverseProxy' => 0; 26 | requires 'Plack::Middleware::Session' => 0; 27 | requires 'Plack::Middleware::Static' => 0; 28 | requires 'Plack::Request' => 0; 29 | requires 'Plack::Session' => 0; 30 | requires 'Parallel::ForkManager' => '0.7.9'; 31 | requires 'Parallel::Scoreboard' => '0.03'; 32 | requires 'Router::Simple' => 0; 33 | requires 'SQL::Maker' => 0; 34 | requires 'Scope::Guard' => 0; 35 | requires 'Starlet' => 0; 36 | requires 'Server::Starter'; 37 | requires 'String::Urandom' => 0; 38 | requires 'Task::Weaken' => 0; 39 | requires 'Text::Xslate' => '1.6001'; 40 | requires 'YAML' => 0; 41 | requires 'STF::Dispatcher::PSGI' => '1.09'; 42 | 43 | # Add these requirement(s) if the environment asks for it 44 | my $queue_type = $ENV{STF_QUEUE_TYPE} || 'Q4M'; 45 | if ($queue_type eq 'Schwartz') { 46 | requires 'TheSchwartz' => 0; 47 | } elsif ($queue_type eq 'Redis') { 48 | requires 'Redis' => 0; 49 | } elsif ($queue_type eq 'Resque') { 50 | requires 'Resque' => 0; 51 | } 52 | 53 | # You need these if you don't have 64 bit ints 54 | # HIGHLY RECOMMENDED THAT YOU USE PERL WITH 64BIT INTS 55 | if (! $Config::Config{use64bitint}) { 56 | requires "Bit::Vector" => 0; 57 | requires "Math::BigInt" => 0; 58 | } 59 | 60 | on build => sub { 61 | requires 'App::Prove' => 0; 62 | requires 'Proc::Guard' => 0; 63 | requires 'Test::TCP' => 0; 64 | requires 'Test::mysqld' => 0; 65 | requires 'Test::MockTime' => 0; 66 | requires 'Plack::Middleware::Reproxy' => '0.00002'; 67 | }; 68 | 69 | -------------------------------------------------------------------------------- /etc/admin.psgi: -------------------------------------------------------------------------------- 1 | use strict; 2 | use lib "lib"; 3 | use Plack::Builder; 4 | use STF::Environment; 5 | use STF::AdminWeb; 6 | 7 | my $ctx = STF::Context->bootstrap; 8 | STF::AdminWeb->new(context => $ctx)->psgi_app; 9 | -------------------------------------------------------------------------------- /etc/config_test.pl: -------------------------------------------------------------------------------- 1 | $ENV{STF_TRACE_SQLITE_DBNAME} = "trace.db"; 2 | $ENV{STF_HOST_ID} = int(rand(10000)); 3 | 4 | my %dbopts = ( RaiseError => 1, AutoCommit => 1, mysql_enable_utf8 => 1, AutoInactiveDestroy => 1 ); 5 | +{ 6 | %$config, 7 | 'Memcached' => { 8 | servers => [ split /,/, $ENV{TEST_MEMCACHED_SERVERS} ], 9 | }, 10 | 'Trace::SQLite' => { 11 | connect_info => [ 12 | "dbi:SQLite:dbname=$ENV{STF_TRACE_SQLITE_DBNAME}", 13 | undef, 14 | undef, 15 | { RaiseError => 1, AutoCommit => 1 } 16 | ], 17 | } 18 | }; 19 | -------------------------------------------------------------------------------- /etc/dispatcher.psgi: -------------------------------------------------------------------------------- 1 | use strict; 2 | use lib "lib"; 3 | use Plack::Builder; 4 | use STF::Environment; 5 | use STF::Dispatcher; 6 | use STF::Dispatcher::PSGI; 7 | 8 | use constant HAS_ACCESS_LOG => !!$ENV{STF_DISPATCHER_ACCESS_LOG}; 9 | 10 | my $rotatelogs; 11 | if ($ENV{STF_DISPATCHER_ACCESS_LOG}) { 12 | require File::RotateLogs; 13 | my $linkname = $ENV{STF_DISPATCHER_ACCESS_LOG}; 14 | $rotatelogs = File::RotateLogs->new( 15 | logfile => "$linkname.%Y%m%d%H", 16 | linkname => $linkname, 17 | rotationtime => $ENV{STF_DISPATCHER_LOG_ROTATTION_TIME} || 86400, 18 | maxage => $ENV{STF_DISPATCHER_LOG_MAXAGE} || 14 * 86400, 19 | ); 20 | } 21 | 22 | my $dispatcher = STF::Dispatcher->bootstrap; 23 | my $app = STF::Dispatcher::PSGI->new( impl => $dispatcher )->to_app; 24 | if ( $ENV{ USE_PLACK_REPROXY } ) { 25 | if( STF::Constants::STF_DEBUG() ) { 26 | print "[Dispatcher] Enabling Plack::Middleware::Reproxy::Furl\n"; 27 | } 28 | require Plack::Middleware::Reproxy::Furl; 29 | $app = Plack::Middleware::Reproxy::Furl->wrap( $app ); 30 | } 31 | 32 | builder { 33 | if (HAS_ACCESS_LOG) { 34 | enable 'AxsLog' => ( 35 | response_time => 1, 36 | logger => sub { $rotatelogs->print(@_) } 37 | ); 38 | } 39 | $app; 40 | }; 41 | 42 | 43 | -------------------------------------------------------------------------------- /etc/storage.psgi: -------------------------------------------------------------------------------- 1 | use strict; 2 | use lib "lib"; 3 | use STF::Environment; 4 | use STF::Storage; 5 | 6 | STF::Storage->new( root => $ENV{STF_STORAGE_ROOT} )->to_app; 7 | -------------------------------------------------------------------------------- /ext/STF-Migrator/Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | 3 | name 'STF-Migrator'; 4 | all_from 'lib/STF/Migrator.pm'; 5 | 6 | requires 'Mouse'; 7 | requires 'Coro'; 8 | requires 'Fcntl'; 9 | requires 'FurlX::Coro'; 10 | requires 'Guard'; 11 | requires 'HTTP::Status; 12 | requires 'DBIx::Connector'; 13 | requires 'Parallel::ForkManager'; 14 | requires 'POSIX'; 15 | 16 | WriteAll; -------------------------------------------------------------------------------- /ext/STF-Migrator/bin/stf-recover-storage: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use Getopt::Long; 4 | use STF::Context; 5 | use STF::Constants qw(STORAGE_MODE_CRASH_RECOVERED STORAGE_MODE_TEMPORARILY_DOWN); 6 | use STF::Migrator; 7 | 8 | main(); 9 | 10 | sub main { 11 | my ($storage_id, $help); 12 | if (! GetOptions( "storage_id=i" => \$storage_id, "help!" => \$help ) ) { 13 | exit 1; 14 | } 15 | 16 | if (! $storage_id) { 17 | print STDERR "No storage_id specified!\n"; 18 | exit 1; 19 | } 20 | 21 | if ($help) { 22 | require Pod::Usage; 23 | Pod::Usage::pod2usage(-verbose => 2, -exitval => 0); 24 | } 25 | 26 | my $ctxt = STF::Context->bootstrap; 27 | 28 | # Get the storage 29 | my $storage_api = $ctxt->get('API::Storage'); 30 | my $storage = $storage_api->lookup( $storage_id ); 31 | if (! $storage) { 32 | print STDERR "Storage $storage_id does not exist!\n"; 33 | exit 1; 34 | } 35 | 36 | # Use migrator, but make sure to put it DOWN, migrate, then put 37 | # in CRASH mode. 38 | 39 | # Make sure to put this DOWN 40 | $storage_api->update( $storage_id, { 41 | mode => STORAGE_MODE_TEMPORARILY_DOWN 42 | } ); 43 | 44 | my $migrator = STF::Migrator->new( 45 | proc_name => "stf-recover-crash", 46 | connect_info => $ctxt->config->{'DB::Master'}, 47 | storage_id => $storage_id, 48 | use_storage_as_source => 0, 49 | ); 50 | $migrator->run; 51 | 52 | $storage_api->update( $storage_id, { 53 | mode => STORAGE_MODE_CRASH_RECOVERED 54 | } ); 55 | } 56 | 57 | __END__ 58 | 59 | =head1 NAME 60 | 61 | stf-recover-storage 62 | 63 | =head1 SYNOPSIS 64 | 65 | stf-recover-storage --storage_id=[id] 66 | 67 | =cut -------------------------------------------------------------------------------- /lib/STF.pm: -------------------------------------------------------------------------------- 1 | package STF; 2 | our $VERSION = '2.00'; 3 | 4 | 1; 5 | 6 | __END__ 7 | 8 | =head1 NAME 9 | 10 | STF - Scalable, Simple Distributed Object Storage 11 | 12 | =head1 SYNOPSIS 13 | 14 | see http://stf-storage.github.com 15 | 16 | =head1 DESCRIPTION 17 | 18 | STF is a distributed object storage, built with Perl, MySQL, Q4M (or TheSchwartz), and Memcached. 19 | 20 | STF uses HTTP as its protocol, so it's very easy for your applications to talk to it. 21 | 22 | =head1 SEE ALSO 23 | 24 | http://stf-storage.github.com - project page. 25 | 26 | L 27 | 28 | L 29 | 30 | =head1 AUTHOR 31 | 32 | Daisuke Maki C<< >> 33 | 34 | =head1 AUTHOR EMERITUS 35 | 36 | Ikebe Tomohiro 37 | 38 | =head1 CONTRIBUTORS 39 | 40 | mattn (Yasuhiro Matsumoto) 41 | 42 | =head1 COPYRIGHT AND LICENSE 43 | 44 | Copyright (C) 2011 by livedoor, inc. 45 | 46 | This library is free software; you can redistribute it and/or modify 47 | it under The Artistic License 2.0 (GPL Compatible) 48 | 49 | L 50 | 51 | =cut -------------------------------------------------------------------------------- /lib/STF/API/Bucket.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Bucket; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | with 'STF::API::WithDBI'; 7 | 8 | sub lookup_by_name { 9 | my ($self, $bucket_name) = @_; 10 | my $dbh = $self->dbh; 11 | $dbh->selectrow_hashref(<dbh; 20 | $dbh->do(<{id}, $args->{name}); 21 | INSERT INTO bucket (id, name, created_at) VALUES (?, ?, UNIX_TIMESTAMP(NOW())) 22 | EOSQL 23 | } 24 | 25 | sub rename { 26 | my ($self, $args) = @_; 27 | 28 | local $STF::Log::PREFIX = "Rename(B)"; 29 | my $name = $args->{name}; 30 | my $bucket_id = $args->{id}; 31 | my $dbh = $self->dbh; 32 | 33 | if (STF_DEBUG) { 34 | debugf( "Renaming bucket '%s' to '%s'", $args->{from}, $name ); 35 | } 36 | 37 | my $rv = $dbh->do(<cache_delete( $self->table => $bucket_id ); 44 | if (STF_DEBUG) { 45 | debugf("Rename was %s", $rv > 1 ? "SUCCESS" : "FAIL"); 46 | } 47 | return $rv; 48 | } 49 | 50 | sub delete { 51 | my ($self, $args) = @_; 52 | 53 | local $STF::Log::PREFIX = "Delete(B)"; 54 | my ($id, $recursive) = @$args{ qw(id recursive) }; 55 | my $dbh = $self->dbh; 56 | 57 | my $rv; 58 | if ($recursive) { 59 | # XXX We return (1) regardless 60 | $self->delete_objects( { id => $id } ); 61 | $rv = 1; 62 | $dbh->do( <do( < 0) { 74 | $self->cache_delete( $self->table => $id ) if ! ref $id; 75 | } 76 | 77 | return $rv; 78 | } 79 | 80 | sub mark_for_delete { 81 | my ($self, $args) = @_; 82 | 83 | local $STF::Log::PREFIX = "Delete(B)"; 84 | my $bucket_id = $args->{id}; 85 | my $dbh = $self->dbh; 86 | 87 | my ($rv_delete, $rv_replace); 88 | $rv_replace = $dbh->do( 89 | "REPLACE INTO deleted_bucket SELECT * FROM bucket WHERE id = ?", 90 | undef, 91 | $bucket_id, 92 | ); 93 | 94 | if ( $rv_replace <= 0 ) { 95 | debugf( 96 | "Failed to insert bucket %s into deleted_bucket (rv = %s)", 97 | $bucket_id, $rv_replace 98 | ) if STF_DEBUG; 99 | } else { 100 | debugf( 101 | "Inserted bucket %s into deleted_bucket (rv = %s)", 102 | $bucket_id, $rv_replace 103 | ) if STF_DEBUG; 104 | 105 | $rv_delete = $dbh->do( 106 | "DELETE FROM bucket WHERE id = ?", 107 | undef, 108 | $bucket_id, 109 | ); 110 | 111 | debugf( 112 | "Deleted bucket %s from bucket (rv = %s)\n", 113 | $bucket_id, $rv_delete 114 | ) if STF_DEBUG; 115 | } 116 | 117 | $self->cache_delete( $self->table, $bucket_id ); 118 | 119 | return $rv_replace && $rv_delete; 120 | } 121 | 122 | sub delete_objects { 123 | my ($self, $args) = @_; 124 | 125 | my $id = $args->{id}; 126 | my $dbh = $self->dbh; 127 | 128 | my $object_id; 129 | my $queue = $self->get('API::Queue'); 130 | my $sth = $dbh->prepare( <execute($id); 134 | $sth->bind_columns(\($object_id)); 135 | 136 | my $object_api = $self->get('API::Object'); 137 | while ( $sth->fetchrow_arrayref ) { 138 | $object_api->mark_for_delete( $object_id ); 139 | $queue->enqueue( "delete_object", $object_id ); 140 | } 141 | 142 | $dbh->do( "DELETE FROM deleted_bucket WHERE id = ?", undef, $id ); 143 | } 144 | 145 | no Mouse; 146 | 147 | 1; 148 | -------------------------------------------------------------------------------- /lib/STF/API/DeletedObject.pm: -------------------------------------------------------------------------------- 1 | package STF::API::DeletedObject; 2 | use Mouse; 3 | 4 | with 'STF::API::WithDBI'; 5 | 6 | no Mouse; 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /lib/STF/API/Notification.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Notification; 2 | use Mouse; 3 | 4 | with 'STF::API::WithDBI'; 5 | 6 | around create => sub { 7 | my ($next, $self, $args) = @_; 8 | 9 | $args->{created_at} ||= time(); 10 | $args->{severity} ||= 'info'; 11 | if (! $args->{source}) { 12 | my $i = 0; 13 | my @caller = caller($i++); 14 | while (@caller && $caller[0] !~ /^STF::/) { 15 | @caller = caller($i++); 16 | } 17 | $args->{source} = join ":", @caller ? @caller[1,2] : "(unknown)"; 18 | } 19 | return unless $self->$next($args); 20 | my $object = $self->lookup($self->dbh->{mysql_insertid}); 21 | $self->get('API::Queue')->enqueue(notify => $object->{id}); 22 | return $object; 23 | }; 24 | 25 | no Mouse; 26 | 27 | 1; -------------------------------------------------------------------------------- /lib/STF/API/Notification/Email.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Notification::Email; 2 | use Mouse; 3 | use STF::Log; 4 | use STF::Constants qw(STF_DEBUG); 5 | use Email::MIME; 6 | use Email::Send; 7 | 8 | has from => ( 9 | is => 'ro', 10 | required => 1, 11 | ); 12 | 13 | has mailer_args => ( 14 | is => 'ro', 15 | default => sub { +{} } 16 | ); 17 | 18 | has mailer_type => ( 19 | is => 'ro', 20 | required => 1, 21 | default => 'Sendmail' 22 | ); 23 | 24 | has mailer => ( 25 | is => 'ro', 26 | lazy => 1, 27 | builder => 'build_mailer', 28 | ); 29 | 30 | sub build_mailer { 31 | my $self = shift; 32 | my $mailer = Email::Send->new({ $self->mailer_type }); 33 | if (my $args = $self->mailer_args) { 34 | $mailer->mailer_args($args); 35 | } 36 | return $mailer; 37 | } 38 | 39 | sub notify { 40 | my ($self, $args, $extra_args) = @_; 41 | 42 | my $to = $args->{to} || $extra_args->{to} || $self->to; 43 | my $message = $args->{message} || $extra_args->{message}; 44 | # XXX Assume all latin-1 ? 45 | my $mime = Email::MIME->create( 46 | header => [ 47 | From => $self->from, 48 | To => $to, 49 | Subject => sprintf 'STF Notification [%s]', $args->{ntype}, 50 | ], 51 | parts => [ $message ] 52 | ); 53 | $self->mailer->send($mime); 54 | if (STF_DEBUG) { 55 | debugf("Email notification for %s has been sent to %s", $args->{ntype}, $to); 56 | } 57 | } 58 | 59 | no Mouse; 60 | 61 | 1; 62 | -------------------------------------------------------------------------------- /lib/STF/API/Notification/Ikachan.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Notification::Ikachan; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | with 'STF::Trait::WithContainer'; 7 | 8 | has url => ( 9 | is => 'rw', 10 | required => 1, 11 | ); 12 | 13 | has method => ( 14 | is => 'rw', 15 | default => 'notice' 16 | ); 17 | 18 | has channel => ( 19 | is => 'rw', 20 | ); 21 | 22 | sub notify { 23 | my ($self, $args, $extra_args) = @_; 24 | 25 | my $method = $extra_args->{method} || $args->{method} || $self->method; 26 | my $channel = $extra_args->{channel} || $args->{channel} || $self->channel; 27 | if (! $method) { 28 | if (STF_DEBUG) { 29 | debugf("No channel specified for Notification::Ikachan, bailing out"); 30 | } 31 | return; 32 | } 33 | 34 | my $url = $self->url; 35 | my $furl = $self->get('Furl'); 36 | 37 | # do a join to make sure that we're in this channel (throw away results 38 | # -- we don't care) 39 | $furl->post( "$url/join", [], [ channel => $channel ]); 40 | 41 | my $message = $args->{message}; 42 | if (my $severity = uc $args->{severity}) { 43 | if ($severity eq 'CRITICAL') { 44 | $message = "\x{02}\x{16}\x{03}04($severity)\x{0f} $message"; 45 | } else { 46 | $message = "$severity $message"; 47 | } 48 | } 49 | my ($code) = $furl->post( "$url/$method", [], [ 50 | channel => $channel, message => $message 51 | ]); 52 | if (STF_DEBUG) { 53 | if ($code ne 200) { 54 | debugf("HTTP request to Ikachan seems to have returned %d", $code); 55 | } 56 | } 57 | } 58 | 59 | 1; -------------------------------------------------------------------------------- /lib/STF/API/NotificationRule.pm: -------------------------------------------------------------------------------- 1 | package STF::API::NotificationRule; 2 | use Mouse; 3 | 4 | with 'STF::API::WithDBI'; 5 | 6 | package 7 | STF::API::NotificationRule::Matcher; 8 | use Mouse; 9 | use feature 'switch'; 10 | 11 | has notifier_name => ( 12 | is => 'ro', 13 | ); 14 | 15 | has extra_args => ( 16 | is => 'ro', 17 | ); 18 | 19 | has operation => ( 20 | is => 'ro', # 'eq', 'ne', 'lt', 'gt', '==', '!=', '>=', '<=', '=~' 21 | ); 22 | 23 | has op_field => ( 24 | is => 'ro', 25 | required => 1, 26 | ); 27 | has op_arg => ( 28 | is => 'ro', 29 | required => 1, 30 | ); 31 | 32 | sub match { 33 | my ($self, $args) = @_; 34 | 35 | # XXX CI smoking shows that perl 5.14.x and 5.12.x behave differently 36 | # in terms of return value for give() {...} block. 5.12.x seems to 37 | # NOT return the value of the evaluated when block. So explicitly 38 | # assign to $match in each when() 39 | my $match = 0; 40 | my $op = $self->operation; 41 | if ($op eq "eq") { 42 | $match = $args->{$self->op_field} eq $self->op_arg; 43 | } elsif ($op eq "==") { 44 | $match = $args->{$self->op_field} == $self->op_arg; 45 | } elsif ($op eq "!=") { 46 | $match = $args->{$self->op_field} != $self->op_arg; 47 | } elsif ($op eq ">=") { 48 | $match = $args->{$self->op_field} >= $self->op_arg; 49 | } elsif ($op eq "<=") { 50 | $match = $args->{$self->op_field} <= $self->op_arg; 51 | } elsif ($op eq "=~") { 52 | $match = $args->{$self->op_field} =~ $self->op_arg; 53 | } 54 | 55 | return $match ? 1 :(); 56 | } 57 | 58 | no Mouse; 59 | 60 | 1; 61 | -------------------------------------------------------------------------------- /lib/STF/API/ObjectMeta.pm: -------------------------------------------------------------------------------- 1 | package STF::API::ObjectMeta; 2 | use Mouse; 3 | use Digest::MD5 (); 4 | 5 | with 'STF::API::WithDBI'; 6 | 7 | sub lookup_for { 8 | my ($self, $object_id) = @_; 9 | my ($meta) = $self->search( { object_id => $object_id } ); 10 | return $meta; 11 | } 12 | 13 | sub update_for { 14 | my ($self, $object_id, $args) = @_; 15 | $self->create( 16 | { %$args, object_id => $object_id }, 17 | { prefix => "REPLACE INTO" } 18 | ); 19 | } 20 | 21 | no Mouse; 22 | 23 | 1; 24 | -------------------------------------------------------------------------------- /lib/STF/API/Queue.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Queue; 2 | use Mouse::Role; 3 | use Digest::MurmurHash (); 4 | use STF::Constants qw(STF_DEBUG); 5 | use STF::Log; 6 | use STF::Utils (); 7 | 8 | has queue_names => ( 9 | is => 'rw', 10 | required => 1, 11 | ); 12 | 13 | requires qw( 14 | enqueue 15 | size_for_queue 16 | ); 17 | 18 | sub size_total { 19 | my ($self, $func) = @_; 20 | my $total = 0; 21 | foreach my $queue_name ( @{ $self->queue_names } ) { 22 | $total += $self->size_for_queue( $func, $queue_name ); 23 | } 24 | return $total; 25 | } 26 | 27 | sub size { 28 | no warnings 'redefine'; 29 | *size = \&size_total; 30 | goto \&size; 31 | } 32 | 33 | sub enqueue_first_available { 34 | my ($self, $func, $object_id, $cb) = @_; 35 | 36 | my $queue_names = $self->queue_names; 37 | my %queues = ( 38 | map { 39 | ( $_ => Digest::MurmurHash::murmur_hash( $_ . $object_id ) ) 40 | } @$queue_names 41 | ); 42 | foreach my $queue_name ( sort { $queues{$a} <=> $queues{$b} } keys %queues) { 43 | if (STF_DEBUG) { 44 | debugf("Attempting to enqueue job into queue '%s'", $queue_name); 45 | } 46 | 47 | my $rv; 48 | my $err = STF::Utils::timeout_call( 0.5, sub { 49 | $rv = $cb->($queue_name, $object_id) 50 | }); 51 | if ( $err ) { 52 | # XXX Don't wrap in STF_DEBUG 53 | critf("Error while enqueuing: %s\n + func: %s\n + object ID = %s\n", 54 | $err, 55 | $func, 56 | $object_id, 57 | ); 58 | next; 59 | } 60 | 61 | return $rv; 62 | } 63 | 64 | return (); 65 | } 66 | 67 | no Mouse::Role; 68 | 69 | 1; -------------------------------------------------------------------------------- /lib/STF/API/Queue/Q4M.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Queue::Q4M; 2 | use Mouse; 3 | use Digest::MurmurHash (); 4 | use STF::Constants qw(:func STF_DEBUG); 5 | use STF::Log; 6 | 7 | with qw( 8 | STF::Trait::WithDBI 9 | STF::API::Queue 10 | ); 11 | 12 | has funcmap => ( 13 | is => 'rw', 14 | lazy => 1, 15 | builder => 'build_funcmap' 16 | ); 17 | 18 | sub build_funcmap { 19 | return { 20 | notify => Q4M_FUNC_NOTIFY, 21 | replicate => Q4M_FUNC_REPLICATE, 22 | delete_object => Q4M_FUNC_DELETE_OBJECT, 23 | delete_bucket => Q4M_FUNC_DELETE_BUCKET, 24 | repair_object => Q4M_FUNC_REPAIR_OBJECT, 25 | } 26 | } 27 | 28 | sub get_func_id { 29 | my ($self, $func) = @_; 30 | 31 | $self->funcmap->{$func}; 32 | } 33 | 34 | sub size_for_queue { 35 | my ($self, $func, $queue_name) = @_; 36 | my $dbh = $self->dbh($queue_name); 37 | my $table = "queue_$func"; 38 | my ($count) = $dbh->selectrow_array( <get_func_id( $func ); 49 | if (! $func_id ) { 50 | croakf("PANIC: Don't know what the function ID for %s is", $func); 51 | } 52 | 53 | if ( ! defined $object_id ) { 54 | croakf("No object_id given for %s", $func); 55 | } 56 | 57 | my $table = "queue_$func"; 58 | 59 | $self->enqueue_first_available( $func, $object_id, sub { 60 | my ($queue_name, $object_id) = @_; 61 | my $dbh = $self->dbh($queue_name); 62 | if (STF_DEBUG) { 63 | debugf( 64 | "INSERT %s into %s for %s on %s", 65 | $object_id, 66 | $table, 67 | $func, 68 | $queue_name 69 | ); 70 | } 71 | return $dbh->do(<get($queue_name); 15 | $queue->llen($func); 16 | } 17 | 18 | sub enqueue { 19 | my ($self, $func, $object_id) = @_; 20 | 21 | local $STF::Log::PREFIX = "Redis"; 22 | 23 | if ( ! defined $object_id ) { 24 | croakf("No object_id given for %s", $func); 25 | } 26 | 27 | my $encoder = $self->get('JSON'); 28 | 29 | $self->enqueue_first_available($func, $object_id, sub { 30 | my ($queue_name, $object_id) = @_; 31 | if (STF_DEBUG) { 32 | debugf( 33 | "INSERT %s for %s on %s", 34 | $object_id, 35 | $func, 36 | $queue_name 37 | ); 38 | } 39 | my $resque = $self->get($queue_name); 40 | $resque->rpush( $func => $encoder->encode({ args => [ $object_id ] })); 41 | }); 42 | } 43 | 44 | no Mouse; 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/STF/API/Queue/Resque.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Queue::Resque; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | with qw( 7 | STF::API::Queue 8 | STF::Trait::WithContainer 9 | ); 10 | 11 | sub size_for_queue { 12 | my ($self, $func, $queue_name) = @_; 13 | 14 | my $queue = $self->get($queue_name); 15 | $queue->size($func); 16 | } 17 | 18 | sub enqueue { 19 | my ($self, $func, $object_id) = @_; 20 | 21 | local $STF::Log::PREFIX = "Resque"; 22 | 23 | if ( ! defined $object_id ) { 24 | croakf("No object_id given for %s", $func); 25 | } 26 | 27 | my $worker_class = ucfirst $func; 28 | $worker_class =~ s/_(\w)/uc $1/ge; 29 | $worker_class = "STF::Worker::${worker_class}::Proxy"; 30 | 31 | $self->enqueue_first_available($func, $object_id, sub { 32 | my ($queue_name, $object_id) = @_; 33 | if (STF_DEBUG) { 34 | debugf( 35 | "INSERT %s for %s (%s) on %s", 36 | $object_id, 37 | $func, 38 | $worker_class, 39 | $queue_name 40 | ); 41 | } 42 | my $resque = $self->get($queue_name); 43 | $resque->push( $func => { 44 | class => $worker_class, 45 | args => [ $object_id ], 46 | }); 47 | }); 48 | } 49 | 50 | no Mouse; 51 | 52 | 1; 53 | -------------------------------------------------------------------------------- /lib/STF/API/Queue/Schwartz.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Queue::Schwartz; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use TheSchwartz; 5 | use STF::Log; 6 | 7 | with qw( 8 | STF::Trait::WithDBI 9 | STF::API::Queue 10 | ); 11 | 12 | has ability_map => ( 13 | is => 'rw', 14 | lazy => 1, 15 | builder => 'build_ability_map', 16 | ); 17 | 18 | sub build_ability_map { 19 | return { 20 | notify => "STF::Worker::Notify::Proxy", 21 | replicate => "STF::Worker::Replicate::Proxy", 22 | delete_object => "STF::Worker::DeleteObject::Proxy", 23 | delete_bucket => "STF::Worker::DeleteBucket::Proxy", 24 | repair_object => "STF::Worker::RepairObject::Proxy", 25 | object_health => "STF::Worker::ObjectHealth::Proxy", 26 | }; 27 | } 28 | 29 | sub size_for_queue { 30 | my ($self, $func, $queue_name) = @_; 31 | my $dbh = $self->get($queue_name); 32 | my $ability = $self->get_ability($func); 33 | my ($count) = $dbh->selectrow_array( <ability_map->{$func}; 45 | } 46 | 47 | sub get_client { 48 | my ($self, $queue_name) = @_; 49 | 50 | my $client = $self->{clients}->{$queue_name}; 51 | if (! $client) { 52 | my $dbh = $self->get($queue_name) or 53 | Carp::confess( "Could not fetch DB::Queue" ); 54 | my $driver = Data::ObjectDriver::Driver::DBI->new( dbh => $dbh ); 55 | $self->{client}->{$queue_name} = $client = 56 | TheSchwartz->new( databases => [ { driver => $driver } ] ); 57 | } 58 | return $client; 59 | } 60 | 61 | sub enqueue { 62 | my ($self, $func, $object_id) = @_; 63 | 64 | my $ability = $self->get_ability($func); 65 | if (! $ability ) { 66 | Carp::confess( "PANIC: Don't know what the schwartz ability for $func is" ); 67 | } 68 | 69 | if ( ! defined $object_id ) { 70 | Carp::confess("No object_id given for $func"); 71 | } 72 | 73 | $self->enqueue_first_available($func, $object_id, sub { 74 | my ($queue_name) = @_; 75 | my $client = $self->get_client($queue_name); 76 | my $rv = $client->insert( $ability, $object_id ); 77 | if (STF_DEBUG) { 78 | debugf("Enqueued %s (%s)", $ability, $object_id); 79 | } 80 | return $rv; 81 | }); 82 | } 83 | 84 | no Mouse; 85 | 86 | 1; 87 | 88 | -------------------------------------------------------------------------------- /lib/STF/API/StorageMeta.pm: -------------------------------------------------------------------------------- 1 | package STF::API::StorageMeta; 2 | use Mouse; 3 | 4 | with qw( STF::API::WithDBI ); 5 | 6 | sub update_for { 7 | my ($self, $storage_id, $args) = @_; 8 | $self->create( 9 | { %$args, storage_id => $storage_id }, 10 | { prefix => "REPLACE INTO" } 11 | ); 12 | } 13 | 14 | no Mouse; 15 | 16 | 1; 17 | 18 | -------------------------------------------------------------------------------- /lib/STF/API/Throttler.pm: -------------------------------------------------------------------------------- 1 | package STF::API::Throttler; 2 | use Mouse; 3 | 4 | with 'STF::Trait::WithContainer'; 5 | 6 | has key => ( 7 | is => 'ro', 8 | required => 1, 9 | ); 10 | 11 | has throttle_span => ( 12 | is => 'ro', 13 | default => 10 14 | ); 15 | 16 | has threshold => ( 17 | is => 'rw', 18 | default => 0 19 | ); 20 | 21 | sub incr { 22 | my ($self, $now) = @_; 23 | 24 | $now ||= time(); 25 | my $time = int($now); 26 | 27 | my $key = join ".", $self->key, $time; 28 | my $memd = $self->get('Memcached'); 29 | if (! $memd->incr($key)) { 30 | # try initializing once 31 | if (! $memd->add($key, 1, $self->throttle_span * 2)) { 32 | # failed? somebody got to the key before us, so 33 | # try again. 34 | $memd->incr($key); 35 | } 36 | } 37 | } 38 | 39 | sub expand_key { 40 | # my ($key, $base_t, $span) = @_; 41 | # for max efficiency... 42 | return map { 43 | join ".", $_[0], ($_[1] - $_) 44 | } 0 .. ($_[2] - 1); 45 | } 46 | 47 | sub current_count_multi { 48 | my ($self, $now, @keys) = @_; 49 | 50 | my $memd = $self->get('Memcached'); 51 | my $time = int($now); 52 | my $span = $self->throttle_span; 53 | my %ret; 54 | foreach my $key (@keys) { 55 | my $h = $memd->get_multi( 56 | expand_key($key, $time, $span) 57 | ); 58 | 59 | my $count = 0; 60 | foreach my $value (values %$h) { 61 | $count += $value || 0; 62 | } 63 | $ret{$key} = $count; 64 | } 65 | 66 | return \%ret; 67 | } 68 | 69 | sub current_count { 70 | my ($self, $now) = @_; 71 | 72 | my $time = int($now); 73 | my $h = $self->get('Memcached')->get_multi( 74 | expand_key($self->key, $time, $self->throttle_span) 75 | ); 76 | 77 | my $count = 0; 78 | foreach my $value (values %$h) { 79 | $count += $value || 0; 80 | } 81 | return $count; 82 | } 83 | 84 | sub should_throttle { 85 | my ($self, $now) = @_; 86 | 87 | my $threshold = $self->threshold; 88 | my $current = $self->current_count($now); 89 | return $threshold <= $current; 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/STF/API/WithDBI.pm: -------------------------------------------------------------------------------- 1 | package STF::API::WithDBI; 2 | use Mouse::Role; 3 | use Scalar::Util (); 4 | use SQL::Maker; 5 | 6 | with qw( 7 | STF::Trait::WithCache 8 | STF::Trait::WithDBI 9 | ); 10 | 11 | has sql_maker => ( 12 | is => 'rw', 13 | lazy => 1, 14 | builder => 'build_sql_maker' 15 | ); 16 | 17 | has table => ( 18 | is => 'rw', 19 | lazy => 1, 20 | builder => 'build_table' 21 | ); 22 | 23 | sub build_sql_maker { 24 | my $self = shift; 25 | return SQL::Maker->new( driver => $self->dbh->{Driver}->{Name} ); 26 | } 27 | 28 | sub build_table { 29 | my $self = shift; 30 | my $table = (split /::/, Scalar::Util::blessed $self)[-1]; 31 | $table =~ s/([a-z0-9])([A-Z])/$1_$2/g; 32 | return lc $table; 33 | 34 | } 35 | 36 | sub lookup { 37 | my ($self, $id) = @_; 38 | 39 | my $obj = ! ref $id && $self->cache_get($self->table => $id); 40 | if ($obj) { 41 | return $obj; 42 | } 43 | 44 | my ($sql, @binds) = $self->sql_maker->select( $self->table, [ '*' ], { id => $id }); 45 | $obj = $self->dbh->selectrow_hashref($sql, undef, @binds); 46 | if ($obj) { 47 | $self->cache_set( [ $self->table => $id ], $obj ); 48 | } 49 | return $obj; 50 | } 51 | 52 | sub lookup_multi { 53 | my ($self, @ids) = @_; 54 | 55 | my %keys = map { 56 | ( $self->cache_key($self->table => $_) => $_ ) 57 | } @ids; 58 | my $cached = $self->cache_get_multi(keys %keys); 59 | my %result; 60 | foreach my $key (keys %keys) { 61 | my $value = $cached->{$key}; 62 | if (defined $value) { 63 | $result{ $keys{$key} } = $value; 64 | } else { 65 | $result{ $keys{$key} } = $self->lookup( $keys{$key} ); 66 | } 67 | } 68 | return \%result; 69 | } 70 | 71 | sub search { 72 | my ($self, $where, $opts) = @_; 73 | my ($sql, @binds) = $self->sql_maker->select( $self->table, [ '*' ], $where, $opts ); 74 | my $results = $self->dbh->selectall_arrayref( $sql, { Slice => {} }, @binds ); 75 | return wantarray ? @$results : $results; 76 | } 77 | 78 | sub create { 79 | my ($self, $args, $opts) = @_; 80 | 81 | $opts ||= {}; 82 | my ($sql, @binds) = $self->sql_maker->insert( 83 | $self->table, 84 | $args, 85 | $opts, 86 | ); 87 | return $self->dbh->do($sql, undef, @binds); 88 | } 89 | 90 | sub update { 91 | my ($self, $id, $args, $where) = @_; 92 | 93 | $where ||= {}; 94 | if (my $ref = ref $id) { 95 | if ($ref eq 'HASH') { 96 | $where = { %$where, %$id }; 97 | } 98 | if ( my $pk = $where->{id} ) { 99 | $self->cache_delete( $self->table => $pk ); 100 | } 101 | } else { 102 | $self->cache_delete( $self->table => $id ); 103 | $where->{id} = $id; 104 | } 105 | 106 | my ($sql, @binds) = $self->sql_maker->update( 107 | $self->table, 108 | $args, 109 | $where, 110 | ); 111 | my $dbh = $self->dbh; 112 | return $dbh->do($sql, undef, @binds); 113 | } 114 | 115 | sub delete { 116 | my ($self, $id) = @_; 117 | 118 | $self->cache_delete( $self->table => $id ) if ! ref $id; 119 | my ($sql, @binds) = $self->sql_maker->delete( 120 | $self->table, 121 | ref $id eq 'HASH' ? $id : { id => $id } 122 | ); 123 | return $self->dbh->do($sql, undef, @binds); 124 | } 125 | 126 | sub count { 127 | my ($self, $where) = @_; 128 | my ($sql, @binds) = $self->sql_maker->select( $self->table, [ \'COUNT(*)' ], $where ); 129 | my ($count) = $self->dbh->selectrow_array( 130 | $sql, 131 | {}, 132 | @binds, 133 | ); 134 | return $count; 135 | } 136 | 137 | no Mouse::Role; 138 | 139 | 1; 140 | -------------------------------------------------------------------------------- /lib/STF/API/WorkerInstances.pm: -------------------------------------------------------------------------------- 1 | package STF::API::WorkerInstances; 2 | use Mouse; 3 | 4 | with 'STF::API::WithDBI'; 5 | 6 | no Mouse; 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Context.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Context; 2 | use Mouse; 3 | use Data::Page; 4 | use URI; 5 | use URI::Escape; 6 | # XXX For some reason Xslate + URI(::Escape) is giving me grief. 7 | # Pre-loading these seems to fix the problem 8 | use URI::_server; 9 | use URI::_generic; 10 | use URI::_query; 11 | use Plack::Request; 12 | use Plack::Session; 13 | 14 | with 'STF::Trait::WithContainer'; 15 | 16 | has finished => ( 17 | is => 'rw', 18 | default => 0, 19 | ); 20 | 21 | has stash => ( 22 | is => 'rw', 23 | default => sub { +{} } 24 | ); 25 | 26 | has match => ( 27 | is => 'rw', 28 | ); 29 | 30 | has request => ( 31 | is => 'rw', 32 | required => 1, 33 | ); 34 | 35 | has response => ( 36 | is => 'rw', 37 | lazy => 1, 38 | default => sub { $_[0]->request->new_response(200) }, 39 | ); 40 | 41 | has session => ( 42 | is => 'rw', 43 | lazy => 1, 44 | default => sub { Plack::Session->new($_[0]->request->env) } 45 | ); 46 | 47 | sub BUILDARGS { 48 | my ($class, %args) = @_; 49 | 50 | if (my $env = delete $args{env}) { 51 | $args{request} = Plack::Request->new( $env ); 52 | } 53 | return \%args; 54 | } 55 | 56 | sub redirect { 57 | my ($self, $uri) = @_; 58 | my $res = $self->response; 59 | $res->status(302); 60 | $res->header( Location => $uri ); 61 | $self->abort; 62 | } 63 | 64 | sub abort { 65 | die "stf.abort"; 66 | } 67 | 68 | sub stf_uri { 69 | my ($self, $bucket, $object) = @_; 70 | 71 | my $object_name = $object->{name}; 72 | $object_name =~ s/^\///; 73 | return join 74 | '/', 75 | $self->container->get('API::Config')->load_variable('stf.global.public_uri'), 76 | $bucket->{name}, 77 | $object->{name}, 78 | ; 79 | } 80 | 81 | sub uri_for { 82 | my( $self, @args ) = @_; 83 | # Plack::App::URLMap 84 | 85 | my $req = $self->request; 86 | my $uri = $req->base; 87 | my $params = 88 | ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} ); 89 | my @path = split '/', $uri->path; 90 | unless ( $args[0] =~ m{^/} ) { 91 | push @path, split( '/', $req->path_info ); 92 | } 93 | push @path, @args; 94 | my $path = join '/', @path; 95 | $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx 96 | $uri->path( $path ); 97 | $uri->query_form( $params ); 98 | return $uri; 99 | } 100 | 101 | 1; -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Controller.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Controller; 2 | use Mojo::Base 'Mojolicious::Controller'; 3 | 4 | sub fillinform { 5 | my ($self, $hash) = @_; 6 | $self->stash(fdat => $hash); 7 | } 8 | 9 | sub validate { 10 | my ($self, $profile, $params) = @_; 11 | my $result = $self->get('AdminWeb::Validator')->check( $params, $profile ); 12 | $self->stash(result => $result); 13 | return $result; 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Controller/Bucket.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Controller::Bucket; 2 | use Mojo::Base 'STF::AdminWeb::Controller'; 3 | 4 | sub load_object { 5 | my ($self, $object_id) = @_; 6 | 7 | $object_id ||= $self->match->captures->{object_id}; 8 | if ($object_id =~ /\D/) { 9 | # resolve bucket/path/to/object to object id 10 | $object_id = $self->resolve_public_name($object_id); 11 | if (! $object_id) { 12 | return; 13 | } 14 | } 15 | 16 | my $object = $self->get('API::Bucket')->lookup( $object_id ); 17 | if (! $object) { 18 | return; 19 | } 20 | $self->stash(bucket => $object); 21 | return $object; 22 | } 23 | 24 | sub api_delete { 25 | my ($self) = @_; 26 | 27 | my $bucket = $self->load_object(); 28 | if (! $bucket) { 29 | $self->render_json({}, status => 404); 30 | return; 31 | } 32 | 33 | $self->get('API::Bucket')->mark_for_delete({ id => $bucket->{id} }); 34 | $self->get('API::Queue')->enqueue( delete_bucket => $bucket->{id} ); 35 | 36 | $self->render_json({ 37 | message => "bucket deleted" 38 | }); 39 | } 40 | 41 | sub list { 42 | my ($self) = @_; 43 | my $limit = 100; 44 | my $pager = $self->pager($limit); 45 | 46 | my %q; 47 | my $req = $self->req; 48 | if ( my $name = $req->param('name') ) { 49 | $q{name} = { LIKE => $name }; 50 | } 51 | 52 | my @buckets = $self->get('API::Bucket')->search( 53 | \%q, 54 | { 55 | limit => $pager->entries_per_page + 1, 56 | offset => $pager->skipped, 57 | order_by => { 'name' => 'ASC' }, 58 | } 59 | ); 60 | # fool pager 61 | if ( scalar @buckets > $limit ) { 62 | $pager->total_entries( $limit * $pager->current_page + 1 ); 63 | } 64 | 65 | $self->fillinform($req->params->to_hash); 66 | $self->stash( 67 | pager => $pager, 68 | buckets => \@buckets 69 | ); 70 | } 71 | 72 | sub view { 73 | my ($self) = @_; 74 | 75 | my $bucket = $self->load_object(); 76 | if (! $bucket) { 77 | $self->render_not_found(); 78 | return; 79 | } 80 | my $total = $self->get('API::Object')->count({ bucket_id => $bucket->{id} }); 81 | my $limit = 100; 82 | my $pager = $self->pager( $limit ); 83 | 84 | my @objects = $self->get('API::Object')->search_with_entity_info( 85 | { bucket_id => $bucket->{id} }, 86 | { 87 | limit => $pager->entries_per_page + 1, 88 | offset => $pager->skipped, 89 | order_by => { 'name' => 'ASC' }, 90 | } 91 | ); 92 | 93 | if ( scalar @objects > $limit ) { 94 | $pager->total_entries( $limit * $pager->current_page + 1 ); 95 | } 96 | $self->stash( 97 | bucket => $bucket, 98 | objects => \@objects, 99 | pager => $pager, 100 | ); 101 | } 102 | 103 | sub add {} 104 | sub add_post { 105 | my ($self) = @_; 106 | 107 | my $params = $self->req->params->to_hash; 108 | my $result = $self->validate(bucket_add => $params); 109 | if ($result->success) { 110 | my $stf_uri = $self->get('API::Config')->load_variable('stf.global.public_uri'); 111 | my $valids = $result->valid; 112 | my $name = $valids->{name}; 113 | my $furl = $self->get('Furl'); 114 | my (undef, $code) = $furl->put( "$stf_uri/$name", [ 'Content-Length' => 0 ] ); 115 | if ($code ne '201') { 116 | $self->render_text("Failed to create bucket at $stf_uri/$name"); 117 | return; 118 | } 119 | my $bucket = $self->get('API::Bucket')->lookup_by_name( $name ); 120 | $self->redirect_to( $self->url_for("/bucket/show/$bucket->{id}") ); 121 | } else { 122 | $self->stash(template => 'bucket/add'); 123 | } 124 | $self->stash(clusters => scalar $self->get('API::StorageCluster')->search({})); 125 | } 126 | 127 | 1; -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Controller/Config.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Controller::Config; 2 | use Mojo::Base 'STF::AdminWeb::Controller'; 3 | use STF::API::Throttler; 4 | 5 | sub notification { 6 | my ($self) = @_; 7 | 8 | my @rules = $self->get('API::NotificationRule')->search(); 9 | $self->stash(rules => \@rules); 10 | } 11 | 12 | sub notification_rule_add { 13 | my ($self) = @_; 14 | 15 | my $params = $self->req->params->to_hash; 16 | my $result = $self->validate("notification_rule_add", $params); 17 | if (! $result->success) { 18 | $self->notification(); # load stuff 19 | $self->stash(template => 'config/notification'); 20 | $self->fillinform( $params ); 21 | return; 22 | } 23 | 24 | $self->get('API::NotificationRule')->create($params); 25 | $self->redirect_to( $self->url_for("/config/notification") ); 26 | } 27 | 28 | sub notification_rule_toggle { 29 | my ($self) = @_; 30 | 31 | my $id = $self->req->param('id'); 32 | my $rule_api = $self->get('API::NotificationRule'); 33 | my $rule = $rule_api->lookup($id); 34 | $rule_api->update($id, { 35 | status => $rule->{status} ? 0 : 1, 36 | }); 37 | 38 | $self->render_json({ message => "toggled rule" }); 39 | } 40 | 41 | sub notification_rule_delete { 42 | my ($self, $c) = @_; 43 | 44 | my $id = $self->req->param('id'); 45 | $self->get('API::NotificationRule')->delete($id); 46 | 47 | $self->render_json({ message => "deleted rule" }); 48 | } 49 | 50 | sub worker { 51 | my ($self, $c) = @_; 52 | 53 | my $worker_name = $self->match->captures->{worker_name}; 54 | 55 | # Find where this worker should be running on 56 | my @drones; 57 | { 58 | my $dbh = $self->get('DB::Master'); 59 | my $sth = $dbh->prepare(<execute( $worker_name ); 63 | my $drone; 64 | $sth->bind_columns(\($drone)); 65 | while ($sth->fetchrow_arrayref) { 66 | push @drones, $drone; 67 | } 68 | } 69 | 70 | # XXX Throttler API sucks. fix it 71 | # Get the current throttling count 72 | my $throttler = STF::API::Throttler->new( 73 | key => "stf.worker.$worker_name.processed_jobs", 74 | throttle_span => 10, 75 | container => $self->app->context->container, 76 | ); 77 | my %states = ( 78 | "stf.worker.$worker_name.processed_jobs" => $throttler->current_count(time()), 79 | ); 80 | 81 | my $prefix = sprintf 'stf.worker.%s.%%', $worker_name; 82 | my $config_vars = $self->get('API::Config')->search({ 83 | varname => [ 84 | { 'LIKE' => $prefix }, 85 | { 'LIKE' => sprintf 'stf.drone.%s.instances', $worker_name } 86 | ] 87 | }); 88 | 89 | $self->stash( 90 | drones => \@drones, 91 | states => \%states, 92 | config_vars => $config_vars, 93 | worker_name => $worker_name, 94 | ); 95 | my %fdat; 96 | foreach my $pair (@$config_vars) { 97 | $fdat{ $pair->{varname} } = $pair->{varvalue}; 98 | } 99 | $self->fillinform( \%fdat ); 100 | } 101 | 102 | sub worker_list { 103 | my ($self) = @_; 104 | 105 | my $config_vars = $self->get('API::Config')->search({}); 106 | $self->stash(config_vars => $config_vars); 107 | my %fdat; 108 | foreach my $pair (@$config_vars) { 109 | $fdat{ $pair->{varname} } = $pair->{varvalue}; 110 | } 111 | $self->fillinform( \%fdat ); 112 | } 113 | 114 | sub reload { 115 | my ($self) = @_; 116 | 117 | my $memd = $self->get('Memcached'); 118 | my $now = time(); 119 | $memd->set_multi( 120 | (map { [ "stf.drone.$_", $now ] } qw(election reload balance)), 121 | (map { [ "stf.worker.$_.reload", $now ] } 122 | qw(ContinuousRepair DeleteBucket DeleteObject RepairObject RepairStorage Replicate StorageHealth)) 123 | ); 124 | 125 | $self->render_json({ message => "reload flag set properly" }); 126 | } 127 | 128 | sub update { 129 | my ($self, $c) = @_; 130 | 131 | my $p = $self->req->params; 132 | my @params = map { ($_ => scalar $p->param($_)) } $p->param; 133 | 134 | $self->get('API::Config')->set(@params); 135 | $self->redirect_to( $self->url_for("/config/worker/list") ); 136 | } 137 | 138 | 1; 139 | -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Controller/Root.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Controller::Root; 2 | use Mojo::Base 'STF::AdminWeb::Controller'; 3 | 4 | sub index {} 5 | 6 | sub setlang { 7 | my ($self) = @_; 8 | 9 | if (my $lang = $self->req->param('lang')) { 10 | my $localizer = $self->get('Localizer')->set_languages( $lang ); 11 | $self->sessions->set(lang => $lang); 12 | } 13 | 14 | $self->redirect_to("/"); 15 | } 16 | 17 | sub state { 18 | my ($self) = @_; 19 | # Load the current state of leader election 20 | # XXX Wrap in ::API ? 21 | my $dbh = $self->get('DB::Master'); 22 | my $list = $dbh->selectall_arrayref(< {} }); 23 | SELECT * FROM worker_election ORDER BY id ASC 24 | EOSQL 25 | $self->stash(election => $list); 26 | 27 | my $memd = $self->get('Memcached'); 28 | my $h = $memd->get_multi( 29 | (map { "stf.drone.$_" } qw(election reload balance)), 30 | ); 31 | my $throttler = STF::API::Throttler->new( 32 | key => "DUMMY", 33 | throttle_span => 10, 34 | container => $self->context->container, 35 | ); 36 | $h = { 37 | %$h, 38 | %{ $throttler->current_count_multi( 39 | time(), 40 | map { "stf.worker.$_.processed_jobs" } 41 | qw(ContinuousRepair DeleteBucket DeleteObject RepairObject RepairStorage Replicate StorageHealth) 42 | ) } 43 | }; 44 | 45 | $self->stash(states => $h); 46 | } 47 | 48 | 1; -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Controller/Worker.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Controller::Worker; 2 | use Mojo::Base 'STF::AdminWeb::Controller'; 3 | 4 | sub api_list { 5 | my $self = shift; 6 | 7 | # Find worker instances 8 | my @workers = $self->get("API::WorkerInstances")->search(); 9 | $self->render_json({ 10 | workers => \@workers 11 | }); 12 | } 13 | 14 | 1; -------------------------------------------------------------------------------- /lib/STF/AdminWeb/Renderer.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::Renderer; 2 | use Mojo::Base 'Mojolicious::Renderer'; 3 | use File::Spec (); 4 | use Mojo::Loader; 5 | use Text::Xslate (); 6 | 7 | has 'xslate'; 8 | 9 | sub build { 10 | my $self = shift->new(@_); 11 | $self->_init(@_); 12 | return sub { $self->render(@_) }; 13 | } 14 | 15 | sub _init { 16 | my ($self, %args) = @_; 17 | 18 | my $app = delete $args{mojo} || delete $args{app}; 19 | my $cache_dir = $args{cache_dir}; 20 | my $path = $args{path}; 21 | if (! $path || scalar(@$path) < 1) { 22 | $path = [ $app->home->rel_dir('templates') ]; 23 | } 24 | 25 | if ($app) { 26 | if (! $cache_dir) { 27 | $cache_dir = $app->home->rel_dir('tmp/compiled_templates'); 28 | } 29 | 30 | push @$path, Mojo::Loader->new->data( 31 | $app->renderer->classes->[0], 32 | ); 33 | } else { 34 | if (! $cache_dir) { 35 | $cache_dir = File::Spec->tmpdir; 36 | } 37 | } 38 | 39 | my %config = ( 40 | cache_dir => $cache_dir, 41 | path => $path, 42 | syntax => 'TTerse', 43 | %args, 44 | ); 45 | 46 | my $xslate = $self->build_xslate(\%config); 47 | $self->xslate($xslate); 48 | 49 | return $self; 50 | } 51 | 52 | sub build_xslate { 53 | my ($self, $config) = @_; 54 | Text::Xslate->new($config); 55 | } 56 | 57 | sub render { 58 | my ($self, $renderer, $c, $output, $options) = @_; 59 | 60 | my $name = $c->stash->{'template_name'} 61 | || $renderer->template_name($options); 62 | my %params = (%{$c->stash}, c => $c); 63 | 64 | eval { 65 | $$output = $self->xslate->render($name, \%params); 66 | }; 67 | if (my $err = $@) { 68 | $c->app->log->error(qq(Template error in "$name": $err)); 69 | $$output = ''; 70 | return 0; 71 | }; 72 | 73 | return 1; 74 | } 75 | 76 | 77 | 1; 78 | 79 | -------------------------------------------------------------------------------- /lib/STF/AdminWeb/View/Xslate.pm: -------------------------------------------------------------------------------- 1 | package STF::AdminWeb::View::Xslate; 2 | use Mouse; 3 | 4 | use Encode (); 5 | use Text::Xslate; 6 | use HTML::FillInForm::Lite; 7 | 8 | has fif => ( 9 | is => 'rw', 10 | default => sub { 11 | HTML::FillInForm::Lite->new; 12 | } 13 | ); 14 | 15 | has suffix => ( 16 | is => 'rw', 17 | ); 18 | 19 | has xslate => ( 20 | is => 'rw', 21 | required => 1, 22 | ); 23 | 24 | sub BUILDARGS { 25 | my ($class, %args) = @_; 26 | 27 | my $app = delete $args{app}; 28 | my $function = $args{function} ||= {}; 29 | $function->{nl2br} = Text::Xslate::html_builder(sub { 30 | my $text = "$_[0]"; 31 | $text =~ s{\n}{
}gsm; 32 | return $text; 33 | }); 34 | $function->{loc} = sub { 35 | $app->context->get('Localizer')->localize(@_); 36 | }; 37 | $function->{strftime} = sub { POSIX::strftime($_[0], localtime($_[1])) }; 38 | 39 | my %parsed; 40 | if (my $fif = delete $args{fif}) { 41 | $parsed{fif} = $fif; 42 | } 43 | if (my $suffix = delete $args{suffix}) { 44 | $parsed{suffix} = $suffix; 45 | } 46 | $parsed{xslate} = Text::Xslate->new(%args); 47 | 48 | return \%parsed; 49 | } 50 | 51 | sub process { 52 | my ($self, $context, $template) = @_; 53 | 54 | my $content = $self->render( $template, $context->stash ); 55 | my $response = $context->response; 56 | my $request = $context->request; 57 | 58 | $response->content_type( "text/html" ); 59 | 60 | if ($response->content_type && $response->content_type =~ m{^text/x?html$}i) { 61 | if ( $request->method eq 'POST' ) { 62 | $content = $self->fif->fill( \$content, $request ); 63 | } elsif ( my $fdat = $context->stash->{fdat} ) { 64 | $content = $self->fif->fill( \$content, $fdat ); 65 | } 66 | } 67 | 68 | $response->body( Encode::encode_utf8( $content ) ); 69 | } 70 | 71 | sub render { 72 | my ($self, $template, $vars) = @_; 73 | 74 | if (my $suffix = $self->suffix) { 75 | $template =~ s/(?xslate->render( $template, $vars ); 79 | } 80 | 81 | no Mouse; 82 | 83 | 1; 84 | -------------------------------------------------------------------------------- /lib/STF/CLI.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI; 2 | use strict; 3 | use Getopt::Long (); 4 | use Class::Load (); 5 | use STF::Context; 6 | 7 | sub new { 8 | my $class = shift; 9 | my $self = bless { 10 | cmds => { 11 | enqueue => 'STF::CLI::Enqueue', 12 | health => 'STF::CLI::Health', 13 | object => 'STF::CLI::Object', 14 | storage => 'STF::CLI::Storage', 15 | } 16 | }, $class; 17 | $self; 18 | } 19 | 20 | sub base_opt_specs { ('config=s', 'debug') } 21 | 22 | sub run { 23 | my $self = shift; 24 | my $base_opts = $self->get_options( $self->base_opt_specs ); 25 | my $command = shift @ARGV; 26 | if (! $command) { 27 | $self->show_subcommands( "Missing subcommand" ); 28 | exit 1; 29 | } 30 | 31 | my $class = $self->{cmds}->{lc $command}; 32 | if (! $class) { 33 | $self->show_subcommands( "No such command" ); 34 | exit 1; 35 | } 36 | 37 | if (! Class::Load::try_load_class($class) ) { 38 | print STDERR "Could not $class\n"; 39 | exit 1; 40 | } 41 | my $opts = $self->get_options( $class->opt_specs ); 42 | my %options = ( 43 | %{$base_opts}, 44 | %{$opts}, 45 | ); 46 | local $ENV{LM_DEBUG} = 1 if $options{debug}; 47 | 48 | my $context = STF::Context->bootstrap; 49 | my $guard = $context->container->new_scope(); 50 | my $c = $class->new( 51 | context => $context, 52 | options => \%options, 53 | ); 54 | $c->run( @ARGV ); 55 | } 56 | 57 | sub get_options { 58 | my( $self, @specs ) = @_; 59 | my $p = Getopt::Long::Parser->new; 60 | $p->configure(qw(pass_through)); 61 | if ($p->getoptions( \my %hash, @specs )) { 62 | return \%hash; 63 | } 64 | } 65 | 66 | sub show_subcommands { 67 | my ($self, $message) = @_; 68 | print STDOUT "$message\n"; 69 | print STDOUT < [options...] 72 | 73 | health [-a] 74 | health [-a] -s -l 75 | 76 | Displays the health status of an object. This means actual HTTP requests 77 | will run to check if the entities are actuall retrievable 78 | 79 | -a will show details. default off. 80 | 81 | object [-a] 82 | object [-a] -s -l 83 | 84 | Displays the object details. can be an object path or object ID. 85 | 86 | -l will show objects in the storage 87 | 88 | -a will show details. default is off. 89 | 90 | storage 91 | storage -L 92 | Displays the storage status. 93 | 94 | -l will show the entire storage list. 95 | 96 | enqueue 97 | 98 | Enqueues the piece of into the queue. Job name may be: 99 | replicate, delete_bucket, delete_object, repair_object, object_health 100 | 101 | EOM 102 | } 103 | 104 | 1; 105 | 106 | __END__ 107 | 108 | =head1 NAME 109 | 110 | STF::CLI - STF CLI 111 | 112 | =head1 SYNOPSIS 113 | 114 | 115 | =cut 116 | -------------------------------------------------------------------------------- /lib/STF/CLI/Base.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI::Base; 2 | use strict; 3 | use POSIX (); 4 | use Class::Accessor::Lite ( 5 | new => 1, 6 | rw => [qw(context options)] 7 | ); 8 | 9 | sub opt_specs { (); } 10 | 11 | sub format_time { 12 | my ($self, $t) = @_; 13 | sprintf '%s (%s)', 14 | POSIX::strftime('%Y-%m-%d %T', localtime($t)), 15 | $t 16 | ; 17 | } 18 | 19 | sub get { shift->context->get(@_) } 20 | 21 | sub get_object { 22 | my ($self, $id_ish) = @_; 23 | 24 | if ($id_ish =~ m{^/?([^/]+)/(.+)}) { # /path/to/object ? 25 | my ($bucket_name, $object_name) = ($1, $2); 26 | my $bucket = $self->get('API::Bucket')->lookup_by_name($bucket_name); 27 | my $object_id = $self->get('API::Object')->find_object_id( { 28 | bucket_id => $bucket->{id}, 29 | object_name => $object_name 30 | } ); 31 | if ($object_id ) { 32 | $id_ish = $object_id; 33 | } 34 | } 35 | 36 | my $object = $self->get('API::Object')->lookup( $id_ish ); 37 | if ($object) { 38 | my $bucket = $self->get('API::Bucket')->lookup( $object->{bucket_id} ); 39 | $object->{bucket_name} = $bucket->{name}; 40 | } 41 | return $object; 42 | } 43 | 44 | sub get_storage { 45 | my ($self, $storage_id) = @_; 46 | $self->get('API::Storage')->lookup($storage_id); 47 | } 48 | 49 | sub get_entities { 50 | my ($self, $object_id, $storage_id) = @_; 51 | 52 | my $sql = <get('DB::Master'); 71 | my $entities = $dbh->prepare($sql); 72 | $entities->execute(@binds); 73 | return @{ $entities->fetchall_arrayref({}) }; 74 | } 75 | 76 | 77 | 1; 78 | -------------------------------------------------------------------------------- /lib/STF/CLI/Enqueue.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI::Enqueue; 2 | use strict; 3 | use parent qw(STF::CLI::Base); 4 | 5 | sub run { 6 | my ($self, $job_name, $arg) = @_; 7 | $self->get('API::Queue')->enqueue( $job_name, $arg ); 8 | print "Enqueued $arg to $job_name\n"; 9 | } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /lib/STF/CLI/Health.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI::Health; 2 | use strict; 3 | use parent qw(STF::CLI::Base); 4 | use JSON (); 5 | use Digest::MD5 (); 6 | 7 | sub opt_specs { 8 | ( 9 | 'all!', 10 | 'storage=i', 11 | ) 12 | } 13 | 14 | sub run { 15 | my ($self, $object_id) = @_; 16 | 17 | my $options = $self->{options}; 18 | if ( my $storage = $options->{storage} ) { 19 | $self->show_object_health_in_storage( $storage, $options->{limit} ); 20 | } else { 21 | my $object = $self->get_object($object_id); 22 | $self->show_object_health( $object ); 23 | } 24 | } 25 | 26 | sub show_object_health_in_storage { 27 | my ($self, $storage_id, $limit) = @_; 28 | if ($limit <= 0) { 29 | $limit = 100; 30 | } 31 | 32 | my $dbh = $self->get('DB::Master'); 33 | my $sth = $dbh->prepare(<execute( $storage_id, $limit ); 40 | while ( my $h = $sth->fetchrow_hashref ) { 41 | my $object = $self->get_object( $h->{id} ); 42 | $self->show_object_health( $object ); 43 | } 44 | } 45 | 46 | sub show_object_health { 47 | my ($self, $object) = @_; 48 | 49 | my $all = $self->{options}->{all}; 50 | 51 | my $storage_api = $self->get('API::Storage'); 52 | my $entity_api = $self->get('API::Entity'); 53 | my @entities = $entity_api->search({ 54 | object_id => $object->{id}, 55 | }); 56 | my $md5 = Digest::MD5->new; 57 | my @results; 58 | foreach my $entity (@entities) { 59 | my $storage = $storage_api->lookup($entity->{storage_id}); 60 | my $url = join "/", $storage->{uri}, $object->{internal_name}; 61 | 62 | my $content = $entity_api->fetch_content({ 63 | storage => $storage, 64 | object => $object, 65 | }); 66 | if ($content) { 67 | $md5->reset; 68 | $md5->addfile($content); 69 | } 70 | 71 | push @results, { 72 | url => $url, 73 | storage => $storage, 74 | $content ? 75 | ( valid => JSON::true(), md5 => $md5->hexdigest ) : 76 | ( valid => JSON::false(), md5 => undef ), 77 | }; 78 | } 79 | 80 | my $formatter = JSON->new->pretty; 81 | $formatter->encode({ 82 | object => $object, 83 | entities => \@results, 84 | }); 85 | 86 | print "---\n"; 87 | } 88 | 89 | 1; -------------------------------------------------------------------------------- /lib/STF/CLI/Object.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI::Object; 2 | use strict; 3 | use parent qw(STF::CLI::Base); 4 | use JSON (); 5 | 6 | sub opt_specs { 7 | ( 8 | 'all!', 9 | 'storage=s', 10 | 'limit=i', 11 | ) 12 | } 13 | 14 | sub run { 15 | my ($self, $object_id) = @_; 16 | 17 | my $options = $self->{options}; 18 | if ( $options->{storage} ) { 19 | $self->show_objects_in_storage( $options->{storage}, $options->{limit} ); 20 | } else { 21 | my $object = $self->get_object($object_id); 22 | if (! $object ) { 23 | die "Could not find object '$object_id'"; 24 | } 25 | 26 | $self->show_object( $object ); 27 | } 28 | } 29 | 30 | sub show_objects_in_storage { 31 | my ($self, $storage_id, $limit) = @_; 32 | 33 | if ($limit <= 0) { 34 | $limit = 100; 35 | } 36 | 37 | my $dbh = $self->get('DB::Master'); 38 | my $sth = $dbh->prepare(<execute( $storage_id, $limit ); 45 | while ( my $h = $sth->fetchrow_hashref ) { 46 | my $object = $self->get_object( $h->{id} ); 47 | $self->show_object( $object ); 48 | } 49 | } 50 | 51 | sub show_object { 52 | my ($self, $object) = @_; 53 | 54 | my $formatter = JSON->new->pretty; 55 | 56 | my $h = { 57 | id => $object->{id}, 58 | path => join( '/', $object->{bucket_name}, $object->{name} ), 59 | internal_name => $object->{internal_name}, 60 | num_replica => $object->{num_replica}, 61 | size => $object->{size}, 62 | created_at => $self->format_time($object->{created_at}), 63 | }; 64 | if ($self->{options}->{all}) { 65 | $h->{ entities } = [ map { 66 | delete $_->{object_id}; 67 | $_->{created_at} = $self->format_time($_->{created_at}); 68 | $_ 69 | } $self->get_entities( $object->{id} ) ]; 70 | } 71 | print $formatter->encode( $h ); 72 | print "---\n"; 73 | } 74 | 75 | 1; 76 | 77 | -------------------------------------------------------------------------------- /lib/STF/CLI/Storage.pm: -------------------------------------------------------------------------------- 1 | package STF::CLI::Storage; 2 | use strict; 3 | use parent qw(STF::CLI::Base); 4 | use JSON (); 5 | 6 | sub opt_specs { 7 | ( 8 | 'list|L!', 9 | 'limit=i', 10 | ) 11 | } 12 | 13 | sub run { 14 | my ($self, $storage_id) = @_; 15 | 16 | my $options = $self->{options}; 17 | if ( $options->{list} ) { 18 | $self->show_all_storages( $options->{limit} ); 19 | } else { 20 | my $storage = $self->get_storage( $storage_id ); 21 | if (! $storage ) { 22 | die "Could not find object '$storage_id'"; 23 | } 24 | $self->show_storage( $storage ); 25 | } 26 | } 27 | 28 | sub show_all_storages { 29 | my ($self, $limit) = @_; 30 | 31 | if ($limit <= 0) { 32 | $limit = 100; 33 | } 34 | 35 | my $dbh = $self->get('DB::Master'); 36 | my $sth = $dbh->prepare(<execute(); 40 | while ( my $h = $sth->fetchrow_hashref ) { 41 | $self->show_storage( $h ); 42 | } 43 | } 44 | 45 | sub show_storage { 46 | my ($self, $storage) = @_; 47 | 48 | my $formatter = JSON->new->pretty; 49 | 50 | local $storage->{created_at} = $self->format_time( $storage->{created_at} ); 51 | local $storage->{updated_at} = $self->format_time( $storage->{updated_at} ); 52 | print $formatter->encode($storage); 53 | print "---\n"; 54 | } 55 | 56 | 1; 57 | 58 | -------------------------------------------------------------------------------- /lib/STF/Container.pm: -------------------------------------------------------------------------------- 1 | package STF::Container; 2 | use Mouse; 3 | use Scope::Guard (); 4 | 5 | has objects => ( 6 | is => 'ro', 7 | default => sub { +{} } 8 | ); 9 | 10 | has registry => ( 11 | is => 'ro', 12 | default => sub { +{} }, 13 | ); 14 | 15 | has scoped_objects => ( 16 | is => 'rw', 17 | default => sub { +{} }, 18 | ); 19 | 20 | has scoped_registry => ( 21 | is => 'rw', 22 | default => sub { +{} }, 23 | ); 24 | 25 | sub new_scope { 26 | my ($self, $initialize) = @_; 27 | $self->scoped_objects({}) if $initialize; 28 | return Scope::Guard->new( sub { $self->scoped_objects({}) } ); 29 | } 30 | 31 | sub get { 32 | my ($self, $key) = @_; 33 | 34 | my $object; 35 | my $is_scoped = exists $self->scoped_registry->{$key}; 36 | if ( $is_scoped ) { 37 | $object = $self->scoped_objects->{ $key }; 38 | } else { 39 | # if it's a regular object, just try to grab it 40 | $object = $self->objects->{$key}; 41 | } 42 | 43 | if (! $object) { 44 | my $code; 45 | if ( $is_scoped ) { 46 | my $code = $self->scoped_registry->{$key}; 47 | if ($object = $code->($self)) { 48 | $self->scoped_objects->{$key} = $object; 49 | } 50 | } elsif ( $code = $self->registry->{$key} ) { 51 | if ( $object = $code->($self) ) { 52 | $self->objects->{$key} = $object; 53 | } 54 | } 55 | } 56 | 57 | if ( ! $object) { 58 | Carp::confess("$key could not be found in container"); 59 | } 60 | 61 | return $object; 62 | } 63 | 64 | sub register { 65 | my ($self, $key, $thing, $opts) = @_; 66 | 67 | $opts ||= {}; 68 | if (ref $thing eq 'CODE') { 69 | if ($opts->{scoped}) { 70 | $self->scoped_registry->{$key} = $thing; 71 | } else { 72 | $self->registry->{$key} = $thing; 73 | } 74 | } else { 75 | $self->objects->{$key} = $thing; 76 | } 77 | } 78 | 79 | no Mouse; 80 | 81 | 1; 82 | -------------------------------------------------------------------------------- /lib/STF/DFV.pm: -------------------------------------------------------------------------------- 1 | # HATE HATE HATE HATE Data::FormValidator. It's a piece of shit code, 2 | # with hacks that make it virtually impossible to extend it in a sane way. 3 | # 4 | # This class needs to add a whopping 76 lines *JUST* to add 1 attribute 5 | # to the object. 6 | # 7 | # HATE HATE HATE Data::FormValidator. It's a PIECE OF SHIT. 8 | 9 | package STF::DFV; 10 | use strict; 11 | use parent qw(Data::FormValidator); 12 | use Class::Accessor::Lite 13 | rw => [ qw( container) ] 14 | ; 15 | 16 | sub new { 17 | my $class = shift; 18 | my $profiles = shift; 19 | my $defaults = (ref $_[0] eq 'HASH') ? shift : {}; 20 | my %args = @_; 21 | 22 | if (! exists $defaults->{missing_optional_valid} ) { 23 | $defaults->{missing_optional_valid} = 1; 24 | } 25 | $defaults->{msgs} = sub { 26 | my $dfv = shift; 27 | my %msgs; 28 | 29 | if ( $dfv->has_missing ) { 30 | foreach my $missing ($dfv->missing) { 31 | my $list = $msgs{ $missing } ||= []; 32 | push @$list, "error.missing"; 33 | } 34 | } 35 | 36 | if ( $dfv->has_invalid ) { 37 | foreach my $invalid ($dfv->invalid) { 38 | my $failed = $dfv->invalid($invalid); 39 | my $list = $msgs{ $invalid } ||= []; 40 | push @$list, map { 41 | ref $_ ? 'error.invalid' : 42 | $_ eq 'eq_with' ? 'error.eq_with' : $_ 43 | } @$failed; 44 | } 45 | } 46 | return \%msgs; 47 | }; 48 | 49 | my $self = $class->SUPER::new( $profiles, $defaults ); 50 | while ( my($field, $value) = each %args ) { 51 | $self->$field( $value ); 52 | } 53 | return $self; 54 | } 55 | 56 | 57 | sub get { shift->container->get(@_) } 58 | 59 | sub check { 60 | my ( $self, $data, $name ) = @_; 61 | 62 | # check can be used as a class method for simple cases 63 | if (not ref $self) { 64 | my $class = $self; 65 | $self = {}; 66 | bless $self, $class; 67 | } 68 | 69 | my $profile; 70 | if ( ref $name ) { 71 | $profile = $name; 72 | } else { 73 | $self->load_profiles; 74 | $profile = $self->{profiles}{$name}; 75 | die "No such profile $name\n" unless $profile; 76 | } 77 | die "input profile must be a hash ref" unless ref $profile eq "HASH"; 78 | 79 | # add in defaults from new(), if any 80 | if ($self->{defaults}) { 81 | $profile = { %{$self->{defaults}}, %$profile }; 82 | } 83 | 84 | # check the profile syntax or die with an error. 85 | Data::FormValidator::_check_profile_syntax($profile); 86 | 87 | my $results = STF::DFV::Results->new( $profile, $data, $self->container ); 88 | 89 | # As a special case, pass through any defaults for the 'msgs' key. 90 | $results->msgs($self->{defaults}->{msgs}) if $self->{defaults}->{msgs}; 91 | 92 | return $results; 93 | } 94 | 95 | package STF::DFV::Results; 96 | use strict; 97 | use parent qw(Data::FormValidator::Results); 98 | use Class::Accessor::Lite 99 | rw => [ qw( container ) ] 100 | ; 101 | 102 | sub new { 103 | my $proto = shift; 104 | my $class = ref $proto || $proto; 105 | my ($profile, $data, $container) = @_; 106 | 107 | my $self = bless { container => $container }, $class; 108 | 109 | $self->_process( $profile, $data ); 110 | $self; 111 | } 112 | 113 | sub add_invalid { 114 | my ($self, $key, $error) = @_; 115 | my $list = $self->invalid->{$key} ||= []; 116 | push @$list, $error; 117 | } 118 | 119 | 1; -------------------------------------------------------------------------------- /lib/STF/Environment.pm: -------------------------------------------------------------------------------- 1 | package STF::Environment; 2 | use strict; 3 | 4 | sub load_dotcloud_env { 5 | my $file = shift; 6 | 7 | require YAML; 8 | my $env = YAML::LoadFile( $file ); 9 | 10 | # $env comes first, because runtime parameters (%ENV) has 11 | # higher precedence 12 | %ENV = (%$env, %ENV); 13 | 14 | my $dbname = uc( $ENV{ STF_DOTCLOUD_DB_SERVICE_NAME } || 'db' ); 15 | my $q_name = uc( $ENV{ STF_DOTCLOUD_QUEUE_SERVICE_NAME } || 'db' ); 16 | 17 | $ENV{ STF_MYSQL_DSN } ||= sprintf( 18 | "dbi:mysql:dbname=stf;host=%s;port=%d", 19 | $ENV{ "DOTCLOUD_${dbname}_MYSQL_HOST" }, 20 | $ENV{ "DOTCLOUD_${dbname}_MYSQL_PORT" } 21 | ); 22 | $ENV{ STF_MYSQL_USERNAME } ||= $ENV{ "DOTCLOUD_${dbname}_MYSQL_LOGIN" }; 23 | $ENV{ STF_MYSQL_PASSWORD } ||= $ENV{ "DOTCLOUD_${dbname}_MYSQL_PASSWORD" }; 24 | 25 | $ENV{ STF_QUEUE_DSN } ||= sprintf( 26 | "dbi:mysql:dbname=stf_queue;host=%s;port=%d", 27 | $ENV{ "DOTCLOUD_${dbname}_MYSQL_HOST" }, 28 | $ENV{ "DOTCLOUD_${dbname}_MYSQL_PORT" } 29 | ); 30 | $ENV{ STF_QUEUE_USERNAME } ||= $ENV{ "DOTCLOUD_${dbname}_MYSQL_LOGIN" }; 31 | $ENV{ STF_QUEUE_PASSWORD } ||= $ENV{ "DOTCLOUD_${dbname}_MYSQL_PASSWORD" }; 32 | } 33 | 34 | BEGIN { 35 | my $dotcloud_envfile = $ENV{ DOTCLOUD_ENVIRONMENT_YML } || '/home/dotcloud/environment.yml'; 36 | if (-f $dotcloud_envfile) { 37 | load_dotcloud_env($dotcloud_envfile); 38 | } 39 | } 40 | 41 | 1; -------------------------------------------------------------------------------- /lib/STF/Log.pm: -------------------------------------------------------------------------------- 1 | package STF::Log; 2 | use Log::Minimal; 3 | use base qw(Exporter); 4 | our @EXPORT = @Log::Minimal::EXPORT; 5 | 6 | our ($PREFIX, $LOGFH); 7 | 8 | BEGIN { 9 | $PREFIX = ""; 10 | if (my $file = $ENV{STF_LOG_FILE}) { 11 | open my $fh, '>>', $file 12 | or die "Could not open log file $file: $!"; 13 | $LOGFH = $fh; 14 | } else { 15 | $LOGFH =\*STDERR; 16 | } 17 | } 18 | 19 | $Log::Minimal::PRINT = sub { 20 | my ($time, $type, $message, $trace) = @_; 21 | printf $LOGFH ( "%5s [%s] %s %s\n", 22 | $$, 23 | $type, 24 | $PREFIX ? sprintf "[%10s]", $PREFIX : "", 25 | $message 26 | ); 27 | }; 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /lib/STF/Test.pm: -------------------------------------------------------------------------------- 1 | package STF::Test; 2 | BEGIN { 3 | $ENV{DEPLOY_ENV} = 'test'; 4 | } 5 | use strict; 6 | use parent qw(Exporter); 7 | use Carp; 8 | use DBI; 9 | use Plack::Runner; 10 | use Proc::Guard (); 11 | use Test::TCP; 12 | use Test::More; 13 | use Log::Minimal (); 14 | $Log::Minimal::LOG_LEVEL ||= "NONE"; 15 | 16 | 17 | our @EXPORT_OK = qw( 18 | clear_objects 19 | clear_queue 20 | random_string 21 | ); 22 | 23 | our $MYSQLD; 24 | our $MEMCACHED; 25 | our @STF_BACKENDS; 26 | 27 | { 28 | # $? がリークすると、prove が 29 | # Dubious, test returned 15 (wstat 3840, 0xf00) 30 | # というので $? を localize する。 31 | package t::Proc::Guard; 32 | use parent qw(Proc::Guard); 33 | sub stop { 34 | my $self = shift; 35 | local $?; 36 | $self->SUPER::stop(@_); 37 | } 38 | } 39 | 40 | sub start_memcached { 41 | my $daemonize = shift; 42 | note "Starting memcached..."; 43 | my $port = Test::TCP::empty_port(); 44 | my $memcached = t::Proc::Guard->new( 45 | code => sub { 46 | open my $logfh, '>', "t/memcached.log"; 47 | { 48 | open STDOUT, '>&', $logfh 49 | or die "dup(2) failed: $!"; 50 | open STDERR, '>&', $logfh 51 | or die "dup(2) failed: $!"; 52 | exec "memcached", ( $daemonize ? "-d" : (), "-vv", "-p", $port ); 53 | }; 54 | die "Failed to execute memcached: $!" if defined $!; 55 | }, 56 | ); 57 | $memcached->{port} = $port; 58 | note " Started at port " . $memcached->{port}; 59 | return $memcached; 60 | } 61 | 62 | sub clear_objects { 63 | my $ctx = STF::Context->bootstrap; 64 | my $c = $ctx->container; 65 | my $dbh = $c->get('DB::Master'); 66 | my $sth = $dbh->prepare(<get('API::Object'); 71 | my $entity_api = $ctx->get('API::Entity'); 72 | 73 | my $object_id; 74 | $sth->execute(); 75 | $sth->bind_columns( \($object_id) ); 76 | while ( $sth->fetchrow_arrayref ) { 77 | $object_api->delete( $object_id ); 78 | $entity_api->delete_for_object_id( $object_id ); 79 | } 80 | } 81 | 82 | sub clear_queue { 83 | no warnings 'redefine'; 84 | my $queue_type = $ENV{STF_QUEUE_TYPE} || 'Q4M'; 85 | if ($queue_type eq 'Resque') { 86 | *clear_queue = \&clear_queue_resque; 87 | } elsif ($queue_type eq 'Redis') { 88 | *clear_queue = \&clear_queue_redis; 89 | } else { 90 | *clear_queue = \&clear_queue_dbi; 91 | } 92 | goto &clear_queue; 93 | } 94 | 95 | sub clear_queue_dbi { 96 | my $dbh = DBI->connect( $ENV{STF_QUEUE_DSN } ); 97 | my $sth = $dbh->prepare( "SHOW TABLES" ); 98 | $sth->execute(); 99 | while ( my ($table) = $sth->fetchrow_array ) { 100 | next unless $table =~ /^queue_|^job$/; 101 | $dbh->do( "TRUNCATE $table" ); 102 | } 103 | } 104 | 105 | sub clear_queue_redis { 106 | require Redis; 107 | my $redis = Redis->new(server => $ENV{STF_REDIS_HOSTPORT}); 108 | foreach my $qname (qw(replicate repair_object delete_object delete_bucket)) { 109 | $redis->del($qname); 110 | } 111 | } 112 | 113 | sub clear_queue_resque { 114 | require Resque; 115 | my $resque = Resque->new(redis => $ENV{STF_REDIS_HOSTPORT}); 116 | foreach my $qname ($resque->queues) { 117 | $resque->remove_queue($qname); 118 | } 119 | } 120 | 121 | # String::URandomとか使っても良いけど面倒くさい 122 | sub random_string { 123 | my @chars = ('a'..'z'); 124 | join "", map { $chars[ rand @chars ] } 1..($_[0] || 8); 125 | } 126 | 127 | 1; -------------------------------------------------------------------------------- /lib/STF/Trace/SQLite.pm: -------------------------------------------------------------------------------- 1 | package STF::Trace::SQLite; 2 | use Mouse; 3 | 4 | use DBD::SQLite; 5 | 6 | has connect_info => ( 7 | is => 'rw', 8 | isa => 'ArrayRef', 9 | ); 10 | 11 | has dbh => ( 12 | is => 'rw', 13 | builder => \&_initialize_dbh 14 | ); 15 | 16 | sub _initialize_dbh { 17 | my $self = shift; 18 | my $connect_info = $self->connect_info; 19 | if (! $connect_info) { 20 | require Carp; 21 | Carp::croak("No connect_info and no dbh provided"); 22 | } 23 | my $dbh = DBI->connect( @$connect_info ); 24 | 25 | $dbh->do(<dbh->do(<dbh->do("DELETE FROM trace_log"); 52 | } 53 | 54 | no Mouse; 55 | 56 | 1; 57 | -------------------------------------------------------------------------------- /lib/STF/Trait/WithCache.pm: -------------------------------------------------------------------------------- 1 | package STF::Trait::WithCache; 2 | use Mouse::Role; 3 | use STF::Constants qw(STF_CACHE_DEBUG); 4 | use STF::Log; 5 | 6 | with 'STF::Trait::WithContainer'; 7 | 8 | our $DEFAULT_CACHE_EXPIRES = 5 * 60; 9 | has cache_expires => ( 10 | is => 'rw', 11 | default => $DEFAULT_CACHE_EXPIRES 12 | ); 13 | 14 | sub cache_key { 15 | my ($self, @keys) = @_; 16 | my $key = join '.', @keys; 17 | if (STF_CACHE_DEBUG) { 18 | debugf("Generated cache key '%s' from [%s]", 19 | $key, 20 | join ", ", @keys 21 | ); 22 | } 23 | return $key; 24 | } 25 | 26 | sub cache_get_multi { 27 | my ($self, @keys) = @_; 28 | 29 | local $STF::Log::PREFIX = "Cache"; 30 | my $ret = $self->get('Memcached')->get_multi( @keys ); 31 | if (STF_CACHE_DEBUG) { 32 | debugf("GET MULTI for (%s) returned %d values", join(", ", @keys), keys %$ret); 33 | foreach my $key (@keys) { 34 | debugf(" %s -> %s", $key, $ret->{$key} ? "HIT" : "MISS"); 35 | } 36 | } 37 | return $ret; 38 | } 39 | 40 | sub cache_get { 41 | my ($self, @keys) = @_; 42 | local $STF::Log::PREFIX = "Cache"; 43 | my $key = $self->cache_key(@keys); 44 | my $ret = $self->get('Memcached')->get( $key ); 45 | if (STF_CACHE_DEBUG) { 46 | debugf("GET %s for %s", ( defined $ret ? "HIT" : "MISS" ), $key); 47 | } 48 | return $ret; 49 | } 50 | 51 | sub cache_set { 52 | my ($self, $key, $value, $expires) = @_; 53 | local $STF::Log::PREFIX = "Cache"; 54 | $key = ref $key eq 'ARRAY' ? $self->cache_key(@$key) : $key; 55 | if (STF_CACHE_DEBUG) { 56 | debugf("SET for %s", $key); 57 | } 58 | $self->get('Memcached')->set( $key, $value, $expires || $self->cache_expires || $DEFAULT_CACHE_EXPIRES ); 59 | } 60 | 61 | sub cache_delete { 62 | my ($self, @keys) = @_; 63 | 64 | local $STF::Log::PREFIX = "Cache"; 65 | my $key = $self->cache_key(@keys); 66 | if (STF_CACHE_DEBUG) { 67 | debugf("DELETE for %s", $key); 68 | } 69 | $self->get('Memcached')->delete( $key ); 70 | } 71 | 72 | no Mouse::Role; 73 | 74 | 1; 75 | -------------------------------------------------------------------------------- /lib/STF/Trait/WithContainer.pm: -------------------------------------------------------------------------------- 1 | package STF::Trait::WithContainer; 2 | use Mouse::Role; 3 | 4 | has container => ( 5 | is => 'ro', 6 | required => 1, 7 | handles => [ qw(get) ], 8 | ); 9 | 10 | no Mouse::Role; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/STF/Trait/WithDBI.pm: -------------------------------------------------------------------------------- 1 | package STF::Trait::WithDBI; 2 | use Mouse::Role; 3 | 4 | with 'STF::Trait::WithContainer'; 5 | 6 | use DBI (); 7 | use Scope::Guard (); 8 | 9 | sub dbh { 10 | my ( $self, $key ) = @_; 11 | $key ||= 'DB::Master'; 12 | $self->get( $key ); 13 | } 14 | 15 | no Mouse::Role; 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /lib/STF/Utils.pm: -------------------------------------------------------------------------------- 1 | package STF::Utils; 2 | use strict; 3 | use POSIX ':signal_h'; 4 | use Time::HiRes (); 5 | use Scope::Guard (); 6 | use STF::Log; 7 | 8 | use parent 'Exporter'; 9 | our @EXPORT_OK = qw(txn_block add_resource_guard); 10 | my @RESOURCE_DESTRUCTION_GUARDS; 11 | END { 12 | undef @RESOURCE_DESTRUCTION_GUARDS; 13 | } 14 | 15 | sub add_resource_guard(@) { 16 | push @RESOURCE_DESTRUCTION_GUARDS, @_; 17 | } 18 | 19 | # Creates a reusable coderef bound to '$self', '$txn' (the actual code invoked) 20 | # and '$dbkey'. $dbkey defaults to DB::Master 21 | sub txn_block(&;$) { 22 | my ($txn, $dbkey) = @_; 23 | 24 | $dbkey ||= 'DB::Master'; 25 | return sub { 26 | my ($ctx, @args) = @_; 27 | my $dbh = $ctx->get($dbkey); 28 | if (! $dbh) { 29 | Carp::confess("Could not get $dbkey from container"); 30 | } 31 | $dbh->begin_work; 32 | my $guard = Scope::Guard->new(sub { 33 | local $@; 34 | eval { $dbh->rollback } 35 | }); 36 | my @res; 37 | eval { 38 | @res = $txn->($ctx, @args); 39 | $dbh->commit; 40 | $guard->dismiss; 41 | }; 42 | return @res ; 43 | }; 44 | } 45 | 46 | sub merge_hashes { 47 | my ($left, $right) = @_; 48 | return { %$left, %$right }; 49 | } 50 | 51 | sub applyenv { 52 | my ($file) = @_; 53 | 54 | my $env = $ENV{DEPLOY_ENV}; 55 | if (! $env ) { 56 | return ($file); 57 | } 58 | 59 | my $x_file = $file; 60 | $x_file =~ s/\.([^\.]+)$/_$env.$1/; 61 | return ($file, $x_file); 62 | } 63 | 64 | sub human_readable_size { 65 | my $bytes = shift; 66 | my $val = $bytes; 67 | my $unit = 'B'; 68 | for my $u(qw(K M G T)) { 69 | last if $val < 1024; 70 | $val /= 1024; 71 | $unit = $u; 72 | } 73 | return sprintf '%.1f%s', $val, $unit; 74 | } 75 | 76 | sub as_bytes { 77 | my $v = shift; 78 | if ($v =~ s/TB?$//i) { 79 | return $v * 1024 * 1024 * 1024 * 1024; 80 | } elsif ($v =~ s/GB?$//i) { 81 | return $v * 1024 * 1024 * 1024; 82 | } elsif ($v =~ s/MB?$//i) { 83 | return $v * 1024 * 1024; 84 | } elsif ($v =~ s/KB?$//i) { 85 | return $v * 1024; 86 | } 87 | return $v; 88 | } 89 | 90 | sub timer_guard { 91 | my $sub = $_[0] || (caller(1))[0,3]; 92 | require Time::HiRes; 93 | my $t0 = [ Time::HiRes::gettimeofday() ]; 94 | return Scope::Guard->new(sub { 95 | my $elapsed = Time::HiRes::tv_interval($t0); 96 | undef $t0; 97 | local $STF::Log::PREFIX = "TIMER"; 98 | debugf("%s took %0.6f seconds", $sub, $elapsed); 99 | } ); 100 | } 101 | 102 | # This is a rather forceful timeout wrapper that allows us to, for example, 103 | # wrap calls to things blocking in the C layer (such as some DBD's). 104 | # Returns the error that occurred. If the call timed out, then this 105 | # error is set to "timeout_call timed out (%d secs)" 106 | sub timeout_call { 107 | my ($timeout, $cb, $timeout_cb, @args) = @_; 108 | 109 | $timeout_cb ||= sub { die sprintf "timeout_call timed out (%d secs)\n", $timeout }; 110 | 111 | # signals to mask in the handler 112 | my $mask = POSIX::SigSet->new( SIGALRM ); 113 | # the handler code ref 114 | my $action = POSIX::SigAction->new( 115 | $timeout_cb, 116 | $mask, 117 | # not using (perl 5.8.2 and later) 'safe' switch or sa_flags 118 | ); 119 | my $oldaction = POSIX::SigAction->new(); 120 | sigaction( SIGALRM, $action, $oldaction ); 121 | my $rv; 122 | eval { 123 | eval { 124 | Time::HiRes::alarm($timeout); # seconds before time out 125 | $cb->(@args); 126 | }; 127 | Time::HiRes::alarm(0); # cancel alarm (if connect worked fast) 128 | die "$@\n" if $@; # connect died 129 | }; 130 | my $e = $@; 131 | sigaction( SIGALRM, $oldaction ); # restore original signal handler 132 | 133 | return $e; 134 | } 135 | 136 | 1; 137 | -------------------------------------------------------------------------------- /lib/STF/Worker/AdaptiveDegrader.pm: -------------------------------------------------------------------------------- 1 | # Gracefully degrade the service by making our storages readonly, when 2 | # loads are high 3 | package STF::Worker::AdaptiveDegrader; 4 | use Mouse; 5 | use STF::Constants qw(STF_DEBUG STORAGE_MODE_READ_WRITE); 6 | use STF::Log; 7 | 8 | extends 'STF::Worker::Base'; 9 | with 'STF::Trait::WithContainer'; 10 | 11 | sub work_once { 12 | my $self = shift; 13 | 14 | # Avoid bringing the entire system down all at once. Keep a good 15 | # interval between current and last degradation 16 | if ($self->next_available < time()) { 17 | return; 18 | } 19 | 20 | my $storage_api = $self->get('API::Storage'); 21 | my @storages = $storage_api->search({ 22 | mode => { IN => [ 23 | STORAGE_MODE_READ_WRITE, 24 | ] } 25 | }); 26 | my $time = time(); 27 | my $t = $time - $time % 60; 28 | my @keys = map { "storage.load.$_->{id}.$t" } @storages; 29 | my $h = $self->get('Memcached')->get_multi(@keys); 30 | my $threshold = $self->get('API::Config')->load_variable("stf.worker.AdaptiveDegrader.threshold") || 1500; 31 | return if $threshold <= 0; 32 | 33 | foreach my $storage (@storages) { 34 | # Fetch the latest load average. The load average data 35 | # should be [ 1min avg, 5min avg, 10min avg ] 36 | # We want to check that the 10min avg is not greater than 37 | # $threshold 38 | 39 | my $key = "storage.load.$storage->{id}.$t"; 40 | my $loadavg = $h->{$key}; 41 | if (! $loadavg) { 42 | if (STF_DEBUG) { 43 | debugf("No load average information found for storage %s", 44 | $storage->{id}); 45 | } 46 | next; 47 | } 48 | 49 | if ($threshold <= $loadavg->[2]) { 50 | my @storages_in_cluster = $storage_api->search({ 51 | cluster_id => $storage->{cluster_id} 52 | }); 53 | my $message = <{id} ($storage->{uri})'s load average is HIGH! 55 | Load average is $loadavg->[0], $loadavg->[1], $loadavg->[2] 56 | Maybe change storage(s) in this cluster to be READONLY? 57 | Storages in cluster $storage->{cluster_id}: 58 | EOM 59 | foreach my $st (@storages_in_cluster) { 60 | $message .= " [$st->{id}][@{[fmt_storage_mode($st->{mode})]}] $st->{uri}\n"; 61 | } 62 | $self->get('API::Notification')->create({ 63 | ntpye => "storage.adaptive_degrader.alter", 64 | severity => "critical", 65 | message => $message, 66 | }); 67 | 68 | $self->next_available(time() + 600); # at least 10 minutes 69 | } 70 | } 71 | } 72 | 73 | no Mouse; 74 | 75 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/Base.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Base; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | has name => ( 7 | is => 'rw', 8 | default => sub { 9 | my $klass = Scalar::Util::blessed($_[0]); 10 | $klass =~ s/^STF::Worker:://; 11 | return $klass; 12 | } 13 | ); 14 | 15 | has interval => ( 16 | is => 'rw', 17 | default => 1_000_000 18 | ); 19 | 20 | has loop_class => ( 21 | is => 'rw', 22 | default => 'Periodic', 23 | ); 24 | 25 | has max_works_per_child => ( 26 | is => 'rw', 27 | default => 1_000 28 | ); 29 | 30 | sub reload {} 31 | 32 | sub create_loop { 33 | my $self = shift; 34 | my $klass = $self->loop_class; 35 | 36 | if ( $klass !~ s/^\+// ) { 37 | $klass = "STF::Worker::Loop::$klass"; 38 | } 39 | Mouse::Util::is_class_loaded($klass) or 40 | Mouse::Util::load_class($klass); 41 | 42 | my $loop = $klass->new( 43 | parent => $self, 44 | container => $self->container, 45 | interval => $self->interval, 46 | max_works_per_child => $self->max_works_per_child, 47 | ); 48 | return $loop; 49 | } 50 | 51 | sub work { 52 | my $self = shift; 53 | 54 | local $STF::Log::PREFIX = $self->name; 55 | infof("Starting %s worker...", $self); 56 | 57 | my $loop = $self->create_loop; 58 | debugf("Starting %s worker...", $self) if STF_DEBUG; 59 | 60 | $loop->work( $self ); 61 | } 62 | 63 | no Mouse; 64 | 65 | 1; 66 | 67 | __END__ 68 | 69 | =head1 NAME 70 | 71 | STF::Worker::Base - Base Worker Class 72 | 73 | =cut 74 | -------------------------------------------------------------------------------- /lib/STF/Worker/ContinuousRepair.pm: -------------------------------------------------------------------------------- 1 | # ContinuousRepair 2 | # * only run if there are no other repairs going on 3 | # * only run if the repair queue isn't big 4 | 5 | package STF::Worker::ContinuousRepair; 6 | use Mouse; 7 | use Scope::Guard (); 8 | use STF::Constants qw(:storage STF_DEBUG); 9 | use STF::Utils (); 10 | use STF::Log; 11 | 12 | extends 'STF::Worker::Base'; 13 | with 'STF::Trait::WithContainer'; 14 | 15 | has '+interval' => ( 16 | default => 86_400 * 1_000_000 17 | ); 18 | 19 | sub work_once { 20 | my $self = shift; 21 | 22 | my $o_e0 = $0; 23 | my $guard = Scope::Guard->new(sub { 24 | $0 = $o_e0; 25 | }); 26 | local $STF::Log::PREFIX = "Repair(CS)" if STF_DEBUG; 27 | eval { 28 | # Signals terminate the process, but don't allow us to fire the 29 | # guard object, so we manually fire it up 30 | my $loop = 1; 31 | my $sig = sub { 32 | my $sig = shift; 33 | return sub { 34 | if (STF_DEBUG) { 35 | debugf("Received signal %s", $sig); 36 | } 37 | $loop = 0; 38 | croakf("Received signal %s", $sig); 39 | }; 40 | }; 41 | local $SIG{INT} = $sig->("INT"); 42 | local $SIG{QUIT} = $sig->("QUIT"); 43 | local $SIG{TERM} = $sig->("TERM"); 44 | 45 | my $bailout = 0; 46 | my $object_id = 0; 47 | my $processed = 0; 48 | my $limit; 49 | my $queue_api = $self->get('API::Queue'); 50 | my $storage_api = $self->get('API::Storage'); 51 | my $dbh = $self->get('DB::Master'); 52 | 53 | # Approximate the number of objects in this system by checking 54 | # getting the difference between max/min object_ids 55 | my ($objcount_guess) = $dbh->selectrow_array(< 10_000_000) { 63 | $limit = 10_000; 64 | } else { 65 | $limit = int($objcount_guess / 1_000); 66 | } 67 | 68 | my $timeout = 0; 69 | 70 | while ( $loop ) { 71 | my $now = time(); 72 | if ($timeout > $now) { 73 | select(undef, undef, undef, rand(5)); 74 | next; 75 | } 76 | 77 | # Only add to queue if there are no more elements to process 78 | # (i.e. this has the lowest priority) 79 | my $size = $queue_api->size( 'repair_object' ); 80 | if ( $size > 0 ) { 81 | $timeout = $now + 60; 82 | next; 83 | } 84 | 85 | # Halt this process for a while if there are pending 86 | # repairs. 87 | my @storages = $storage_api->search( { 88 | mode => { IN => [ 89 | STORAGE_MODE_REPAIR, 90 | STORAGE_MODE_REPAIR_NOW, 91 | ] } 92 | } ); 93 | if (@storages > 0) { 94 | $timeout = $now + 300; # check every 5 minutes 95 | next; 96 | } 97 | 98 | my $offset = int rand $limit; 99 | my $sth = $dbh->prepare(< ? ORDER BY id ASC LIMIT 100 OFFSET $offset 101 | EOSQL 102 | if ($sth->execute( $object_id ) <= 0 ) { 103 | $loop = 0; 104 | next; 105 | } 106 | 107 | $sth->bind_columns( \($object_id) ); 108 | while ( $loop && $sth->fetchrow_arrayref ) { 109 | $queue_api->enqueue( repair_object => "NP:$object_id" ); 110 | $processed++; 111 | $0 = "$o_e0 (object_id: $object_id, $processed)"; 112 | select(undef, undef, undef, rand 1); 113 | } 114 | } 115 | }; 116 | if (my $e = $@) { 117 | if ($e !~ /Received signal/) { 118 | Carp::confess("Failed to run repair storage: $e"); 119 | } else { 120 | Carp::confess("Bailing out because of signal; $e" ); 121 | } 122 | } 123 | } 124 | 125 | no Mouse; 126 | 127 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/DeleteBucket.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::DeleteBucket; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | extends 'STF::Worker::Base'; 7 | with 'STF::Trait::WithDBI'; 8 | 9 | has loop_class => ( 10 | is => 'ro', 11 | default => sub { $ENV{ STF_QUEUE_TYPE } || 'Q4M' } 12 | ); 13 | 14 | sub work_once { 15 | my ($self, $bucket_id) = @_; 16 | 17 | local $STF::Log::PREFIX = "Worker(DB)"; 18 | debugf("Delete bucket id = %s", $bucket_id) if STF_DEBUG; 19 | eval { 20 | $self->get('API::Bucket')->delete_objects( { id => $bucket_id } ); 21 | }; 22 | if ($@) { 23 | print "Failed to delete bucket $bucket_id: $@\n"; 24 | } 25 | } 26 | 27 | no Mouse; 28 | 29 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/DeleteObject.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::DeleteObject; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | extends 'STF::Worker::Base'; 7 | with 'STF::Trait::WithDBI'; 8 | 9 | has loop_class => ( 10 | is => 'ro', 11 | default => sub { $ENV{ STF_QUEUE_TYPE } || 'Q4M' } 12 | ); 13 | 14 | sub work_once { 15 | my ($self, $object_id) = @_; 16 | 17 | local $STF::Log::PREFIX = "Worker(DO)"; 18 | debugf("Delete object id = %s", $object_id) if STF_DEBUG; 19 | eval { 20 | $self->get('API::Entity')->delete_for_object_id( $object_id ); 21 | }; 22 | if ($@) { 23 | print "Failed to delete $object_id: $@\n"; 24 | } 25 | } 26 | 27 | no Mouse; 28 | 29 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/Loop/Periodic.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Loop::Periodic; 2 | use Mouse; 3 | 4 | extends 'STF::Worker::Loop'; 5 | with 'STF::Trait::WithContainer'; 6 | 7 | has '+interval' => ( 8 | default => 60 * 1_000_000 9 | ); 10 | 11 | sub work { 12 | my ($self, $impl) = @_; 13 | 14 | die "Interval is not specified" unless $self->interval; 15 | 16 | my $guard = $self->container->new_scope(); 17 | while ( $self->should_loop ) { 18 | $self->incr_processed(); 19 | my $perloop_scope = $impl->container->new_scope(); 20 | $impl->work_once(); 21 | 22 | if ( $self->should_loop ) { 23 | Time::HiRes::usleep($self->interval); 24 | } 25 | } 26 | } 27 | 28 | no Mouse; 29 | 30 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/Loop/Q4M.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Loop::Q4M; 2 | use Mouse; 3 | use POSIX qw(:signal_h); 4 | use Scalar::Util (); 5 | use Time::HiRes (); 6 | use Scope::Guard (); 7 | use STF::Constants qw(STF_DEBUG); 8 | use STF::Log; 9 | 10 | extends 'STF::Worker::Loop'; 11 | with 'STF::Trait::WithDBI'; 12 | 13 | sub queue_table { 14 | my ($self, $impl) = @_; 15 | 16 | if ( my $code = $impl->can('queue_table') ) { 17 | return $code->($impl); 18 | } 19 | 20 | my $table = (split /::/, Scalar::Util::blessed $impl)[-1]; 21 | $table =~ s/([a-z0-9])([A-Z])/$1_$2/g; 22 | return sprintf 'queue_%s', lc $table; 23 | } 24 | 25 | sub queue_waitcond { 26 | my ($self, $impl) = @_; 27 | 28 | if ( my $code = $impl->can('queue_waitcond') ) { 29 | return $code->($impl); 30 | } 31 | 32 | $self->queue_table( $impl ); 33 | } 34 | 35 | sub work { 36 | my ($self, $impl) = @_; 37 | 38 | local $STF::Log::PREFIX = "Loop::Q4M" if STF_DEBUG; 39 | my $guard = $self->container->new_scope(); 40 | 41 | my $table = $self->queue_table( $impl ); 42 | my $waitcond = $self->queue_waitcond( $impl ); 43 | my $queue_name = $self->queue_name; 44 | my $dbh = $self->get($queue_name) or 45 | Carp::confess( "Could not fetch $queue_name" ); 46 | 47 | my $loop = 1; 48 | my $object_id; 49 | 50 | my $sigset = POSIX::SigSet->new( SIGINT, SIGQUIT, SIGTERM ); 51 | my $sth; 52 | my $cancel_q4m = POSIX::SigAction->new(sub { 53 | if ( $loop ) { 54 | eval { $sth->cancel }; 55 | eval { $dbh->disconnect }; 56 | $loop = 0; 57 | } 58 | }, $sigset, &POSIX::SA_NOCLDSTOP); 59 | my $setsig = sub { 60 | # XXX use SigSet to properly interrupt the process 61 | POSIX::sigaction( SIGINT, $cancel_q4m ); 62 | POSIX::sigaction( SIGQUIT, $cancel_q4m ); 63 | POSIX::sigaction( SIGTERM, $cancel_q4m ); 64 | }; 65 | 66 | $setsig->(); 67 | 68 | my $default = POSIX::SigAction->new('DEFAULT'); 69 | $sth = $dbh->prepare(<should_loop ) { 73 | $self->update_now(); 74 | $self->check_state(); 75 | $self->reload(); 76 | if ($self->is_throttled) { 77 | next if $self->check_throttle(); 78 | } 79 | 80 | $self->incr_processed(); 81 | my $rv = $sth->execute(); 82 | $sth->bind_columns( \$object_id ); 83 | while ( $sth->fetchrow_arrayref ) { 84 | my $extra_guard; 85 | if (STF_DEBUG) { 86 | my ($row_id) = $dbh->selectrow_array( "SELECT queue_rowid()" ); 87 | if (STF_DEBUG) { 88 | debugf("---- START %s:%s ----", $table, $row_id); 89 | debugf("Got new item from %s (%s)", $table, $object_id); 90 | } 91 | $extra_guard = Scope::Guard->new(sub { 92 | debugf("---- END %s:%s ----", $table, $row_id) if STF_DEBUG; 93 | } ); 94 | } 95 | 96 | my $sig_guard = Scope::Guard->new(\&$setsig); 97 | 98 | # XXX Disable signal handling during work_once 99 | POSIX::sigaction( SIGINT, $default ); 100 | POSIX::sigaction( SIGQUIT, $default ); 101 | POSIX::sigaction( SIGTERM, $default ); 102 | 103 | my $guard = $impl->container->new_scope; 104 | eval { $impl->work_once( $object_id ) }; 105 | warn $@ if $@; 106 | if ( (my $interval = $self->interval) > 0 ) { 107 | Time::HiRes::usleep( $interval ); 108 | } 109 | } 110 | $self->check_throttle(); 111 | eval { $dbh->do("SELECT queue_end()") }; 112 | } 113 | 114 | infof("Process %d exiting... (%s)", $$, $impl); 115 | } 116 | 117 | no Mouse; 118 | 119 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/Loop/Redis.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Loop::Redis; 2 | use Mouse; 3 | use Time::HiRes (); 4 | use Redis; 5 | use STF::Log; 6 | use STF::Constants qw(STF_DEBUG STF_TIMER); 7 | 8 | extends 'STF::Worker::Loop'; 9 | with 'STF::Trait::WithContainer'; 10 | 11 | sub work { 12 | my ($self, $impl) = @_; 13 | 14 | local $STF::Log::PREFIX = "Loop::Redis" if STF_DEBUG; 15 | 16 | my $queue_name = $self->queue_name; 17 | my $redis = $impl->get($queue_name); 18 | my $func = Scalar::Util::blessed($impl); 19 | $func =~ s/^STF::Worker:://; 20 | $func =~ s/([a-z])([A-Z])/"$1_$2"/eg; 21 | $func = lc $func; 22 | 23 | my $decoder = $impl->get('JSON'); 24 | my $loop = 1; 25 | $SIG{TERM} = $SIG{INT} = $SIG{QUIT} = sub { 26 | critf("Signal received"); 27 | $loop = 0; 28 | }; 29 | while ( $loop && $self->should_loop ) { 30 | my $timer; 31 | if (STF_TIMER) { 32 | $timer = STF::Utils::timer_guard("$impl loop iteration (Redis)"); 33 | } 34 | $self->update_now; 35 | $self->check_state; 36 | $self->reload; 37 | if ($self->is_throttled) { 38 | next if $self->check_throttle(); 39 | } 40 | 41 | my $payload = $redis->lpop($func); 42 | if ($payload) { 43 | my $job = $decoder->decode($payload); 44 | eval { 45 | $impl->work_once( $job->{args}->[0] ); 46 | }; 47 | $self->incr_processed; 48 | $self->check_throttle(); 49 | } else { 50 | if ( (my $interval = $self->interval) > 0 ) { 51 | Time::HiRes::usleep( $interval ); 52 | } 53 | } 54 | } 55 | } 56 | 57 | 1; 58 | -------------------------------------------------------------------------------- /lib/STF/Worker/Loop/Resque.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Loop::Resque; 2 | use Mouse; 3 | use Resque; 4 | use STF::Log; 5 | use STF::Constants qw(STF_DEBUG); 6 | use feature 'state'; 7 | 8 | extends 'STF::Worker::Loop'; 9 | with 'STF::Trait::WithContainer'; 10 | 11 | sub work { 12 | my ($self, $impl) = @_; 13 | 14 | local $STF::Log::PREFIX = "Loop::Resque" if STF_DEBUG; 15 | 16 | my $resque = $impl->get($self->queue_name); 17 | state $w = $resque->worker; 18 | 19 | # Add a proxy worker to call the impl 20 | my $impl_class = Scalar::Util::blessed($impl); 21 | my $proxy_class = "${impl_class}::Proxy"; 22 | 23 | # Resque::Job does a $job->class->require, and since we 24 | # haven't declared this class in a file, it SILENTLY 25 | # fails. grrr. so lie to Perl that this class has already 26 | # been loaded. 27 | my $defined = $INC{ join( "/", split qr/::/, $proxy_class ) . ".pm" }++; 28 | if (! $defined) { 29 | no strict 'refs'; 30 | no warnings 'redefine'; 31 | *{"${proxy_class}::perform"} = sub { 32 | my $job = shift; 33 | $impl->work_once($job->args->[0]); 34 | }; 35 | 36 | if ($impl_class !~ /^STF::Worker::(.*)$/) { 37 | die "$impl_class not supported. Send in patches!"; 38 | } 39 | my $func = lcfirst $1; 40 | $func =~ s/([a-z])([A-Z])/join "_", $1, lc $2/eg; 41 | if (STF_DEBUG) { 42 | debugf("Worker listening to function %s", $func); 43 | } 44 | $w->add_queue( $func ); 45 | } 46 | 47 | my $loop = 1; 48 | $SIG{TERM} = $SIG{INT} = $SIG{QUIT} = sub { 49 | critf("Signal received"); 50 | $loop = 0; 51 | }; 52 | $w->cant_fork(1); 53 | $w->startup; 54 | while ( $loop && ! $w->shutdown && $self->max_works_per_child > $w->processed ) { 55 | $self->update_now; 56 | $self->check_state; 57 | $self->reload; 58 | if ($self->is_throttled) { 59 | next if $self->check_throttle(); 60 | } 61 | 62 | if ( !$w->paused && ( my $job = $w->reserve ) ) { 63 | $w->work_tick($job); 64 | $self->incr_processed; 65 | $self->check_throttle(); 66 | } 67 | elsif( $w->interval ) { 68 | my $status = $w->paused ? "Paused" : 'Waiting for ' . join( ', ', @{$w->queues} ); 69 | $w->procline( $status ); 70 | $w->log( $status ); 71 | sleep( $w->interval ); 72 | } 73 | } 74 | $w->unregister_worker; 75 | } 76 | 77 | 1; 78 | -------------------------------------------------------------------------------- /lib/STF/Worker/Loop/Schwartz.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Loop::Schwartz; 2 | use Mouse; 3 | use Scalar::Util (); 4 | use Scope::Guard (); 5 | use STF::Constants qw(STF_DEBUG STF_TIMER); 6 | use STF::Log; 7 | use STF::Utils (); 8 | use TheSchwartz; 9 | use Time::HiRes (); 10 | 11 | extends 'STF::Worker::Loop'; 12 | with 'STF::Trait::WithContainer'; 13 | 14 | sub create_client { 15 | my ($self, $impl) = @_; 16 | 17 | local $STF::Log::PREFIX = "Schwartz"; 18 | my $dbh = $self->get('DB::Queue') or 19 | Carp::confess( "Could not fetch DB::Queue" ); 20 | my $driver = Data::ObjectDriver::Driver::DBI->new( dbh => $dbh ); 21 | my $client = TheSchwartz->new( databases => [ { driver => $driver } ] ); 22 | 23 | # XXX Hack! TheSchwartz only allows classnames to be registered to 24 | # the worker. I hate it. But you can always workaround it by wasting 25 | # one GV and creating a proxy class name. 26 | my $ability = Scalar::Util::blessed($impl) . '::Proxy'; 27 | if ( ! $ability->can("work") ) { 28 | no strict 'refs'; 29 | require TheSchwartz::Worker; 30 | @{ "${ability}::ISA" } = qw(TheSchwartz::Worker); 31 | *{ "${ability}::work" } = sub { 32 | my ($class, $job) = @_; 33 | 34 | my $extra_guard; 35 | if ( STF_DEBUG ) { 36 | debugf("---- START %s:%s ----", $ability, $job->arg) if STF_DEBUG; 37 | $extra_guard = Scope::Guard->new( sub { 38 | debugf("---- END %s:%s ----", $ability, $job->arg) if STF_DEBUG; 39 | } ); 40 | } 41 | 42 | eval { 43 | $impl->work_once( $job->arg ); 44 | }; 45 | # XXX Retry? Naahhhh 46 | if ($@) { 47 | critf("Error from work_once: %s", $@); 48 | } 49 | eval { $job->completed }; 50 | undef $extra_guard; 51 | }; 52 | } 53 | $client->can_do( $ability ); 54 | 55 | return $client; 56 | } 57 | 58 | sub work { 59 | my ($self, $impl) = @_; 60 | 61 | my $client = $self->create_client($impl); 62 | while ( $self->should_loop ) { 63 | my $timer; 64 | if (STF_TIMER) { 65 | $timer = STF::Utils::timer_guard("$impl loop iteration (Schwartz)"); 66 | } 67 | 68 | $self->update_now(); 69 | $self->check_state(); 70 | $self->reload(); 71 | if ($self->is_throttled) { 72 | next if $self->check_throttle; 73 | } 74 | 75 | if ( $client->work_once ) { 76 | $self->incr_processed; 77 | $self->check_throttle; 78 | } else { 79 | if ( (my $interval = $self->interval) > 0 ) { 80 | Time::HiRes::usleep( $interval ); 81 | } 82 | } 83 | } 84 | } 85 | 86 | no Mouse; 87 | 88 | 1; -------------------------------------------------------------------------------- /lib/STF/Worker/Notify.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Notify; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | use STF::API::NotificationRule; 6 | 7 | extends 'STF::Worker::Base'; 8 | with 'STF::Trait::WithDBI'; 9 | 10 | has '+loop_class' => ( 11 | default => sub { 12 | $ENV{ STF_QUEUE_TYPE } || 'Q4M', 13 | } 14 | ); 15 | 16 | has rules => ( 17 | is => 'rw', 18 | default => sub { +[] } 19 | ); 20 | 21 | has keep_notifications => ( 22 | is => 'rw', 23 | default => 0 24 | ); 25 | 26 | sub work_once { 27 | my ($self, $notification_id) = @_; 28 | 29 | local $STF::Log::PREFIX = "Notify"; 30 | eval { 31 | $self->notify($notification_id); 32 | }; 33 | if ($@) { 34 | Carp::confess("Failed to notify: $@"); 35 | } 36 | } 37 | 38 | sub reload { 39 | my $self = shift; 40 | 41 | my $keep = $self->get('API::Config')->load_variable("stf.worker.Notify.keep_notifications"); 42 | $self->keep_notifications($keep ? 1 : 0); 43 | my @rules = $self->get("API::NotificationRule")->search( 44 | { status => 1, }, 45 | ); 46 | $self->rules([ map { STF::API::NotificationRule::Matcher->new(%$_) } @rules ]); 47 | } 48 | 49 | sub notify { 50 | my ($self, $notification_id) = @_; 51 | 52 | my $notification_api =$self->get('API::Notification'); 53 | my $notification = $notification_api->lookup($notification_id); 54 | return unless $notification; 55 | 56 | foreach my $rule ( @{$self->rules} ) { 57 | next unless $rule->match($notification); 58 | 59 | my $notifier = eval { $self->get($rule->notifier_name) }; 60 | if ($@) { 61 | critf("Error while trying to notify: %s", $@); 62 | next; 63 | } 64 | my $extra_args = $self->get('JSON')->decode($rule->extra_args || "null"); 65 | $notifier->notify($notification, $extra_args); 66 | } 67 | 68 | # By default delete the notification that just got handled. 69 | # If you want to keep them, it's your responsibility to delete them 70 | # as appropriate. 71 | if (! $self->keep_notifications) { 72 | $notification_api->delete($notification_id); 73 | } 74 | } 75 | 76 | no Mouse; 77 | 78 | 1; 79 | -------------------------------------------------------------------------------- /lib/STF/Worker/RepairObject.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::RepairObject; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | extends 'STF::Worker::Base'; 7 | with 'STF::Trait::WithDBI'; 8 | 9 | has '+loop_class' => ( 10 | default => sub { 11 | $ENV{ STF_QUEUE_TYPE } || 'Q4M', 12 | } 13 | ); 14 | 15 | sub work_once { 16 | my ($self, $object_id) = @_; 17 | 18 | local $STF::Log::PREFIX = "Repair(W)"; 19 | 20 | # legacy 21 | my $propagate = 1; 22 | if ($object_id =~ s/^NP://) { 23 | $propagate = 0; 24 | } 25 | 26 | eval { 27 | my $object_api = $self->get('API::Object'); 28 | if ($object_api->repair( $object_id )) { 29 | debugf("Repaired object %s.", $object_id) if STF_DEBUG; 30 | } 31 | }; 32 | if ($@) { 33 | Carp::confess("Failed to repair $object_id: $@"); 34 | } 35 | } 36 | 37 | no Mouse; 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/STF/Worker/Replicate.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::Replicate; 2 | use Mouse; 3 | use STF::Constants qw(STF_DEBUG); 4 | use STF::Log; 5 | 6 | extends 'STF::Worker::Base'; 7 | with 'STF::Trait::WithContainer'; 8 | 9 | has '+loop_class' => ( 10 | default => sub { 11 | $ENV{ STF_QUEUE_TYPE } || 'Q4M', 12 | } 13 | ); 14 | 15 | sub work_once { 16 | my ($self, $object_id) = @_; 17 | 18 | eval { 19 | my $object_api = $self->get('API::Object'); 20 | if ($object_api->repair( $object_id )) { 21 | debugf("Replicated object %s.", $object_id) if STF_DEBUG; 22 | } 23 | }; 24 | if ($@) { 25 | Carp::confess( "Failed to replicate object ID: $object_id: $@" ); 26 | } 27 | } 28 | 29 | no Mouse; 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/STF/Worker/StatsCollector.pm: -------------------------------------------------------------------------------- 1 | package STF::Worker::StatsCollector; 2 | use Mouse; 3 | use URI; 4 | use Net::SNMP; 5 | use STF::Constants qw(:storage STF_DEBUG); 6 | use STF::Log; 7 | 8 | extends 'STF::Worker::Base'; 9 | with 'STF::Trait::WithContainer'; 10 | 11 | has '+interval' => ( 12 | # XXX IF YOU CHANGE THIS, YOU NEED TO CHANGE ALL THE SNMP QUERYING! 13 | # See L below 14 | default => 30 * 1_000_000 15 | ); 16 | 17 | sub work_once { 18 | my $self = shift; 19 | 20 | eval { 21 | local $SIG{TERM} = sub { die "Received Signal" }; 22 | $self->collect_storage_loads(); 23 | }; 24 | if ($@) { 25 | critf("Bailing out of worker: %s", $@); 26 | # Commit suicide 27 | kill TERM => $$; 28 | } 29 | } 30 | 31 | sub create_snmp_session { 32 | my ($self, $host) = @_; 33 | 34 | # XXX cheat. Should this information be retrieved from DB? 35 | my $config = $self->get('config')->{SNMP} || {}; 36 | return Net::SNMP->session( 37 | -timeout => 5, 38 | -hostname => $host, 39 | %$config, 40 | ); 41 | } 42 | 43 | sub collect_storage_loads { 44 | my $self = shift; 45 | 46 | if (STF_DEBUG) { 47 | debugf("Collecting storage loads."); 48 | } 49 | 50 | # Find the max load average in the whole system, and make sure 51 | # that it doesn't get over $la_threshold 52 | my @storages = $self->get("API::Storage")->search({ 53 | mode => { IN => [ 54 | STORAGE_CLUSTER_MODE_READ_ONLY, 55 | STORAGE_CLUSTER_MODE_READ_WRITE, 56 | STORAGE_MODE_REPAIR_NOW, 57 | ] } 58 | }); 59 | 60 | my $time = time(); 61 | # XXX NORMALIZING THE KEY 62 | # This SNMP information will be stored in $key.