bin/engine-di.fm

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 require LWP::Simple;
   8 use Data::Dumper;
   9 require HTTP::Headers;
  10 require HTTP::Request;
  11 require LWP::UserAgent;
  12 require HTTP::Cookies;
  13
  14 my $USERNAME="lace";
  15 my $PASSWORD=&_priv_postget("di.fm.pwd");
  16
  17 delete $ENV{"http_proxy"};
  18
  19 sub _priv_postget($)
  20 {
  21 my($base)=@_;
  22
  23         my $full=$ENV{"HOME"}."/priv/postget.".$base;
  24         local *F;
  25         open F,$full or die "$full: $!";
  26         my $r=do { local $/; <F>; } or die "read \"$full\": $!";
  27         close F or die "close \"$full\": $!";
  28         chomp $r;
  29         return $r;
  30 }
  31
  32 sub paidget($$)
  33 {
  34         my($url,$site)=@_;
  35
  36         my $ua=LWP::UserAgent->new() or die "UA: $!";
  37         my $jar=HTTP::Cookies->new() or die "jar: $!";
  38         $ua->cookie_jar($jar);
  39         my $req=HTTP::Request->new(
  40                 "POST",
  41                 q{http://}.$site.q{/pro/login.php},
  42                 HTTP::Headers->new(
  43                         "Host"=>$site,
  44                         "Content-Type"=>"application/x-www-form-urlencoded",
  45                 ),
  46                 join('&',
  47                         q{amember_login=}.$USERNAME,
  48                         q{amember_pass=}.$PASSWORD,
  49                         q{refer_back_url=http://}.$site.q{/},
  50                         q{login_attempt_id=}.(0+time()),
  51                         q{remember_login=1},
  52                 ),
  53         );
  54         my $resp=$ua->request($req) or die "resp(0): $!";
  55         die "!success(0)" if !$resp->is_success();
  56         die "!content(0)" if !(my $content=$resp->content());
  57         $content=~m{You will be redirected to protected area} or die $content;
  58         $req=HTTP::Request->new(
  59                 "GET",
  60                 $url,
  61         );
  62         $resp=$ua->request($req) or die "resp(1): $!";
  63         die "!success(1)" if !$resp->is_success();
  64         die "!content(1)" if !($content=$resp->content());
  65         return $content;
  66 }
  67
  68 if ("build" eq ($ARGV[0]||"")) {
  69         my @symlink;
  70         local $_;
  71         while (<*>) {
  72                 chomp;
  73                 next if !/^(?:\Qdi.fm\E|\Qsky.fm\E)-/;
  74                 -l or next;
  75                 push @symlink,$_;
  76         }
  77         @symlink or die "No existing symlinks found";
  78         my $TARGET="engine-di.fm";
  79         -x $TARGET or die "Target $TARGET not found";
  80
  81         sub sitedump($$)
  82         {
  83                 my($site,$page)=@_;
  84
  85                 my @newdashed;
  86                 while ($page=~m{"((?:http://www.'$site')?([^":]*(?<!_low)[.](?:pls|asx)))"}g) {
  87                         local $_=$1;
  88                         next if m{^/aacplus/};
  89                         next if m{/(?:32|56|64|128)k[.]};
  90                         tr{/}{-};
  91                         push @newdashed,$_;
  92                 }
  93                 @newdashed or die "No URLs found";
  94                 for (@symlink) {
  95                         unlink or die "unlink \"$_\": $!";
  96                 }
  97                 @symlink=();
  98                 for (@newdashed) {
  99                         my $dest="$site$_";
 100                         next if -l $dest;
 101                         symlink $TARGET,$dest or die "symlink \"$dest\": $!";
 102                 }
 103         }
 104
 105         for my $site (qw(di.fm)) {      # FIXME: sky.fm
 106                 my $freepageurl="http://$site/";
 107                 my $freepage=LWP::Simple::get($freepageurl) or die $freepageurl;
 108                 sitedump $site,$freepage;
 109                 my $paidpage=paidget $freepageurl,$site;
 110                 sitedump $site,$paidpage;
 111         }
 112         print "OK\n";
 113         exit 0;
 114 }
 115
 116 my $pathslashed=$0;
 117 $pathslashed=~s{^.*/}{};
 118 $pathslashed=~tr{-}{/};
 119 my $streamlisturl="http://$pathslashed";
 120 for (;;) {
 121
 122         sub streamlist_get($)
 123         {
 124                 my($streamlist)=@_;
 125
 126                 my @streamlist;
 127                 while ($streamlist=~m{^File\d*\s*=\s*"?(\S+?)"?\s*$}gm) {
 128                         push @streamlist,$1;
 129                 }
 130                 while ($streamlist=~m{<ref\s+href\s*=\s*"(mms://[\S^"]+?)"\s*/>}g) {
 131                         my $url=$1;
 132                         $url=~s{&amp;}{&};
 133                         push @streamlist,$url;
 134                 }
 135                 return @streamlist;
 136         }
 137
 138         my $streamlist=LWP::Simple::get($streamlisturl) or die $streamlisturl;
 139         my @streamlist=streamlist_get $streamlist;
 140         if (!@streamlist) {
 141                 $streamlist=~m{Digitally Imported :: Login} or die "No streams found (free): $streamlisturl";
 142                 $streamlist=paidget $streamlisturl,"di.fm";     # FIXME: sky.fm
 143                 @streamlist=streamlist_get $streamlist;
 144                 @streamlist or die "No streams found (paid): $streamlisturl: $streamlist";
 145         }
 146         warn Dumper(\@streamlist);
 147         for my $stream (@streamlist) {
 148                 if (my($host,$port)=($stream=~m{^http://(?:[^@]+@)?([^:/@]+)(?::(\d+))?})) {
 149                         $port||=80;
 150                         warn "Connecting {$host}:{$port}...\n";
 151                         my $tcp=IO::Socket::INET->new(
 152                                 Proto=>"tcp",
 153                                 PeerHost=>$host,
 154                                 PeerPort=>$port,
 155                                 Timeout=>2,
 156                         ) or next;
 157                         close $tcp or die "Close TCP: $!";
 158                 }
 159                 my $mplayer="mplayer";
 160                 my @list=($mplayer,qw(-cache 512),$stream);
 161                 warn Dumper(\@list);
 162                 system $mplayer @list;
 163                 exit 0 if $?;
 164         }
 165 }