@@ -3,103 +3,188 @@ package HTFeed::BackupExpiration;
33
44use strict;
55use warnings;
6+
67use HTFeed::Config qw( get_config) ;
78use HTFeed::DBTools qw( get_dbh) ;
89use HTFeed::Volume;
9- use Carp;
10+
11+ use Carp ();
12+ use File::Spec ();
13+ use File::Temp ();
1014use Log::Log4perl qw( get_logger) ;
11- use File::Temp;
15+ use YAML::XS ();
16+
17+ my $select_expired_sql = <<~'SQL' ;
18+ SELECT namespace,id
19+ FROM feed_backups
20+ WHERE deleted IS NULL
21+ AND storage_name= ?
22+ AND version < DATE_FORMAT(DATE_SUB(NOW(), INTERVAL 180 DAY)," %Y%m%d%H%i%S" )
23+ GROUP BY namespace,id
24+ HAVING COUNT (* ) > 1
25+ SQL
26+
27+ my $select_versions_sql = <<~'SQL' ;
28+ SELECT version
29+ FROM feed_backups
30+ WHERE deleted IS NULL
31+ AND storage_name= ?
32+ AND namespace= ?
33+ AND id= ?
34+ AND version < DATE_FORMAT(DATE_SUB(NOW(), INTERVAL 180 DAY)," %Y%m%d%H%i%S" )
35+ ORDER BY version DESC
36+ SQL
1237
13- use HTFeed::Storage::PrefixedVersions;
14- use HTFeed::Storage::ObjectStore;
1538
1639sub new {
1740 my $class = shift ;
1841
1942 my $self = {
2043 storage_name => undef ,
44+ custom_storage_config => 0,
45+ max_workers => 8,
46+ job_size => 10000,
47+ limit => undef ,
2148 @_
2249 };
2350
2451 unless ($self -> {storage_name }) {
25- croak " $class cannot be constructed without a storage name" ;
52+ Carp::croak " $class cannot be constructed without a storage name" ;
53+ }
54+
55+ # Test can init with `storage_config` because it is transient and must be known to workers.
56+ # Production just reads the config as normal
57+ if ($self -> {storage_config }) {
58+ $self -> {custom_storage_config } = 1;
59+ } else {
60+ my $config = get_config(' storage_classes' );
61+ my $storage_config = $config -> {$self -> {storage_name }};
62+ die (" Can't find storage configuration for " . $self -> {storage_name }) unless $storage_config ;
63+ $self -> {storage_config } = $storage_config ;
2664 }
2765
66+ $self -> {temp_directory } = File::Temp-> newdir;
67+ $self -> {workers } = {};
68+
2869 bless ($self , $class );
2970 return $self ;
3071}
3172
3273sub run {
3374 my $self = shift ;
3475
35- my $dry_run = $self -> {dry_run };
36- my $dry_run_text = " " ;
37- $dry_run_text = " (DRY RUN)" if $dry_run ;
38-
39- my $config = get_config(' storage_classes' );
40- my $storage_config = $config -> {$self -> {storage_name }};
41- die (" Can't find storage configuration for " . $self -> {storage_name }) unless $storage_config ;
42-
43- # find everything with more than one version that is at least 6 months old
44- # delete all but the most recent > 6 months old version
45- my $sth = get_dbh()-> prepare(<<'SQL' );
46- SELECT namespace,id
47- FROM feed_backups
48- WHERE deleted IS NULL
49- AND storage_name= ?
50- AND version < DATE_FORMAT(DATE_SUB(NOW(), INTERVAL 180 DAY)," %Y%m%d%H%i%S" )
51- GROUP BY namespace,id
52- HAVING COUNT (* ) > 1
53- SQL
54-
55- my $versions_sth = get_dbh()-> prepare(<<'SQL' );
56- SELECT version
57- FROM feed_backups
58- WHERE deleted IS NULL
59- AND storage_name= ?
60- AND namespace= ?
61- AND id= ?
62- AND version < DATE_FORMAT(DATE_SUB(NOW(), INTERVAL 180 DAY)," %Y%m%d%H%i%S" )
63- ORDER BY version DESC
64- SQL
76+ # Write storage config to the temp directory for child processes to get at it.
77+ # Unnecessary for production, needed for testing because it is generated as part
78+ # of the test suite.
79+ if ($self -> {custom_storage_config }) {
80+ $self -> {storage_config_file } = File::Spec-> catfile($self -> {temp_directory }, ' storage_config.yml' );
81+ my $yaml = YAML::XS::Dump($self -> {storage_config });
82+ open (my $fh , ' >' , $self -> {storage_config_file }) or die " Could not open storage config YAML $! " ;
83+ print $fh $yaml ;
84+ close $fh ;
85+ }
6586
66- my $update_sth = get_dbh()-> prepare(<<'SQL' );
67- UPDATE feed_backups SET deleted= 1
68- WHERE namespace= ?
69- AND id= ?
70- AND version= ?
71- AND storage_name= ?
72- SQL
87+ my $sth = get_dbh()-> prepare($self -> select_expired_sql);
88+ my $versions_sth = get_dbh()-> prepare($select_versions_sql );
7389
90+ my $job = [];
91+ # Iterate over the entirety of feed_backups
92+ # Reaching the end and restarting the query must take place at a
93+ # higher level, perhaps with $self->run called repeatedly.
7494 $sth -> execute($self -> {storage_name });
7595 while (my $row = $sth -> fetchrow_hashref) {
7696 $versions_sth -> execute($self -> {storage_name }, $row -> {namespace }, $row -> {id });
7797 my @versions = map { $_ -> [0]; } @{$versions_sth -> fetchall_arrayref};
7898 shift @versions ; # jettison the most recent
7999 foreach my $version (@versions ) {
80- my $volume = new HTFeed::Volume(namespace => $row -> {namespace },
81- objid => $row -> {id },
82- package_type => ' ht' );
83- my $storage = $storage_config -> {class }-> new(volume => $volume ,
84- config => $storage_config ,
85- name => $self -> {storage_name });
86- unless (defined $storage ) {
87- die " Unable to get storage for $volume ->{namespace}.$volume ->{objid}" ;
100+ push (@$job , [$row -> {namespace }, $row -> {id }, $version ]);
101+ # Do we have enough to spawn a worker?
102+ if (scalar @$job >= $self -> {job_size }) {
103+ $self -> wait_for_available_worker;
104+ $self -> spawn_worker($job );
105+ $job = [];
88106 }
89- $storage -> {timestamp } = $version ;
90- $storage -> {zip_suffix } = ' .gpg' ;
91- get_logger-> trace(" deleting archive for $volume ->{namespace}.$volume ->{objid} version $version " . $dry_run_text );
92- next if $dry_run ;
93- unless ($storage -> delete_objects) {
94- die " Unable to delete $volume ->{namespace}.$volume ->{objid}" ;
107+ }
108+ }
109+ # Submit the leftovers if any
110+ if (scalar @$job > 0) {
111+ $self -> wait_for_available_worker;
112+ $self -> spawn_worker($job );
113+ $job = [];
114+ }
115+ # Set max workers to 0 so we wait for all of them to finish.
116+ $self -> {max_workers } = 0;
117+ # Wait for all the workers to finish.
118+ while (scalar keys %{$self -> {workers }} > 0) {
119+ $self -> wait_for_available_worker;
120+ }
121+ }
122+
123+ # waitpid on existing workers (if any) until one finishes up
124+ # but only if we are at maximum capacity.
125+ # Only waits for workers to finish if we already have the maximum number on the go,
126+ # or if we are finished and have set the maximum to 0.
127+ sub wait_for_available_worker {
128+ my $self = shift ;
129+
130+ if (scalar keys %{$self -> {workers }} >= $self -> {max_workers }) {
131+ my $pid = 0;
132+ do {
133+ # Wait for any worker. This blocks indefinitely but there's nothing else
134+ # for this process to do but wait.
135+ $pid = waitpid (-1, 0);
136+ if ($pid > 0) {
137+ my $job_file = $self -> {workers }-> {$pid };
138+ get_logger-> trace(" worker [$pid ] exited with status $? - removing $job_file " );
139+ unlink $job_file -> filename;
140+ delete $self -> {workers }-> {$pid };
95141 }
96- get_logger-> trace(" setting deleted=1 for $volume ->{namespace}.$volume ->{objid} version $version " );
97- $update_sth -> execute($row -> {namespace }, $row -> {id },
98- $version , $self -> {storage_name });
142+ } while ($pid > 0);
143+ }
144+ }
145+
146+ sub spawn_worker {
147+ my $self = shift ;
148+ my $job = shift ;
149+
150+ my $job_file = File::Temp-> new(
151+ DIR => $self -> {temp_directory },
152+ SUFFIX => ' .tsv' ,
153+ CLEANUP => 0
154+ );
155+ foreach my $version (@$job ) {
156+ print $job_file join (" \t " , @$version ) . " \n " ;
157+ }
158+ $job_file -> close ;
159+ my $pid = fork ();
160+ if (!defined $pid ) {
161+ die " Fork failed: $! " ;
162+ } elsif ($pid == 0) {
163+ # WORKER PROCESS
164+ my $worker_script = File::Spec-> catfile($ENV {FEED_HOME }, ' bin' , ' expire_versions.pl' );
165+ my @cmd = (' perl' , $worker_script , ' -s' , $self -> {storage_name });
166+ if ($self -> {custom_storage_config }) {
167+ push @cmd , ' --config' , $self -> {storage_config_file };
168+ }
169+ if ($self -> {dry_run }) {
170+ push @cmd , ' --dry-run' ;
99171 }
172+ push @cmd , $job_file -> filename;
173+ exec (@cmd ) or die " worker [$$ ] exec failed to run: $! \n " ;
174+ } else {
175+ # PARENT PROCESS
176+ get_logger-> trace(" worker [$pid ] started with $job_file (" . scalar (@$job ) . " items)" );
177+ $self -> {workers }-> {$pid } = $job_file ;
100178 }
101179}
102180
181+ sub select_expired_sql {
182+ my $self = shift ;
183+
184+ my $limit_clause = (defined $self -> {limit }) ? " LIMIT $self ->{limit}" : ' ' ;
185+ return $select_expired_sql . $limit_clause ;
186+ }
187+
1031881;
104189
105190__END__
0 commit comments