File Coverage

blib/lib/Net/PhotoBackup/Server.pm
Criterion Covered Total %
statement 76 139 54.6
branch 21 62 33.8
condition 6 19 31.5
subroutine 15 19 78.9
pod 6 7 85.7
total 124 246 50.4


line stmt bran cond sub pod time code
1             package Net::PhotoBackup::Server;
2              
3 2     2   2539150 use 5.008001;
  2         7  
4 2     2   12 use strict;
  2         4  
  2         47  
5 2     2   19 use warnings;
  2         4  
  2         75  
6              
7             =encoding utf-8
8              
9             =head1 NAME
10              
11             Net::PhotoBackup::Server - perl5 server for https://photobackup.github.io
12              
13             =head1 SYNOPSIS
14              
15             # Initial setup of server config.
16             photobackup.pl init
17              
18             # Launch server using config.
19             photobackup.pl run
20              
21             =head1 DESCRIPTION
22              
23             Net::PhotoBackup::Server provides a server and startup script for
24             L Android app. It was developed by
25             reading the L
26             and looking at the sourcecode of the
27             L and
28             L python implementations.
29              
30             =cut
31              
32 2     2   968 use Data::Dumper; $Data::Dumper::Sortkeys = 1;
  2         6203  
  2         189  
33 2     2   3274 use Digest::SHA ();
  2         12165  
  2         57  
34 2     2   1627 use File::Copy ();
  2         5036  
  2         42  
35 2     2   4949 use File::HomeDir ();
  2         18789  
  2         52  
36 2     2   14 use File::Spec ();
  2         6  
  2         41  
37 2     2   2186 use Plack::Request;
  2         129621  
  2         73  
38 2     2   1502 use Plack::Runner;
  2         16737  
  2         61  
39 2     2   14 use Try::Tiny;
  2         4  
  2         3236  
40              
41             our $VERSION = "0.11";
42 0     0 0 0 sub version { $VERSION }
43              
44             =head2 new()
45              
46             Constructor.
47              
48             Any args will be added to $self, overriding any defaults.
49              
50             =cut
51              
52             sub new {
53 1     1 1 5704 my $class = shift;
54 1         7 my %args = @_;
55              
56 1         13 return bless {
57             config_file => File::Spec->catfile(File::HomeDir->my_home, '.photobackup'),
58             pid => File::Spec->catfile(File::HomeDir->my_home, '.photobackup.pid'),
59             env => 'deployment',
60             daemonize => 1,
61             workers => 3,
62             %args,
63             }, $class;
64              
65             }
66              
67             =head2 init()
68              
69             Create, or recreate the user's config file.
70              
71             The user will be prompted for the following information:
72              
73             Media root - Directory where the pictures will be stored.
74              
75             Server password - The password to use for all HTTP operations.
76              
77             Server port - Defaults to 8420.
78              
79             Some rudimentary checking will be done for valid input.
80              
81             =cut
82              
83             sub init {
84 0     0 1 0 my $self = shift;
85              
86 0         0 my $config = $self->config;
87              
88             do {
89 0 0       0 print "Media root - Where should the pictures be stored" . ($config->{MediaRoot} ? " [$config->{MediaRoot}]: " : ": ");
90 0         0 my $media_root = ;
91 0         0 chomp $media_root;
92 0 0       0 $config->{MediaRoot} = $media_root unless $media_root eq '';
93             }
94 0         0 while ( ! $config->{MediaRoot} );
95 0 0       0 if ( ! -d $config->{MediaRoot} ) {
96 0         0 print "MediaRoot '$config->{MediaRoot}' does not exist. Creating...\n";
97             mkdir $config->{MediaRoot}
98 0 0       0 or die "FATAL: Unable to create '$config->{MediaRoot}' - $!";
99             }
100              
101 0         0 my $password;
102 0         0 do {
103 0         0 print "Server password - The password required for HTTP operations: ";
104 0         0 system "stty -echo";
105 0         0 $password = ;
106 0         0 chomp $password;
107 0         0 print "\n";
108 0         0 system "stty echo";
109             }
110             while ( ! $password );
111 0         0 $config->{Password} = Digest::SHA::sha512_hex $password;
112              
113             do {
114 0   0     0 print "Server port [" . ($config->{Port} || 8420) . "]: ";
115 0         0 my $port = ;
116 0         0 chomp $port;
117 0 0 0     0 $config->{Port} = $port eq '' ? ($config->{Port} || 8420) : $port =~ m{ \A \d+ \z }xms ? $port : undef;
    0          
118             }
119 0         0 while ( ! $config->{Port} );
120              
121 0         0 $self->config($config);
122              
123 0         0 print "\nConfig written. Launch PhotoBackup server with 'photobackup.pl run'\n";
124             }
125              
126             =head2 config()
127              
128             Read and write server config file.
129              
130             Returns undef if config file doesn't exist, or doesn't hold all required
131             data.
132              
133             The config will be written to ~/.photobackup in INI format.
134              
135             I'm reading and writing this simple INI file manually rather than using a
136             CPAN module so as to reduce the dependencies.
137              
138             =cut
139              
140             sub config {
141 1     1 1 2 my $self = shift;
142 1         2 my $config = shift;
143              
144 1         4 my @required_keys = qw( MediaRoot Password Port );
145              
146 1 50       4 if ($config) {
147              
148 0         0 foreach my $key (@required_keys) {
149 0 0       0 die "config() config hashref arg missing '$key'. Got " . Dumper($config) unless $config->{$key};
150             }
151              
152             open my $FH, '>', $self->{config_file}
153 0 0       0 or die "config() unable to open config file '$self->{config_file}' for writing - $!";
154              
155 0         0 print $FH "# Settings for Net::PhotoBackup::Server - perldoc Net::PhotoBackup::Server\n";
156 0         0 print $FH "[photobackup]\n";
157 0         0 foreach my $key (@required_keys) {
158 0         0 print $FH "$key=$config->{$key}\n";
159             }
160              
161 0 0       0 close $FH
162             or die "config() unable to close config file '$self->{config_file}' after writing - $!";
163             }
164             else {
165 1 50       21 if ( -f "$self->{config_file}" ) {
166             open my $FH, '<', $self->{config_file}
167 1 50       35 or die "config() unable to open config file '$self->{config_file}' for reading - $!";
168 1         3 my $in_section;
169 1         15 LINE: foreach my $line ( <$FH> ) {
170 6         8 chomp $line;
171 6 100       19 if ( $in_section ) {
    100          
172 3 50       19 if ( $line =~ m{ \A \s* \[ }xms ) {
173 0         0 last LINE;
174             }
175             # MediaRoot can contain everything but NUL.
176 3 100       20 if ( $line =~ m{ \A \s* MediaRoot \s* = \s* ([^\0]+) \s* \z }xms ) {
    100          
    50          
177 1         5 $config->{MediaRoot} = $1;
178             }
179             # Password is 128 hex digits only.
180             elsif( $line =~ m{ \A \s* Password \s* = \s* ([0-9A-F]{128}) \s* \z }ixms ) {
181 1         4 $config->{Password} = $1;
182             }
183             # Port is just digits.
184             elsif ( $line =~ m{ \A \s* Port \s* = \s* (\d+) \s* \z }xms ) {
185 1         21 $config->{Port} = $1;
186             }
187             }
188             elsif ( $line =~ m{ \A \s* \[ photobackup \] \s* \z }xms ) {
189 1         3 $in_section = 1;
190 1         2 next LINE;
191             }
192             else {
193 2         5 next LINE;
194             }
195             }
196 1         3 foreach my $key (@required_keys) {
197 3 50       16 die "config() config hashref from file '$self->{config_file}' missing '$key'. Got " . Dumper($config) unless $config->{$key};
198             }
199             }
200             }
201 1         5 return $config;
202             }
203              
204             =head2 run()
205              
206             Launch the PhotoBackup web service using config from the conf file.
207              
208             =cut
209              
210             sub run {
211 0     0 1 0 my $self = shift;
212              
213 0 0       0 $self->init unless $self->config;
214              
215 0         0 my $config = $self->config;
216              
217             my $runner = Plack::Runner->new(
218             daemonize => $self->{daemonize},
219             env => $self->{env},
220 0         0 server => 'Starman',
221             version_cb => \&version
222             );
223             $runner->parse_options(
224             '--port' => $config->{Port},
225             '--workers' => $self->{workers},
226             '--pid' => $self->{pid},
227 0         0 );
228 0         0 $runner->run( $self->app );
229            
230             }
231              
232             =head2 stop()
233              
234             Kill any running PhotoBackup web service.
235              
236             =cut
237              
238             sub stop {
239 0     0 1 0 my $self = shift;
240              
241 0 0       0 return unless -f $self->{pid};
242              
243 0         0 my $pid = do { local( @ARGV, $/ ) = $self->{pid} ; <> };
  0         0  
  0         0  
244 0         0 chomp $pid;
245              
246 0 0       0 kill 'TERM', $pid if $pid;
247              
248 0         0 unlink $self->{pid};
249             }
250              
251             =head2 app()
252              
253             Return the PSGI application subref.
254              
255             =cut
256              
257             sub app {
258 1     1 1 114 my $self = shift;
259 1   33     10 my $config = shift || $self->config;
260              
261             return sub {
262 4     4   28267 my $env = shift; # PSGI env
263            
264 4         33 my $req = Plack::Request->new($env);
265 4         40 my $path_info = $req->path_info;
266 4         32 my $method = $req->method;
267 4         26 my $post_vars = $req->body_parameters;
268              
269 4 100 66     1255 if ( $path_info eq '' || $path_info eq '/' ) {
    50          
270 1 50       13 if ( $method eq 'GET' ) {
    0          
271             # GET / : Redirect to https://photobackup.github.io/
272 1         13 return [301, [ Location => 'https://photobackup.github.io/' ], []];
273             }
274             elsif ( $method eq 'POST' ) {
275             # POST / : Store new image file in MediaRoot. Needs password.
276 0 0 0     0 if ( ! length $post_vars->{password} || $post_vars->{password} ne $config->{Password} ) {
277 0         0 return [ 403, [], [ "403 - wrong password!" ] ];
278             }
279 0         0 my $upload = $req->uploads->{upfile};
280 0 0 0     0 if ( ! $upload || ! -f $upload->path ) {
281 0         0 return [ 401, [], [ "401 - no file in the request!" ] ];
282             }
283 0         0 my $filesize = $req->body_parameters->{filesize};
284 0 0       0 if ( ! $filesize ) {
285 0         0 return [ 400, [], [ "400 - missing file size in the request!" ] ];
286             }
287 0         0 my $store_path = File::Spec->catfile($config->{MediaRoot}, $upload->basename);
288 0         0 File::Copy::move $upload->path, $store_path;
289              
290 0         0 return [ 200, [], [ "200 - file stored" ] ];
291              
292             }
293             }
294             elsif ( $path_info eq '/test' ) {
295             # POST /test : Check password, then attempt to write test file to MediaRoot.
296 3 100 100     22 if ( ! length $post_vars->{password} || $post_vars->{password} ne $config->{Password} ) {
297 2         22 return [ 403, [], [ "403 - wrong password!"]];
298             }
299 1 50       62 if ( ! -d $config->{MediaRoot} ) {
300 0         0 return [ 500, [], [ "500 - MediaRoot '$config->{MediaRoot}' does not exist" ]];
301             }
302 1         20 my $tmp_file = File::Spec->catfile($config->{MediaRoot}, '__photobackup_test_file_' . $$);
303             try {
304 1         186 open my $FH, '>', $tmp_file;
305 1         12 print $FH 'TEST';
306 1         62 unlink $tmp_file;
307 1         192 return [ 200, [], [ "200 - All tests passed" ]];
308             }
309             catch {
310 0           return [ 500, [], [ "500 - Can't write to MediaRoot '$config->{MediaRoot}'" ]];
311 1         11 };
312             }
313              
314 1         8 };
315             }
316              
317             1;
318              
319             __END__