For checkouts or to view logs direct your SVN client to svn://svn.saintamh.org/code/mapedit/data.cgi

#!/usr/bin/perl -Tw
use warnings;
use strict;
$|++;

# file: data.cgi

# Herve Saint-Amand
# Edinburgh
# Thu Jun 10 07:13:52 2010

# This script serves and saves JSON data. It is called by the JS code.
# It does not parse the JSON data, however -- for simplicity, all
# knowledge of how that data is structured is left to the JS code.

#------------------------------------------------------------------------------
# includes

# Standard modules
use CGI;
use CGI::Util qw/unescape/;
use Compress::Zlib;

# External libs
use lib 'lib';
use Saintamh::Files qw/&read &write/;

#------------------------------------------------------------------------------
# init

$ENV{PATH} = '';

use constant {
    CAN_COMPRESS => (($ENV{HTTP_ACCEPT_ENCODING} || '') =~ m!\bgzip\b!),
    DAT_DIR => 'dat',
};

# 2010-06-19 - I can't get the YUI connection manager to send anything but
# "application/x-www-form-urlencoded" as the content-type for POST requests.
# Google says it's Firefox' fault. So we actually override it in here, before
# CGI.pm does its thing.
$ENV{CONTENT_TYPE} = 'text/plain; charset=UTF-8'
    if $ENV{CONTENT_TYPE};

my $cgi = new CGI;

# 2010-06-19 - now I'm really puzzled -- does CGI.pm not parse both GET and
# POST params if given a POST request with parameters in the URL itself? Had a
# look at the source code, it doesn't seem to. (CGI.pm-3.49/lib/CGI.pm:674)
# Odd.
$cgi->parse_params ($ENV{QUERY_STRING})
    if $cgi->request_method eq 'POST' && $ENV{QUERY_STRING};

my $action = $cgi->param ('action');
my $map_id = $cgi->param ('mapid');

my $submitted_json;
($submitted_json = unescape($cgi->param('POSTDATA'))) =~ s/=$//
    if $cgi->request_method eq 'POST';

#------------------------------------------------------------------------------
# everything this script outputs must be JSON with a 'status' and a 'contents'

sub json_str_literal {
    my ($str) = @_;
    $str =~ s/[\"\\]/\\$&/g;
    $str =~ s/\n/\\n/g;
    return qq/"$str"/;
}

sub print_out {
    my ($status, $contents) = @_;

    $contents = &json_str_literal($contents)
        unless ($contents =~ /^\s*[\{\[]/);

    my @headers = ('Content-Type: text/plain');
    my $json = qq/{"status":"$status","contents":$contents}/;

    if (CAN_COMPRESS) {
        $json = Compress::Zlib::memGzip ($json);
        push @headers, 'Content-Encoding: gzip';
    }

    print join ('', map "$_\n", @headers), "\n", $json;
    exit 0;
}

BEGIN {
    $SIG{__DIE__} = sub {
        my ($mesg) = @_;
        chomp ($mesg);
        &print_out ('died', $mesg);
    };
}

#------------------------------------------------------------------------------
# misc. utils

sub force_login {

    my ($domain) = &read ('.domain');

    # We only load the module when required, because it creates a CGI object,
    # and that messes up the hacky trickery we perform above with environment
    # variables
    use lib '/home/saintam1/www/inc/perl';
    require login;
    &login::force_login ($domain);

}

sub map_file_name {
    my ($map_id) = @_;
    die unless ($map_id =~ /^([\w\-]+(?:\.\d+)?)$/);
    return DAT_DIR . "/$1.json";
}

#------------------------------------------------------------------------------
# main

my $output_contents;

if ($action eq 'listmaps') {

    opendir (DIR, DAT_DIR);
    my @map_ids = sort {
        (lc $a) cmp (lc $b);
    } grep {
        $_ = $1 if /^([\w\-]+)\.json$/;
    } readdir DIR;
    closedir DIR;

    $output_contents = '[' . join (',', map qq!"$_"!, @map_ids) . ']';

} elsif ($action eq 'getmap') {

    die "No map?" unless $map_id;
    my $file_name = &map_file_name ($map_id);
    $output_contents = &read ($file_name);

} elsif ($action eq 'savemap') {

    &force_login();
    die "No map?" unless $map_id;
    die "No dat?" unless $submitted_json;

    my $file_name = &map_file_name ($map_id);
    if (-f $file_name) {
        for (my $i = 1; $i < 1_000_000; $i++) {
            my $new_file_name = &map_file_name ("$map_id.$i");
            unless (-f "$new_file_name.gz") {
                rename $file_name, $new_file_name;
                # backticks to avoid gzip output going to our stdout
                `/usr/bin/gzip $new_file_name`;
                last;
            }
        }
    }

    &write ($file_name, $submitted_json);
    $output_contents = "";

} else {
    die "Bad 'action' param";
}

&print_out ('OK', $output_contents);

#------------------------------------------------------------------------------