rss.cgi

   1 #!/usr/bin/perl
   2 use CGI::Fast qw/:cgi/;
   3 use Blerg::Database;
   4 use URI::Escape;
   5 use POSIX qw/strftime/;
   6 use MIME::Base64;
   7 use strict;
   8
   9 my $baseurl = Blerg::Database::constant('BASEURL');
  10
  11 sub xml_escape {
  12     local $_ = shift;
  13     s/&/&amp;/g;
  14     s/</&lt;/g;
  15     s/>/&gt;/g;
  16     return $_;
  17 }
  18
  19 sub decode_basic_auth {
  20     my ($q) = @_;
  21
  22     my ($method, $base64) = split(/\s+/, $q->http('Authorization'));
  23     if (!defined $method) {
  24         return;
  25     } elsif ($method ne 'Basic') {
  26         return;
  27     }
  28
  29     my ($username, $password) = split(':', decode_base64($base64), 2);
  30     if (!defined $username) {
  31         return;
  32     }
  33
  34     return ($username, $password);
  35 }
  36
  37 sub print_401 {
  38     print header(-type => 'text/html',
  39                  -status => '401 Unauthorized',
  40                  -WWW_Authenticate => 'Basic realm="blerg"');
  41     print <<DOC;
  42 <!DOCTYPE html>
  43 <h1>401 Unauthorized</h1>
  44 Please log in.
  45 DOC
  46 }
  47
  48 sub print_404 {
  49     print header(-type => 'text/html',
  50                  -status => '404 Not Found');
  51     print <<DOC;
  52 <!DOCTYPE html>
  53 <h1>404 Not Found</h1>
  54 Not Found
  55 DOC
  56 }
  57
  58 sub fetch_records {
  59     my @out;
  60     local $_;
  61
  62     foreach (@_) {
  63         my $b = Blerg::Database->open_existing($_->{author});
  64         my $data = $b->fetch($_->{record});
  65         if (!defined $data) {
  66             $b->close;
  67             next;
  68         }
  69         my $timestamp = $b->timestamp($_->{record});
  70         $b->close;
  71         push @out, {
  72             author => $_->{author},
  73             record => $_->{record},
  74             data => $data,
  75             timestamp => $timestamp,
  76         };
  77     }
  78
  79     return @out;
  80 }
  81
  82 sub print_rss {
  83     my ($type, $name, @items) = @_;
  84
  85     my ($title, $link);
  86     if ($type eq 'user') {
  87         $title = "${name}'s blërg";
  88         $link = "${baseurl}#$name";
  89     } elsif ($type eq 'feed') {
  90         $title = "${name}'s stalking feed";
  91         $link = "${baseurl}#/feed";
  92     } elsif ($type eq 'tag' || $type eq 'ref') {
  93         $title = $name;
  94         my $basename = $name;
  95         $basename =~ s/^.//;
  96         $link = "${baseurl}#/$type/$basename";
  97     }
  98
  99     print <<HEADER;
 100 <?xml version="1.0" encoding="utf-8" ?>
 101 <rss version="2.0">
 102   <channel>
 103     <title>$title</title>
 104     <link>$link</link>
 105     <description>Textual vomit</description>
 106 HEADER
 107
 108     for my $i (@items) {
 109         my $author = defined $i->{author} ? $i->{author} : $name;
 110         my $data = xml_escape(qq{<a href="${baseurl}#$author"><strong>\@$author</strong></a><br> $i->{data}});
 111         my $post_time = strftime("%a, %d %b %Y %H:%M:%S %Z", localtime($i->{timestamp}));
 112         print <<ITEM;
 113     <item>
 114       <pubDate>$post_time</pubDate>
 115       <guid>${baseurl}get/$author/$i->{record}</guid>
 116       <link>${baseurl}#$author/$i->{record}</link>
 117       <description>$data</description>
 118     </item>
 119 ITEM
 120     }
 121
 122     print <<'FOOTER'
 123   </channel>
 124 </rss>
 125 FOOTER
 126 }
 127
 128 REQUEST:
 129 while (my $q = new CGI::Fast) {
 130     $q->charset('utf8');
 131     my @path = split('/', $ENV{PATH_INFO});
 132     shift @path;
 133
 134     if ($path[0] eq 'feed') {
 135         my ($username, $password) = decode_basic_auth($q);
 136         if (!defined $username) {
 137             print_401;
 138             next REQUEST;
 139         }
 140         if (!Blerg::Database::auth_check_password($username, $password)) {
 141             print_401;
 142             next REQUEST;
 143         }
 144
 145         my $b = Blerg::Database->open_existing($username);
 146         my @list = fetch_records($b->subscription_list());
 147         $b->close;
 148
 149         print header(-type => 'application/rss+xml');
 150         print_rss(feed => $username, @list);
 151     } elsif (@path == 1) {
 152         # Assume this is a username; redirect to /user/<username>
 153         my $username = $path[0];
 154         my $b = Blerg::Database->open_existing($username);
 155         if (!defined $b) {
 156             print_404;
 157             next REQUEST;
 158         }
 159         print header(-type => 'application/rss+xml',
 160                      -charset => 'utf8',
 161                      -status => '301 Moved Permanently',
 162                      -location => "${baseurl}rss/user/$username");
 163         # And present the content in case their client is broken
 164         my $i = {
 165             record => '?failed_redirect',
 166             timestamp => time,
 167             data => qq{Your RSS aggregator is dumb and isn't following 301 redirects.  Please manually redirect it here: ${baseurl}rss/user/$username}
 168         };
 169         print_rss(user => $username, $i);
 170     } elsif ($path[0] eq 'user') {
 171         my $username = $path[1];
 172         my $b = Blerg::Database->open_existing($username);
 173         if (!defined $b) {
 174             print_404;
 175             next REQUEST;
 176         }
 177         print header(-type => 'application/rss+xml');
 178         my $n = $b->record_count - 1;
 179         my @list = reverse map {
 180             {
 181                 record    => $_,
 182                 data      => $b->fetch($_),
 183                 timestamp => $b->timestamp($_),
 184             }
 185         } ($n > 50 ? $n - 50 : 0)..$n;
 186         $b->close;
 187         print_rss(user => $username, @list);
 188     } elsif ($path[0] eq 'tag' || $path[0] eq 'ref') {
 189         my $tag = $path[1];
 190         my $atag;
 191         if ($path[0] eq 'tag') {
 192             $atag = '#' . $tag;
 193         } else {
 194             $atag = '@' . $tag;
 195         }
 196
 197         my @list = fetch_records(Blerg::Database::tag_list($atag, 0, -1));
 198
 199         print header(-type => 'application/rss+xml');
 200         print_rss($path[0] => $atag, @list);
 201     }
 202 }