#!/usr/bin/perl

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

# shout-randomly.pl --- feeds MP3 files from a directory to an icecast server,
# one after another, selecting files randomly.
#
# 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 LWP::UserAgent;
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 $slowcat = "/home/jwz/src/archiver/slowcat";
my $bps = "128";

my $conn;  # icecast shout connection

my $archive_loc   = "DNA Lounge";
my $archive_name  = "DNA Lounge Radio";
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");

# Permutes the array (reference) in place.  "Fisher Yates Shuffle".
#
sub shuffle_array($) {
  my ($array) = @_;
  for (my $i = @$array; --$i;) {
    my $j = int rand ($i+1);
    next if ($i == $j);
    @$array[$i,$j] = @$array[$j,$i];
  }
}


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

  if (opendir (my $dirh, $dir)) {
    foreach (readdir($dirh)) {
      next if (m/^\./);
      my $f = "$dir/$_";
      if (m/\.mp3$/) {
        push @files, $f;
      } elsif (-d $f) {
        push @files, archive_files ($f);
      }
    }
    closedir ($dirh);
  } else {
    print STDERR blurb() . "$dir: $!\n";
  }

  return sort @files;
}


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

  my $metadata = "$dir/metadata.txt";

  open_shouter ($url, $pass);

  while (1) {
    my @files = archive_files ($dir);
    print STDERR blurb() . ($#files + 1) . " files\n" if ($verbose);
    error ("no files to stream found in $dir") unless ($#files > 0);
    shuffle_array (\@files);
    foreach my $file (@files) {
      slowcat_one_file ($file, $url, $pass, $metadata);
    }
  }
}


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

  if ($debug_p) {
    print STDERR blurb() . "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 blurb() . "writing to http://$them:$port/$path\n"
    if ($verbose);

  my $server_protocol;				# Shout 1.1
  $server_protocol = SHOUT_PROTOCOL_HTTP;

  $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 blurb() . "couldn't connect: " . $conn->get_error . "\n";
    exit $conn->get_errno;
  }

  print STDERR blurb() . "connected\n" if ($verbose > 1);
}


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

  print STDERR blurb() . "picked $file\n" if ($verbose);

  my $file2 = $file;
  $file2 =~ s@(["\$])@\\$1@g;
#  my $desc = `id3v2 --list "$file2"`;
  my $desc = `id3info "$file2"`;
  $desc =~ s/^=* *//gm;
  my ($artist) = ($desc =~ m/^TPE?1.*?:\s*(.*)$/m);
  my ($album)  = ($desc =~ m/^TALB?.*?:\s*(.*)$/m);
  my ($track)  = ($desc =~ m/^TI?T2.*?:\s*(.*)$/m);
  my ($fbps)   = ($desc =~ m/^Bitrate:\s*(.*)KBps$/m);
  $artist = '?' unless $artist;
  $album  = '?' unless $album;
  $track  = '?' unless $track;
  $fbps   = 0   unless $fbps;
  $desc = "$artist -- $track";

  if ($fbps != $bps) {
    print STDERR "$progname: skipping bad bitrate $fbps: $file\n";
    return;
  }

  write_metadata ($url, $pass, $desc);
  save_metadata ($metadata_file, $desc);

  my $cmd = "$slowcat --bps ${bps}k";
  $cmd .= " --verbose" if ($verbose);
  $cmd .= " \"$file2\"";

  print STDERR blurb() . "command: $cmd\n" if ($verbose > 1);

  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 blurb() . "write: ", $conn->error, "\n";

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

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

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

  print STDERR blurb() . "closing $file\n" if ($verbose > 1);
  close $in;
}

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

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

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

  print STDERR blurb() . "metadata: $data\n" if ($verbose);
  return if ($debug_p);

  $data = url_quote ($data);

  my $user = 'admin';
  my ($base, $path) = ($url =~ m@^((?:[a-z]+:)?//[^/]+)(.*)$@si);
  $url = ("$base/admin/metadata" .
          "?mount=$path" .
          "&mode=updinfo" .
          "&song=$data");

  print STDERR blurb() . "URL: $url\n" if ($verbose > 1);

  my $req = HTTP::Request->new (GET => $url);
  $req->authorization_basic ($user, $pass);

  my $ua = LWP::UserAgent->new;
  $ua->agent("$progname/$version");

  my $res = $ua->request($req);
  my $ret = ($res && $res->code) || 'null';

  if ($ret ne '200') {
    print STDERR blurb() . "error $ret: URL: $url\n";
  }
}

sub save_metadata($$) {
  my ($file, $data) = @_;

  $data = "DNA Lounge Radio: $data\n";

  open (my $out, '>', $file) || error ("$file: $!");
  print $out $data;
  close $out;
}


sub blurb() {
  my ($sec, $min, $hour) = localtime;
  return "$progname: " . sprintf("%02d:%02d:%02d: ", $hour, $min, $sec);
}

sub error($) {
  my ($err) = @_;
  print STDERR blurb() . "$err\n";
  exit 1;
}

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

sub main() {
  my $dir = undef;
  my $url = undef;
  my $pass = 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 = $_; }
    else { usage; }
  }

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

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

main;
exit 0;