package StaticFarm::API; use strict; use warnings; use Apache2::Const -compile => qw(:common); use Apache2::RequestIO (); use Apache2::RequestRec (); use Apache2::ServerUtil; use ExtUtils::Command; use File::Path qw(remove_tree); use JSON; use POSIX qw(strftime ctime); use constant IOBUFSIZE => 8192; my $CONTENT_DIR = $ENV{API_CONTENT_DIR}; # ... now setup some serious stuff!! my $URI_PREFIX = '/-api'; sub handler { my $r = shift; $r->content_type('application/json'); my $method = $r->method(); my $d = { method => $method, uri => $r->uri(), args => $r->args(), out => { message => "" }, }; ($d->{path}) = $r->uri() =~ /^$URI_PREFIX(.*)/; $d->{fullpath} = "$CONTENT_DIR$d->{path}"; my %params = map { s/\.\.//g; my ($k, $v) = split '=', $_; $v //= ''; $k => $v; } split '&', $r->args(); $d->{params} = \%params; if ($method eq 'GET') { handler_get($r, $d); } elsif ($method eq 'DELETE') { handler_delete($r, $d); } elsif ($method eq 'POST') { handler_post($r, $d); } elsif ($method eq 'PUT') { handler_put($r, $d); } else { handler_unknown($r, $d); } return Apache2::Const::DONE; } sub data_out { my ($r, $d, $status, $message) = @_; my $p = $d->{params}; $d->{out}{message} = $message if defined $message; $d->{out}{fullpath} = $d->{fullpath}; $status //= 200; $d->{out}{status} = $status; $r->status($status); if (exists $p->{debug} and $p->{debug} == 1) { for (grep !/^out$/, keys %$d) { $d->{out}{debug}{$_} = $d->{$_}; } } print JSON->new->allow_nonref->pretty->encode($d->{out}); } sub my_time { return strftime("%Y-%m-%d %H:%M:%S", localtime(shift)); } sub path_stat { my $f = shift; my @stat = stat($f); my %data = ( size => -s $f, hardlinks => $stat[3], uid => $stat[4], gid => $stat[5], last_access => my_time($stat[8]), last_modified => my_time($stat[9]), last_status_change => my_time($stat[10]), blocks => $stat[12], ascii => (-T $f eq '' ? 0 : 1), is_directory => (-d $f eq '' ? 0 : 1), is_symlink => (-l $f eq '' ? 0 : 1), is_file => (-f $f eq '' ? 0 : 1), ); return \%data; } sub path_ls { my $f = shift; return [ map { s#.*/##; $_ } glob("$f/*") ]; } sub path_exists { my ($r, $d) = @_; unless ( -e $d->{fullpath}) { data_out($r, $d, 404, "No such file or directory: $d->{fullpath}"); return 0; } return 1; } sub path_writable { my ($r, $d) = @_; if (-e $d->{fullpath} && ! -w $d->{fullpath}) { data_out($r, $d, 403, "Error: $d->{fullpath} permission denied."); return 0; } return 1; } sub path_write { my ($r, $d, $content) = @_; return unless path_writable($r, $d); if (defined $content) { if ( -f $d->{fullpath} or ! -e $d->{fullpath} ) { open my $fh, '>', $d->{fullpath} or do { $d->{out}{message} = "Error: $d->{fullpath} $!"; data_out($r, $d, 500); return; }; print $fh $content; close $fh; $d->{out}{message} = "Wrote file successfully."; } else { data_out($r, $d, 500, "Can't put or post content like that. Destination may be a directory."); return; } } else { system("/usr/bin/touch \"$d->{fullpath}\""); $d->{out}{message} = "Touched file or directory successfully."; } $d->{out}{stat} = path_stat($d->{fullpath}); data_out($r, $d); } sub handler_get { my ($r, $d) = @_; my $p = $d->{params}; return unless path_exists($r, $d); $d->{out}{stat} = path_stat($d->{fullpath}); $d->{out}{content} = path_ls($d->{fullpath}) if -d $d->{fullpath} and exists $p->{ls} and $p->{ls} == 1; data_out($r, $d, 200); } sub handler_delete { my ($r, $d) = @_; my $p = $d->{params}; return unless path_exists($r, $d); $d->{out}{stat} = path_stat($d->{fullpath}); if ( -d $d->{fullpath} ) { if (exists $p->{iamsure} and $p->{iamsure} == 1) { my $err; remove_tree($d->{fullpath}, { error => \$err }); unless (@$err) { data_out($r, $d, 200, 'Directory deleted successfully.'); } else { data_out($r, $d, 500, "Directory could not deleted completely. Run ls to see what's left over."); } } else { data_out($r, $d, 403, 'Not removing directory recursively. If you want to do this set iamsure=1.'); } } elsif ( -f $d->{fullpath} ) { if (unlink($d->{fullpath})) { data_out($r, $d, 200, 'File deleted successfully.'); } else { data_out($r, $d, 500, "Error deleting: $d->{fullpath} $!."); } } } sub handler_post { my ($r, $d) = @_; my ($content, $buffer, $len) = ('', '', IOBUFSIZE); $content .= $buffer while $r->read($buffer, $len); path_write($r, $d, $content); } sub handler_put { my ($r, $d) = @_; my $p = $d->{params}; my $content = do { if (exists $p->{content}) { $p->{content}; } else { undef; } }; path_write($r, $d, $content); } sub handler_unknown { my ($r, $d) = @_; data_out($r, $d, 501, "Method $d->{method} is not implemented."); } 1;