File Coverage

lib/Provision/Unix/Web.pm
Criterion Covered Total %
statement 54 81 66.6
branch 19 46 41.3
condition 2 27 7.4
subroutine 8 11 72.7
pod 1 6 16.6
total 84 171 49.1


line stmt bran cond sub pod time code
1             package Provision::Unix::Web;
2             # ABSTRACT: provision web hosting accounts
3              
4 2     2   1374 use strict;
  2         4  
  2         58  
5 2     2   9 use warnings;
  2         3  
  2         77  
6              
7             our $VERSION = '0.09';
8              
9 2     2   9 use Params::Validate qw( :all );
  2         3  
  2         348  
10              
11 2     2   11 use lib "lib";
  2         3  
  2         11  
12              
13             my ( $prov, $util );
14              
15             sub new {
16 1     1 1 39 my $class = shift;
17              
18 1         80 my %p = validate(
19             @_,
20             { prov => { type => OBJECT },
21             debug => { type => BOOLEAN, optional => 1, default => 1 },
22             fatal => { type => BOOLEAN, optional => 1, default => 1 },
23             }
24             );
25              
26 1         20 my $self = {
27             debug => $p{debug},
28             fatal => $p{fatal},
29             };
30 1         7 bless( $self, $class );
31              
32 1         3 $prov = $p{prov};
33 1         5 $prov->audit("loaded Web");
34 1 50       9 $self->{server} = $self->_get_server( debug => $p{debug}, fatal => $p{fatal} )
35             or return;
36              
37 1         4 $util = $prov->get_util;
38 1         7 return $self;
39             }
40              
41             sub create {
42 1     1 0 2 my $self = shift;
43 1         7 return $self->{server}->create(@_);
44             }
45              
46             sub enable {
47 0     0 0 0 my $self = shift;
48 0         0 return $self->{server}->enable(@_);
49             };
50              
51             sub disable {
52 0     0 0 0 my $self = shift;
53 0         0 return $self->{server}->disable(@_);
54             };
55              
56             sub _get_server {
57              
58 1     1   3 my $self = shift;
59              
60 1         27 my %p = validate(
61             @_,
62             { debug => { type => BOOLEAN, optional => 1, default => 1 },
63             fatal => { type => BOOLEAN, optional => 1, default => 1 },
64             }
65             );
66              
67 1 50       12 my $chosen_server = $prov->{config}{Web}{server}
68             or $prov->error( 'missing [Web] server setting in provision.conf',
69             debug => $p{debug},
70             fatal => $p{fatal},
71             );
72              
73 1 50       6 return if ! $chosen_server;
74              
75 1 50       4 if ( $chosen_server eq "apache" ) {
    0          
76 1         1457 require Provision::Unix::Web::Apache;
77 1         17 return Provision::Unix::Web::Apache->new(
78             prov => $prov,
79             web => $self,
80             debug => $p{debug},
81             fatal => $p{fatal},
82             );
83             }
84             elsif ( $chosen_server eq "lighttpd" ) {
85 0         0 require Provision::Unix::Web::Lighttpd;
86 0         0 return Provision::Unix::Web::Lighttpd->new(
87             prov => $prov,
88             web => $self,
89             debug => $p{debug},
90             fatal => $p{fatal},
91             );
92             }
93             else {
94 0         0 return $prov->error( "unknown web server. Supported values are lighttpd and apache.",
95             debug => $p{debug},
96             fatal => $p{fatal},
97             );
98             }
99              
100 0         0 return;
101              
102             # use Data::Dumper;
103             # print "\n\n";
104             # print Dumper($request);
105             }
106              
107             sub get_vhost_attributes {
108              
109 2     2 0 1388 my $self = shift;
110              
111 2         46 my %p = validate(
112             @_,
113             { 'request' => { type => HASHREF, optional => 1 },
114             'prompt' => { type => BOOLEAN, optional => 1, default => 0 },
115             },
116             );
117              
118 2         12 my $vals = $p{'request'};
119              
120 2 50       6 if ( $p{'prompt'} ) {
121 0   0     0 $vals->{'vhost'} ||= $util->ask( 'vhost name' );
122             }
123              
124 2 50       6 my $vhost = $vals->{'vhost'}
125             or $prov->error( "vhost is required" );
126              
127 2 50       5 if ( $p{'prompt'} ) {
128 0   0     0 $vals->{'ip'} ||= $util->ask( 'ip', default => '*:80' );
129 0   0     0 $vals->{'serveralias'}
130             ||= $util->ask( 'serveralias', default => "www.$vhost" );
131             }
132              
133 2 50       8 if ( !$vals->{'documentroot'} ) {
134              
135             # calculate a default documentroot
136 2   50     16 my $vdoc_root = $prov->{config}{'Web'}{'vdoc_root'} || "/home";
137 2   50     10 my $vdoc_suffix = $prov->{config}{'Web'}{'vdoc_suffix'} || "html";
138 2         4 my $docroot = "$vdoc_root/$vhost/$vdoc_suffix";
139              
140 2 50       6 if ( $p{'prompt'} ) {
141              
142             # prompt with a sensible default
143 0         0 $vals->{'documentroot'}
144             = $util->ask( 'documentroot', default => $docroot );
145             }
146             else {
147 2         5 $vals->{'documentroot'} = $docroot;
148             }
149             }
150              
151 2 50       5 if ( $p{'prompt'} ) {
152 0   0     0 $vals->{'ssl'} ||= $util->ask( 'ssl' );
153             }
154              
155 2 50       5 if ( $vals->{'ssl'} ) {
156 0   0     0 my $certs = $prov->{config}{'Web'}{'sslcerts'}
157             || "/usr/local/etc/apache2/certs";
158              
159 0 0       0 if ( $p{'prompt'} ) {
160 0   0     0 $vals->{'sslcert'} ||= $util->ask( 'sslcert',
161             default => "$certs/$vhost.crt"
162             );
163 0   0     0 $vals->{'sslkey'} ||= $util->ask( 'sslkey',
164             default => "$certs/$vhost.key"
165             );
166             }
167             }
168              
169 2         9 while ( my ( $key, $val ) = each %$vals ) {
170 4 50       10 next if $key eq "debug";
171 4 50       8 next if $key eq "phpmyadmin";
172 4 50       11 next if $key =~ /ssl/;
173 4 50       9 next if $key =~ /custom/;
174 4 50       9 next if $key eq "options";
175 4 50       6 next if $key eq "verbose";
176 4 50       5 next if $key eq "redirect";
177              
178 4 50       16 $util->ask( $key ) if !defined $val;
179             }
180              
181 2         10 return $vals;
182             }
183              
184             sub check_apache_setup {
185              
186 0     0 0   my $self = shift;
187 0           my $conf = $self->{'conf'};
188              
189 0           my %r;
190              
191             # make sure apache etc dir exists
192 0           my $dir = $conf->{'apache_dir_etc'};
193 0 0 0       unless ( $dir && -d $dir ) {
194             return {
195 0           'error_code' => 401,
196             'error_desc' =>
197             'web_check_setup: cannot find Apache\'s conf dir! Please set apache_dir_etc in sysadmin.conf.\n'
198             };
199             }
200              
201             # make sure apache vhost setting exists
202 0           $dir = $conf->{'apache_dir_vhosts'};
203              
204             #unless ( $dir && (-d $dir || -f $dir) ) # can also be a fnmatch pattern!
205 0 0         unless ($dir) {
206             return {
207 0           'error_code' => 401,
208             'error_desc' =>
209             'web_check_setup: cannot find Apache\'s vhost file/dir! Please set apache_dir_vhosts in sysadmin.conf.\n'
210             };
211             }
212              
213             # all is well
214             return {
215 0           'error_code' => 200,
216             'error_desc' => 'web_check_setup: all tests pass!\n'
217             };
218             }
219              
220             1;
221              
222              
223              
224             =pod
225              
226             =head1 NAME
227              
228             Provision::Unix::Web - provision web hosting accounts
229              
230             =head1 VERSION
231              
232             version 1.06
233              
234             =head1 SYNOPSIS
235              
236             Provision web hosting accounts.
237              
238             use Provision::Unix::Web;
239              
240             my $foo = Provision::Unix::Web->new();
241             ...
242              
243             =head1 FUNCTIONS
244              
245             =head2 new
246              
247             Creates and returns a new Provision::Unix::Web object.
248              
249             =head1 BUGS
250              
251             Please report any bugs or feature requests to C<bug-unix-provision-web at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Provision-Unix>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
252              
253             =head1 SUPPORT
254              
255             You can find documentation for this module with the perldoc command.
256              
257             perldoc Provision::Unix
258              
259             You can also look for information at:
260              
261             =over 4
262              
263             =item * RT: CPAN's request tracker
264              
265             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Provision-Unix>
266              
267             =item * AnnoCPAN: Annotated CPAN documentation
268              
269             L<http://annocpan.org/dist/Provision-Unix>
270              
271             =item * CPAN Ratings
272              
273             L<http://cpanratings.perl.org/d/Provision-Unix>
274              
275             =item * Search CPAN
276              
277             L<http://search.cpan.org/dist/Provision-Unix>
278              
279             =back
280              
281             =head1 ACKNOWLEDGEMENTS
282              
283             =head1 AUTHOR
284              
285             Matt Simerson <msimerson@cpan.org>
286              
287             =head1 COPYRIGHT AND LICENSE
288              
289             This software is copyright (c) 2013 by The Network People, Inc..
290              
291             This is free software; you can redistribute it and/or modify it under
292             the same terms as the Perl 5 programming language system itself.
293              
294             =cut
295              
296              
297             __END__
298              
299