#!/opt/local/bin/perl -w
# Copyright © 2007-2021 Jamie Zawinski <jwz@jwz.org>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# This is a script that implements prettier directory listings of MP3 files
# on a web server.  Instead of just listing the file names, it displays the
# MP3 data.  It also includes a magic link that downloads the entire contents
# of a directory as a single ZIP file.
#
# To install:
#
#   - Install a few Perl modules:
#
#       sudo cpan MP3::Tag MP3::Info MP4::Info
#
#   - In this file, edit $base_dir to be the full path name of where your
#     MP3 files live (e.g., your iTunes Media/Music/ directory).
#
#   - Also edit $header_file to point to the HTML file that you want to be
#     the header of each generate page (for title and colors and so on).
#
#   - Install this file in your web server document directory with the
#     name you want for the root of your MP3 tree, e.g.,
#
#       cp ..../mp3dir.pl /var/www/html/MP3
#
#     Don't give it a file extension.  If you call this file "MP3",
#     then the URL you will access it with will be "http://localhost/MP3/"
#
#   - in the .htaccess file in that directory, mark the file as a CGI:
#
#       Options +ExecCGI
#       <Files ~ "^MP3$">
#         SetHandler cgi-script
#       </Files>
#
#   - To make .htaccess files work, you might also need to edit the
#     global /etc/httpd/conf/httpd.conf file:
#
#       AllowOverride All
#
#   - Optional: install slowcat, from https://www.jwz.org/hacks/#slowcat
#     If you do this, then files will be served at a maximum of 100 KB/s.
#     Otherwise, they will be served at full speed.  This is handy if
#     you have a slow uplink and don't want leechers destroying your
#     outbound bandwidth.  Adjust $slowcat and $slowcat_kbps.
#
# Created: 19-Jun-2007.

require 5;
#use diagnostics;
use strict;
use POSIX qw(strftime);
use Encode;
use HTML::Entities;
use utf8;

use open ":encoding(utf8)";

use MP3::Tag;
#use MP3::Info;
use MP4::Info;

my $progname = $0; $progname =~ s@.*/@@g;
my ($version) = ('$Revision: 1.61 $' =~ m/\s(\d[.\d]+)\s/s);

$ENV{PATH} = "/opt/local/bin:/usr/local/bin:$ENV{PATH}"; # for exiftool

my $verbose = 0;

my $base_dir = '/Users/jwz/Music/iTunes/iTunes Media/Music';
my $header_file = '/Library/WebServer/Documents/header.html';

my @zip_video_exclude = ('mov', 'mp4', 'm4v', 'mpg', 'mpeg');


# If this program exists, it will be used to stream files out at
# slower-than-full-speed.  If it doesn't exist, files will be
# served as fast as possible.  https://www.jwz.org/hacks/#slowcat
#
my $slowcat = '/var/www/dnalounge/backstage/src/archiver/slowcat';
my $slowcat_kbps = 10240;  # max kbits per second for sending files.


sub url_quote($) {
  my ($s) = @_;
  $s =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
  return $s;
}

sub url_unquote($) {
  my ($u) = @_;
#  $u =~ s/[+]/ /g;
  $u =~ s/%([a-z0-9]{2})/chr(hex($1))/ige;
  return $u;
}

# Converts &, <, >, " and any UTF8 characters to HTML entities.
#
sub html_quote($) {
  my ($s) = @_;
  return HTML::Entities::encode_entities ($s,
    # Exclude "=042 &=046 <=074 >=076
    '^ \n\040\041\043-\045\047-\073\075\077-\176');
}


sub handle_path($) {
  my ($file) = @_;
  $file = url_unquote($file);

  if ($file eq '' ||		# Redirect "/foo/MP3" to "/foo/MP3/".
      -d "$base_dir$file" && $file !~ m@/$@s) {

    error ("SERVER_NAME undefined") unless $ENV{SERVER_NAME};
    error ("SERVER_PORT undefined") unless $ENV{SERVER_PORT};
    error ("REQUEST_URI undefined") unless $ENV{REQUEST_URI};

    my $url = ((($ENV{HTTPS} && $ENV{HTTPS} eq "on") ? "https" : "http") .
               "://" . $ENV{SERVER_NAME});
    $url .= ":" . $ENV{SERVER_PORT} unless ($ENV{SERVER_PORT} eq '80');
    $url .= $ENV{REQUEST_URI};
    $url .= "/";
    print STDOUT ("Location: $url\r\n" . 
                  "Content-Type: text/plain\r\n\r\n" . 
                  $url . "\r\n");
    return;
  }

  $file = $base_dir . $file;
  if (-d $file) {
    list_dir ($file);
  } elsif ($file =~ m@/([^/]+)/\1\.zip$@si) {
    zip_dir ($file);
  } elsif ($file =~ m@/thumb\.(jpg|png)$@si) {
    thumb_image ($file);
  } else {
    stream_file ($file);
  }
}


sub size_abbr($) {
  my ($s) = @_;
  if ($s < 1024) { return "$s "; }
  $s /= 1024;
  if ($s < 1024) { return sprintf("%d KB", $s); }
  $s /= 1024;
  if ($s < 1024) { return sprintf("%.1f MB", $s); }
  $s /= 1024;
  return sprintf("%.1f GB", $s);
}


sub dir_sortkey($) {
  my ($s) = @_;
  $s = lc($s);
  my $o = $s;

  $s = Encode::decode ('utf8', $s);

  $s =~ s/^[^[:alpha:]\d ]+//s;              # ignore leading non-alphanumeric
  $s = "!! $s" if ($s eq 'compilations');    # sort comps at the top
  $s =~ s/^(the|a|an) //s;		     # ignore leading small words

  $s = "0 $o" if ($s eq '');  # stupid Unicode Witch House bands...

  # sort leading numbers ordinally, at the bottom
  $s = sprintf("\277\277 %08d %s", $1, $2) if ($s =~ m/^(\d+)(.*)$/s);

  # You'd think that Unicode::Normalize::NFKD would help with this, but no.
  $s =~ s/[àáâãäå]/a/gs;
  $s =~ s/æ/ae/gs;
  $s =~ s/ç/c/gs;
  $s =~ s/[èéêë]/e/gs;
  $s =~ s/ß/ff/gs;
  $s =~ s/[ìíîï]/i/gs;
  $s =~ s/ñ/n/gs;
  $s =~ s/[òóôõö]/o/gs;
  $s =~ s/[ùúûü]/u/gs;
  $s =~ s/[ýÿ]/y/gs;

  return $s;
}


# Given a directory, read the first few entries in it looking for an MP3;
# and return the year encoded in that MP3's ID3 tags, if any.
# Prefers the date on the file of track 1; only reads the ID3 of one file.
#
sub guess_album_year($) {
  my ($dir) = @_;
  my $year = '';

  # If the directory name itself begins with a year, just use that.
  # (For "2016 Year-End Picks")
  return $1 if ($dir =~ m@/(\d{4})\b[^/]*/?$@s && $1 > 1900 && $1 < 2100);

  if (opendir (my $dirp, $dir)) {
    my $count = 0;
    my $file = undef;
    foreach (sort (readdir ($dirp))) {
      if (m/\.(mp3|mov|mp4|m4a|m4p|m4v|mpg|mpeg)$/si) {
        $file = $_ unless $file;
        last if (m/^01 /s);
      }
      last if ($count++ > 20);
    }
    closedir $dirp;

    if ($file) {
      my $tags = MP3::Tag->new("$dir/$file");
      if ($tags) {
        $tags->get_tags();
        $year = $tags->year() || '';
      }
      if (! $year) {
        $tags = get_mp4tag ("$dir/$file");
        $year = $tags->{DAY} || ''
          if ($tags);
      }
      if (! $year) {
        # Oh, FFS. Sometimes exiftool works when MP3::Tag does not.
        my $qfile = "$dir/$file";
        $qfile =~ s@([^-a-z\d._/])@\\$1@gsi;
        my $cmd = "exiftool -ContentCreateDate $qfile";
        my $ret = `$cmd 2>&-`;
        chomp ($ret);
        ($year) = ($ret =~ m/^Content *Create *Date *: *([^\s]+)$/s);
      }
    }
  }
  return $year;
}


sub list_dir($) {
  my ($dir) = @_;
  $dir =~ s@/$@@s;
  opendir (my $dirp, $dir) || error ("$dir: $!");
  my @files = sort { dir_sortkey($a) cmp dir_sortkey($b) } readdir ($dirp);
  closedir $dirp;

  my $long_dir_p = (@files > 100);   # probably the root dir or "Compilations"
				     # or something equally unwieldy.

  my $mp3_output  = '';
  my $file_output = '';
  my $mp3_count = 0;

  my $mp3_headline =
    ("<TR>" .
      "<TD></TD>" .
      "<TD><B>Title</B></TD>" .
      "<TD NOWRAP ALIGN=RIGHT><B>Time &nbsp; </B></TD>" .
      "<TD NOWRAP ALIGN=RIGHT><B>Size &nbsp; </B></TD>" .
      "<TD NOWRAP><B>Artist &nbsp; </B></TD>" .
      "<TD NOWRAP><B>Album &nbsp; </B></TD>" .
      "<TD NOWRAP><B>Year &nbsp; </B></TD>" .
      "<TD></TD>" .
     "</TR>\n" .
     "<TR><TD COLSPAN=8><HR></TD></TR>\n"
    );

  my $file_headline =
    ("<TR>" .
      "<TD></TD>" .
      "<TD><B>Name</B></TD>" .
      "<TD><B>Year</B></TD>" .
      "<TD ALIGN=CENTER><B>Last Modified</B></TD>" .
      "<TD NOWRAP ALIGN=RIGHT><B>Size</B></TD>" .
      "<TD></TD>" .
     "</TR>\n" .
     "<TR><TD COLSPAN=8><HR></TD></TR>\n"
    );

  my $i = 1;
  my $prev_file = '';
  foreach my $file (@files) {
    next if ($file =~ m/^\./);
    next if ($file eq "Icon\r");
    next if ($file =~ m/\.(sh|pl|php)$/);

    # When the various MP3 libraries crap out, mention which file it was.
    local $SIG{__WARN__} = sub { 
      print STDERR "$dir/$file: " . shift . "\n";
    };

    # #### Why did I do this?  To normalize something?
    # $file = Encode::encode ('utf8', Encode::decode ('utf8', $file));

    if ($file =~ m/\.(mp3|mov|mp4|m4a|m4p|m4v|mpg|mpeg)$/si) {

      my ($title, $len, $size, $width, $height, $artist, $album, $track,
          $year, $comm);

      # It seems completely random which fields are readable by MP3::Tag,
      # and which are readable by mdls, so we try both and see what we
      # can see.

      # MP3::Tag works on MP3, and sometimes on MP4, M4V and MOV.
      # Does this work on anything that MP3::Info does not?
      #

      MP3::Tag->config ('autoinfo',
                        'ParseData',
                        'ID3v2',
                        'ID3v1',
                        'filename',		# filename before ExifTool,
                        'ImageExifTool',	# However this is required.
                        # Don't need these?
                        # 'CDDB_File',
                        # 'Inf',
                        # 'Cue',
                        # 'ImageSize',
                        # 'LastResort'
                       );

      my $tags = MP3::Tag->new("$dir/$file");
      # error ("$file: unreadable tags?") unless ($mp3);
      if ($tags) {
        $tags->get_tags();
        $title  = $tags->title();
        $len    = $tags->time_mm_ss();
        $artist = $tags->artist();
        $album  = $tags->album();
        $track  = $tags->track();
        $year   = $tags->year();
        $comm   = $tags->comment();
      }

      # Prince kludge
      ($title, $artist, $album) = ($file, '', '', '')
        if ($file =~ m/^Sound Board/s);

      foreach ($title, $artist, $album, $comm) {
        next unless defined($_);

        # Need this for Latin1 in ID3 tags if FB_CROAK is specified...
        # And need it sometimes for ID3 tags with emoji? I don't understand.
        Encode::_utf8_off ($_);

        my $ok = 0;
        eval {
          # $_ = Encode::decode ('utf8', $_, Encode::FB_CROAK);
          $_ = Encode::decode ('utf8', $_);
          $ok = 1; 
        };
        # error ("$dir/$file: $@ ($_)") unless $ok;
        print STDERR "$progname: $dir/$file: $@ ($_)\n" unless $ok;
      }


      # MP3::Info.  Does this work on anything that MP3::Tag does not?
      # I think maybe MP3::Tag calls MP3::Info?
      #
#      $tags = get_mp3tag ("$dir/$file");
#      # error ("$file: unreadable tags?") unless ($tags);
#      if ($tags) {
#        my $info = get_mp3info ("$dir/$file");
#        $title  = $tags->{TITLE}    unless $title;
#        $len    = $info->{TIME}     unless $len;
#        $artist = $tags->{ARTIST}   unless $artist;
#        $album  = $tags->{ALBUM}    unless $album;
#        $track  = $tags->{TRACKNUM} unless $track;
#        $year   = $tags->{YEAR}     unless $year;
#        $comm   = $tags->{COMMENT}  unless $comm;
#
#        # WTF. MP3::Info returns some iTunes bullshit as the comment,
#        # but MP3::Tag does not.
#        $comm = '' if ($comm =~ m/^iTunes_|^iTunNORM|^iTunSMPB/);
#      }

      # MP4::Info works on MP4 and M4V, and sometimes on MOV.
      #
      $tags = get_mp4tag ("$dir/$file");
      if ($tags) {
        $title  = $tags->{NAM}	unless $title;
        $len    = $tags->{SECS}	unless $len;
        $artist = $tags->{ART}	unless $artist;
        $album  = $tags->{ALB}	unless $album;
	$track  = $tags->{TRKN}	unless $track;
        $year   = $tags->{DAY}	unless $year;
        $comm   = $tags->{CMT}	unless $comm;
      }

      # Oh, FFS. Sometimes exiftool works when MP3::Tag does not.
      if (! $year) {
        my $qfile = "$dir/$file";
        $qfile =~ s@([^-a-z\d._/])@\\$1@gsi;
        my $cmd = "exiftool -ContentCreateDate $qfile";
        my $ret = `$cmd 2>&-`;
        chomp ($ret);
        ($year) = ($ret =~ m/^Content *Create *Date *: *([^\s]+)$/s);
      }

      $size = (stat("$dir/$file"))[7];

      # "mdls" works only on MP3s and MOVs.  However it sometimes works on
      # MOVs in cases where MP3::Tag and MP4::Info do not.
      #
      # Update, on 10.8, mdls can't read anything when run by httpd.
      # Mother fuckers.
      #
#      my $qfile = "$dir/$file";
#      $qfile =~ s@([^-a-z\d._/])@\\$1@gsi;
#      my $mdata = `mdls $qfile`;
#
#      error ("$file: unreadable mdata? $qfile") unless ($mdata);
#      $_ = $mdata;
#      s/\\U(\d{4})/{chr(hex($1))}/gse;  # Unicrud: "\U0308"
#      my $k = 'kMDItem';
#      ($title)  = m/^${k}Title        \s+=\s+\" (.*)\"\s*$/xmi  unless $title;
#      ($len)    = m/^${k}DurationSeconds\s+=\s+   (.*)\s*$/xmi;#unless $len;
#      ($size)   = m/^${k}FSSize       \s+=\s+   (.*)\s*$/xmi    unless $size;
#      ($width)  = m/^${k}PixelWidth   \s+=\s+   (.*)\s*$/xmi    unless $width;
#      ($height) = m/^${k}PixelHeight  \s+=\s+   (.*)\s*$/xmi    unless $height;
#      ($artist) = m/^${k}Authors      \s+=\s+\(?\s*\"?([^\"\n]*?)\"?\s*$/xmi
#        unless $artist;
#      ($album)  = m/^${k}Album        \s+=\s+  \"(.*)\"\s*$/xmi unless $album;
#      ($track)  = m/^${k}FSName       \s+=\s+\"(\d\d+)\s.*$/xmi unless $track;
#      ($comm)   = m/^${k}Comment      \s+=\s+\"(.*) \"\s*$/xmi  unless $comm;

      $len    = '' unless $len;
      $size   = 0  unless $size;
      $track  = '' unless $track;
      $year   = '' unless $year;
      $comm   = '' unless $comm;

      if (! $title) {
        $title  = $file;
        $title =~ s/^\d+ //s;
        $title =~ s/\.[a-z\d]+$//s;

        if (!$artist && $title =~ m/^(.*) -- (.*)$/s) {
          $artist = $1;
          $title = $2;
        }
      }

      # If title is "artist -- title", fix it.
      if ($title && $artist) {
        $title =~ s/^\Q$artist\E -- //si;
      }

      # If title is "title (year)", fix it.
      if ($title && $year) {
        $title =~ s/\s*\(\Q$year\E\)$//si;
      }

      if (! $album) {
        ($album) = ($dir =~ m@/([^/]+)/?$@s);
        $album = undef if ($album && $album =~ m/^\d+$/s);
      }

      if (! $artist) {
        ($artist) = ($dir =~ m@/([^/]+)/[^/]+/?$@s);
        $artist = '' if ($artist eq ' Mixtapes'); # kludge
        $artist = '' if ($artist eq 'Compilations'); # kludge
      }

      if ($len =~ m/^[\d.]+$/) {
        $len = int($len);
        $len = sprintf("%d:%02d", $len/60, $len%60);
      } else {
        $len =~ s/^(0)(\d:)/$2/s;
      }

      # For videos on "Unknown Album", replace the album name with
      # a link to a YouTube search.  (Duplicated in itunes-recent.pl)
      #
      my $search = undef;
      if ($file =~ m/\.(mov|mp4|m4v|mpg|mpeg)$/si) {

#        my $qfile = "$dir/$file";
#        $qfile =~ s@([^-a-z\d._/])@\\$1@gsi;
#        $search = `xattr -p user.xdg.origin.url $qfile 2>&-`;
#        chomp ($search);

        if (! $search) {
          my $a = $artist;
          my $t = $title;
          foreach ($a, $t) {
            s/ \(.*?\)//gsi;
           #s/[^-a-z\d._ ]//gsi;
            s/^(.* .*)$/"$1"/gsi;
          }

          $search = "$a, $t, video";
          # Leave UTF8 characters intact in the search string
          # $search = url_quote ($search);
          $search =~ s|([\000-\057\072-\100\133-\140\173-\277])
                      |sprintf("%%%02X", ord($1))|gex;
          $search = 'http://www.youtube.com/results?search_query=' . $search;
        }
      }

      $year =~ s/[.,\s]*$//si if $year;  # Sometimes has trailing commas??

      $track =~ s@/.*@@s if $track;	 # "3/15" => "3".

      $album = 'Unknown Album' unless ($album);

      $comm =~ s/^from (Tivo|VHS)\b/640x480/si; # Kludge

      $comm = '' if ($comm eq 'Created by Grip');  # stupid grip.
      $comm = '' if ($width && $height &&
                     $comm =~ m/^\s*\d+\s*x\s*\d+\s*$/s);

      if (! $width) {
        if ($comm =~ s/^\s*(\d+)\s*x\s*(\d+)\b\s*//s) {
          ($width, $height) = ($1, $2);
        }
      }

      my $wh = "$width&times;$height" if ($width);

      if ($search) {
        if (!$width || !$album || $album eq 'Unknown Album') {
          if ($search =~ m@/watch@s) {
            $album = "<A HREF=\"$search\">YouTube</A>";
          } else {
            $album = "<A HREF=\"$search\">Search YouTube</A>";
          }
        } else {
          $wh = "<A HREF=\"$search\">$wh</A>";
        }
      }

      $size = size_abbr ($size);

      $title  = html_quote ($title);
      $len    = html_quote ($len);
      $size   = html_quote ($size);
      $artist = html_quote ($artist);
      $album  = html_quote ($album) unless ($album =~ m/^<A /s);
      $track  = html_quote ($track);
      $year   = html_quote ($year);
      $comm   = html_quote ($comm);

      $size = "&nbsp; $size &nbsp";
      $size = ("<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=\"100%\">" .
               "<TR><TD NOWRAP>$wh</TD>" .
               "<TD NOWRAP ALIGN=RIGHT>$size</TD></TR></TABLE>")
        if ($width);

      $track =~ s@/@ of @;
      $track =~ s@/.*$@@s;

      # Instead of using the track number in the file, number the files
      # from the top of the directory:
      $track = $i++;

      # But if the file name itself begins with a number, believe that.
      $track = ($1+0) if ($file =~ m/^(\d\d) /s);

      $comm = "<I>$comm</I>" if ($comm);

      my $f2 = $title;
      $f2 = "<SPAN STYLE=\"color:#F00\">$f2</SPAN>"
        unless -f "$dir/$file";
      $title = "<A HREF=\"" . url_quote($file) . "\">$f2</A>";

      $mp3_output .=
       ("<TR>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT>" .
           "<DIV CLASS='trunc'>$track &nbsp; </DIV></TD>" .
         "<TD VALIGN=TOP ALIGN=LEFT>" .
           "<DIV CLASS='trunc title'>$title</DIV></TD>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT>" .
           "<DIV CLASS='trunc'> &nbsp; $len &nbsp; </DIV></TD>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT>" .
           "<DIV CLASS='trunc'>$size</DIV></TD>" .
         "<TD VALIGN=TOP ALIGN=LEFT>" .
           "<DIV CLASS='trunc'>$artist &nbsp; </DIV></TD>" .
         "<TD VALIGN=TOP ALIGN=LEFT>" .
           "<DIV CLASS='trunc'>$album &nbsp; </DIV></TD>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT>" .
           "<DIV CLASS='trunc'>$year &nbsp; </DIV></TD>" .
         "<TD VALIGN=TOP ALIGN=LEFT>" .
           "<DIV CLASS='trunc'>$comm</DIV></TD>" .
         "</TR>\n");

      $mp3_count++ if ($file =~ m/\.mp3$/si);

    } else {					# unknown extension

      my @st = stat("$dir/$file");
      my $size = html_quote (size_abbr ($st[7]));
      my $mod  = html_quote (localtime ($st[9]));

#      my $sk = dir_sortkey($file);
      my $name = $file;
      my $year = '';
      if (-d "$dir/$file") {
        $name .= '/' unless $name =~ m@/$@s;
        $file .= '/' unless $file =~ m@/$@s;
        $size = '-';
        $year = guess_album_year ("$dir/$file") unless ($long_dir_p);
      }
      $name = ("<A HREF=\"" . url_quote($file) . "\">" . 
               html_quote(Encode::decode ('utf8', $name)) . "</A>");
#      $name .= "<TT> [$sk]</TT>";

      # If some file names begin with a space (to make them sort at the top)
      # insert an HR between the "space" files and the "regular" files.
      #
      if ($file =~ m/^[^ ]/s && $prev_file =~ m/^ /s) {
        $file_output .= "<TR><TD COLSPAN=4><HR></TD></TR>\n";
      }

      $mod =~ s@^(... ... ..) (.*)$@<NOBR>$1</NOBR> <NOBR>$2</NOBR>@si;
      $file_output .=
        ("<TR>" .
         "<TD></TD>" .
         "<TD VALIGN=TOP ALIGN=LEFT>$name &nbsp; </TD>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT>$year &nbsp; </TD>" .
         "<TD VALIGN=TOP ALIGN=RIGHT>$mod</TD>" .
         "<TD NOWRAP VALIGN=TOP ALIGN=RIGHT> &nbsp; $size</TD>" .
         "</TR>\n");
      $i++;
    }
    $prev_file = $file;
  }

  if ($file_output && !$long_dir_p) {	# Sort by year
    sub yy($) {
      my ($f) = @_;
      my ($prefix) = ($f =~ m/HREF=\"(\d+)\b/si);  #  "01 Dir/"
      my $r = "9999";
      $r = $1 if ($f =~ m@^.*?<TD.*?<TD.*?<TD[^<>]*>\s*(\d+)@si);  # 4th TD
      $r = "$prefix $r" if $prefix;
      return "$r $f";
    }
    $file_output = join("\n",
                        sort { yy($a) cmp yy($b) }
                        split("\n", $file_output));
  }


  $mp3_output  = $mp3_headline  . $mp3_output  if ($mp3_output);
  $file_output = $file_headline . $file_output if ($file_output);

  open (my $in, '<', $header_file) || error ("$header_file: $!");
  local $/ = undef;  # read entire file
  my $output = <$in>;
  close $in;

  $output .= ("<DIV ALIGN=CENTER><IMG SRC=\"thumb.jpg\"" .
              " STYLE=\"width: 15em; height: auto;" .
              " border: 1px solid #888;\"></DIV>\n")
    if ($mp3_count);

  # Wrap both tables inside another table, to center them,
  # but have them be flush-left relative to each other.
  #
  $output .= ("<P><DIV ALIGN=CENTER>\n" .
              "<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>\n" .
              "<TR><TD>\n")
    if ($mp3_output || $file_output);

  $output .= ("<TABLE BORDER=0 CELLPADDING=1 CELLSPACING=0>\n" .
              $mp3_output . "</TABLE>\n")
    if ($mp3_output);

  $output .= "<P>\n" if ($mp3_output && $file_output);

  $output .= ("<TABLE BORDER=0 CELLPADDING=1 CELLSPACING=0>\n" .
              $file_output . "</TABLE>\n")
    if ($file_output);

  # close outer table
  $output .= ("</TD></TR></TABLE>\n</DIV><P>\n")
    if ($mp3_output || $file_output);


  if ($i > 2 && $i < 100) {

    my $d = $dir;
    $d =~ s@/$@@s;
    $d =~ s@^.*/@@s;
    $d = url_quote($d);

    my $cmd  = "du -Lhs ";
    my $cmd2 = $cmd;
    foreach (@zip_video_exclude) { $cmd2 .= " -I \*.$_"; }
    my $size      = `$cmd  "$dir"`;
    my $novidsize = `$cmd2 "$dir"`;

    $size =~ s/^\s+//s;
    $size =~ s/\s.*$//s;
    $size =~ s/([GM])$/ $1B/s;

    $novidsize =~ s/^\s+//s;
    $novidsize =~ s/\s.*$//s;
    $novidsize =~ s/([GM])$/ $1B/s;

    $output .= "<P ALIGN=CENTER>\n";

    my $vids_p = ($novidsize ne '0B' && $novidsize ne $size);
    if ($vids_p) {
      $output .= ("Zip archive of this directory:<BR>" .
                  "<A HREF=\"$d.zip\">$size (with videos)</A><BR>" .
                  "<A HREF=\"$d.zip?novid=1\">$novidsize (without)</A>\n");
    } else {
      $output .= ("<A HREF=\"$d.zip\">" .
                  "Zip archive of this directory ($size)</A>");
    }
  }
  $output .= "\n<P>\n";
  $output .= "</BODY>\n</HTML>\n";

  $dir = url_unquote ($ENV{REQUEST_URI}) if ($ENV{REQUEST_URI});
  $dir = html_quote (Encode::decode ('utf8', $dir));

  $dir =~ s@(^/|/$)@@gs;
  my @dir = split('/', $dir);
  my $u = "/";
  my $tail = pop @dir;
  foreach my $d (@dir) {
    $u .= "$d/";
    $d = "<A HREF=\"$u\">$d</A>";
  }
  push @dir, $tail;
  $dir = join(" &bull; ", @dir);
  my $tt = $dir;
  $tt =~ s/<[^<>]*>//gs;

  $output =~ s@(<TITLE>.*?)(</TITLE>)@$1: $tt$2@si;
  $output =~ s@(<B>.*?)(</B>)@$1<BR>$dir$2@si;

  binmode (STDOUT, ':utf8');
  print STDOUT ("Content-Type: text/html; charset=UTF-8\n" .
                "Content-Length: " . length ($output) . "\n" .
                "\n" .
                $output);
}


# Get the image data from the ID3 tags of the first MP3 in the directory.
#
sub thumb_image($) {
  my ($file) = @_;
  my ($dir, $ext) = ($file =~ m@^(.*)/[^/]+\.([^/.]+)$@gs);
  error ("unparsable") unless ($ext);

  opendir (my $dirp, $dir) || error ("$dir: $!");
  my @files = sort { dir_sortkey($a) cmp dir_sortkey($b) } readdir ($dirp);
  closedir $dirp;

  foreach my $f2 (@files) {
    next if ($f2 =~ m/^\./);
    next unless ($f2 =~ m/\.mp3$/si);
    $file = $f2;
    last;
  }

  MP3::Tag->config ('autoinfo',
                    'ParseData',
                    'ID3v2',
                    'ImageExifTool',
                   );
  my $tags = MP3::Tag->new("$dir/$file");
  error ("no tags") unless $tags;
  $tags->get_tags();
  my $id3v2 = $tags->{ID3v2};
  error ("no ID3v2") unless $id3v2;

  my ($info, $name, @rest) = $id3v2->get_frame('APIC');
  foreach my $apic ($info, @rest) {
    next unless ref $apic;
    my $data = $apic->{'_Data'};
    next unless $data;
    my $type = $apic->{'MIME type'};
    next unless $type;
    binmode (STDOUT, ':raw');
    print STDOUT ("Content-Type: $type\n" .
                  "Content-Length: " . length($data) . "\n" .
                  "\n" .
                  $data);
    return;
  }
  error ("no images");
}


sub stream_file($) {
  my ($file) = @_;
  
  my $ct = 'application/octet-stream';
  if    ($file =~ m/\.html?$/i)  { $ct = 'text/html';       }
  elsif ($file =~ m/\.mp3$/i)    { $ct = 'audio/mpeg';      }
  elsif ($file =~ m/\.m4[au]$/i) { $ct = 'audio/mpeg';      }
  elsif ($file =~ m/\.aiff?$/i)  { $ct = 'audio/aiff';      }
  elsif ($file =~ m/\.wav$/i)    { $ct = 'audio/wav';       }
  elsif ($file =~ m/\.amr$/i)    { $ct = 'audio/amr';       }
  elsif ($file =~ m/\.m3u$/i)    { $ct = 'audio/mpegurl';   }
  elsif ($file =~ m/\.pls$/i)    { $ct = 'audio/x-scpls';   }
  elsif ($file =~ m/\.ra?m$/i)   { $ct = 'audio/x-pn-realaudio'; }
  elsif ($file =~ m/\.mp4$/i)    { $ct = 'video/mp4';       }
  elsif ($file =~ m/\.m4v$/i)    { $ct = 'video/x-m4v';     }
  elsif ($file =~ m/\.mov$/i)    { $ct = 'video/quicktime'; }
  elsif ($file =~ m/\.mqv$/i)    { $ct = 'video/quicktime'; }
  elsif ($file =~ m/\.qt$/i)     { $ct = 'video/quicktime'; }
  elsif ($file =~ m/\.3gpp?$/i)  { $ct = 'audio/3gpp';      }
  elsif ($file =~ m/\.3gpp?2$/i) { $ct = 'audio/3gpp2';     }
  elsif ($file =~ m/\.3g2$/i)    { $ct = 'video/3g2';       }
  elsif ($file =~ m/\.flv$/i)    { $ct = 'video/x-flv';     }
  elsif ($file =~ m/\.wmv$/i)    { $ct = 'video/x-ms-wmv';  }
  elsif ($file =~ m/\.zip$/i)    { $ct = 'application/zip'; }
  elsif ($file =~ m/\.gif$/i)    { $ct = 'image/gif';       }
  elsif ($file =~ m/\.p?jpe?g$/i){ $ct = 'image/jpeg';      }
  elsif ($file =~ m/\.png$/i)    { $ct = 'image/png';       }
  elsif ($file =~ m/\.te?xt$/i)  { $ct = 'text/plain';      }

  my $size = (stat($file))[7];

  binmode (STDOUT, ($ct =~ m/^text/s ? ':utf8' : ':raw'));

  if (! defined($size)) {
    print STDOUT ("Status: 404\n" .
                  "Content-Type: text/html\n" .
                  "\n" .
                  "<H1>404</H1>\n");
    return;
  }

  my $range_start = undef;
  my $range_end   = undef;
  my $start_byte  = 0;
  my $end_byte    = $size;
  my $length      = $end_byte - $start_byte;
  my $date        = (stat ($file))[7];

  my $headers = "";

  $headers .= "Content-Type: $ct\r\n";

  $headers .= "Last-Modified: " .
    strftime ("%a, %d %b %Y %T GMT", gmtime($date)) . "\n";


  {
    my $http_range = $ENV{HTTP_RANGE};
    if ($http_range) {
      if ($http_range =~ m/^bytes=(\d*)-(\d*)$/) {
        #
        # 0-0 means return the first byte.
        # 0-1 means return the first two bytes.
        # 0-  is the same as 0-0.
        # 1-  is the same as 1-1.
        #
        $range_start = $1 || 0;		# treat invalid "-N" as "0-N".
        $range_end   = $2;
        $range_end = $range_start if ($range_end eq '');
        if ($range_end > $length) {
          error ("Range out of range: ($range_end > $length)",
                 "416 Requested Range Not Satisfiable");
        }
      } else {
        error ("unparsable Range header: $http_range",
               "400 Bad Request");
      }
    }
  }

  my $cl = $length;

  {
    $headers .= "Accept-Ranges: bytes\r\n";

    # The Content-Length header is always the length of the data actually sent.
    if (defined($range_start) || defined($range_end)) {
      $cl = $range_end - $range_start + 1;
    }

    # Always return 206 instead of 200 if there's a range-start, even if
    # the range covers the entire file.  200 would also be appropriate there,
    # but maybe some things get confused?
    #
    if (defined ($range_start)) {
      my $re = $range_end;
      # Need both 206 and Content-Range for WinAmp to do the right thing.
      $headers = "Status: 206 Partial Content\r\n" . $headers;
      $headers .= "Content-Range: bytes $range_start-$re/$length\r\n";
      $end_byte = $start_byte + $range_end;
      $start_byte += $range_start;
    }
  }

  $headers .= "Content-Length: $cl\r\n" if (defined ($cl));

  $headers .= "\r\n";

  print STDOUT $headers;
  $headers = undef;

  if (defined ($cl) && $cl == 0) {	# request for null data.
    return;
  }

  if ($ct =~ m/^(image|text)/s) {	# Let small files go out faster.
    $slowcat_kbps *= 25;
  }

  if ($slowcat) {
    #
    # Overlay this process with the "slowcat" program.
    #
    my @args = ( "--bps", $slowcat_kbps . "k",
                 "--range", $start_byte, $end_byte + 1,
               );
    push @args, ( "--burst", 5 ) if ($ct =~ m/audio|video/si);
    push @args, $file;

    unshift @args, "--verbose" if ($verbose);

    print STDERR "$progname: exec: $slowcat " . join(' ', @args) . "\n"
      if ($verbose);

    exec { $slowcat } ($slowcat, @args );
    die "$progname: exec $slowcat failed: $?\n";

  } else {
    #
    # Cat the file out at full speed.
    #
    open (my $in, '<:raw', $file)  || die "$progname: $file: open: $?\n";
    seek ($in, $start_byte, 0)     || die "$progname: $file: seek: $?\n";

    binmode (STDOUT, ($ct =~ m/^text/si ? ':utf8' : ':raw'));

    print STDERR "$progname: no slowcat!  streaming fast.\n" if ($verbose);

    my $buf = '';
    my $n;
    do {
      $n = read ($in, $buf, 10240);
      print STDOUT $buf;
    } while ($n > 0);
    close ($in);
  }
}


my $tmpfile = undef;
END {
  my $exit = $?;
  unlink $tmpfile if defined ($tmpfile);
  $? = $exit;  # Don't clobber this script's exit code.
}

sub signal_cleanup() { exit (1); }  # This causes END{} to run.

$SIG{TERM} = \&signal_cleanup;  # kill
$SIG{INT}  = \&signal_cleanup;  # shell ^C
$SIG{QUIT} = \&signal_cleanup;  # shell ^|
$SIG{KILL} = \&signal_cleanup;  # nope
$SIG{ABRT} = \&signal_cleanup;
$SIG{HUP}  = \&signal_cleanup;


sub zip_dir($) {
  my ($file) = @_;

  my $dir;
  ($dir, $file) = ($file =~ m@^(.*/)([^/]+)(/[^/]+)$@s);

  unlink $tmpfile if $tmpfile;
  $tmpfile = sprintf ("%s/mp3dir-%08x.zip", ($ENV{TMPDIR} || "/tmp"),
                      rand(0xFFFFFFFF));

  my $zargs = '-ro0D';
  $zargs .= 'q' unless ($verbose);

  chdir ($dir);
  my @cmd = ('nice', 'zip', $zargs, $tmpfile, $file);

  if ($ENV{QUERY_STRING} =~ /(^|&)novid=[^0&]/s) {
    foreach (@zip_video_exclude) {
      push @cmd, ('-x', "*.$_");
    }
  }

  print STDERR "$progname: executing: " . join(' ', @cmd) . "\n"
    if ($verbose);

  unlink $tmpfile;
  system @cmd;

  my $L = (stat ($tmpfile))[7];
  print STDERR "$progname: zip: got $L bytes\n" if ($verbose);

  stream_file ($tmpfile);

  unlink $tmpfile;  # also deleted in "END".
  $tmpfile = undef;
}


my $inside_error_p = 0;

sub error($;$);
sub error($;$) {
  my ($err, $http) = @_;

  die "RECURSIVE: $err" if $inside_error_p;
  $inside_error_p++;

  if (defined($ENV{REQUEST_URI})) {

    my $html = '';
    my $stat = 400;
    my $tmpl = 500;
    my $file = "$tmpl.html";

    if ($http) {
      if ($http =~ m/^(\d\d\d)[:\s]/s) {
        $stat = $1;
      }
    }

    $file = "../$file" unless (-f $file);
    $file = "../$file" unless (-f $file);
    $file = "../$file" unless (-f $file);
    $file = "/var/www/dnalounge/$tmpl.html" unless (-f $file);

    open (my $in, '<', $file) || error ("$file: $!");
    print STDERR "$progname: reading $file\n" if ($verbose > 7);
    local $/ = undef;  # read entire file
    $html = <$in>;
    close $in;

    $err =~ s/^error:\s+//si;
    $err =~ s/^(.)/\u$1/s;
    $err .= '.' if ($err =~ m/[a-z\d]$/s);

    my $title = $http ? $http : $err;

    foreach ($err, $title) {
      $_ = html_quote ("Error: $_");
    }

    $html =~ s@(<TITLE>)[^<>]*@$1DNA Lounge: $title@si;
#   $html =~ s@\b$tmpl\b@$stat@gs;
    $html =~ s@\b$tmpl\b@ERROR@gs;

    $err =~ s/^error:\s*//si;

    $err =~ s/\n/<BR>/gs;

    $err .= "<BR><BR>";
    $html =~ s@(</TR>\s*<TR>\s*<TD[^<>]*>\s*).*?(\s*<P>)@$1$err$2@si;

    print "Status: $stat\n";
    print "Content-Type: text/html\n\n";
    print $html;
    exit (0);

  } else {
    print STDERR "$progname: ERROR: $err\n";
    exit 1;
  }
}

# returns the full path of the named program, or undef.
#
sub which($) {
  my ($prog) = @_;
  return undef unless defined($prog);
  return $prog if ($prog =~ m@^/@s && -x $prog);
  foreach (split (/:/, $ENV{PATH})) {
    return $prog if (-x "$_/$prog");
  }
  return undef;
}


sub usage() {
  print STDERR "usage: $progname [--verbose]\n";
  exit 1;
}

sub main {
  $|=1;

  binmode (STDOUT, ':utf8');
  binmode (STDERR, ':utf8');

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-./) { usage; }
    else { usage; }
  }

  # if the "slowcat" program doesn't exist, stream at full speed.
  $slowcat = which ($slowcat);

  handle_path ($ENV{PATH_INFO} || '');
}


main();
exit 0;