File Coverage

lib/VM/EC2/Staging/Manager.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package VM::EC2::Staging::Manager;
2              
3             =head1 NAME
4              
5             VM::EC2::Staging::Manager - Automate VMs and volumes for moving data in and out of cloud.
6              
7             =head1 SYNOPSIS
8              
9             use VM::EC2::Staging::Manager;
10              
11             my $ec2 = VM::EC2->new(-region=>'us-east-1');
12             my $staging = $ec2->staging_manager(-on_exit => 'stop', # default, stop servers when process exists
13             -verbose => 1, # default, verbose progress messages
14             -scan => 1, # default, scan region for existing staging servers and volumes
15             -image_name => 'ubuntu-precise-12.04', # default server image
16             -user_name => 'ubuntu', # default server login name
17             );
18              
19             # Assuming an EBS image named ami-12345 is located in the US, copy it into
20             # the South American region, returning the AMI ID in South America
21             my $new_image = $staging->copy_image('ami-12345','sa-east-1');
22              
23             # provision a new server, using defaults. Name will be assigned automatically
24             my $server = $staging->provision_server(-availability_zone => 'us-east-1a');
25              
26             # retrieve a new server named "my_server", if one exists. If not, it creates one
27             # using the specified options
28             my $server = $staging->get_server(-name => 'my_server',
29             -availability_zone => 'us-east-1a',
30             -instance_type => 't1.micro');
31              
32             # open up an ssh session in an xterm
33             $server->shell;
34              
35             # run a command over ssh on the server. See VM::EC2::Staging::Server
36             $server->ssh('whoami');
37              
38             # run a command over ssh on the server, returning the result as an array of lines or a
39             # scalar string, similar to backticks (``)
40             my @password_lines = $server->scmd('cat /etc/passwd');
41              
42             # run a command on the server and read from it using a filehandle
43             my $fh = $server->scmd_read('ls -R /usr/lib');
44             while (<$fh>) { # do something }
45              
46             # run a command on the server and write to it using a filehandle
47             my $fh = $server->scmd_write('sudo -s "cat >>/etc/fstab"');
48             print $fh "/dev/sdf3 /mnt/demo ext3 0 2\n";
49             close $fh;
50              
51             # Provision a new volume named "Pictures". Will automatically be mounted to a staging server in
52             # the specified zone. Server will be created if needed.
53             my $volume = $staging->provision_volume(-name => 'Pictures',
54             -fstype => 'ext4',
55             -availability_zone => 'us-east-1a',
56             -size => 2) or die $staging->error_str;
57              
58             # gets an existing volume named "Pictures" if it exists. Otherwise provisions a new volume;
59             my $volume = $staging->get_volume(-name => 'Pictures',
60             -fstype => 'ext4',
61             -availability_zone => 'us-east-1a',
62             -size => 2) or die $staging->error_str;
63              
64             # copy contents of local directory /opt/test to remote volume $volume using rsync
65             # See VM::EC2::Staging::Volume
66             $volume->put('/opt/test/');
67              
68             # same thing, but first creating a subdirectory on the remote volume
69             $volume->put('/opt/test/' => './mirrors/');
70              
71             # copy contents of remote volume $volume to local directory /tmp/test using rsync
72             $volume->get('/tmp/test');
73              
74             # same thing, but from a subdirectory of the remote volume
75             $volume->get('./mirrors/' => '/tmp/test');
76              
77             # server to server transfer (works both within and between availability regions)
78             my $south_america = VM::EC2->new(-region=>'sa-east-1')->staging_manager; # create a staging manager in Sao Paolo
79             my $volume2 = $south_america->provision_volume(-name => 'Videos',
80             -availability_zone => 'sa-east-1a',
81             -size => 2);
82             $staging->rsync("$volume/mirrors" => "$volume2/us-east");
83              
84             $staging->stop_all_servers();
85             $staging->start_all_servers();
86             $staging->terminate_all_servers();
87             $staging->force_terminate_all_servers();
88              
89             =head1 DESCRIPTION
90              
91             VM::EC2::Staging::Manager manages a set of EC2 volumes and servers
92             in a single AWS region. It was primarily designed to simplify the
93             process of provisioning and populating volumes, but it also provides a
94             handy set of ssh commands that allow you to run remote commands
95             programmatically.
96              
97             The manager also allows you to copy EBS-backed AMIs and their attached
98             volumes from one region to another, something that is otherwise
99             difficult to do.
100              
101             The main classes are:
102              
103             VM::EC2::Staging::Manager -- A set of volume and server resources in
104             a single AWS region.
105              
106             VM::EC2::Staging::Server -- A staging server running somewhere in the
107             region. It is a VM::EC2::Instance
108             extended to provide remote command and
109             copy facilities.
110              
111             VM::EC2::Staging::Volume -- A staging disk volume running somewhere in the
112             region. It is a VM::EC2::Volume
113             extended to provide remote copy
114             facilities.
115              
116             Staging servers can provision volumes, format them, mount them, copy
117             data between local and remote (virtual) machines, and execute secure
118             shell commands. Staging volumes can mount themselves on servers, run a
119             variety of filesystem-oriented commands, and invoke commands on the
120             servers to copy data around locally and remotely.
121              
122             See L and L for
123             the full details.
124              
125             =head1 Constructors
126              
127             The following methods allow you to create new
128             VM::EC2::Staging::Manager instances. Be aware that only one manager is
129             allowed per EC2 region; attempting to create additional managers in
130             the same region will return the same one each time.
131              
132             =cut
133              
134 1     1   2243 use strict;
  1         3  
  1         83  
135 1     1   2815 use VM::EC2 ':standard';
  0            
  0            
136             use Carp 'croak','longmess';
137             use File::Spec;
138             use File::Path 'make_path','remove_tree';
139             use File::Basename 'dirname','basename';
140             use Scalar::Util 'weaken';
141             use String::Approx 'adistr';
142             use File::Temp 'tempfile';
143              
144             use constant GB => 1_073_741_824;
145             use constant SERVER_STARTUP_TIMEOUT => 120;
146             use constant LOCK_TIMEOUT => 10;
147             use constant VERBOSE_DEBUG => 3;
148             use constant VERBOSE_INFO => 2;
149             use constant VERBOSE_WARN => 1;
150              
151             my (%Zones,%Instances,%Volumes,%Managers);
152             my $Verbose;
153             my ($LastHost,$LastMt);
154              
155             =head2 $manager = $ec2->staging_manager(@args)
156              
157             This is a simplified way to create a staging manager. First create the
158             EC2 object in the desired region, and then call its staging_manager()
159             method:
160              
161             $manager = VM::EC2->new(-region=>'us-west-2')->staging_manager()
162              
163             The staging_manager() method is only known to VM::EC2 objects if you
164             first "use" VM::EC2::Staging::Manager.
165              
166             =over 4
167              
168             =item Required Arguments
169              
170             None.
171              
172             =item Optional Arguments
173              
174             The optional arguments change the way that the manager creates new
175             servers and volumes.
176              
177             -on_exit What to do with running servers when the manager goes
178             out of scope or the script exits. One of 'run',
179             'stop' (default), or 'terminate'. "run" keeps all
180             created instances running, so beware!
181              
182             -architecture Architecture for newly-created server
183             instances (default "i386"). Can be overridden in calls to get_server()
184             and provision_server().
185              
186             -instance_type Type of newly-created servers (default "m1.small"). Can be overridden
187             in calls to get_server() and provision_server().
188              
189             -root_type Root type for newly-created servers (default depends
190             on the -on_exit behavior; "ebs" for exit behavior of
191             "stop" and "instance-store" for exit behavior of "run"
192             or "terminate".
193              
194             -image_name Name or ami ID of the AMI to use for creating the
195             instances of new servers. Defaults to 'ubuntu-precise-12.04'.
196             If the image name begins with "ami-", then it is
197             treated as an AMI ID. Otherwise it is treated as
198             a name pattern and will be used to search the AMI
199             name field using the wildcard search "*$name*".
200             Names work better than AMI ids here, because the
201             latter change from one region to another. If multiple
202             matching image candidates are found, then an alpha
203             sort on the name is used to find the image with the
204             highest alpha sort value, which happens to work with
205             Ubuntu images to find the latest release.
206              
207             -availability_zone Availability zone for newly-created
208             servers. Default is undef, in which case a random
209             zone is selected.
210              
211             -username Username to use for ssh connections. Defaults to
212             "ubuntu". Note that this user must be able to use
213             sudo on the instance without providing a password,
214             or functionality of this module will be limited.
215            
216             -verbose Integer level of verbosity. Level 1 prints warning
217             messages. Level 2 (the default) adds informational
218             messages as well. Level 3 adds verbose debugging
219             messages. Level 0 suppresses all messages.
220              
221             -quiet (deprecated) If true, turns off all verbose messages.
222              
223             -scan Boolean, default true. If true, scans region for
224             volumes and servers created by earlier manager
225             instances.
226              
227             -reuse_key Boolean, default true. If true, creates a single
228             ssh keypair for each region and reuses it. Note that
229             the private key is kept on the local computer in the
230             directory ~/.vm-ec2-staging, and so additional
231             keypairs may be created if you use this module on
232             multiple local machines. If this option is false,
233             then a new keypair will be created for every server
234             you partition.
235              
236             -reuse_volumes Boolean, default true. If this flag is true, then
237             calls to provision_volume() will return existing
238             volumes if they share the same name as the requested
239             volume. If no suitable existing volume exists, then
240             the most recent snapshot of this volume is used to
241             create it in the specified availability zone. Only
242             if no volume or snapshot exist will a new volume be
243             created from scratch.
244              
245             -dotdir Path to the directory that contains keyfiles and other
246             stable configuration information for this module.
247             Defaults to ~/.vm_ec2_staging. You may wish to change
248             this to, say, a private dropbox directory or an NFS-mount
249             in order to share keyfiles among machines. Be aware of
250             the security implications of sharing private key files.
251              
252             -server_class By default, staging server objects created by the manager
253             are of class type VM::EC2::Staging::Server. If you create
254             a custom server subclass, you need to let the manager know
255             about it by passing the class name to this argument.
256              
257             -volume_class By default, staging volume objects created by the manager
258             are of class type VM::EC2::Staging::Volume. If you create
259             a custom volume subclass, you need to let the manager know
260             about it by passing the class name to this argument.
261              
262             =back
263              
264             =head2 $manager = VM::EC2::Staging::Manager(-ec2 => $ec2,@args)
265              
266             This is a more traditional constructur for the staging manager.
267              
268             =over 4
269              
270             =item Required Arguments
271            
272             -ec2 A VM::EC2 object.
273              
274             =item Optional Arguments
275              
276             All of the arguments listed in the description of
277             VM::EC2->staging_manager().
278              
279             =back
280              
281             =cut
282              
283             sub VM::EC2::staging_manager {
284             my $self = shift;
285             return VM::EC2::Staging::Manager->new(@_,-ec2=>$self)
286             }
287              
288              
289             sub new {
290             my $self = shift;
291             my %args = @_;
292             $args{-ec2} ||= VM::EC2->new();
293              
294             if (my $manager = $self->find_manager($args{-ec2}->endpoint)) {
295             return $manager;
296             }
297              
298             $args{-on_exit} ||= $self->default_exit_behavior;
299             $args{-reuse_key} ||= $self->default_reuse_keys;
300             $args{-username} ||= $self->default_user_name;
301             $args{-architecture} ||= $self->default_architecture;
302             $args{-root_type} ||= $self->default_root_type;
303             $args{-instance_type} ||= $self->default_instance_type;
304             $args{-reuse_volumes} ||= $self->default_reuse_volumes;
305             $args{-image_name} ||= $self->default_image_name;
306             $args{-availability_zone} ||= undef;
307             $args{-verbose} = $self->default_verbosity unless exists $args{-verbose};
308             $args{-scan} = 1 unless exists $args{-scan};
309             $args{-pid} = $$;
310             $args{-dotdir} ||= $self->default_dot_directory_path;
311             $args{-volume_class} ||= $self->default_volume_class;
312             $args{-server_class} ||= $self->default_server_class;
313              
314             $args{-verbose} = 0 if $args{-quiet};
315              
316             # bring in classes
317             foreach ('-server_class','-volume_class') {
318             eval "use $args{$_};1" or croak "Can't use $args{$_}"
319             unless $args{$_}->can('new');
320             }
321              
322             # create accessors
323             my $class = ref $self || $self;
324             foreach (keys %args) {
325             (my $func_name = $_) =~ s/^-//;
326             next if $self->can($func_name);
327             eval <
328             sub ${class}::${func_name} {
329             my \$self = shift;
330             my \$d = \$self->{$_};
331             \$self->{$_} = shift if \@_;
332             return \$d;
333             }
334             END
335             die $@ if $@;
336             }
337              
338             $Verbose = $args{-verbose}; # package global, for a few edge cases
339             my $obj = bless \%args,ref $class || $class;
340             weaken($Managers{$obj->ec2->endpoint} = $obj);
341             if ($args{-scan}) {
342             $obj->info("Scanning for existing staging servers and volumes in ",$obj->ec2->endpoint,".\n");
343             $obj->scan_region;
344             }
345             return $obj;
346             }
347              
348              
349             # class method
350             # the point of this somewhat odd way of storing managers is to ensure that there is only one
351             # manager per endpoint, and to avoid circular references in the Server and Volume objects.
352             sub find_manager {
353             my $class = shift;
354             my $endpoint = shift;
355             return unless $endpoint;
356             return $Managers{$endpoint};
357             }
358              
359             =head1 Interzone Copying of AMIs and Snapshots
360              
361             This library provides convenience methods for copying whole AMIs as
362             well as individual snapshots from one zone to another. It does this by
363             gathering information about the AMI/snapshot in the source zone,
364             creating staging servers in the source and target zones, and then
365             copying the volume data from the source to the target. If an
366             AMI/snapshot does not use a recognized filesystem (e.g. it is part of
367             an LVM or RAID disk set), then block level copying of the entire
368             device is used. Otherwise, rsync() is used to minimize data transfer
369             fees.
370              
371             Note that interzone copying of instance-backed AMIs is B
372             supported. Only EBS-backed images can be copied in this way.
373              
374             See also the command-line script migrate-ebs-image.pl that comes with
375             this package.
376              
377             =head2 $new_image_id = $manager->copy_image($source_image,$destination_zone,@register_options)
378              
379             This method copies the AMI indicated by $source_image from the zone
380             that $manager belongs to, into the indicated $destination_zone, and
381             returns the AMI ID of the new image in the destination zone.
382              
383             $source_image may be an AMI ID, or a VM::EC2::Image object.
384              
385             $destination_zone may be a simple region name, such as "us-west-2", or
386             a VM::EC2::Region object (as returned by VM::EC2->describe_regions),
387             or a VM::EC2::Staging::Manager object that is associated with the
388             desired region. The latter form gives you control over the nature of
389             the staging instances created in the destination zone. For example, if
390             you wish to use 'm1.large' high-I/O instances in both the source and
391             destination reasons, you would proceed like this:
392              
393             my $source = VM::EC2->new(-region=>'us-east-1'
394             )->staging_manager(-instance_type=>'m1.large',
395             -on_exit =>'terminate');
396             my $destination = VM::EC2->new(-region=>'us-west-2'
397             )->staging_manager(-instance_type=>'m1.large',
398             -on_exit =>'terminate');
399             my $new_image = $source->copy_image('ami-123456' => $destination);
400              
401             If present, the named argument list @register_options will be passed
402             to register_image() and used to override options in the destination
403             image. This can be used to set ephemeral device mappings, which cannot
404             currently be detected and transferred automatically by copy_image():
405              
406             $new_image =$source->copy_image('ami-123456' => 'us-west-2',
407             -description => 'My AMI western style',
408             -block_devices => '/dev/sde=ephemeral0');
409              
410             =head2 $dest_kernel = $manager->match_kernel($src_kernel,$dest_zone)
411              
412             Find a kernel in $dest_zone that matches the $src_kernel in the
413             current zone. $dest_zone can be a VM::EC2::Staging manager object, a
414             region name, or a VM::EC2::Region object.
415              
416             =cut
417              
418             #############################################
419             # copying AMIs from one zone to another
420             #############################################
421             sub copy_image {
422             my $self = shift;
423             my ($imageId,$destination,@options) = @_;
424             my $ec2 = $self->ec2;
425              
426             my $image = ref $imageId && $imageId->isa('VM::EC2::Image') ? $imageId
427             : $ec2->describe_images($imageId);
428             $image
429             or croak "Unknown image '$imageId'";
430             $image->imageType eq 'machine'
431             or croak "$image is not an AMI";
432             # $image->platform eq 'windows'
433             # and croak "It is not currently possible to migrate Windows images between regions via this method";
434             $image->rootDeviceType eq 'ebs'
435             or croak "It is not currently possible to migrate instance-store backed images between regions via this method";
436            
437             my $dest_manager = $self->_parse_destination($destination);
438              
439             my $root_type = $image->rootDeviceType;
440             if ($root_type eq 'ebs') {
441             return $self->_copy_ebs_image($image,$dest_manager,\@options);
442             } else {
443             return $self->_copy_instance_image($image,$dest_manager,\@options);
444             }
445             }
446              
447             =head2 $new_snapshot_id = $manager->copy_snapshot($source_snapshot,$destination_zone)
448              
449             This method copies the EBS snapshot indicated by $source_snapshot from
450             the zone that $manager belongs to, into the indicated
451             $destination_zone, and returns the ID of the new snapshot in the
452             destination zone.
453              
454             $source_snapshot may be an string ID, or a VM::EC2::Snapshot object.
455              
456             $destination_zone may be a simple region name, such as "us-west-2", or
457             a VM::EC2::Region object (as returned by VM::EC2->describe_regions),
458             or a VM::EC2::Staging::Manager object that is associated with the
459             desired region.
460              
461             Note that this call uses the Amazon CopySnapshot API call that was
462             introduced in 2012-12-01 and no longer involves the creation of
463             staging servers in the source and destination regions.
464              
465             =cut
466              
467             sub copy_snapshot {
468             my $self = shift;
469             my ($snapId,$dest_manager) = @_;
470             my $snap = $self->ec2->describe_snapshots($snapId)
471             or croak "Couldn't find snapshot for $snapId";
472             my $description = "duplicate of $snap, created by ".__PACKAGE__." during snapshot copying";
473             my $dest_region = ref($dest_manager) && $dest_manager->can('ec2')
474             ? $dest_manager->ec2->region
475             : "$dest_manager";
476              
477             $self->info("Copying snapshot $snap from ",$self->ec2->region," to $dest_region...\n");
478             my $snapshot = $snap->copy(-region => $dest_region,
479             -description => $description);
480              
481             while (!eval{$snapshot->current_status}) {
482             sleep 1;
483             }
484             $self->info("...new snapshot = $snapshot; status = ",$snapshot->current_status,"\n");
485              
486             # copy snapshot tags
487             my $tags = $snap->tags;
488             $snapshot->add_tags($tags);
489              
490             return $snapshot;
491             }
492              
493             sub _copy_instance_image {
494             my $self = shift;
495             croak "This module is currently unable to copy instance-backed AMIs between regions.\n";
496             }
497              
498             sub _copy_ebs_image {
499             my $self = shift;
500             my ($image,$dest_manager,$options) = @_;
501              
502             # apply overrides
503             my %overrides = @$options if $options;
504              
505             # hashref with keys 'name', 'description','architecture','kernel','ramdisk','block_devices','root_device'
506             # 'is_public','authorized_users'
507             $self->info("Gathering information about image $image.\n");
508             my $info = $self->_gather_image_info($image);
509              
510             my $name = $info->{name};
511             my $description = $info->{description};
512             my $architecture = $info->{architecture};
513             my $root_device = $info->{root_device};
514             my $platform = $info->{platform};
515             my ($kernel,$ramdisk);
516              
517             # make sure we have a suitable image in the destination region
518             # if the virtualization type is HVM
519             my $is_hvm = $image->virtualization_type eq 'hvm';
520             if ($is_hvm) {
521             $self->_find_hvm_image($dest_manager->ec2,
522             $root_device,
523             $architecture,
524             $platform)
525             or croak "Destination region ",$dest_manager->ec2->region," does not currently support HVM images of this type";
526             }
527              
528             if ($info->{kernel} && !$overrides{-kernel}) {
529             $self->info("Searching for a suitable kernel in the destination region.\n");
530             $kernel = $self->_match_kernel($info->{kernel},$dest_manager,'kernel')
531             or croak "Could not find an equivalent kernel for $info->{kernel} in region ",$dest_manager->ec2->endpoint;
532             $self->info("Matched kernel $kernel\n");
533             }
534            
535             if ($info->{ramdisk} && !$overrides{-ramdisk}) {
536             $self->info("Searching for a suitable ramdisk in the destination region.\n");
537             $ramdisk = ( $self->_match_kernel($info->{ramdisk},$dest_manager,'ramdisk')
538             || $dest_manager->_guess_ramdisk($kernel)
539             ) or croak "Could not find an equivalent ramdisk for $info->{ramdisk} in region ",$dest_manager->ec2->endpoint;
540             $self->info("Matched ramdisk $ramdisk\n");
541             }
542              
543             my $block_devices = $info->{block_devices}; # format same as $image->blockDeviceMapping
544              
545             $self->info("Copying EBS volumes attached to this image (this may take a long time).\n");
546             my @bd = @$block_devices;
547             my %dest_snapshots = map {
548             $_->snapshotId
549             ? ($_->snapshotId => $self->copy_snapshot($_->snapshotId,$dest_manager))
550             : ()
551             } @bd;
552            
553             $self->info("Waiting for all snapshots to complete. This may take a long time.\n");
554             my $state = $dest_manager->ec2->wait_for_snapshots(values %dest_snapshots);
555             my @errored = grep {$state->{$_} eq 'error'} values %dest_snapshots;
556             croak ("Snapshot(s) @errored could not be completed due to an error")
557             if @errored;
558              
559             # create the new block device mapping
560             my @mappings;
561             for my $source_ebs (@$block_devices) {
562             my $dest = "$source_ebs"; # interpolates into correct format
563             $dest =~ s/=([\w-]+)/'='.($dest_snapshots{$1}||$1)/e; # replace source snap with dest snap
564             push @mappings,$dest;
565             }
566              
567             # ensure choose a unique name
568             if ($dest_manager->ec2->describe_images({name => $name})) {
569             print STDERR "An image named '$name' already exists in destination region. ";
570             $name = $self->_token($name);
571             print STDERR "Renamed to '$name'\n";
572             }
573              
574             # merge block device mappings if present
575             if (my $m = $overrides{-block_device_mapping}||$overrides{-block_devices}) {
576             push @mappings,(ref $m ? @$m : $m);
577             delete $overrides{-block_device_mapping};
578             delete $overrides{-block_devices};
579             }
580              
581             # helpful for recovering failed process
582             my $block_device_info_args = join ' ',map {"-b $_"} @mappings;
583              
584             my $img;
585              
586             if ($is_hvm) {
587             $self->info("Registering snapshot in destination with the equivalent of:\n");
588             $self->info("ec2-register -n '$name' -d '$description' -a $architecture --virtualization-type hvm --root-device-name $root_device $block_device_info_args\n");
589             $self->info("Note: this is a notional command line that can only be used by AWS development partners.\n");
590             $img = $self->_create_hvm_image(-ec2 => $dest_manager->ec2,
591             -name => $name,
592             -root_device_name => $root_device,
593             -block_device_mapping => \@mappings,
594             -description => $description,
595             -architecture => $architecture,
596             -platform => $image->platform,
597             %overrides);
598             }
599              
600             else {
601             $self->info("Registering snapshot in destination with the equivalent of:\n");
602             $self->info("ec2-register -n '$name' -d '$description' -a $architecture --kernel '$kernel' --ramdisk '$ramdisk' --root-device-name $root_device $block_device_info_args\n");
603             $img = $dest_manager->ec2->register_image(-name => $name,
604             -root_device_name => $root_device,
605             -block_device_mapping => \@mappings,
606             -description => $description,
607             -architecture => $architecture,
608             $kernel ? (-kernel_id => $kernel): (),
609             $ramdisk ? (-ramdisk_id => $ramdisk): (),
610             %overrides,
611             );
612             $img or croak "Could not register image: ",$dest_manager->ec2->error_str;
613             }
614            
615             # copy launch permissions
616             $img->make_public(1) if $info->{is_public};
617             $img->add_authorized_users(@{$info->{authorized_users}}) if @{$info->{authorized_users}};
618            
619             # copy tags
620             my $tags = $image->tags;
621             $img->add_tags($tags);
622              
623             # Improve the snapshot tags
624             my $source_region = $self->ec2->region;
625             my $dest_region = $dest_manager->ec2->region;
626             for (@mappings) {
627             my ($snap) = /(snap-[0=9a-f]+)/ or next;
628             $snap = $dest_manager->ec2->describe_snapshots($snap) or next;
629             $snap->add_tags(Name => "Copy image $image($source_region) to $img($dest_region)");
630             }
631              
632             return $img;
633             }
634              
635             # copying an HVM image requires us to:
636             # 1. Copy each of the snapshots to the destination region
637             # 2. Find a public HVM image in the destination region that matches the architecture, hypervisor type,
638             # and root device type of the source image. (note: platform must not be 'windows'
639             # 3. Run a cc2 instance: "cc2.8xlarge", but replace default block device mapping with the new snapshots.
640             # 4. Stop the image.
641             # 5. Detach the root volume
642             # 6. Initialize and attach a new root volume from the copied source root snapshot.
643             # 7. Run create_image() on the instance.
644             # 8. Terminate the instance and clean up.
645             sub _create_hvm_image {
646             my $self = shift;
647             my %args = @_;
648              
649             my $ec2 = $args{-ec2};
650              
651             # find a suitable image that we can run
652             $self->info("Searching for a suitable HVM image in destination region\n");
653             my $ami = $self->_find_hvm_image($ec2,$args{-root_device_name},$args{-architecture},$args{-platform});
654             $ami or croak "Could not find suitable HVM image in region ",$ec2->region;
655              
656             $self->info("...Found $ami (",$ami->name,")\n");
657              
658             # remove root device from the block device list
659             my $root = $args{-root_device_name};
660             my @nonroot_devices = grep {!/^$root/} @{$args{-block_device_mapping}};
661             my ($root_snapshot) = "@{$args{-block_device_mapping}}" =~ /$root=(snap-[0-9a-f]+)/;
662            
663             my $instance_type = $args{-platform} eq 'windows' ? 'm1.small' : 'cc2.8xlarge';
664             $self->info("Launching an HVM staging server in the target region. Heuristically choosing instance type of '$instance_type' for this type of HVM..\n");
665              
666             my $instance = $ec2->run_instances(-instance_type => $instance_type,
667             -image_id => $ami,
668             -block_devices => \@nonroot_devices)
669             or croak "Could not run HVM instance: ",$ec2->error_str;
670             $self->info("Waiting for instance to become ready.\n");
671             $ec2->wait_for_instances($instance);
672            
673             $self->info("Stopping instance temporarily to swap root volumes.\n");
674             $instance->stop(1);
675              
676             $self->info("Detaching original root volume...\n");
677             my $a = $instance->detach_volume($root) or croak "Could not detach $root: ", $ec2->error_str;
678             $ec2->wait_for_attachments($a);
679             $a->current_status eq 'detached' or croak "Could not detach $root, status = ",$a->current_status;
680             $ec2->delete_volume($a->volumeId) or croak "Could not delete original root volume: ",$ec2->error_str;
681              
682             $self->info("Creating and attaching new root volume..\n");
683             my $vol = $ec2->create_volume(-availability_zone => $instance->placement,
684             -snapshot_id => $root_snapshot)
685             or croak "Could not create volume from root snapshot $root_snapshot: ",$ec2->error_str;
686             $ec2->wait_for_volumes($vol);
687             $vol->current_status eq 'available' or croak "Volume creation failed, status = ",$vol->current_status;
688              
689             $a = $instance->attach_volume($vol,$root) or croak "Could not attach new root volume: ",$ec2->error_str;
690             $ec2->wait_for_attachments($a);
691             $a->current_status eq 'attached' or croak "Attach failed, status = ",$a->current_status;
692             $a->deleteOnTermination(1);
693              
694             $self->info("Creating image in destination region...\n");
695             my $img = $instance->create_image($args{-name},$args{-description});
696              
697             # get rid of the original copied snapshots - we no longer need them
698             foreach (@{$args{-block_device_mapping}}) {
699             my ($snapshot) = /(snap-[0-9a-f]+)/ or next;
700             $ec2->delete_snapshot($snapshot)
701             or $self->warn("Could not delete unneeded snapshot $snapshot; please delete manually: ",$ec2->error_str)
702             }
703              
704             # terminate the staging server.
705             $self->info("Terminating the staging server\n");
706             $instance->terminate; # this will delete the volume as well because of deleteOnTermination
707              
708             return $img;
709             }
710              
711             sub _find_hvm_image {
712             my $self = shift;
713             my ($ec2,$root_device_name,$architecture,$platform) = @_;
714              
715             my $cache_key = join (';',@_);
716             return $self->{_hvm_image}{$cache_key} if exists $self->{_hvm_image}{$cache_key};
717              
718             my @i = $ec2->describe_images(-executable_by=> 'all',
719             -owner => 'amazon',
720             -filter => {
721             'virtualization-type' => 'hvm',
722             'root-device-type' => 'ebs',
723             'root-device-name' => $root_device_name,
724             'architecture' => $architecture,
725             });
726             @i = grep {$_->platform eq $platform} @i;
727             return $self->{_hvm_image}{$cache_key} = $i[0];
728             }
729              
730              
731             =head1 Instance Methods for Managing Staging Servers
732              
733             These methods allow you to create and interrogate staging
734             servers. They each return one or more VM::EC2::Staging::Server
735             objects. See L for more information about
736             what you can do with these servers once they are running.
737              
738             =head2 $server = $manager->provision_server(%options)
739              
740             Create a new VM::EC2::Staging::Server object according to the passed
741             options, which override the default options provided by the Manager
742             object.
743              
744             -name Name for this server, which can be used to retrieve
745             it later with a call to get_server().
746              
747             -architecture Architecture for the newly-created server
748             instances (e.g. "i386"). If not specified, then defaults
749             to the default_architecture() value. If explicitly
750             specified as undef, then the architecture of the matching
751             image will be used.
752              
753             -instance_type Type of the newly-created server (e.g. "m1.small").
754              
755             -root_type Root type for the server ("ebs" or "instance-store").
756              
757             -image_name Name or ami ID of the AMI to use for creating the
758             instance for the server. If the image name begins with
759             "ami-", then it is treated as an AMI ID. Otherwise it
760             is treated as a name pattern and will be used to
761             search the AMI name field using the wildcard search
762             "*$name*". Names work better than AMI ids here,
763             because the latter change from one region to
764             another. If multiple matching image candidates are
765             found, then an alpha sort on the name is used to find
766             the image with the highest alpha sort value, which
767             happens to work with Ubuntu images to find the latest
768             release.
769              
770             -availability_zone Availability zone for the server, or undef to
771             choose an availability zone randomly.
772              
773             -username Username to use for ssh connections. Defaults to
774             "ubuntu". Note that this user must be able to use
775             sudo on the instance without providing a password,
776             or functionality of this server will be limited.
777              
778             In addition, you may use any of the options recognized by
779             VM::EC2->run_instances() (e.g. -block_devices).
780              
781             =cut
782              
783             sub provision_server {
784             my $self = shift;
785             my @args = @_;
786              
787             # let subroutine arguments override manager's args
788             my %args = ($self->_run_instance_args,@args);
789              
790             # fix possible gotcha -- instance store is not allowed for micro instances.
791             $args{-root_type} = 'ebs' if $args{-instance_type} eq 't1.micro';
792             $args{-name} ||= $self->new_server_name;
793              
794             my ($keyname,$keyfile) = $self->_security_key;
795             my $security_group = $self->_security_group;
796             my $image = $self->_search_for_image(%args) or croak "No suitable image found";
797             $args{-architecture} = $image->architecture;
798              
799             my ($instance) = $self->ec2->run_instances(
800             -image_id => $image,
801             -security_group_id => $security_group,
802             -key_name => $keyname,
803             %args,
804             );
805             $instance or croak $self->ec2->error_str;
806              
807             my $success;
808             while (!$success) {
809             # race condition...
810             $success = eval{ $instance->add_tags(StagingRole => 'StagingInstance',
811             Name => "Staging server $args{-name} created by ".__PACKAGE__,
812             StagingUsername => $self->username,
813             StagingName => $args{-name});
814             }
815             }
816              
817             my $class = $args{-server_class} || $self->server_class;
818            
819             my $server = $class->new(
820             -keyfile => $keyfile,
821             -username => $self->username,
822             -instance => $instance,
823             -manager => $self,
824             -name => $args{-name},
825             @args,
826             );
827             eval {
828             local $SIG{ALRM} = sub {die 'timeout'};
829             alarm(SERVER_STARTUP_TIMEOUT);
830             $self->wait_for_servers($server);
831             };
832             alarm(0);
833             croak "server did not start after ",SERVER_STARTUP_TIMEOUT," seconds"
834             if $@ =~ /timeout/;
835             $self->register_server($server);
836             return $server;
837             }
838              
839             sub _run_instance_args {
840             my $self = shift;
841             my @args;
842             for my $arg (qw(instance_type availability_zone architecture image_name root_type)) {
843             push @args,("-${arg}" => $self->$arg);
844             }
845             return @args;
846             }
847              
848             =head2 $server = $manager->get_server(-name=>$name,%other_options)
849              
850             =head2 $server = $manager->get_server($name)
851              
852             Return an existing VM::EC2::Staging::Server object having the
853             indicated symbolic name, or create a new server if one with this name
854             does not already exist. The server's instance characteristics will be
855             configured according to the options passed to the manager at create
856             time (e.g. -availability_zone, -instance_type). These options can be
857             overridden by %other_args. See provision_volume() for details.
858              
859             =cut
860              
861             sub get_server {
862             my $self = shift;
863             unshift @_,'-name' if @_ == 1;
864              
865             my %args = @_;
866             $args{-name} ||= $self->new_server_name;
867              
868             # find servers of same name
869             local $^W = 0; # prevent an uninitialized value warning
870             my %servers = map {$_->name => $_} $self->servers;
871             my $server = $servers{$args{-name}} || $self->provision_server(%args);
872              
873             # this information needs to be renewed each time
874             $server->username($args{-username}) if $args{-username};
875             bless $server,$args{-server_class} if $args{-server_class};
876              
877             $server->start unless $server->ping;
878             return $server;
879             }
880              
881             =head2 $server = $manager->get_server_in_zone(-zone=>$availability_zone,%other_options)
882              
883             =head2 $server = $manager->get_server_in_zone($availability_zone)
884              
885             Return an existing VM::EC2::Staging::Server running in the indicated
886             symbolic name, or create a new server if one with this name does not
887             already exist. The server's instance characteristics will be
888             configured according to the options passed to the manager at create
889             time (e.g. -availability_zone, -instance_type). These options can be
890             overridden by %other_args. See provision_server() for details.
891              
892             =cut
893              
894             sub get_server_in_zone {
895             my $self = shift;
896             unshift @_,'-availability_zone' if @_ == 1;
897             my %args = @_;
898             my $zone = $args{-availability_zone};
899             if ($zone && (my $servers = $Zones{$zone}{Servers})) {
900             my $server = (values %{$servers})[0];
901             $server->start unless $server->is_up;
902             return $server;
903             }
904             else {
905             return $self->provision_server(%args);
906             }
907             }
908              
909             =head2 $server = $manager->find_server_by_instance($instance_id)
910              
911             Given an EC2 instanceId, return the corresponding
912             VM::EC2::Staging::Server, if any.
913              
914             =cut
915              
916             sub find_server_by_instance {
917             my $self = shift;
918             my $server = shift;
919             return $Instances{$server};
920             }
921              
922             =head2 @servers $manager->servers
923              
924             Return all registered VM::EC2::Staging::Servers in the zone managed by
925             the manager.
926              
927             =cut
928              
929             sub servers {
930             my $self = shift;
931             my $endpoint = $self->ec2->endpoint;
932             return $self->_servers($endpoint);
933             }
934              
935             =head2 $manager->start_all_servers
936              
937             Start all VM::EC2::Staging::Servers that are currently in the "stop"
938             state.
939              
940             =cut
941              
942             sub start_all_servers {
943             my $self = shift;
944             my @servers = $self->servers;
945             my @need_starting = grep {$_->current_status eq 'stopped'} @servers;
946             return unless @need_starting;
947             eval {
948             local $SIG{ALRM} = sub {die 'timeout'};
949             alarm(SERVER_STARTUP_TIMEOUT);
950             $self->_start_instances(@need_starting);
951             };
952             alarm(0);
953             croak "some servers did not start after ",SERVER_STARTUP_TIMEOUT," seconds"
954             if $@ =~ /timeout/;
955             }
956              
957             =head2 $manager->stop_all_servers
958              
959             Stop all VM::EC2::Staging::Servers that are currently in the "running"
960             state.
961              
962             =cut
963              
964             sub stop_all_servers {
965             my $self = shift;
966             my $ec2 = $self->ec2;
967             my @servers = grep {$_->ec2 eq $ec2} $self->servers;
968             @servers or return;
969             $self->info("Stopping servers @servers.\n");
970             $self->ec2->stop_instances(@servers);
971             $self->ec2->wait_for_instances(@servers);
972             }
973              
974             =head2 $manager->terminate_all_servers
975              
976             Terminate all VM::EC2::Staging::Servers and unregister them.
977              
978             =cut
979              
980             sub terminate_all_servers {
981             my $self = shift;
982             my $ec2 = $self->ec2 or return;
983             my @servers = $self->servers or return;
984             $self->_terminate_servers(@servers);
985             }
986              
987             =head2 $manager->force_terminate_all_servers
988              
989             Force termination of all VM::EC2::Staging::Servers, even if the
990             internal registration system indicates that some may be in use by
991             other Manager instances.
992              
993             =cut
994              
995             sub force_terminate_all_servers {
996             my $self = shift;
997             my $ec2 = $self->ec2 or return;
998             my @servers = $self->servers or return;
999             $ec2->terminate_instances(@servers) or warn $self->ec2->error_str;
1000             $ec2->wait_for_instances(@servers);
1001             }
1002              
1003             sub _terminate_servers {
1004             my $self = shift;
1005             my @servers = @_;
1006             my $ec2 = $self->ec2 or return;
1007              
1008             my @terminate;
1009             foreach (@servers) {
1010             my $in_use = $self->unregister_server($_);
1011             if ($in_use) {
1012             $self->warn("$_ is still in use. Will not terminate.\n");
1013             next;
1014             }
1015             push @terminate,$_;
1016             }
1017            
1018             if (@terminate) {
1019             $self->info("Terminating servers @terminate.\n");
1020             $ec2->terminate_instances(@terminate) or warn $self->ec2->error_str;
1021             $ec2->wait_for_instances(@terminate);
1022             }
1023              
1024             unless ($self->reuse_key) {
1025             $ec2->delete_key_pair($_) foreach $ec2->describe_key_pairs(-filter=>{'key-name' => 'staging-key-*'});
1026             }
1027             }
1028              
1029             =head2 $manager->wait_for_servers(@servers)
1030              
1031             Wait until all the servers on the list @servers are up and able to
1032             accept ssh commands. You may wish to wrap this in an eval{} and
1033             timeout in order to avoid waiting indefinitely.
1034              
1035             =cut
1036              
1037             sub wait_for_servers {
1038             my $self = shift;
1039             my @instances = @_;
1040             my $status = $self->ec2->wait_for_instances(@instances);
1041             my %pending = map {$_=>$_} grep {$_->current_status eq 'running'} @instances;
1042             $self->info("Waiting for ssh daemon on @instances.\n") if %pending;
1043             while (%pending) {
1044             for my $s (values %pending) {
1045             unless ($s->ping) {
1046             sleep 5;
1047             next;
1048             }
1049             delete $pending{$s};
1050             }
1051             }
1052             return $status;
1053             }
1054              
1055             sub _start_instances {
1056             my $self = shift;
1057             my @need_starting = @_;
1058             $self->info("starting instances: @need_starting.\n");
1059             $self->ec2->start_instances(@need_starting);
1060             $self->wait_for_servers(@need_starting);
1061             }
1062              
1063             =head1 Instance Methods for Managing Staging Volumes
1064              
1065             These methods allow you to create and interrogate staging
1066             volumes. They each return one or more VM::EC2::Staging::Volume
1067             objects. See L for more information about
1068             what you can do with these staging volume objects.
1069              
1070             =head2 $volume = $manager->provision_volume(%options)
1071              
1072             Create and register a new VM::EC2::Staging::Volume and mount it on a
1073             staging server in the appropriate availability zone. A new staging
1074             server will be created for this purpose if one does not already
1075             exist.
1076              
1077             If you provide a symbolic name for the volume and the manager has
1078             previously snapshotted a volume by the same name, then the snapshot
1079             will be used to create the volume (this behavior can be suppressed by
1080             passing -reuse=>0). This allows for the following pattern for
1081             efficiently updating a snapshotted volume:
1082              
1083             my $vol = $manager->provision_volume(-name=>'MyPictures',
1084             -size=>10);
1085             $vol->put('/usr/local/my_pictures/'); # will do an rsync from local directory
1086             $vol->create_snapshot; # write out to a snapshot
1087             $vol->delete;
1088              
1089             You may also explicitly specify a volumeId or snapshotId. The former
1090             allows you to place an existing volume under management of
1091             VM::EC2::Staging::Manager and returns a corresponding staging volume
1092             object. The latter creates the staging volume from the indicated
1093             snapshot, irregardless of whether the snapshot was created by the
1094             staging manager at an earlier time.
1095              
1096             Newly-created staging volumes are automatically formatted as ext4
1097             filesystems and mounted on the staging server under
1098             /mnt/Staging/$name, where $name is the staging volume's symbolic
1099             name. The filesystem type and the mountpoint can be modified with the
1100             -fstype and -mount arguments, respectively. In addition, you may
1101             specify an -fstype of "raw", in which case the volume will be attached
1102             to a staging server (creating the server first if necessary) but not
1103             formatted or mounted. This is useful when creating multi-volume RAID
1104             or LVM setups.
1105              
1106             Options:
1107              
1108             -name Name of the staging volume. A fatal error issues if a staging
1109             volume by this name already exists (use get_volume() to
1110             avoid this). If no name is provided, then a random
1111             unique one is chosen for you.
1112              
1113             -availability_zone
1114             Availability zone in which to create this
1115             volume. If none is specified, then a zone is chosen that
1116             reuses an existing staging server, if any.
1117              
1118             -size Size of the desired volume, in GB.
1119              
1120             -fstype Filesystem type for the volume, ext4 by default. Supported
1121             types are ext2, ext3, ext4, xfs, reiserfs, jfs, hfs,
1122             ntfs, vfat, msdos, and raw.
1123              
1124             -mount Mount point for this volume on the staging server (e.g. /opt/bin).
1125             Use with care, as there are no checks to prevent you from mounting
1126             two staging volumes on top of each other or mounting over essential
1127             operating system paths.
1128              
1129             -label Volume label. Only applies to filesystems that support labels
1130             (all except hfs, vfat, msdos and raw).
1131              
1132             -volume_id Create the staging volume from an existing EBS volume with
1133             the specified ID. Most other options are ignored in this
1134             case.
1135              
1136             -snapshot_id
1137             Create the staging volume from an existing EBS
1138             snapshot. If a size is specified that is larger than the
1139             snapshot, then the volume and its filesystem will be
1140             automatically extended (this only works for ext volumes
1141             at the moment). Shrinking of volumes is not currently
1142             supported.
1143              
1144             -reuse If true, then the most recent snapshot created from a staging
1145             volume of the same name is used to create the
1146             volume. This is the default. Pass 0 to disable this
1147             behavior.
1148              
1149             The B<-reuse> argument is intended to support the following use case
1150             in which you wish to rsync a directory on a host system somewhere to
1151             an EBS snapshot, without maintaining a live server and volume on EC2:
1152              
1153             my $volume = $manager->provision_volume(-name=>'backup_1',
1154             -reuse => 1,
1155             -fstype => 'ext3',
1156             -size => 10);
1157             $volume->put('fred@gw.harvard.edu:my_music');
1158             $volume->create_snapshot('Music Backup '.localtime);
1159             $volume->delete;
1160              
1161             The next time this script is run, the "backup_1" volume will be
1162             recreated from the most recent snapshot, minimizing copying. A new
1163             snapshot is created, and the staging volume is deleted.
1164              
1165             =cut
1166              
1167             sub provision_volume {
1168             my $self = shift;
1169             my %args = @_;
1170              
1171             $args{-name} ||= $self->new_volume_name;
1172             $args{-size} ||= 1 unless $args{-snapshot_id} || $args{-volume_id};
1173             $args{-volume_id} ||= undef;
1174             $args{-snapshot_id} ||= undef;
1175             $args{-reuse} = $self->reuse_volumes unless defined $args{-reuse};
1176             $args{-mount} ||= '/mnt/Staging/'.$args{-name}; # BUG: "/mnt/Staging" is hardcoded in multiple places
1177             $args{-fstype} ||= 'ext4';
1178             $args{-availability_zone} ||= $self->_select_used_zone;
1179             $args{-label} ||= $args{-name};
1180              
1181             $self->find_volume_by_name($args{-name}) &&
1182             croak "There is already a volume named $args{-name} in this region";
1183            
1184             if ($args{-snapshot_id}) {
1185             $self->info("Provisioning volume from snapshot $args{-snapshot_id}.\n");
1186             } elsif ($args{-volume_id}) {
1187             $self->info("Provisioning volume from volume $args{-volume_id}.\n");
1188             my $v = $self->ec2->describe_volumes($args{-volume_id});
1189             $args{-availability_zone} = $v->availabilityZone if $v;
1190             $args{-size} = $v->size if $v;
1191             } else {
1192             $self->info("Provisioning a new $args{-size} GB $args{-fstype} volume.\n");
1193             }
1194              
1195             $args{-availability_zone} ? $self->info("Obtaining a staging server in zone $args{-availability_zone}.\n")
1196             : $self->info("Obtaining a staging server.\n");
1197             my $server = $self->get_server_in_zone($args{-availability_zone});
1198             $server->start unless $server->ping;
1199             my $volume = $server->provision_volume(%args);
1200             $self->register_volume($volume);
1201             return $volume;
1202             }
1203              
1204             =head2 $volume = $manager->get_volume(-name=>$name,%other_options)
1205              
1206             =head2 $volume = $manager->get_volume($name)
1207              
1208             Return an existing VM::EC2::Staging::Volume object with the indicated
1209             symbolic name, or else create a new volume if one with this name does
1210             not already exist. The volume's characteristics will be configured
1211             according to the options in %other_args. See provision_volume() for
1212             details. If called with no arguments, this method returns Volume
1213             object with default characteristics and a randomly-assigned name.
1214              
1215             =cut
1216              
1217             sub get_volume {
1218             my $self = shift;
1219              
1220             unshift @_,'-name' if @_ == 1;
1221             my %args = @_;
1222             $args{-name} ||= $self->new_volume_name;
1223              
1224             # find volume of same name
1225             my %vols = map {$_->name => $_} $self->volumes;
1226             my $vol = $vols{$args{-name}} || $self->provision_volume(%args);
1227             return $vol;
1228             }
1229              
1230             =head2 $result = $manager->rsync($src1,$src2,$src3...,$dest)
1231              
1232             This method provides remote synchronization (rsync) file-level copying
1233             between one or more source locations and a destination location via an
1234             ssh tunnel. Copying among arbitrary combinations of local and remote
1235             filesystems is supported, with the caveat that the remote filesystems
1236             must be contained on volumes and servers managed by this module (see
1237             below for a workaround).
1238              
1239             You may provide two or more directory paths. The last path will be
1240             treated as the copy destination, and the source paths will be treated
1241             as copy sources. All copying is performed using the -avz options,
1242             which activates recursive directory copying in which ownership,
1243             modification times and permissions are preserved, and compresses the
1244             data to reduce network usage. Verbosity is set so that the names of
1245             copied files are printed to STDERR. If you do not wish this, then use
1246             call the manager's quiet() method with a true value.
1247              
1248             Source paths can be formatted in one of several ways:
1249              
1250             /absolute/path
1251             Copy the contents of the directory /absolute/path located on the
1252             local machine to the destination. This will create a
1253             subdirectory named "path" on the destination disk. Add a slash
1254             to the end of the path (i.e. "/absolute/path/") in order to
1255             avoid creating this subdirectory on the destination disk.
1256              
1257             ./relative/path
1258             Relative paths work the way you expect, and depend on the current
1259             working directory. The terminating slash rule applies.
1260              
1261             $staging_volume
1262             Pass a VM::EC2::Staging::Volume to copy the contents of the
1263             volume to the destination disk starting at the root of the
1264             volume. Note that you do *not* need to have any knowledge of the
1265             mount point for this volume in order to copy its contents.
1266              
1267             $staging_volume:/absolute/path
1268             $staging_volume:absolute/path
1269             $staging_volume/absolute/path
1270             All these syntaxes accomplish the same thing, which is to
1271             copy a subdirectory of a staging volume to the destination disk.
1272             The root of the volume is its top level, regardless of where it
1273             is mounted on the staging server. Because of string
1274             interpolation magic, you can enclose staging volume object names
1275             in quotes in order to construct the path, as in
1276             "$picture_volume:/family/vacations/". As in local paths, a
1277             terminating slash indicates that the contents of the last
1278             directory in the path are to be copied without creating the
1279             enclosing directory on the desetination. Note that you do *not*
1280             need to have any knowledge of the mount point for this volume in
1281             order to copy its contents.
1282              
1283             $staging_server:/absolute/path
1284             Pass a staging server object and absolute path to copy the contents
1285             of this path to the destination disk. Because of string interpolation
1286             you can include server objects in quotes: "$my_server:/opt"
1287              
1288             $staging_server:relative/path
1289             This form will copy data from paths relative to the remote user's home
1290             directory on the staging server. Typically not very useful, but supported.
1291              
1292             The same syntax is supported for destination paths, except that it
1293             makes no difference whether a path has a trailing slash or not.
1294              
1295             As with the rsync command, if you proceed a path with a single colon
1296             (:/my/path), it is a short hand to use the previous server/volume/host
1297             in the source list.
1298              
1299             When specifying multiple source directories, all source directories must
1300             reside on the same local or remote machine. This is legal:
1301              
1302             $manager->rsync("$picture_volume:/family/vacations",
1303             "$picture_volume:/family/picnics"
1304             => "$backup_volume:/recent_backups");
1305              
1306             This is not:
1307              
1308             $manager->rsync("$picture_volume:/family/vacations",
1309             "$audio_volume:/beethoven"
1310             => "$backup_volume:/recent_backups");
1311              
1312             When specifying multiple sources, you may give the volume or server
1313             once for the first source and then start additional source paths with
1314             a ":" to indicate the same volume or server is to be used:
1315              
1316             $manager->rsync("$picture_volume:/family/vacations",
1317             ":/family/picnics"
1318             => "$backup_volume:/recent_backups");
1319              
1320             When copying to/from the local machine, the rsync process will run as
1321             the user that the script was launched by. However, on remote servers
1322             managed by the staging manager, the rsync process will run as
1323             superuser.
1324              
1325             The rsync() method will also accept regular remote DNS names and IP
1326             addresses, optionally preceded by a username:
1327              
1328             $manager->rsync("$picture_volume:/family/vacations" => 'fred@gw.harvard.edu:/tmp')
1329              
1330             When called in this way, the method does what it can to avoid
1331             prompting for a password or passphrase on the non-managed host
1332             (gw.harvard.edu in the above example). This includes turning off
1333             strict host checking and forwarding the user agent information from
1334             the local machine.
1335              
1336             =head2 $result = $manager->rsync(\@options,$src1,$src2,$src3...,$dest)
1337              
1338             This is a variant of the rsync command in which extra options can be
1339             passed to rsync by providing an array reference as the first argument.
1340             For example:
1341              
1342             $manager->rsync(['--exclude' => '*~'],
1343             '/usr/local/backups',
1344             "$my_server:/usr/local");
1345              
1346             =cut
1347              
1348             # most general form
1349             #
1350             sub rsync {
1351             my $self = shift;
1352             croak "usage: VM::EC2::Staging::Manager->rsync(\$source_path1,\$source_path2\...,\$dest_path)"
1353             unless @_ >= 2;
1354              
1355             my @p = @_;
1356             my @user_args = ($p[0] && ref($p[0]) eq 'ARRAY')
1357             ? @{shift @p}
1358             : ();
1359              
1360             undef $LastHost;
1361             undef $LastMt;
1362             my @paths = map {$self->_resolve_path($_)} @p;
1363              
1364             my $dest = pop @paths;
1365             my @source = @paths;
1366              
1367             my %hosts;
1368             local $^W=0; # avoid uninit value errors
1369             foreach (@source) {
1370             $hosts{$_->[0]} = $_->[0];
1371             }
1372             croak "More than one source host specified" if keys %hosts > 1;
1373             my ($source_host) = values %hosts;
1374             my $dest_host = $dest->[0];
1375              
1376             my @source_paths = map {$_->[1]} @source;
1377             my $dest_path = $dest->[1];
1378              
1379             my $rsync_args = $self->_rsync_args;
1380             my $dots;
1381              
1382             if ($self->verbosity == VERBOSE_INFO) {
1383             $rsync_args .= 'v'; # print a line for each file
1384             $dots = '2>&1|/tmp/dots.pl t';
1385             }
1386             $rsync_args .= ' '.join ' ', map {_quote_shell($_)} @user_args if @user_args;
1387              
1388             my $src_is_server = $source_host && UNIVERSAL::isa($source_host,'VM::EC2::Staging::Server');
1389             my $dest_is_server = $dest_host && UNIVERSAL::isa($dest_host,'VM::EC2::Staging::Server');
1390              
1391             # this is true when one of the paths contains a ":", indicating an rsync
1392             # path that contains a hostname, but not a managed server
1393             my $remote_path = "@source_paths $dest_path" =~ /:/;
1394              
1395             # remote rsync on either src or dest server
1396             if ($remote_path && ($src_is_server || $dest_is_server)) {
1397             my $server = $source_host || $dest_host;
1398             $self->_upload_dots_script($server) if $dots;
1399             return $server->ssh(['-t','-A'],"sudo -E rsync -e 'ssh -o \"CheckHostIP no\" -o \"StrictHostKeyChecking no\"' $rsync_args @source_paths $dest_path $dots");
1400             }
1401              
1402             # localhost => localhost
1403             if (!($source_host || $dest_host)) {
1404             my $dots_cmd = $self->_dots_cmd;
1405             return system("rsync @source $dest $dots_cmd") == 0;
1406             }
1407              
1408             # localhost => DataTransferServer
1409             if ($dest_is_server && !$src_is_server) {
1410             return $dest_host->_rsync_put($rsync_args,@source_paths,$dest_path);
1411             }
1412              
1413             # DataTransferServer => localhost
1414             if ($src_is_server && !$dest_is_server) {
1415             return $source_host->_rsync_get($rsync_args,@source_paths,$dest_path);
1416             }
1417              
1418             if ($source_host eq $dest_host) {
1419             $self->info("Beginning rsync @source_paths $dest_path...\n");
1420             my $result = $source_host->ssh('sudo','rsync',$rsync_args,@source_paths,$dest_path);
1421             $self->info("...rsync done.\n");
1422             return $result;
1423             }
1424              
1425             # DataTransferServer1 => DataTransferServer2
1426             # this one is slightly more difficult because datatransferserver1 has to
1427             # ssh authenticate against datatransferserver2.
1428             my $keyname = $self->_authorize($source_host => $dest_host);
1429              
1430             my $dest_ip = $dest_host->instance->dnsName;
1431             my $ssh_args = $source_host->_ssh_escaped_args;
1432             my $keyfile = $source_host->keyfile;
1433             $ssh_args =~ s/$keyfile/$keyname/; # because keyfile is embedded among args
1434             $self->info("Beginning rsync @source_paths $dest_ip:$dest_path...\n");
1435             $self->_upload_dots_script($source_host) if $dots;
1436             my $result = $source_host->ssh('sudo','rsync',$rsync_args,
1437             '-e',"'ssh $ssh_args'",
1438             "--rsync-path='sudo rsync'",
1439             @source_paths,"$dest_ip:$dest_path",$dots);
1440             $self->info("...rsync done.\n");
1441             return $result;
1442             }
1443              
1444             sub _quote_shell {
1445             my $thing = shift;
1446             $thing =~ s/\s/\ /;
1447             $thing =~ s/(['"])/\\($1)/;
1448             $thing;
1449             }
1450              
1451             =head2 $manager->dd($source_vol=>$dest_vol)
1452              
1453             This method performs block-level copying of the contents of
1454             $source_vol to $dest_vol by using dd over an SSH tunnel, where both
1455             source and destination volumes are VM::EC2::Staging::Volume
1456             objects. The volumes must be attached to a server but not
1457             mounted. Everything in the volume, including its partition table, is
1458             copied, allowing you to make an exact image of a disk.
1459              
1460             The volumes do B actually need to reside on this server, but can
1461             be attached to any staging server in the zone.
1462              
1463             =cut
1464              
1465             # for this to work, we have to create the concept of a "raw" staging volume
1466             # that is attached, but not mounted
1467             sub dd {
1468             my $self = shift;
1469              
1470             @_==2 or croak "usage: VM::EC2::Staging::Manager->dd(\$source_vol=>\$dest_vol)";
1471              
1472             my ($vol1,$vol2) = @_;
1473             my ($server1,$device1) = ($vol1->server,$vol1->mtdev);
1474             my ($server2,$device2) = ($vol2->server,$vol2->mtdev);
1475             my $hush = $self->verbosity < VERBOSE_INFO ? '2>/dev/null' : '';
1476             my $use_pv = $self->verbosity >= VERBOSE_WARN;
1477             my $gigs = $vol1->size;
1478              
1479             if ($use_pv) {
1480             $self->info("Configuring PV to show dd progress...\n");
1481             $server1->ssh("if [ ! -e /usr/bin/pv ]; then sudo apt-get -qq update >/dev/null 2>&1; sudo apt-get -y -qq install pv >/dev/null 2>&1; fi");
1482             }
1483              
1484             if ($server1 eq $server2) {
1485             if ($use_pv) {
1486             print STDERR "\n";
1487             $server1->ssh(['-t'], "sudo dd if=$device1 2>/dev/null | pv -f -s ${gigs}G -petr | sudo dd of=$device2 2>/dev/null");
1488             } else {
1489             $server1->ssh("sudo dd if=$device1 of=$device2 $hush");
1490             }
1491             } else {
1492             my $keyname = $self->_authorize($server1,$server2);
1493             my $dest_ip = $server2->instance->dnsName;
1494             my $ssh_args = $server1->_ssh_escaped_args;
1495             my $keyfile = $server1->keyfile;
1496             $ssh_args =~ s/$keyfile/$keyname/; # because keyfile is embedded among args
1497             my $pv = $use_pv ? "2>/dev/null | pv -s ${gigs}G -petr" : '';
1498             $server1->ssh(['-t'], "sudo dd if=$device1 $hush $pv | gzip -1 - | ssh $ssh_args $dest_ip 'gunzip -1 - | sudo dd of=$device2'");
1499             }
1500             }
1501              
1502             # take real or symbolic name and turn it into a two element
1503             # list consisting of server object and mount point
1504             # possible forms:
1505             # /local/path
1506             # vol-12345/relative/path
1507             # vol-12345:/relative/path
1508             # vol-12345:relative/path
1509             # $server:/absolute/path
1510             # $server:relative/path
1511             #
1512             # treat path as symbolic if it does not start with a slash
1513             # or dot characters
1514             sub _resolve_path {
1515             my $self = shift;
1516             my $vpath = shift;
1517              
1518             my ($servername,$pathname);
1519             if ($vpath =~ /^(vol-[0-9a-f]+):?(.*)/ &&
1520             (my $vol = VM::EC2::Staging::Manager->find_volume_by_volid($1))) {
1521             my $path = $2 || '/';
1522             $path = "/$path" if $path && $path !~ m!^/!;
1523             $vol->_spin_up;
1524             $servername = $LastHost = $vol->server;
1525             my $mtpt = $LastMt = $vol->mtpt;
1526             $pathname = $mtpt;
1527             $pathname .= $path if $path;
1528             } elsif ($vpath =~ /^(i-[0-9a-f]{8}):(.+)$/ &&
1529             (my $server = VM::EC2::Staging::Manager->find_server_by_instance($1))) {
1530             $servername = $LastHost = $server;
1531             $pathname = $2;
1532             } elsif ($vpath =~ /^:(.+)$/) {
1533             $servername = $LastHost if $LastHost;
1534             $pathname = $LastHost && $LastMt ? "$LastMt/$2" : $2;
1535             } else {
1536             return [undef,$vpath]; # localhost
1537             }
1538             return [$servername,$pathname];
1539             }
1540              
1541             sub _rsync_args {
1542             my $self = shift;
1543             my $verbosity = $self->verbosity;
1544             return $verbosity < VERBOSE_WARN ? '-azq'
1545             :$verbosity < VERBOSE_INFO ? '-azh'
1546             :$verbosity < VERBOSE_DEBUG ? '-azh'
1547             : '-azhv'
1548             }
1549              
1550             sub _authorize {
1551             my $self = shift;
1552             my ($source_host,$dest_host) = @_;
1553             my $keyname = "/tmp/${source_host}_to_${dest_host}";
1554             unless ($source_host->has_key($keyname)) {
1555             $source_host->info("creating ssh key for server to server data transfer.\n");
1556             $source_host->ssh("ssh-keygen -t dsa -q -f $keyname/dev/null");
1557             $source_host->has_key($keyname=>1);
1558             }
1559             unless ($dest_host->accepts_key($keyname)) {
1560             my $key_stuff = $source_host->scmd("cat ${keyname}.pub");
1561             chomp($key_stuff);
1562             $dest_host->ssh("mkdir -p .ssh; chmod 0700 .ssh; (echo '$key_stuff' && cat .ssh/authorized_keys) | sort | uniq > .ssh/authorized_keys.tmp; mv .ssh/authorized_keys.tmp .ssh/authorized_keys; chmod 0600 .ssh/authorized_keys");
1563             $dest_host->accepts_key($keyname=>1);
1564             }
1565              
1566             return $keyname;
1567             }
1568              
1569             =head2 $volume = $manager->find_volume_by_volid($volume_id)
1570              
1571             Given an EC2 volumeId, return the corresponding
1572             VM::EC2::Staging::Volume, if any.
1573              
1574             =cut
1575              
1576             sub find_volume_by_volid {
1577             my $self = shift;
1578             my $volid = shift;
1579             return $Volumes{$volid};
1580             }
1581              
1582             =head2 $volume = $manager->find_volume_by_name($name)
1583              
1584             Given a staging name (assigned at volume creation time), return the
1585             corresponding VM::EC2::Staging::Volume, if any.
1586              
1587             =cut
1588              
1589             sub find_volume_by_name {
1590             my $self = shift;
1591             my $name = shift;
1592             my %volumes = map {$_->name => $_} $self->volumes;
1593             return $volumes{$name};
1594             }
1595              
1596             =head2 @volumes = $manager->volumes
1597              
1598             Return all VM::EC2::Staging::Volumes managed in this zone.
1599              
1600             =cut
1601              
1602             sub volumes {
1603             my $self = shift;
1604             return grep {$_->ec2->endpoint eq $self->ec2->endpoint} values %Volumes;
1605             }
1606              
1607             =head1 Instance Methods for Accessing Configuration Options
1608              
1609             This section documents accessor methods that allow you to examine or
1610             change configuration options that were set at create time. Called with
1611             an argument, the accessor changes the option and returns the option's
1612             previous value. Called without an argument, the accessor returns the
1613             option's current value.
1614              
1615             =head2 $on_exit = $manager->on_exit([$new_behavior])
1616              
1617             Get or set the "on_exit" option, which specifies what to do with
1618             existing staging servers when the staging manager is destroyed. Valid
1619             values are "terminate", "stop" and "run".
1620              
1621             =head2 $reuse_key = $manager->reuse_key([$boolean])
1622              
1623             Get or set the "reuse_key" option, which if true uses the same
1624             internally-generated ssh keypair for all running instances. If false,
1625             then a new keypair will be created for each staging server. The
1626             keypair will be destroyed automatically when the staging server
1627             terminates (but only if the staging manager initiates the termination
1628             itself).
1629              
1630             =head2 $username = $manager->username([$new_username])
1631              
1632             Get or set the username used to log into staging servers.
1633              
1634             =head2 $architecture = $manager->architecture([$new_architecture])
1635              
1636             Get or set the architecture (i386, x86_64) to use for launching
1637             new staging servers.
1638              
1639             =head2 $root_type = $manager->root_type([$new_type])
1640              
1641             Get or set the instance root type for new staging servers
1642             ("instance-store", "ebs").
1643              
1644             =head2 $instance_type = $manager->instance_type([$new_type])
1645              
1646             Get or set the instance type to use for new staging servers
1647             (e.g. "t1.micro"). I recommend that you use "m1.small" (the default)
1648             or larger instance types because of the extremely slow I/O of the
1649             micro instance. In addition, micro instances running Ubuntu have a
1650             known bug that prevents them from unmounting and remounting EBS
1651             volumes repeatedly on the same block device. This can lead to hangs
1652             when the staging manager tries to create volumes.
1653              
1654             =head2 $reuse_volumes = $manager->reuse_volumes([$new_boolean])
1655              
1656             This gets or sets the "reuse_volumes" option, which if true causes the
1657             provision_volumes() call to create staging volumes from existing EBS
1658             volumes and snapshots that share the same staging manager symbolic
1659             name. See the discussion under VM::EC2->staging_manager(), and
1660             VM::EC2::Staging::Manager->provision_volume().
1661              
1662             =head2 $name = $manager->image_name([$new_name])
1663              
1664             This gets or sets the "image_name" option, which is the AMI ID or AMI
1665             name to use when creating new staging servers. Names beginning with
1666             "ami-" are treated as AMI IDs, and everything else is treated as a
1667             pattern match on the AMI name.
1668              
1669             =head2 $zone = $manager->availability_zone([$new_zone])
1670              
1671             Get or set the default availability zone to use when creating new
1672             servers and volumes. An undef value allows the staging manager to
1673             choose the zone in a way that minimizes resources.
1674              
1675             =head2 $class_name = $manager->volume_class([$new_class])
1676              
1677             Get or set the name of the perl package that implements staging
1678             volumes, VM::EC2::Staging::Volume by default. Staging volumes created
1679             by the manager will have this class type.
1680              
1681             =head2 $class_name = $manager->server_class([$new_class])
1682              
1683             Get or set the name of the perl package that implements staging
1684             servers, VM::EC2::Staging::Server by default. Staging servers created
1685             by the manager will have this class type.
1686              
1687             =head2 $boolean = $manager->scan([$boolean])
1688              
1689             Get or set the "scan" flag, which if true will cause the zone to be
1690             scanned quickly for existing managed servers and volumes when the
1691             manager is first created.
1692              
1693             =head2 $path = $manager->dot_directory([$new_directory])
1694              
1695             Get or set the dot directory which holds private key files.
1696              
1697             =cut
1698              
1699             sub dot_directory {
1700             my $self = shift;
1701             my $dir = $self->dotdir;
1702             unless (-e $dir && -d $dir) {
1703             mkdir $dir or croak "mkdir $dir: $!";
1704             chmod 0700,$dir or croak "chmod 0700 $dir: $!";
1705             }
1706             return $dir;
1707             }
1708              
1709             =head1 Internal Methods
1710              
1711             This section documents internal methods that are not normally called
1712             by end-user scripts but may be useful in subclasses. In addition,
1713             there are a number of undocumented internal methods that begin with
1714             the "_" character. Explore the source code to learn about these.
1715              
1716             =head2 $ok = $manager->environment_ok
1717              
1718             This performs a check on the environment in which the module is
1719             running. For this module to work properly, the ssh, rsync and dd
1720             programs must be found in the PATH. If all three programs are found,
1721             then this method returns true.
1722              
1723             This method can be called as an instance method or class method.
1724              
1725             =cut
1726              
1727             sub environment_ok {
1728             my $self = shift;
1729             foreach (qw(dd ssh rsync)) {
1730             chomp (my $path = `which $_`);
1731             return unless $path;
1732             }
1733             return 1;
1734             }
1735              
1736             =head2 $name = $manager->default_verbosity
1737              
1738             Returns the default verbosity level (2: warning+informational messages). This
1739             is overridden using -verbose at create time.
1740              
1741             =cut
1742              
1743             sub default_verbosity { VERBOSE_INFO }
1744              
1745             =head2 $name = $manager->default_exit_behavior
1746              
1747             Return the default exit behavior ("stop") when the manager terminates.
1748             Intended to be overridden in subclasses.
1749              
1750             =cut
1751              
1752             sub default_exit_behavior { 'stop' }
1753              
1754             =head2 $name = $manager->default_image_name
1755              
1756             Return the default image name ('ubuntu-precise-12.04') for use in
1757             creating new instances. Intended to be overridden in subclasses.
1758              
1759             =cut
1760              
1761             sub default_image_name { 'ubuntu-precise-12.04' }; # launches faster than precise
1762              
1763             =head2 $name = $manager->default_user_name
1764              
1765             Return the default user name ('ubuntu') for use in creating new
1766             instances. Intended to be overridden in subclasses.
1767              
1768             =cut
1769              
1770             sub default_user_name { 'ubuntu' }
1771              
1772             =head2 $name = $manager->default_architecture
1773              
1774             Return the default instance architecture ('i386') for use in creating
1775             new instances. Intended to be overridden in subclasses.
1776              
1777             =cut
1778              
1779             sub default_architecture { 'i386' }
1780              
1781             =head2 $name = $manager->default_root_type
1782              
1783             Return the default instance root type ('instance-store') for use in
1784             creating new instances. Intended to be overridden in subclasses. Note
1785             that this value is ignored if the exit behavior is "stop", in which case an
1786             ebs-backed instance will be used. Also, the m1.micro instance type
1787             does not come in an instance-store form, so ebs will be used in this
1788             case as well.
1789              
1790             =cut
1791              
1792             sub default_root_type { 'instance-store'}
1793              
1794             =head2 $name = $manager->default_instance_type
1795              
1796             Return the default instance type ('m1.small') for use in
1797             creating new instances. Intended to be overridden in subclasses. We default
1798             to m1.small rather than a micro instance because the I/O in m1.small
1799             is far faster than in t1.micro.
1800              
1801             =cut
1802              
1803             sub default_instance_type { 'm1.small' }
1804              
1805             =head2 $name = $manager->default_reuse_keys
1806              
1807             Return the default value of the -reuse_keys argument ('true'). This
1808             value allows the manager to create an ssh keypair once, and use the
1809             same one for all servers it creates over time. If false, then a new
1810             keypair is created for each server and then discarded when the server
1811             terminates.
1812              
1813             =cut
1814              
1815             sub default_reuse_keys { 1 }
1816              
1817             =head2 $name = $manager->default_reuse_volumes
1818              
1819             Return the default value of the -reuse_volumes argument ('true'). This
1820             value instructs the manager to use the symbolic name of the volume to
1821             return an existing volume whenever a request is made to provision a
1822             new one of the same name.
1823              
1824             =cut
1825              
1826             sub default_reuse_volumes { 1 }
1827              
1828             =head2 $path = $manager->default_dot_directory_path
1829              
1830             Return the default value of the -dotdir argument
1831             ("$ENV{HOME}/.vm-ec2-staging"). This value instructs the manager to
1832             use the symbolic name of the volume to return an existing volume
1833             whenever a request is made to provision a new one of the same name.
1834              
1835             =cut
1836              
1837             sub default_dot_directory_path {
1838             my $class = shift;
1839             my $dir = File::Spec->catfile($ENV{HOME},'.vm-ec2-staging');
1840             return $dir;
1841             }
1842              
1843             =head2 $class_name = $manager->default_volume_class
1844              
1845             Return the class name for staging volumes created by the manager,
1846             VM::EC2::Staging::Volume by default. If you wish a subclass of
1847             VM::EC2::Staging::Manager to create a different type of volume,
1848             override this method.
1849              
1850             =cut
1851              
1852             sub default_volume_class {
1853             return 'VM::EC2::Staging::Volume';
1854             }
1855              
1856             =head2 $class_name = $manager->default_server_class
1857              
1858             Return the class name for staging servers created by the manager,
1859             VM::EC2::Staging::Server by default. If you wish a subclass of
1860             VM::EC2::Staging::Manager to create a different type of volume,
1861             override this method.
1862              
1863             =cut
1864              
1865             sub default_server_class {
1866             return 'VM::EC2::Staging::Server';
1867             }
1868              
1869             =head2 $server = $manager->register_server($server)
1870              
1871             Register a VM::EC2::Staging::Server object. Usually called
1872             internally.
1873              
1874             =cut
1875              
1876             sub register_server {
1877             my $self = shift;
1878             my $server = shift;
1879             sleep 1; # AWS lag bugs
1880             my $zone = $server->placement;
1881             $Zones{$zone}{Servers}{$server} = $server;
1882             $Instances{$server->instance} = $server;
1883             return $self->_increment_usage_count($server);
1884             }
1885              
1886             =head2 $manager->unregister_server($server)
1887              
1888             Forget about the existence of VM::EC2::Staging::Server. Usually called
1889             internally.
1890              
1891             =cut
1892              
1893             sub unregister_server {
1894             my $self = shift;
1895             my $server = shift;
1896             my $zone = eval{$server->placement} or return; # avoids problems at global destruction
1897             delete $Zones{$zone}{Servers}{$server};
1898             delete $Instances{$server->instance};
1899             return $self->_decrement_usage_count($server);
1900             }
1901              
1902             =head2 $manager->register_volume($volume)
1903              
1904             Register a VM::EC2::Staging::Volume object. Usually called
1905             internally.
1906              
1907             =cut
1908              
1909             sub register_volume {
1910             my $self = shift;
1911             my $vol = shift;
1912             $self->_increment_usage_count($vol);
1913             $Zones{$vol->availabilityZone}{Volumes}{$vol} = $vol;
1914             $Volumes{$vol->volumeId} = $vol;
1915             }
1916              
1917             =head2 $manager->unregister_volume($volume)
1918              
1919             Forget about a VM::EC2::Staging::Volume object. Usually called
1920             internally.
1921              
1922             =cut
1923              
1924             sub unregister_volume {
1925             my $self = shift;
1926             my $vol = shift;
1927             my $zone = $vol->availabilityZone;
1928             $self->_decrement_usage_count($vol);
1929             delete $Zones{$zone}{$vol};
1930             delete $Volumes{$vol->volumeId};
1931             }
1932              
1933             =head2 $pid = $manager->pid([$new_pid])
1934              
1935             Get or set the process ID of the script that is running the
1936             manager. This is used internally to detect the case in which the
1937             script has forked, in which case we do not want to invoke the manager
1938             class's destructor in the child process (because it may stop or
1939             terminate servers still in use by the parent process).
1940              
1941             =head2 $path = $manager->dotdir([$new_dotdir])
1942              
1943             Low-level version of dot_directory(), differing only in the fact that
1944             dot_directory will automatically create the path, including subdirectories.
1945              
1946             =cut
1947              
1948             =head2 $manager->scan_region
1949              
1950             Synchronize internal list of managed servers and volumes with the EC2
1951             region. Called automatically during new() and needed only if servers &
1952             volumes are changed from outside the module while it is running.
1953              
1954             =cut
1955              
1956             # scan for staging instances in current region and cache them
1957             # into memory
1958             # status should be...
1959             # -on_exit => {'terminate','stop','run'}
1960             sub scan_region {
1961             my $self = shift;
1962             my $ec2 = shift || $self->ec2;
1963             $self->_scan_instances($ec2);
1964             $self->_scan_volumes($ec2);
1965             }
1966              
1967             sub _scan_instances {
1968             my $self = shift;
1969             my $ec2 = shift;
1970             my @instances = $ec2->describe_instances({'tag:StagingRole' => 'StagingInstance',
1971             'instance-state-name' => ['running','stopped']});
1972             for my $instance (@instances) {
1973             my $keyname = $instance->keyName or next;
1974             my $keyfile = $self->_check_keyfile($keyname) or next;
1975             my $username = $instance->tags->{'StagingUsername'} or next;
1976             my $name = $instance->tags->{StagingName} || $self->new_server_name;
1977             my $server = $self->server_class()->new(
1978             -name => $name,
1979             -keyfile => $keyfile,
1980             -username => $username,
1981             -instance => $instance,
1982             -manager => $self,
1983             );
1984             $self->register_server($server);
1985             }
1986             }
1987              
1988             sub _scan_volumes {
1989             my $self = shift;
1990             my $ec2 = shift;
1991              
1992             # now the volumes
1993             my @volumes = $ec2->describe_volumes(-filter=>{'tag:StagingRole' => 'StagingVolume',
1994             'status' => ['available','in-use']});
1995             for my $volume (@volumes) {
1996             my $status = $volume->status;
1997             my $zone = $volume->availabilityZone;
1998              
1999             my %args;
2000             $args{-endpoint} = $self->ec2->endpoint;
2001             $args{-volume} = $volume;
2002             $args{-name} = $volume->tags->{StagingName};
2003             $args{-fstype} = $volume->tags->{StagingFsType};
2004             $args{-mtpt} = $volume->tags->{StagingMtPt};
2005             my $mounted;
2006              
2007             if (my $attachment = $volume->attachment) {
2008             my $server = $self->find_server_by_instance($attachment->instance);
2009             $args{-server} = $server;
2010             ($args{-mtdev},$mounted) = $server->ping &&
2011             $server->_find_mount($attachment->device);
2012             }
2013              
2014             my $vol = $self->volume_class()->new(%args);
2015             $vol->mounted(1) if $mounted;
2016             $self->register_volume($vol);
2017             }
2018             }
2019              
2020             =head2 $group = $manager->security_group
2021              
2022             Returns or creates a security group with the permissions needed used
2023             to manage staging servers. Usually called internally.
2024              
2025             =cut
2026              
2027             sub security_group {
2028             my $self = shift;
2029             return $self->{security_group} ||= $self->_security_group();
2030             }
2031              
2032             =head2 $keypair = $manager->keypair
2033              
2034             Returns or creates the ssh keypair used internally by the manager to
2035             to access staging servers. Usually called internally.
2036              
2037             =cut
2038              
2039             sub keypair {
2040             my $self = shift;
2041             return $self->{keypair} ||= $self->_new_keypair();
2042             }
2043              
2044             sub _security_key {
2045             my $self = shift;
2046             my $ec2 = $self->ec2;
2047             if ($self->reuse_key) {
2048             my @candidates = $ec2->describe_key_pairs(-filter=>{'key-name' => 'staging-key-*'});
2049             for my $c (@candidates) {
2050             my $name = $c->keyName;
2051             my $keyfile = $self->_key_path($name);
2052             return ($c,$keyfile) if -e $keyfile;
2053             }
2054             }
2055             my $name = $self->_token('staging-key');
2056             $self->info("Creating keypair $name.\n");
2057             my $kp = $ec2->create_key_pair($name) or die $ec2->error_str;
2058             my $keyfile = $self->_key_path($name);
2059             my $private_key = $kp->privateKey;
2060             open my $k,'>',$keyfile or die "Couldn't create $keyfile: $!";
2061             chmod 0600,$keyfile or die "Couldn't chmod $keyfile: $!";
2062             print $k $private_key;
2063             close $k;
2064             return ($kp,$keyfile);
2065             }
2066              
2067             sub _security_group {
2068             my $self = shift;
2069             my $ec2 = $self->ec2;
2070             my @groups = $ec2->describe_security_groups(-filter=>{'tag:StagingRole' => 'StagingGroup'});
2071             return $groups[0] if @groups;
2072             my $name = $self->_token('ssh');
2073             $self->info("Creating staging security group $name.\n");
2074             my $sg = $ec2->create_security_group(-name => $name,
2075             -description => "SSH security group created by ".__PACKAGE__
2076             ) or die $ec2->error_str;
2077             $sg->authorize_incoming(-protocol => 'tcp',
2078             -port => 'ssh');
2079             $sg->update or die $ec2->error_str;
2080             $sg->add_tag(StagingRole => 'StagingGroup');
2081             return $sg;
2082              
2083             }
2084              
2085             =head2 $name = $manager->new_volume_name
2086              
2087             Returns a new random name for volumes provisioned without a -name
2088             argument. Currently names are in of the format "volume-12345678",
2089             where the numeric part are 8 random hex digits. Although no attempt is
2090             made to prevent naming collisions, the large number of possible names
2091             makes this unlikely.
2092              
2093             =cut
2094              
2095             sub new_volume_name {
2096             return shift->_token('volume');
2097             }
2098              
2099             =head2 $name = $manager->new_server_name
2100              
2101             Returns a new random name for server provisioned without a -name
2102             argument. Currently names are in of the format "server-12345678",
2103             where the numeric part are 8 random hex digits. Although no attempt
2104             is made to prevent naming collisions, the large number of possible
2105             names makes this unlikely.
2106              
2107             =cut
2108              
2109             sub new_server_name {
2110             return shift->_token('server');
2111             }
2112              
2113             sub _token {
2114             my $self = shift;
2115             my $base = shift or croak "usage: _token(\$basename)";
2116             return sprintf("$base-%08x",1+int(rand(0xFFFFFFFF)));
2117             }
2118              
2119             =head2 $description = $manager->volume_description($volume)
2120              
2121             This method is called to assign a description to newly-created
2122             volumes. The current format is "Staging volume for Foo created by
2123             VM::EC2::Staging::Manager", where Foo is the volume's symbolic name.
2124              
2125             =cut
2126              
2127             sub volume_description {
2128             my $self = shift;
2129             my $vol = shift;
2130             my $name = ref $vol ? $vol->name : $vol;
2131             return "Staging volume for $name created by ".__PACKAGE__;
2132             }
2133              
2134             =head2 $manager->debug("Debugging message\n")
2135              
2136             =head2 $manager->info("Informational message\n")
2137              
2138             =head2 $manager->warn("Warning message\n")
2139              
2140             Prints an informational message to standard error if current
2141             verbosity() level allows.
2142              
2143             =cut
2144              
2145             sub info {
2146             my $self = shift;
2147             return if $self->verbosity < VERBOSE_INFO;
2148             my @lines = split "\n",longmess();
2149             my $stack_count = grep /VM::EC2::Staging::Manager/,@lines;
2150             print STDERR '[info] ',' ' x (($stack_count-1)*3),@_;
2151             }
2152              
2153             sub warn {
2154             my $self = shift;
2155             return if $self->verbosity < VERBOSE_WARN;
2156             my @lines = split "\n",longmess();
2157             my $stack_count = grep /VM::EC2::Staging::Manager/,@lines;
2158             print STDERR '[warn] ',' ' x (($stack_count-1)*3),@_;
2159             }
2160              
2161             sub debug {
2162             my $self = shift;
2163             return if $self->verbosity < VERBOSE_DEBUG;
2164             my @lines = split "\n",longmess();
2165             my $stack_count = grep /VM::EC2::Staging::Manager/,@lines;
2166             print STDERR '[debug] ',' ' x (($stack_count-1)*3),@_;
2167             }
2168              
2169             =head2 $verbosity = $manager->verbosity([$new_value])
2170              
2171             The verbosity() method get/sets a flag that sets the level of
2172             informational messages.
2173              
2174             =cut
2175              
2176             sub verbosity {
2177             my $self = shift;
2178             my $d = ref $self ? $self->verbose : $Verbose;
2179             if (@_) {
2180             $Verbose = shift;
2181             $self->verbose($Verbose) if ref $self;
2182             }
2183             return $d;
2184             }
2185              
2186              
2187             sub _search_for_image {
2188             my $self = shift;
2189             my %args = @_;
2190             my $name = $args{-image_name};
2191              
2192             $self->info("Searching for a staging image...\n");
2193              
2194             my $root_type = $self->on_exit eq 'stop' ? 'ebs' : $args{-root_type};
2195             my @arch = $args{-architecture} ? ('architecture' => $args{-architecture}) : ();
2196              
2197             my @candidates = $name =~ /^ami-[0-9a-f]+/ ? $self->ec2->describe_images($name)
2198             : $self->ec2->describe_images({'name' => "*$args{-image_name}*",
2199             'root-device-type' => $root_type,
2200             @arch});
2201             return unless @candidates;
2202             # this assumes that the name has some sort of timestamp in it, which is true
2203             # of ubuntu images, but probably not others
2204             my ($most_recent) = sort {$b->name cmp $a->name} @candidates;
2205             $self->info("...found $most_recent: ",$most_recent->name,".\n");
2206             return $most_recent;
2207             }
2208              
2209             sub _gather_image_info {
2210             my $self = shift;
2211             my $image = shift;
2212             return {
2213             name => $image->name,
2214             description => $image->description,
2215             architecture => $image->architecture,
2216             kernel => $image->kernelId || undef,
2217             ramdisk => $image->ramdiskId || undef,
2218             root_device => $image->rootDeviceName,
2219             block_devices=> [$image->blockDeviceMapping],
2220             is_public => $image->isPublic,
2221             platform => $image->platform,
2222             virtualizationType => $image->virtualizationType,
2223             hypervisor => $image->hypervisor,
2224             authorized_users => [$image->authorized_users],
2225             };
2226             }
2227              
2228             sub _parse_destination {
2229             my $self = shift;
2230             my $destination = shift;
2231              
2232             my $ec2 = $self->ec2;
2233             my $dest_manager;
2234             if (ref $destination && $destination->isa('VM::EC2::Staging::Manager')) {
2235             $dest_manager = $destination;
2236             } else {
2237             my $dest_region = ref $destination && $destination->isa('VM::EC2::Region')
2238             ? $destination
2239             : $ec2->describe_regions($destination);
2240             $dest_region
2241             or croak "Invalid EC2 Region '$dest_region'; usage VM::EC2::Staging::Manager->copy_image(\$image,\$dest_region)";
2242             my $dest_endpoint = $dest_region->regionEndpoint;
2243             my $dest_ec2 = VM::EC2->new(-endpoint => $dest_endpoint,
2244             -access_key => $ec2->access_key,
2245             -secret_key => $ec2->secret)
2246             or croak "Could not create new VM::EC2 in $dest_region";
2247              
2248             $dest_manager = $self->new(-ec2 => $dest_ec2,
2249             -scan => $self->scan,
2250             -on_exit => 'destroy',
2251             -instance_type => $self->instance_type);
2252             }
2253              
2254             return $dest_manager;
2255             }
2256              
2257             sub match_kernel {
2258             my $self = shift;
2259             my ($src_kernel,$dest) = @_;
2260             my $dest_manager = $self->_parse_destination($dest) or croak "could not create destination manager for $dest";
2261             return $self->_match_kernel($src_kernel,$dest_manager,'kernel');
2262             }
2263              
2264             sub _match_kernel {
2265             my $self = shift;
2266             my ($imageId,$dest_manager) = @_;
2267             my $home_ec2 = $self->ec2;
2268             my $dest_ec2 = $dest_manager->ec2; # different endpoints!
2269             my $image = $home_ec2->describe_images($imageId) or return;
2270             my $type = $image->imageType;
2271             my @candidates;
2272              
2273             if (my $name = $image->name) { # will sometimes have a name
2274             @candidates = $dest_ec2->describe_images({'name' => $name,
2275             'image-type' => $type,
2276             });
2277             }
2278             unless (@candidates) {
2279             my $location = $image->imageLocation; # will always have a location
2280             my @path = split '/',$location;
2281             $location = $path[-1];
2282             @candidates = $dest_ec2->describe_images(-filter=>{'image-type'=>'kernel',
2283             'manifest-location'=>"*/$location"},
2284             -executable_by=>['all','self']);
2285             }
2286             unless (@candidates) { # go to approximate match
2287             my $location = $image->imageLocation;
2288             my @path = split '/',$location;
2289             my @kernels = $dest_ec2->describe_images(-filter=>{'image-type'=>'kernel',
2290             'manifest-location'=>"*/*"},
2291             -executable_by=>['all','self']);
2292             my %k = map {$_=>$_} @kernels;
2293             my %locations = map {my $l = $_->imageLocation;
2294             my @path = split '/',$l;
2295             $_ => \@path} @kernels;
2296              
2297             my %level0 = map {$_ => abs(adistr($path[0],$locations{$_}[0]))} keys %locations;
2298             my %level1 = map {$_ => abs(adistr($path[1],$locations{$_}[1]))} keys %locations;
2299             @candidates = sort {$level0{$a}<=>$level0{$b} || $level1{$a}<=>$level1{$b}} keys %locations;
2300             @candidates = map {$k{$_}} @candidates;
2301             }
2302             return $candidates[0];
2303             }
2304              
2305             # find the most likely ramdisk for a kernel based on preponderant configuration of public images
2306             sub _guess_ramdisk {
2307             my $self = shift;
2308             my $kernel = shift;
2309             my $ec2 = $self->ec2;
2310             my @images = $ec2->describe_images({'image-type' => 'machine',
2311             'kernel-id' => $kernel});
2312             my %ramdisks;
2313              
2314             foreach (@images) {
2315             $ramdisks{$_->ramdiskId}++;
2316             }
2317              
2318             my ($highest) = sort {$ramdisks{$b}<=>$ramdisks{$a}} keys %ramdisks;
2319             return $highest;
2320             }
2321              
2322             sub _check_keyfile {
2323             my $self = shift;
2324             my $keyname = shift;
2325             my $dotpath = $self->dot_directory;
2326             opendir my $d,$dotpath or die "Can't opendir $dotpath: $!";
2327             while (my $file = readdir($d)) {
2328             if ($file =~ /^$keyname.pem/) {
2329             return $1,$self->_key_path($keyname,$1);
2330             }
2331             }
2332             closedir $d;
2333             return;
2334             }
2335              
2336             sub _select_server_by_zone {
2337             my $self = shift;
2338             my $zone = shift;
2339             my @servers = values %{$Zones{$zone}{Servers}};
2340             return $servers[0];
2341             }
2342              
2343             sub _select_used_zone {
2344             my $self = shift;
2345             if (my @servers = $self->servers) {
2346             my @up = grep {$_->ping} @servers;
2347             my $server = $up[0] || $servers[0];
2348             return $server->placement;
2349             } elsif (my $zone = $self->availability_zone) {
2350             return $zone;
2351             } else {
2352             return;
2353             }
2354             }
2355              
2356             sub _key_path {
2357             my $self = shift;
2358             my $keyname = shift;
2359             return File::Spec->catfile($self->dot_directory,"${keyname}.pem")
2360             }
2361              
2362             # can be called as a class method
2363             sub _find_server_in_zone {
2364             my $self = shift;
2365             my $zone = shift;
2366             my @servers = sort {$a->ping cmp $b->ping} values %{$Zones{$zone}{Servers}};
2367             return unless @servers;
2368             return $servers[-1];
2369             }
2370              
2371             sub _servers {
2372             my $self = shift;
2373             my $endpoint = shift; # optional
2374             my @servers = values %Instances;
2375             return @servers unless $endpoint;
2376             return grep {$_->ec2->endpoint eq $endpoint} @servers;
2377             }
2378              
2379             sub _lock {
2380             my $self = shift;
2381             my ($resource,$lock_type) = @_;
2382             $lock_type eq 'SHARED' || $lock_type eq 'EXCLUSIVE'
2383             or croak "Usage: _lock(\$resource,'SHARED'|'EXCLUSIVE')";
2384              
2385             $resource->refresh;
2386             my $tags = $resource->tags;
2387             if (my $value = $tags->{StagingLock}) {
2388             my ($type,$pid) = split /\s+/,$value;
2389              
2390             if ($pid eq $$) { # we've already got lock
2391             $resource->add_tags(StagingLock=>"$lock_type $$")
2392             unless $type eq $lock_type;
2393             return 1;
2394             }
2395            
2396             if ($lock_type eq 'SHARED' && $type eq 'SHARED') {
2397             return 1;
2398             }
2399              
2400             # wait for lock
2401             eval {
2402             local $SIG{ALRM} = sub {die 'timeout'};
2403             alarm(LOCK_TIMEOUT); # we get lock eventually one way or another
2404             while (1) {
2405             $resource->refresh;
2406             last unless $resource->tags->{StagingLock};
2407             sleep 1;
2408             }
2409             };
2410             alarm(0);
2411             }
2412             $resource->add_tags(StagingLock=>"$lock_type $$");
2413             return 1;
2414             }
2415              
2416             sub _unlock {
2417             my $self = shift;
2418             my $resource = shift;
2419             $resource->refresh;
2420             my $sl = $resource->tags->{StagingLock} or return;
2421             my ($type,$pid) = split /\s+/,$sl;
2422             return unless $pid eq $$;
2423             $resource->delete_tags('StagingLock');
2424             }
2425              
2426             sub _safe_update_tag {
2427             my $self = shift;
2428             my ($resource,$tag,$value) = @_;
2429             $self->_lock($resource,'EXCLUSIVE');
2430             $resource->add_tag($tag => $value);
2431             $self->_unlock($resource);
2432             }
2433              
2434             sub _safe_read_tag {
2435             my $self = shift;
2436             my ($resource,$tag) = @_;
2437             $self->_lock($resource,'SHARED');
2438             my $value = $resource->tags->{$tag};
2439             $self->_unlock($resource);
2440             return $value;
2441             }
2442              
2443              
2444             sub _increment_usage_count {
2445             my $self = shift;
2446             my $resource = shift;
2447             $self->_lock($resource,'EXCLUSIVE');
2448             my $in_use = $resource->tags->{'StagingInUse'} || 0;
2449             $resource->add_tags(StagingInUse=>$in_use+1);
2450             $self->_unlock($resource);
2451             $in_use+1;
2452             }
2453              
2454             sub _decrement_usage_count {
2455             my $self = shift;
2456             my $resource = shift;
2457              
2458             $self->_lock($resource,'EXCLUSIVE');
2459             my $in_use = $resource->tags->{'StagingInUse'} || 0;
2460             $in_use--;
2461             if ($in_use > 0) {
2462             $resource->add_tags(StagingInUse=>$in_use);
2463             } else {
2464             $resource->delete_tags('StagingInUse');
2465             $in_use = 0;
2466             }
2467             $self->_unlock($resource);
2468             return $in_use;
2469             }
2470              
2471             sub _dots_cmd {
2472             my $self = shift;
2473             return '' unless $self->verbosity == VERBOSE_INFO;
2474             my ($fh,$dots_script) = tempfile('dots_XXXXXXX',SUFFIX=>'.pl',UNLINK=>1,TMPDIR=>1);
2475             print $fh $self->_dots_script;
2476             close $fh;
2477             chmod 0755,$dots_script;
2478             return "2>&1|$dots_script t";
2479             }
2480              
2481             sub _upload_dots_script {
2482             my $self = shift;
2483             my $server = shift;
2484             my $fh = $server->scmd_write('cat >/tmp/dots.pl');
2485             print $fh $self->_dots_script;
2486             close $fh;
2487             $server->ssh('chmod +x /tmp/dots.pl');
2488             }
2489              
2490             sub _dots_script {
2491             my $self = shift;
2492             my @lines = split "\n",longmess();
2493             my $stack_count = grep /VM::EC2::Staging::Manager/,@lines;
2494             my $spaces = ' ' x (($stack_count-1)*3);
2495             return <
2496             #!/usr/bin/perl
2497             my \$mode = shift || 'b';
2498             print STDERR "[info] ${spaces}One dot equals ",(\$mode eq 'b'?'100 Mb':'100 files'),': ';
2499             my \$b;
2500             READ:
2501             while (1) {
2502             do {read(STDIN,\$b,1e5) || last READ for 1..1000} if \$mode eq 'b';
2503             do {<> || last READ for 1.. 100} if \$mode eq 't';
2504             print STDERR '.';
2505             }
2506             print STDERR ".\n";
2507             END
2508             }
2509              
2510             sub DESTROY {
2511             my $self = shift;
2512             if ($$ == $self->pid) {
2513             my $action = $self->on_exit;
2514             $self->terminate_all_servers if $action eq 'terminate';
2515             $self->stop_all_servers if $action eq 'stop';
2516             }
2517             delete $Managers{$self->ec2->endpoint};
2518             }
2519              
2520              
2521              
2522             1;
2523              
2524              
2525             =head1 SEE ALSO
2526              
2527             L
2528             L
2529             L
2530             L
2531              
2532             =head1 AUTHOR
2533              
2534             Lincoln Stein Elincoln.stein@gmail.comE.
2535              
2536             Copyright (c) 2012 Ontario Institute for Cancer Research
2537              
2538             This package and its accompanying libraries is free software; you can
2539             redistribute it and/or modify it under the terms of the GPL (either
2540             version 1, or at your option, any later version) or the Artistic
2541             License 2.0. Refer to LICENSE for the full license text. In addition,
2542             please see DISCLAIMER.txt for disclaimers of warranty.
2543              
2544             =cut
2545