#!/usr/bin/perl use warnings; use strict; use HTTP::Date; use HTTP::Daemon; use HTTP::Status; use HTTP::Response; use IO::File; use File::Find; use Digest::MD5 qw(md5_hex); use Data::Dumper; use XML::RSS; use threads; use threads::shared; die "System variable PERL_SIGNALS needs to be set to 'unsafe'\n. Rerun as 'PERL_SIGNALS=unsafe $0 ...\n" unless ($ENV{'PERL_SIGNALS'} || '') eq 'unsafe'; # -- Map of filenames to { transcoder => ..., filename => ..., count => ...} # use vars qw(%GC $BASE @MEDIA_EXTENSIONS $MAX_RSS $URL); %GC = (); $BASE = '/data/Incoming'; $MAX_RSS = 14; @MEDIA_EXTENSIONS = qw(avi mpg ts mov wmv); my $d = undef; my $port = 8090; $d = new HTTP::Daemon( LocalPort => ++$port ) while !$d; ($URL) = `ifconfig \$(netstat -arn | head -n 3 | awk '{print \$8}' | tail -n 1)` =~ /^\s+inet\s+addr:(\d+\.\d+\.\d+\.\d+) /m; $URL = "http://$URL:$port"; print "Please contact me at: \n"; local $SIG{CHLD} = \&REAPER; local $SIG{PIPE} = \&REAPER; while (my $c = $d->accept) { while (my $r = $c->get_request) { my $resp = HTTP::Response->new(200); if ($r->url->path =~ m!/rss/(.*)!) { my $obj = unescape($1); doRss($c, $r, $resp, $obj); } elsif ($r->url->path =~ m!/do/(.*)!) { my $obj = unescape($1); if (&isMedia("$BASE/$obj")) { serve($c, $r, $resp, $obj); } elsif (-d "$BASE/$obj") { my $content = < mediaserv: $obj

$obj

$title

\n"; $resp->header( 'Content-Type' => 'text/html' ); $resp->content($content); $c->send_response($resp); } else { $c->send_error(RC_NOT_FOUND); } } elsif ($r->url->path =~ m!^/?$!) { $c->send_redirect( "$URL/do/" ); } else { print "Unknown request for ".$r->url->path."\n"; $c->send_error(RC_NOT_FOUND) } } $c->close; undef($c); } exit; # -- Return a list of objects describing the media in a given directory... # sub readmedia { my ($dir) = @_; my @results = (); opendir(DIR, "$BASE/$dir") or return (); $dir =~ s![^/]$!$&/!; foreach my $f (sort readdir(DIR)) { #next if $f =~ /^\./; my $path = "$BASE/$dir$f"; my $type = -d $path ? 'dir' : &isMedia($path) ? 'media' : undef; next unless $type; my $entry = { file => "$dir$f", type => $type, title => $f }; push @results, $entry; } closedir(DIR); return @results; } # -- Is the given file a media file? # sub isMedia { my ($file) = @_; my $regexp = "(".join("|", @MEDIA_EXTENSIONS).")"; return -f $file && ($file =~ /\.$regexp$/i); } # -- Return an RSS feed for the given directory, and everything # underneath it... # sub doRss { my ($c, $r, $resp, $dir) = @_; my @files = (); find(sub { push @files, $File::Find::name if &isMedia($File::Find::name) }, "$BASE/$dir"); @files = (map { s/$BASE\/$dir//; $_ } sort { (stat($b))[9] <=> (stat($a))[9] } @files)[0..$MAX_RSS]; my $rss = new XML::RSS( version => '2.0', encoding => 'utf-8' ); $rss->channel( title => "$dir media", link => "$URL/do/$dir", description => "On-demand content from $dir", pubDate => time2str() ); foreach my $file (reverse(@files)) { $rss->add_item( title => $file, link => "$URL/do/$file", pubDate => time2str((stat("$BASE/$dir/$file"))[9]), mode => 'insert', enclosure => { url => "$URL/do/$file", type => 'video/x-msvideo' }, ); } $resp->header( 'Content-Type' => 'application/xhtml+xml' ); $resp->content( $rss->as_string ); # $resp->header( 'Content-Type' => 'text/plain' ); # $resp->content( Dumper(\@files) ); $c->send_response($resp); } # -- The real meat: serve up a media file, possibly invoking the # transcoder.. # sub serve { my ($c, $r, $resp, $file) = @_; if (!$GC{$file}) { my $avi = '/tmp/'.md5_hex($file).'.avi'; my $child = fork; $GC{$file} = { source => $file, transcoder => $child, filename => $avi, count => 0 }; $GC{$child} = $file; #$GC{$file}; if ($child == 0) { if ($r->method eq 'GET') { print "Starting transcode of $file -> $avi\n"; exec("770-encode", "-q", "$BASE/$file", $avi) unless -f $avi; } exit; } else { print "+++ Transcoding child: $child\n"; sleep 5; } } print "About to start worker: ".Dumper($GC{$file}); my $avi = $GC{$file}->{filename}; my $worker = fork; if ($worker == 0) { open(IN, "<$avi"); $resp->header( 'Content-Type' => 'video/x-msvideo' ); $resp->content( sub { &read_file } ) if $r->method eq 'GET'; $c->send_response($resp); close(IN); exit; } else { print "+++ New worker thread: $worker\n"; $GC{$file}->{count}++; $GC{$worker} = $file; #$GC{$file}; } } # -- Read a file in blocks, in response to an HTTP request... # sub read_file { my $data = ''; my $n = read(IN, $data, 10240); return $data; } # -- Tidy up child processes as they die... # sub REAPER { my $pid = wait; $SIG{CHLD} = \&REAPER; $SIG{PIPE} = \&REAPER; return unless $pid > 0 and $GC{$pid}; print "Tidying up $pid: ".Dumper(\%GC); my $file = $GC{$pid}; delete $GC{$pid}; print "+++ Some child died ($pid): $file...\n"; if ($GC{$file}->{transcoder} and $GC{$file}->{transcoder} == $pid) { print "Transcoder finished.\n"; delete $GC{$file}->{transcoder}; } else { print "Possibly deleting file after 30s...\n"; share($GC{$file}->{count}); my $tid = threads->new(\&tidyWorker, \%GC, $file); print "Tidyup thread started: $tid\n"; } } #-- Thread which deletes media files after no-one's using them... # sub tidyWorker { my ($gcRef, $file) = @_; print "Tidy up thread has: ".Dumper($gcRef); sleep 30; if (--$gcRef->{$file}->{count} <= 0) { my $avi = $gcRef->{$file}->{filename}; print "Last client finished with $file ($avi)\n"; kill 9, $gcRef->{$file}->{transcoder} if $gcRef->{$file}->{transcoder}; unlink $avi; delete $gcRef->{$file}; } else { print "File now in use. Keeping: ".Dumper($gcRef); } } # -- Decode URL-encoded string... # sub unescape { my($todecode) = @_; $todecode =~ tr/+/ /; # pluses become spaces $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; return $todecode; }