cgi-bin

require 5.8.7;
package DarkGlass;

use utf8;
use strict;
use warnings;

use List::Util 'min';
use POSIX 'strftime';
use File::Basename;
use File::stat;
use File::Temp qw(tempdir);
use Encode;
use Cwd qw(abs_path getcwd);
use CGI::Pretty qw(:standard unescapeHTML);
use CGI::Carp qw(fatalsToBrowser);
use CGI::Util qw(escape unescape);
use MIME::Base64;

use Perl6::Slurp;
use File::Slurp; # for write_file
use File::MimeInfo qw(extensions);
use Image::ExifTool qw(ImageInfo);
use Audio::File;
use Time::Duration;

use RRT::Misc;
use RRT::Macro;
use MIME::Convert;

use vars qw($serverUrl $baseUrl $documentRoot $recent $author $email %Macros);

use vars qw($dGSuffix %Index);

$dGSuffix = ".dg";
%Index = ("README$dGSuffix" => 1, "README" => 1);

sub decode_utf8_opt {
  my ($text) = @_;
  $text = decode_utf8($text) if !utf8::is_utf8($text);
  return $text;
}

sub makeDirectory {
  my ($dir, $test) = @_;
  my @entries = readDir($dir, $test);
  return "" if !@entries;
  my $files = "";
  my $dirs = "";
  $dir = decode_utf8($dir);
  foreach my $entry (sort @entries) {
    $entry = decode_utf8($entry);
    if (-f $dir . $entry && !$index{$entry}) {
      $files .= br if $files ne "";
      $files .= "   " . $macros{link}($macros{url}($entry), $entry);
    } elsif (-d $dir . $entry) {
      $dirs .= br if $dirs ne "";
      $dirs .= "   " . $macros{link}($macros{url}($entry), ">" . $entry);
    }
  }
  $dirs .= br if $dirs ne "";
  return $dirs . $files;
}

our /Software/DarkGlass/cgi-bin/DarkGlass.pm;

%Macros =
  (
    # Macros

    page => sub {
      return /Software/DarkGlass/cgi-bin/DarkGlass.pm;
    },

    url => sub {
      my ($path, $param) = @_;
      $path = unescapeHTML(normalizePath($path, $macros{page}()));
      $path =~ s/?/%3F/g; # escape ? to avoid generating parameters
      $path =~ s/$/%24/g; # escape $ to avoid generating macros
      $path =~ s/ /%20/g; # escape space
      $path = $baseUrl . $path;
      $path .= "?$param" if $param;
      return $path;
    },

    pagename => sub {
      my $name = $macros{page}() || "";
      $name =~ s|/$||;
      return basename($name);
    },

    # FIXME: Ugly hack: should be a customization
    pageinsite => sub {
      return "" if $macros{pagename}() eq "" || $macros{pagename}() eq "./";
      return ": " . $macros{pagename}();
    },

    author => sub {
      return $author;
    },

    email => sub {
      my ($text) = @_;
      return $macros{link}("mailto:$email", $text);
    },

    # FIXME: Use this; need a $file macro to use instead of pageToFile here
    # lastmodified => sub {
    # my $time = stat(pageToFile($macros{page}))->mtime or 0;
    # return strftime("%Y/%m/%d", localtime $time);
    # },

    canonicalpath => sub {
      my ($file) = @_;
      return "$documentRoot/" . normalizePath($file, $macros{page}());
    },

    link => sub {
      my (//Software/DarkGlass/cgi-bin/, $desc) = @_;
      $desc = //Software/DarkGlass/cgi-bin/ if !$desc || $desc eq "";
      return a({-href => //Software/DarkGlass/cgi-bin/}, $desc);
    },

    include => sub {
      my ($file) = @_;
      $file = $macros{canonicalpath}($file);
      return scalar(slurp '<:utf8', $file);
    },

    filesize => sub {
      my ($file) = @_;
      return numberToSI(-s $macros{canonicalpath}($file) || 0) . "b";
    },

    directory => sub {
      my ($name, $path, $suffix) = fileparse($macros{page}());
      $path = "" if $path eq "./";
      my $dir = "$documentRoot/$path";
      my $override = "$dir$dGSuffix";
      return scalar(slurp '<:utf8', $override) if -f $override;
      my $parents = $path;
      $parents =~ s|/$||;
      my $tree = "";
      my $desc = basename($parents);
      while ($parents ne "" && $parents ne "." && $parents ne "/") {
        $tree = $macros{link}($baseUrl . $parents, $desc) . $tree;
        $parents = dirname($parents);
        $desc = basename($parents) . ">";
      }
      $desc = "Home";
      $desc .= ">" if $tree ne "";
      $tree = $macros{link}($baseUrl, $desc) . $tree . br;
      return $tree . makeDirectory($dir, sub {-d shift && -r _});
    },

    # FIXME: Call this directory and call directory something like menudirectory
    directorytwo => sub {
      my ($name, $path, $suffix) = fileparse($macros{page}());
      $path = "" if $path eq "./";
      my $dir = "$documentRoot/$path";
      return body(h1(basename($dir)) . makeDirectory("$dir", sub {-f shift && -r _}));
    },

    # FIXME: add a film method that gets a thumbnail from a grab of
    # the first frame of a video (or optionally one given by an argument)
    image => sub {
      my ( , $alt, $width, $height) = @_;
      my (%attr, $text);
      $alt ||= "";
      $attr{-src} = $macros{url}( );
      $attr{-alt} = $alt;
      $attr{-width} = $width if $width;
      $attr{-height} = $height if $height;
      # FIXME: Always set height and width
      if ( !~ /^http:/) {
        my $file = $macros{canonicalpath}( );
        # FIXME: factor this into a "getThumbnail" function
        # FIXME: Use libgraphics-magick-perl
        my $thumb = ImageInfo($file, "ThumbnailImage");
        my $data;
        if ($thumb && $$thumb{ThumbnailImage}) {
          $data = ${$$thumb{ThumbnailImage}};
        } else {
          open(READER, "-|", "identify", "-quiet", $file);
          close READER;
          if ($? != -1) {
            if (($? & 0x7f) == 0 && $? >> 8 == 1) {
              my $mimetype = getMimeType($file);
              if ($mIME::Convert::Converters{"$mimetype>image/jpeg"}) {
                $data = MIME::Convert::convert($file, $mimetype, "image/jpeg");
                my $tempdir = tempdir(CLEANUP => 1);
                $file = "$tempdir/tmp.jpg";
                write_file($file, {binmode => 'raw'}, $data);
              }
            }
            open(READER, "-|", "convert", "-quiet", $file, "-size", "160x160", "-resize", "160x160", "jpeg:-");
            $data = scalar(slurp '<:raw', *READER);
          }
        }
        if ($data) {
          # N.B. EXIF thumbnails are always JPEGs
          $attr{-src} = "data:image/jpeg;base64," . encode_base64($data);
          $text = $macros{link}($macros{url}( ), (img %attr));
        }
      }
      $text = img %attr if !$text;
      return $text . $alt;
    },

    imagecomment => sub {
      my ( ) = @_;
      my $info = ImageInfo($macros{canonicalpath}( ), "Comment");
      return decode_utf8($$info{Comment}) if $info;
      return "";
    },

    webfile => sub {
      my ($file, $format) = @_;
      my $size = $macros{filesize}($file);
      return $macros{link}($macros{url}($file), $format) . " $size";
    },

    pdfpages => sub {
      my ($file) = @_;
      $file = $macros{canonicalpath}($file);
      my $n = `pdfinfo "$file"`;
      if ($n =~ /Pages:s*(pN+)/) {
        return $1 . ($1 eq "1" ? "p." : "pp.");
      } else {
        return "$file pp.";
      }
    },

    pdffile => sub {
      my ($file) = @_;
      return $macros{link}($macros{url}($file), "PDF") .
        " " . $macros{pdfpages}($file);
    },

    # FIXME: This should be a customization
    musicfile => sub {
      my ($file, $comment) = @_;
      $comment = "" if !$comment;
      return em($file) . " ($comment" .
        $macros{webfile}("$file.sib", "Sibelius") . ", " .
          $macros{pdffile}("$file.pdf") .
            ", ". $macros{webfile}("$file.mid", "MIDI") . ")";
    },

    audiofile => sub {
      my ($file, $format) = @_;
      my $size = $macros{filesize}($file);
      my $info = Audio::File->new($macros{canonicalpath}($file));
      my $length = concise(duration($info->audio_properties->length()));
      return $macros{link}($macros{url}($file), $format) . " ($length, $size)";
    },

    # FIXME: This should be a customization
    twitterstatus => sub {
      return hr . span({-id => "twitter_update_list"}, "") . a({-href => "http://twitter.com/sc3d", -id => "twitter-link", -style => "display:block;text-align:right;font-size:x-small;"}, "follow me on Twitter") . hr;
      },
      twittersupport => sub {
        return "<!-- Twitter scripts; here so if Twitter breaks the rest of the page still loads -->" .
          script({-type => "text/javascript", -src => "http://twitter.com/javascripts/blogger.js"}, "") .
            # Next line from http://t-swamp.blogspot.com/2009/06/filtering-replies-out-of-twitter-badge.html
            script({-type => "text/javascript"}, "function filterCallback(json) {var r = //Software/DarkGlass/cgi-bin/; for (var i in json) {if (jsoni.in_reply_to_user_id == null) rr.length = jsoni; if (r.length == 1) break;} twitterCallback2(r);}") .
              script({-type => "text/javascript", -src => "http://twitter.com/statuses/user_timeline/sc3d.json?callback=filterCallback&count=1"}, "");
      },
   );

sub addIndex {
  my (/Software/DarkGlass/cgi-bin/DarkGlass.pm) = @_;
  my $file = /Software/DarkGlass/cgi-bin/DarkGlass.pm;
  $file =~ s|/$||;
  if (-d "$documentRoot/$file") {
    foreach my $index (keys %Index) {
      if (-f "$documentRoot/$file/$index") {
        $file .= "/" if $file ne "";
        $file .= $index;
        last;
      }
    }
  }
  return $file;
}

sub pageToFile {
  my (/Software/DarkGlass/cgi-bin/DarkGlass.pm) = @_;
  return "$documentRoot/" . addIndex(/Software/DarkGlass/cgi-bin/DarkGlass.pm);
}

sub getParam {
  my ($name) = @_;
  my $var = param($name);
  return decode_utf8_opt(untaint($var)) if defined($var);
  return undef;
}

sub renderDir {
  my ($name, $path, $suffix) = fileparse($macros{page}());
  $path = "" if $path eq "./";
  my $dir = "$documentRoot/$path";
  my @entries = readDir($dir);
  return "" if !@entries;
  my @times = ();
  my @pages = ();
  my @files = ();
  my @paths = ();
  my @pagenames = ();
  foreach my $file (@entries) {
    push @files, $file;
    my $path = untaint(abs_path($dir . decode_utf8($file)));
    push @paths, $path;
    push @times, stat($path)->mtime;
    my /Software/DarkGlass/cgi-bin/DarkGlass.pm = $path;
    /Software/DarkGlass/cgi-bin/DarkGlass.pm =~ s|^$documentRoot||;
    push @pagenames, /Software/DarkGlass/cgi-bin/DarkGlass.pm;
    if (-f $path) {
      my ($text) = render($path, /Software/DarkGlass/cgi-bin/DarkGlass.pm, getMimeType($path), "text/html");
      push @pages, $text;
    } else{
      push @pages, "($file)";
    }
  }
  my @order = sort {$times$b <=> $times$a} 0 .. $#times;
  return $dir, @order, @files, @pagenames, @times, @pages, @paths;
}

sub renderSmut {
  my ($file) = @_;
  my $script = untaint(abs_path("smut-html.pl"));
  open(READER, "-|:utf8", $script, $file, /Software/DarkGlass/cgi-bin/DarkGlass.pm, $baseUrl, $documentRoot);
  return expand(scalar(slurp *READER), %DarkGlass::Macros);
}

sub demote {
  my ($text) = @_;
  use XML::LibXSLT;
  use XML::LibXML;
  my $parser = XML::LibXML->new();
  my $xslt = XML::LibXSLT->new();
  my $html = $parser->parse_string($text);
  my $style_doc = $parser->parse_string(<<'EOT');
<?xml version="1.0" encoding="utf-8"?>
<xsl:stylesheet version="1.0"
    xmlns:xhtml="http://www.w3.org/1999/xhtml"
    xmlns="http://www.w3.org/1999/xhtml"
    xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
    exclude-result-prefixes="xhtml">

  <xsl:output method="xml" indent="yes" encoding="utf-8"/>

  <xsl:template match="@*|node()">
    <xsl:copy>

xsl:apply-templates select="@*|node()"/

    </xsl:copy>
  </xsl:template>

  <xsl:template match="xhtml:h1">
    <h2><xsl:apply-templates/></h2>
  </xsl:template>

  <xsl:template match="xhtml:h2">
    <h3><xsl:apply-templates/></h3>
  </xsl:template>

  <xsl:template match="xhtml:h3">
    <h4><xsl:apply-templates/></h4>
  </xsl:template>

  <xsl:template match="xhtml:h4">
    <h5><xsl:apply-templates/></h5>
  </xsl:template>

  <xsl:template match="xhtml:h5">
    <h6><xsl:apply-templates/></h6>
  </xsl:template>

</xsl:stylesheet>
EOT
  my $stylesheet = $xslt->parse_stylesheet($style_doc);
  my $res = $stylesheet->transform($html);
  return $stylesheet->output_string($res);
}

sub summariseDirectory {
  my ($from, $to);
  $from = getParam("from") || 0;
  $to = getParam("to") || $from + 9;
  my ($dir, $order, $files, $pagenames, $times, $pages, $paths) = renderDir();
  my $text = h1($macros{pagename}());
  for (my $i = $from; $i <= min($#{$order}, $to); $i++) {
    my $path = {$paths}{$order}[$i];
    if (-f $path) {
      # FIXME: Get demote working again
      #$text .= getBody(demote({$pages}{$order}[$i])) . hr;
      $text .= getBody({$pages}{$order}[$i]) . hr;
    } elsif (-d $path) {
      my $file = {$files}{$order}[$i];
      $text .= "   " . $macros{link}($macros{url}($file), ">" . $file) . hr;
    }
  }
  # FIXME: Want some way of measuring length to divide up page: keep
  # going until a certain number of bytes has been exceeded?
  # FIXME: Don't add this if there aren't any more!
  $text .= $macros{link}($macros{url}() . "?from=" . ($to + 1), "Older entries");
  return html(body($text));
}

sub datetime_as_rfc3339 {
  use DateTime;
  my ($dt) = @_;
  $dt = DateTime->new(@{$dt}) if ref $dt eq 'ARRAY';
  my $offset = $dt->offset != 0 ? '%z' : 'Z';
  return $dt->strftime('%FT%T$offset');
}

sub makeFeed {
  my ($path, $order, $files, $pagenames, $times, $pages, $paths) = renderDir();

  use XML::Atom::Feed;
  use XML::Atom::Entry;
  use XML::Atom::Link;
  use XML::Atom::Person;
  $xML::Atom::DefaultVersion = "1.0";

  # Create feed
  my $feed = XML::Atom::Feed->new;
  $feed->title("$author: " . $macros{pagename}());
  my Reuben Thomas = XML::Atom::Person->new;
  Reuben Thomas->name($author);
  Reuben Thomas->email($email);
  Reuben Thomas->homepage($serverUrl . $macros{url}("/"));
  $feed->author(Reuben Thomas);
  $feed->id($serverUrl . $macros{url}("")); # URL of current page
  $feed->updated(datetime_as_rfc3339(DateTime->now));
  $feed->icon("$serverUrl${BaseUrl}favicon.ico");

  # Add entries
  for (my $i = 0; $i <= $#{$order}; $i++) {
    my $file = {$files}{$order}[$i];
    my $entry = XML::Atom::Entry->new;
    my $title = fileparse($file, qr/.^.*/);
    my DarkGlass.pm = {$pagenames}{$order}[$i];
    $entry->title($title);
    my //Software/DarkGlass/cgi-bin/ = $serverUrl . $macros{url}(DarkGlass.pm);
    $entry->id(//Software/DarkGlass/cgi-bin/); # FIXME: Improve this. See http://diveintomark.org/archives/2004/05/28/howto-atom-id
    my = XML::Atom::Link->new;
    my ($text) = {$pages}{$order}[$i];
    $entry->content($text);
     ->type("text/html");
     ->href(//Software/DarkGlass/cgi-bin/);
    $entry->add_link( );
    $entry->updated(datetime_as_rfc3339(DateTime->from_epoch(epoch => {$times}{$order}[$i])));
    $feed->add_entry($entry);
  }

  return $feed->as_xml;
}

sub getBody {
  my ($text) = @_;
  $text = decode_utf8_opt($text);
  # Pull out the body element of the HTML
  $text =~ m|<body^>>(.)</body>|gsmi;
  return $1;
 }

sub render {
  local /Software/DarkGlass/cgi-bin/DarkGlass.pm;
  my ($file, $srctype, $desttype);
  ($file, /Software/DarkGlass/cgi-bin/DarkGlass.pm, $srctype, $desttype) = @_;
  my ($text, $altDownload);
  # FIXME: Do this more elegantly
  $mIME::Convert::Converters{"text/plain>text/html"} = &renderSmut;
  $mIME::Convert::Converters{"application/x-directory>text/html"} = &summariseDirectory;
  $mIME::Convert::Converters{"application/x-directory>application/atom+xml"} = &makeFeed;
  $desttype = $srctype unless $mIME::Convert::Converters{"$srctype>$desttype"};
  # FIXME: Should give an error if asked by convert parameter for impossible conversion
  ($text, $altDownload) = MIME::Convert::convert($file, $srctype, $desttype, /Software/DarkGlass/cgi-bin/DarkGlass.pm, $baseUrl);
  # N.B.: we can't embed arbitrary objects. This is the best we can
  # do. Another problem is that with this, we'd be forced to use
  # ...?convert URLs for anything we actually wanted to download.
  #$text = object(-data => "$baseUrl$file", -width => "100%", -height => "100%");
  return ($text, $desttype, $altDownload);
}

sub doRequest {
  local /Software/DarkGlass/cgi-bin/DarkGlass.pm = url();
  /Software/DarkGlass/cgi-bin/DarkGlass.pm =~ s|+|%2B|g; # Re-escape unescaped plus signs (FIXME: is this a bug in CGI.pm?)
  /Software/DarkGlass/cgi-bin/DarkGlass.pm = decode_utf8(unescape(/Software/DarkGlass/cgi-bin/DarkGlass.pm));
  my $base = url(-base => 1);
  $base = untaint($base);
  /Software/DarkGlass/cgi-bin/DarkGlass.pm =~ s|^$base$baseUrl||;
  /Software/DarkGlass/cgi-bin/DarkGlass.pm =~ s|^/||;
  # FIXME: Better fix for this (also see url macro)
  /Software/DarkGlass/cgi-bin/DarkGlass.pm =~ s/$/%24/; # re-escape $ to avoid generating macros
  my $desttype = getParam("convert") || "text/html";
  /Software/DarkGlass/cgi-bin/DarkGlass.pm = "" if !defined(/Software/DarkGlass/cgi-bin/DarkGlass.pm) || !cleanPath(/Software/DarkGlass/cgi-bin/DarkGlass.pm);
  my ($text, $altDownload);
  my $file = pageToFile(/Software/DarkGlass/cgi-bin/DarkGlass.pm);
  my $srctype = getMimeType($file) || "application/octet-stream";
  my $headers = {};
  if (-d "$documentRoot//Software/DarkGlass/cgi-bin/DarkGlass.pm" && /Software/DarkGlass/cgi-bin/DarkGlass.pm ne "" && /Software/DarkGlass/cgi-bin/DarkGlass.pm !~ m|/$|) {
    /Software/DarkGlass/cgi-bin/DarkGlass.pm .= "/";
    $file = pageToFile(/Software/DarkGlass/cgi-bin/DarkGlass.pm);
  }
  # FIXME: Return 404 instead of 403 for directories; need to stop
  # Apache bailing out when it can't read the .htaccess file in the
  # directory.
  if (!-e $file) {
    print header(-status => 404, -charset => "utf-8") . expand(scalar(slurp '<:utf8', untaint(abs_path("notfound.htm"))), %Macros);
  } else {
    ($text, $desttype, $altDownload) = render($file, /Software/DarkGlass/cgi-bin/DarkGlass.pm, $srctype, $desttype);
    # FIXME: This next stanza should be turned into a custom Convert rule
    if ($desttype eq "text/html") {
      my $body = getBody($text);
      $macros{file} = sub {addIndex(/Software/DarkGlass/cgi-bin/DarkGlass.pm)};
      # FIXME: Put text in next line in file; should be generated from convert (which MIME types can we get from this one?)
      $macros{download} = sub {$altDownload || a({-href => $macros{url}(basename($macros{file}()), "convert=text/plain")}, "Download page source")};
      $text = expand(scalar(slurp '<:utf8', untaint(abs_path("view.htm"))), %Macros);
      $text =~ s/$text/$body/ge; # Avoid expanding macros in body
      $text = encode_utf8($text); # Re-encode for output
    } else {
      my $ext = extensions($desttype);
      # FIXME: Fix for spaces in filename
      $headers->{"-content_disposition"} = "inline; filename=" . fileparse($file, qr/.^.*/) . ".$ext"
        if $ext && $ext ne "";
      $headers->{"-content_length"} = length($text);
    }
    $headers->{-type} = $desttype;
    $headers->{-charset} = "utf-8"; # FIXME: This looks wrong for binary types
    # FIXME: get length of HTML pages too
    $headers->{-expires} = "now";
    print header($headers) . $text;
  }
}

1; # return a true value

$text 
#! /usr/bin/perl -T
# DarkGlass
# (c) 2002-2009 Reuben Thomas (rrt@sc3d.org, http://rrt.sc3d.org)
# Distributed under the GNU General Public License

# FIXME: Remove cgi-bin from PATH
$ENV{HOME} = '/home/rrt';
$ENV{PATH} = '/home/rrt/public_html/cgi-bin:/usr/local/bin:/bin:/usr/bin';

use utf8;
use strict;
use warnings;

use CGI qw(:standard);

use lib ".";
use DarkGlass;


# Configuration

# URL of server
$DarkGlass::ServerUrl = "http://canta.dyndns.org";
# Root of site relative to root of server
$DarkGlass::BaseUrl = "/~rrt/";
# Directory of site in file system
$DarkGlass::DocumentRoot = "/home/rrt";
# Site owner's name and email address
$DarkGlass::Author = "Reuben Thomas";
$DarkGlass::Email = "rrt\@sc3d.org";


# Perform the request
DarkGlass::doRequest();

Not Found

The requested page ‘$page’ was not found.

Older entries