#!/usr/bin/perl

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

# ice-downcoder.pl --- listens to one icecast stream and shouts it to another,
# after changing the bit rate.
#
# Copyright © 2000-2004 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: 30-Jun-2000.
#
# ASD support added by fgmr, 18-Jul-2001

require 5;
#use diagnostics;
use strict;
use bytes;

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

use Shout;

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

my $verbose = 0;
my $public_p = 0;
my $parent_pid = undef;

my $timeout = 10;    # if no data read for this many seconds, exit.

my $report_underflows = 0;   # we only report bitrate underflows when we
                             #  are simply copying, not downcoding.


# Lame 3.87:
#   -S: silent
#   -b: bitrate (kbps)
#   -a: convert stereo to mono
#   -r: input is raw PCM
#   -x: force byte-swapping of input
#   -f: fst mode (low quality)
#   -h: slower but (maybe) higher quality
#   --noshort: do not use short blocks

# It would be more efficient (one less process in the pipeline) to just let
# LAME decode the MP3 stream as well as re-encode it; but in practice, that
# doesn't work out, because LAME is not at all lenient on what it accepts:
# if there are network glitches and the inoput MP3 stream gets out of sync,
# then LAME gets confused and starts putting out static foreveermore.
# This is not a problem if xaudio is used to do the MP3 decoding, presumably
# because the code in xaudio is more robust in the face of glitchy input.

#my $downsample_cmd = "lame -S --mp3input --noshort %OPTS% - -";
my $downsample_cmd = "xaudio -output=- | lame --noshort -r -x -f %OPTS% - -";

#my $liveaudio_cmd = "arecord -qrm | lame --noshort -x -r -f %OPTS% - -";
my $liveaudio_cmd = "arecord -q -f cd | lame --noshort -x -r -f %OPTS% - -";

# perhaps the sox command "rec -c2 -sw -r44100 -" would also do?

my $liveaudio_loc   = "The DNA Lounge";
my $liveaudio_name  = "dnalounge.com";
my $liveaudio_desc  = "Live from $liveaudio_loc";
my $liveaudio_iurl  = "http://www.dnalounge.com/audio/";
my $liveaudio_genre = "whatever";


my %downsample_opts = (   8 => "-b   8 -a --resample 16",
                         16 => "-b  16 -a --resample 22.05",
                         24 => "-b  24 -a --resample 22.05",
                         32 => "-b  32 -a --resample 32",
                         40 => "-b  40 -a --resample 32",
                         48 => "-b  48 -a --resample 32",
                         56 => "-b  56 -a --resample 44.1",
                         64 => "-b  64    --resample 22.05",
                         80 => "-b  80    --resample 22.05",
                         96 => "-b  96    --resample 44.1",
                        112 => "-b 112    --resample 44.1",
                        128 => "-b 128    --resample 44.1",
                        144 => "-b 144    --resample 22.05",
                        160 => "-b 160    --resample 48"
                       );


sub error_alarm {
  print STDERR "$progname: timeout: $timeout seconds with no data!\n";
  print STDERR "$progname: bailing!\n";

# exit 1;               # This doesn't fucking work!  we're in another process.
# kill 3, $parent_pid;  # Send QUIT to self -- which also doesn't fucking work!
  kill 9, $parent_pid;  # Send KILL to self.  Finally.
}


my $bytes_60 = 0;
my $bytes_10 = 0;
my $bytes_1  = 0;
my $bytes_01 = 0;
my $start_60 = 0;
my $start_10 = 0;
my $start_1  = 0;
my $start_01 = 0;

sub sample_stats {
  my ($bytes, $bps) = @_;
  my $now = time;

  if ($start_60 == 0) {
    $start_60 = $now;
    $start_10 = $now;
    $start_1  = $now;
    $start_01 = $now;
  }

  if ($now - $start_01 > 10) {
#    report_stats ($bps, $bytes_01, $now - $start_01);
    $start_01 = $now;
    $bytes_01 = 0;
  }

  if ($now - $start_1  > 60) {
    report_stats ($bps, $bytes_1, $now - $start_1);
    $start_1 = $now;
    $bytes_1 = 0;
  }

  if ($now - $start_10 > (60 * 10)) {
    report_stats ($bps, $bytes_10, $now - $start_10);
    $start_10 = $now;
    $bytes_10 = 0;
  }

  if ($now - $start_60 > (60 * 60)) {
    report_stats ($bps, $bytes_60, $now - $start_60);
    $start_60 = $now;
    $bytes_60 = 0;
  }

  $bytes_60 += $bytes;
  $bytes_10 += $bytes;
  $bytes_1  += $bytes;
  $bytes_01 += $bytes;
}

sub report_stats {
  my ($bps, $bytes_read, $seconds_elapsed) = @_;
  my $target = $bps * 128 * $seconds_elapsed;

  print STDERR "$progname: checking ($seconds_elapsed secs, " .
    "$bytes_read bytes, $target target, " .
    int($bytes_read * 100 / $target) . "%)\n"
      if ($verbose > 1);

  if ($bytes_read < ($target * 0.95)) {
    my $desc = ($seconds_elapsed >= (60 * 60)
                ? "" . int($seconds_elapsed / (60 * 60)) . " hour"
                : $seconds_elapsed >= 60
                ? "" . int($seconds_elapsed / 60) . " minute"
                : "" . $seconds_elapsed . " second");
    my $pct = int ((1.0 - ($bytes_read / $target)) * 100);
    print STDERR "$progname: $pct% underflow, $desc interval " .
      "($bytes_read / $target)\n";
  }
}


sub relay {
  my ($in_url, $out_url, $bps, $pass) = @_;

  my $live_p = !defined($in_url);

  my $cmd = ($live_p ? $liveaudio_cmd : $downsample_cmd);
  my $opts = $downsample_opts{$bps};
  die "$progname: unsupported bitrate $bps.\n" unless $opts;
  $cmd =~ s/%OPTS%/$opts/g;

  my ($loc, $name, $desc, $iurl, $genre, $ibps, $pub);

  if (!$live_p) {

    #########################################################################
    #
    # Reading MP3 data from an Icecast URL.
    # Open the input stream and read the headers
    #
    #########################################################################


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

    $path = "" unless $path;

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

    print STDERR "$progname: $$: connecting to $serverstring...\n"
      if (($verbose > 1) ||
          ($verbose == 1 && $report_underflows));

    my ($remote, $iaddr, $paddr, $proto, $line);
    $remote = $them;
    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
    $port || die "$progname: getservbyname($port, 'tcp')";
    $iaddr = inet_aton($remote) || die "$progname: inet_aton($remote)";
    $paddr = sockaddr_in($port, $iaddr);

    $proto   = getprotobyname('tcp');
    socket(IN, PF_INET, SOCK_STREAM, $proto) || die "$progname: socket: $!\n";
    connect(IN, $paddr) || die "$progname: connect($serverstring): $!\n";

    select(IN); $| = 1; select(STDOUT);

    print IN ("GET /$path HTTP/1.0\r\n" .
              "Host: $them\r\n" .
              "User-Agent: $progname/$version\r\n" .
              "\r\n");
    my $http = <IN>;

    if (! ($http =~ m@^HTTP/1.\d+ 2\d\d\b@ ||
           $http =~ m@^ICY 2\d\d\b@ )) {
      $http =~ s/[\r\n]+$//gs;
      $http = "null response" if ($http =~ m/^\s*$/s);
      die "$progname: $http\n";
    }

    my $head = "";
    while (<IN>) {
      s/\r\n$/\n/;
      $head .= $_;
      last if m@^\n@;
    }

    $_ = $head;
    my $X;
    ($X, $loc)      = m/^(x-audiocast|icy|ice)-location:[ \t]*([^\n]*)$/mi;
    ($X, $name)     = m/^(x-audiocast|icy|ice)-name:[ \t]*([^\n]*)$/mi;
    ($X, $X, $desc)=m/^(x-audiocast|icy|ice)-desc(ription)?:[ \t]*([^\n]*)$/mi;
    ($X, $iurl)     = m/^(x-audiocast|icy|ice)-url:[ \t]*([^\n]*)$/mi;
    ($X, $genre)    = m/^(x-audiocast|icy|ice)-genre:[ \t]*([^\n]*)$/mi;
    ($X, $pub)      = m/^(x-audiocast|icy|ice)-public:[ \t]*([^\n]*)$/mi;
    ($X, $X, $ibps) = m/^(x-audiocast|icy|ice)-(bitrate|br):[ \t]*([^\n]*)$/mi;

    $loc = $name unless $loc;

  } else {

    #########################################################################
    #
    # Reading raw audio data from the local machine's sound card.
    # Open the input pipeline set up the header data.
    #
    #########################################################################

    $loc   = $liveaudio_loc;
    $name  = $liveaudio_name;
    $desc  = $liveaudio_desc;
    $iurl  = $liveaudio_iurl;
    $genre = $liveaudio_genre;
    $ibps  = $bps;
    $pub   = $public_p;
  }

  my $ibps_suffix = "";
  if (!defined ($ibps)) {
    $ibps = 128;
    $ibps_suffix = " (assumed)";
  }

  if ($verbose > 1) {
    print STDERR "$progname: reading from " .
          ($live_p ? "sound card" : $in_url) . ":\n" .
      "$progname:   location:    $loc\n" .
      "$progname:   name:        $name\n" .
      "$progname:   description: $desc\n" .
      "$progname:   url:         $iurl\n" .
      "$progname:   genre:       $genre\n" .
      "$progname:   bitrate:     $ibps$ibps_suffix\n" .
      "$progname:   public:      $pub\n";
  }

  ###########################################################################
  #
  # Open the output stream and write the headers
  #
  ###########################################################################

  my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $out_url, 4);
  if (! ($url_proto && $url_proto =~ m/^http:$/i)) {
    die "$progname: not an HTTP URL: $out_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 > 1) ||
        ($verbose == 1 && $report_underflows));

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

  my $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		=> $name,
    url			=> $iurl,
    genre		=> $genre,
    description		=> $desc,
#   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;
  }

  if ($verbose > 1) {
    print STDERR "$progname: writing to $out_url:\n";
    print "$progname:   bitrate:     $bps\n";
    print "$progname:   public:      $public_p\n" if ($pub != $public_p);
  }


  ###########################################################################
  #
  # Open the filtering pipe...
  #
  ###########################################################################

  if (!$live_p && $bps == $ibps) {
    $report_underflows = 1;

    print STDERR "$progname: no bitrate change: unfiltered copy.\n"
      if ($verbose > 1);
  } else {
    print STDERR "$progname: filter: $cmd\n" if ($verbose > 1);
    local *Reader;
    local *Writer;
    pipe (Reader, Writer) || die "$progname: pipe: $!\n";
    my $pid = fork;
    if ($pid < 0) { die "$progname: fork: $!\n"; }
    if ($pid) {

      if (!$live_p) {
        open (STDIN, "<&IN")    || die "$progname: dup stdin: $!\n";
      }

      open (STDOUT, ">&Writer") || die "$progname: dup stdout: $!\n";
      open (STDERR, ">/dev/null") unless ($verbose > 1);
      exec "$cmd"               || die "$progname: exec $cmd: $!\n";
    }
    open (IN, "<&Reader")       || die "$progname: dup stdin: $!\n";
    $| = 1;
  }


  ###########################################################################
  #
  # Copy the data from in to out...
  #
  ###########################################################################

  my ( $buffer, $bytes ) = ( '', 0 );

  $SIG{ALRM} = \&error_alarm;
  alarm $timeout;

  my $tick = 0;
  my $ticks = 20;
  my $cumul_bytes = 0;

  while ( ($bytes = sysread (IN, $buffer, 4096)) > 0 ) {

    my $L = length($buffer);
    print STDERR "$progname: writing $L bytes\n" if ($verbose > 3);

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

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

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

    $conn->sync;					# Shout 1.1

    $cumul_bytes += $bytes;
    if ($tick++ > $ticks) {
      if ($report_underflows) {
        sample_stats ($cumul_bytes, $bps);
      }
      $tick = 0;
      $cumul_bytes = 0;
    }

    alarm $timeout;   # reset timeout before next read.
  }

  print STDERR "$progname: EOF!\n" if ($verbose);

  alarm 0;   # no more alarms


  ###########################################################################
  #
  # Done: hit end of input stream.
  #
  ###########################################################################

#  $conn->disconnect;
  close IN;
}


sub usage {
  my ($whine) = @_;
  print STDERR "$progname: $whine\n" if $whine;
  print STDERR "usage: $progname [--verbose] [--public] " .
    "in-url out-url bitrate password\n";
  print STDERR "\t\t\t(in-url may be \"soundcard\")\n";
  exit 1;
}

sub main {
  my ($in_url, $out_url, $bps, $pass);

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif ($_ eq "--public") { $public_p++; }
    elsif (m/^-/) { usage "unknown option $_"; }
    elsif (!defined($in_url)) {
      if ($_ ne "soundcard" &&
          ! m@^http://@) { usage "not an HTTP URL: $_"; }
      $in_url = $_;
    } elsif (!defined($out_url)) {
      if (! m@^http://@) { usage "not an HTTP URL: $_"; }
      $out_url = $_;
    } elsif (!defined($bps)) {
      if (! m/^\d+$/) { usage "non-numeric BPS: $_"; }
      $bps = $_;
    } elsif (!defined($pass)) {
      $pass = $_;
    } else {
      usage "unknown option: $_";
    }
  }

  usage "no input URL" unless $in_url;
  usage "no output URL" unless $out_url;
  usage "no BPS" unless $bps;
  usage "no password" unless $pass;

  $in_url = undef if ($in_url eq "soundcard");

  $_ = $out_url;
  s@^.*/@@;
  $progname =~ s/\.pl$//;
  $progname .= ": $_";

  $parent_pid = $$;
  relay ($in_url, $out_url, $bps, $pass);
}

main;
exit (0);