#!/usr/bin/perl

##!/usr/bin/perl -w
# (the Shout library causes warnings if we use -w)

# shout-archive.pl --- feeds files from the archive to an icecast server,
# one after another.
#
# Copyright © 2001-2013 Jamie Zawinski <jwz@dnalounge.com>
#
# 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.
#
# Created: 22-Jul-01.

require 5;
#use diagnostics;
use strict;

use Socket;
require POSIX;
use IPC::Open2;

use Shout;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.14 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

my $verbose = 0;
my $public_p = 0;
my $debug_p = 0;

my $max_age = 15;	# ignore any files older than this many days


my $slowcat = "/home/jwz/src/archiver/slowcat";
my $bps = "128";

my $conn;  # icecast shout connection

my $archive_loc   = "DNA Lounge";
my $archive_name  = "dnalounge.com";
my $archive_iurl  = "http://www.dnalounge.com/audio/";
my $archive_genre = "whatever";

my @months = ("January", "February", "March", "April", "May", "June", "July",
              "August", "September", "October", "November", "December");
my @days   = ("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday",
              "Saturday");

sub error {
  ($_) = @_;
  print STDERR "$progname: $_\n";
  exit 1;
}



# Returns a sorted list of the MP3 files in the directory.
# Skips files older than $max_age.
#
sub archive_files {
  my ($dir) = @_;
  $dir =~ s@/+$@@;
  my @files;

  my @allfiles = ();

  my $now = time;

  opendir (my $ddir, "$dir") || error "$dir: $!";
  foreach my $y (readdir($ddir)) {
    if ($y =~ m/^\d{4}$/) {
      opendir (my $ydir, "$dir/$y") || error "$dir/$y: $!";
      foreach my $m (readdir($ydir)) {
        push @allfiles, "$dir/$y/$m";
      }
      closedir ($ydir);
    }
  }
  closedir ($ddir);

  @allfiles = sort (@allfiles);

  my $newest_file = "";
  my $newest_date = 0;
  foreach my $file (@allfiles) {
    next if ($file =~ m@/\.@);
    next unless ($file =~ m/\.mp3$/);
    my $date = (stat($file))[9];
    my $age_days = int (($now - $date) / (60 * 60 * 24));
    if ($age_days > $max_age) {
      print STDERR "$progname: skipping $file ($age_days days old)...\n"
        if ($verbose > 2);
      next;
    }
    if ($date >= $newest_date) {
      $newest_file = $file;
      $newest_date = $date;
    }
    push @files, $file;
  }

  # return a sorted list of all the mp3 files under the directory,
  # excluding the most-recently-written mp3 file.
  # Unless that file was written more than 24 hours ago, in
  # which case, it's ok.

  $newest_file = "" if ($newest_date < ($now - (60 * 60 * 24)));

  my @files2;
  foreach my $file (@files) {
    push @files2, $file unless ($file eq $newest_file);
  }

  if ($verbose > 2) {
    foreach my $file (@files2) {
      print STDERR "$progname:  keeping $file\n";
    }
  }

  print STDERR "$progname: $dir: " . ($#files2+1) . " files\n"
    if ($verbose > 1);

  # if there's only one file, use it!
  if ($#files2 < 0 && $newest_file) {
    print STDERR "$progname: ugh! only one file! $newest_file\n"
      if ($verbose > 1);
    @files2 = ($newest_file);
  }

  return @files2;
}


# Make a guess as to what the most-recently-played archive file is,
# from the given files.
#
sub guess_last_file {
  my (@files) = @_;

  my ($candidate_file, $candidate_time);

  foreach my $file (@files) {
    my @st = stat ($file);
    my $atime = $st[8];
    my $mtime = $st[9];

    # This file is not a candidate if has not been read since it was written.
    # That would mean this is the most-recently-written file, but that it
    # has not been played back yet.
    #
    next if ($mtime >= $atime);

    # This file is the best candidate so far if it is the first candidate;
    # or if it has a later access time than the previous candidate.
    #
    if (!defined($candidate_time) ||
        $atime > $candidate_time) {
      $candidate_file = $file;
      $candidate_time = $atime;
    }
  }

  print STDERR "$progname: last-played file guess: $candidate_file\n"
    if ($verbose > 2);

  return $candidate_file;
}


sub pick_file {
  my ($last_file, @files) = @_;

  # If there is a $last_file, return the next file after it in the list.
  # If there is no $last_file, return the first file in the list.
  #
  my $file = undef;
  my $found = !defined($last_file);
  foreach my $ff (@files) {
    if (!$found && $ff eq $last_file) {
      $found = 1;
    } elsif ($found) {
      $file = $ff;
      last;
    }
  }

  # If the $last_file was the last one in the list, wrap around to the first.
  $file = $files[0] unless ($file);

  return $file;
}


sub slowcat_archive {
  my ($dir, $url, $pass, $metafile) = @_;

  open_shouter ($url, $pass);

  my @files = archive_files ($dir);
  my $file = guess_last_file (@files);

  while (1) {
    $file = pick_file ($file, @files);
    error ("no files to stream found in $dir") unless $file;
    slowcat_one_file ($file, $url, $pass, $metafile);
    @files = archive_files ($dir);  # re-read the directory
  }
}


sub open_shouter {
  my ($url, $pass) = @_;

  if ($debug_p) {
    print STDERR "$progname: debug: open $url\n";
    sleep 1;
    return;
  }

  my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
  if (! ($url_proto && $url_proto =~ m/^http:$/i)) {
    error "not an HTTP URL: $url\n";
  }

  $path = "" unless $path;

  my ($them, $port) = split(/:/, $serverstring);
  $port = 80 unless $port;


  print STDERR "$progname: writing to http://$them:$port/$path\n"
    if ($verbose);

  my $server_protocol;				# Shout 1.1
  # try and guess which icecast server is running...
  if (-f "/usr/local/icecast/etc/icecast.xml") {
    $server_protocol = SHOUT_PROTOCOL_HTTP;
  } else {
    $server_protocol = SHOUT_PROTOCOL_XAUDIOCAST,
  }

  $conn = new Shout
#   ip  		=> $them,		# Shout 1.0
    host  		=> $them,		# Shout 1.1
    port		=> $port,
    mount		=> $path,
    password		=> $pass,
#   icy_compat		=> 0,			# Shout 1.0
    dumpfile		=> undef,
    name		=> $archive_name,
    url			=> $archive_iurl,
    genre		=> $archive_genre,
    description		=> $archive_name,
#   bitrate		=> $bps,		# Shout 1.0
    format		=> SHOUT_FORMAT_MP3,	# Shout 1.1
    protocol		=> $server_protocol,    # Shout 1.1 for icecast2

						# Shout 1.0
#   ispublic		=> $public_p    # set this to what "--public" said
						# Shout 1.1
    public		=> $public_p    # set this to what "--public" said
      ;

# $conn->connect || error "shout connect: " . $conn->error;  # Shout 1.0

  if (! $conn->open) {				# Shout 1.1
    print STDERR "$progname: couldn't connect: " . $conn->get_error . "\n";
    exit $conn->get_errno;
  }

  print STDERR "$progname: connected\n" if ($verbose > 1);
}



sub slowcat_one_file {
  my ($file, $url, $pass, $metafile) = @_;

  my $desc = read_desc_file ($file);
  update_metadata ($metafile, $desc);

  my $cmd = "$slowcat --bps ${bps}k $file";
  print STDERR "$progname: command: $cmd\n" if ($verbose);

  if ($debug_p) {
    sleep 1;
    return;
  }

  open (my $in, "$cmd |") || error "exec: $!";

  my ( $buffer, $bytes ) = ( '', 0 );
  while ( ($bytes = sysread ($in, $buffer, 4096)) > 0 ) {

#   $conn->sendData ($buffer) ||			# Shout 1.0
#     die "$progname: write: ", $conn->error, "\n";

    if (! $conn->send_data ($buffer)) {			# Shout 1.1
      print STDERR "$progname: write: " . $conn->get_error . "\n";
      exit 2;
    }

    print STDERR "$progname: wrote " . length($buffer) . " bytes\n"
      if ($verbose > 2);

    $conn->sync;					# Shout 1.1
  }
  $buffer = undef;
  close $in;
}


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

  # get time of mp3 file
  my @st = stat($file);
  my $tt = $st[9];

  # if there's a .time file, get time of that instead
  $file =~ s/\.[^.]+$/.time/;
  @st = stat($file);
  $tt = $st[9] if (@st);

  my ($sec,$min,$hour,$dotm,$mon,$year,$dotw,$yday,$isdst) = localtime($tt);
  $mon = $months[$mon];
  $mon =~ s/^(...).*$/$1/;
  $dotw = $days[$dotw];
  $dotw =~ s/^(...).*$/$1/;

  return "$dotw, $mon $dotm";
}


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

  my $intro = "$archive_loc: " . file_timestring ($file);

  $file =~ s/\.[^.]+$/.desc/;

  if (! -f $file) {
#    print STDERR "$progname: $file does not exist\n" if ($verbose);
    return $intro;
  }

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

  $body =~ s/^([^\s]+\.html)\n//si;  # lose html file name on first line

  $body =~ s/<BR>/\n/g;     # convert newlines
  $body =~ s/<P>/\n\n/g;    # convert paragraphs
  $body =~ s/<[^>]+>//g;    # delete HTML tags
  $body =~ s/[ \t]+/ /g;    # compress horizontal whitespace
  $body =~ s/^\s+//gm;      # delete leading whitespace
  $body =~ s/\s+$//gm;      # delete trailing whitespace

  $body =~ s/\n+/ -- /g;    # convert newlines to dashes

  return $intro if ($body eq "");
  return "$intro: $body";
}


sub update_metadata {
  my ($file, $desc) = @_;
  if (!$debug_p) {
    open (my $out, '>', $file)  || error "$file: $!";
    (print $out "$desc\n") || error "$file: $!";
    close ($out) || error "$file: $!";
  }
  print STDERR "$progname: wrote $file ($desc)\n" if ($verbose > 1);
}


sub usage {
  print STDERR "usage: $progname [--verbose] [--public] " .
    "directory out-url password metadata-file\n";
  exit 1;
}

sub main {
  my $dir = undef;
  my $url = undef;
  my $pass = undef;
  my $metafile = undef;
  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif ($_ eq "--debug") { $debug_p++; }
    elsif (m/^-./) { usage; }
    elsif (!defined($dir)) { $dir = $_; }
    elsif (!defined($url)) { $url = $_; }
    elsif (!defined($pass)) { $pass = $_; }
    elsif (!defined($metafile)) { $metafile = $_; }
    else { usage; }
  }

  usage unless ($dir && $url && $pass && $metafile);
  error "not an HTTP URL: $url" unless ($url =~ m@^http://@);

  slowcat_archive ($dir, $url, $pass, $metafile);
}

main;
exit 0;