<VirtualHost 1.2.3.4:80>
        ServerName      share.lifelogs.com
        DocumentRoot    /var/www/html
        ErrorLog        /var/log/apache/error-share.log
        PerlRequire     /home/tzz/mod_perl_require_share.pl
        <Location />
                SetHandler      perl-script
                PerlHandler     SharePerlHandler
        </Location>
        SetEnv AWS_KEY my-AWS-key
        SetEnv AWS_SECRET_KEY my-secret-AWS-key
</VirtualHost>

				
#!/usr/bin/perl -w

use strict

use lib /home/tzz

use SharePerlHandler

1

				
package SharePerlHandler
use Apache::Constants qw(:common REDIRECT)
use strict
use Carp qw/verbose cluck carp croak confess/
use Data::Dumper
use Apache::Request
use Template
use POSIX
use Digest::HMAC_SHA1 qw(hmac_sha1 hmac_sha1_hex)
use MIME::Base64
use Data::UUID				# generates unique IDs
use lib /home/tzz/amazon-simpledb-2007-11-07-perl-library/src/
use Amazon::SimpleDB::Client

				
use constant IMAGE_MODE   => 0
use constant COMMENT_MODE => 1

use constant VERBOSE => 1 # can also be done through the environment or some other way

my $template = Template->new( {
			       INCLUDE_PATH => /home/tzz/templates/share,
			       RECURSION => 1,
			      }
			    )

my $uuid = Data::UUID->new()

				
sub handler
{
 my $r = shift @_
 my $q = Apache::Request->new($r,
                        POST_MAX => 4096,
                        DISABLE_UPLOADS => 1)

 my $user = (rand 2 > 1) ? bob : ted 
                              # pick a user randomly between bob and ted
                              # (50% chance each)

 handle_photo($q)   
                              # always try to delete, add, or edit a URL
                              # if its passed as a parameter
 handle_comment($q) 
                              # always try to delete, add, or edit a comment
                              # if its passed as a parameter
 
 my $uri = $q->uri()
 my $tfile = $uri
 $tfile =~ s,^/,,            # remove the starting "/" in the name if it exists
 $tfile =~ s,/$,,            # remove the ending "/" in the name if it exists
 $tfile =~ s,/,_,g           # "/" in the file name becomes "_" so all the
                              # templates can be in one directory

 $tfile = index unless length $tfile	
                              # make the URI "index" if its
                              # empty (e.g. someone hit the / URI)
 
 if ($tfile =~ m/\.html$/)
 {
  $tfile =~ s/html$/tmpl/    # map ANYTHING.html to ANYTHING.tmpl
 }
 else
 {
  $tfile .= .tmpl          # map ANYTHING to ANYTHING.tmpl
 }

 my $policy = 
 my $signature = 

 if ($tfile eq upload.tmpl)
 {
  $template->process(policy.tmpl,
                 {
                  username => $user,
                 },
                 \$policy) || croak($template->error())

  my $key = $ENV{AWS_SECRET_KEY}
  $policy = encode_base64($policy)
  $policy =~ s/\n//g
  $signature = encode_base64(hmac_sha1($policy, $key))
  $signature =~ s/\n//g
 }
 
 $q->send_http_header(text/html charset=utf-8)
 my $output = 
 
 $template->process($tfile,
     {
      request   => $q,
      username  => $user,
      policy    => $policy,
      signature => $signature,
      env       => \%ENV,
      params    => \%{$q->param()},
      fimages   => sub { return list_simpledb(sprintf(SELECT * from `%s`,
                   simpledb_image_domain_name())) },
      fcomments => \&get_comments,
     },
     \$output) || croak($template->error())
	
 print $output
 return OK
}

				
{"expiration": "3000-01-01T00:00:00Z",
  "conditions": [
    {"bucket": "images.share.lifelogs.com"}, 
    {"acl": "public-read"},
    ["starts-with", "$key", ""],
    ["starts-with", "$Content-Type", ""],
    ["starts-with", "$success_action_redirect",
     "http://share.lifelogs.com/s3uploaded?user=[% username %]"],
    ["content-length-range", 0, 1048576]
  ]
}

				
sub handle_comment
{
 my $q = shift @_

 my $user           = $q->param(user)
 my $imageid   	  = $q->param(refimageid)
 my $comment   	  = $q->param(comment)
 my $refcommentid   = $q->param(refcommentid)
 my $commentid 	  = $q->param(commentid)
 my $deleteid 	  = $q->param(deletecommentid)

 my $result
 
 if (defined $deleteid) # delete
 {
  $result = delete_simpledb($deleteid, COMMENT_MODE)
 }
 elsif (defined $commentid && defined $comment) # edit
 {
  my %q = (
         comment => $comment,
        )

  put_simpledb($commentid, COMMENT_MODE, %q)
  $result = get_simpledb($commentid, COMMENT_MODE)
 }
 elsif (defined $imageid && defined $comment) # new comment
 {
  my %q = (
         image_id => $imageid,
         comment => $comment,
        )

  $q{reply_to} = $refcommentid if defined $refcommentid
  $q{user} = $user if defined $user

  my $id = new_uuid()
  put_simpledb($id, COMMENT_MODE, %q)
  $result = get_simpledb($id, COMMENT_MODE)
 }

 $q->param()->{result} = $result
}

				
sub handle_photo
{
 my $q = shift @_

 my $user     = $q->param(user)
 my $name     = $q->param(name)
 my $bucket   = $q->param(bucket)
 my $key      = $q->param(key)
 my $url      = $q->param(url)
 my $editid   = $q->param(imageid)
 my $deleteid = $q->param(deleteimageid)

 # set the URL from the S3 key and bucket if necessary
 if (!defined $url && defined $key && defined $bucket)
 {
  $url = sprintf("http://%s.s3.amazonaws.com/%s", $bucket, $key)
 }

 my $result

 if (defined $deleteid) # delete
 {
  $result = delete_simpledb($deleteid, IMAGE_MODE)
 }
 elsif (defined $name && defined $editid) # editing an image name
 {
  my %q = (
         name => $name,
        )

  put_simpledb($editid, IMAGE_MODE, %q)
  $result = get_simpledb($editid, IMAGE_MODE)
 }
 elsif (defined $url && defined $name && defined $user) # adding a new one
 {
  my %q = (
         url => $url,
         name => $name,
         user => $user,
        )

  $q{bucket} = $bucket if defined $bucket

  my $id = new_uuid()
  put_simpledb($id, IMAGE_MODE, %q)
  $result = get_simpledb($id, IMAGE_MODE)
 }

 $q->param()->{result} = $result
}

				
sub qlog
{
 printf STDERR @_
 print STDERR "\n"
}

sub new_uuid
{
 return $uuid->to_string($uuid->create())
}

sub simpledb_image_domain_name
{
 return simpledb_domain_name(IMAGE_MODE)
}

sub simpledb_comment_domain_name
{
 return simpledb_domain_name(COMMENT_MODE)
}

sub simpledb_domain_name
{
 return sprintf "%s.share.lifelogs.com",
  (shift == IMAGE_MODE) ? share_photos : share_comments
}