#!/usr/bin/perl -t
use strict;
use warnings;

# Copyright 2008 Andrew Sterling Hanenkamp.
#
# This is free software and may be modified or distributed under the same terms
# as Perl itself.
#

##### WARNING ##### DO NOT PLACE THIS SERVICE ON AN OPEN WEB SERVER THAT JUST
##### WARNING ##### ANYONE COULD ACCESS. THIS SCRIPT HAS ONLY MINIMAL SECURITY
##### WARNING ##### FEATURES AND COULD MAKE YOUR WEB SERVER SUSCEPTIBLE TO
##### WARNING ##### ATTACK. IT IS MEANT TO BE USED AS A SAMPLE IN A CONTROLLED
##### WARNING ##### LOCALHOST ENVIRONMENT. 
##### WARNING #####
##### WARNING ##### PLEASE BE SENSIBLE FOR CRYING OUT LOUD!!!

use constant CONFIG_DIR => "/home/USER/RESTLibrary";

# Installation Instructions:
#
#   1. Drop this baby into your cgi-bin directory for scripts.
#   2. Find the line above that looks like this:
#
#        use constant CONFIG_DIR => "...";
#
#      Change the "..." to a directory that is writable for your web server (or
#      world writable).
#   3. Go to the CONFIG_DIR you just set and run "echo 0 > last_id".
#   4. Go to http://localhost/cgi-bin/library.cgi/= in your web browser.
#   5. If you see the API documentation rather than something else, you win.
#   6. If you do not, try the following:
#
#      a. Your cgi-bin directory might be located somewhere else. It's up to to
#         find it. For example, when I worked at Kansas State University, my
#         personal cgi-bin was located differently, so I would have done this:
#
#           http://localhost/~sterling/cgi-bin/library.cgi/=
#
#      b. Make sure your cgi-bin directory is configured correctly. In Apache,
#         this usually means making sure the "ScriptAlias" or "Options Exec"
#         and "AddHandler cgi-script .cgi" are setup properly. Read your server
#         documentation for more information.
#
#      c. Make sure the permissions are correct on the script and the cgi-bin
#         directory.
#           
#           chmod 755 cgi-bin/library.cgi
#           chmod 755 cgi-bin
#
#      d. Make sure your path to Perl is correct. At the start of the file make
#         sure that this line:
#
#           #!/usr/bin/perl -t
#
#         matches the location of Perl on your system. This can usually be
#         discovered using this command:
#
#           which perl
#
#         or you might try replacing the line above with:
#
#           #!/usr/bin/env perl -t
#
#      e. In general, you should only access this server from localhost because
#         this script checks to see that the remote client is on the localhost.
#         If you are trying to access it from somewhere else, you will need to
#         modify the lines below reading:
#
#           barf 403, "Go Away!", "I only talk to localhost!"
#               unless $q->remote_host eq 'localhost'
#                   or $q->remote_host eq '127.0.0.1';
#
#         JUST BE CAREFUL when you do it. Very bad things can happen to you if
#         you don't. Warts, gangrene, and halitosis are very likely if you
#         screw this up. You don't want some nut job adding files on your
#         computer because you left this open to the whole world.
#
# If you still can't get it to work, check you server logs. In Apache, you can
# usually find these around /var/log/apache2/error_log or somewhere similar
# depending on your operating system and such. (I recommend Console.app in
# Applications/Utilities for locating this file for Mac OS X users.)
#
# Barring that, you might beg me for help. I can be reached via
# hanenkamp@cpan.org or by visiting my blog at http://contentment.org/feedback
# or feel free to message me on Facebook: Andrew Sterling Hanenkamp should not
# be hard to find.

use CGI '3.30', ();
use Fcntl ':flock';
use Scalar::Util qw/ reftype /; # reftype is better than ref sometimes
use YAML (); # if performance is an issue, we should consider YAML::Syck

# Helps during debugging
$ENV{REQUEST_METHOD} = 'GET' unless defined $ENV{REQUEST_METHOD};

my $q = CGI->new;

# The local path according to settings
sub get_local_path($) {
    my $id = shift;
    return CONFIG_DIR.'/'.$id.'.yaml';
}

sub barf($$;$) {
    my ($status, $title, $message) = @_;

    die {
        status  => $status, 
        title   => $title, 
        message => $message,
    };
}

# Use the next unused ID. This won't work if your CONFIG_DIR is stored on an
# NFS file system or anywhere else flock() is broken. See perldoc -f flock
sub next_id() {
    my $last_id_file = CONFIG_DIR.'/last_id';

    # If no such file exists, die
    die "Please create $last_id_file like this: echo 0 > $last_id_file" 
        unless -f $last_id_file;

    # Open the last_id file and lock it for exclusive use
    open my $idfh, '+<', $last_id_file or die "Cannot open $last_id_file: $!";
    flock($idfh, LOCK_EX);

    # Read the current last ID
    my $last_id = <$idfh>;
    chomp $last_id;

    # Keep going until we find a next_id we haven't used
    my $next_id = $last_id;
    while (-f get_local_path(++$next_id)) {}

    # Write back the current last ID
    seek $idfh, 0, 0;
    print $idfh "$next_id\n";

    flock($idfh, LOCK_UN);

    return $next_id;
}

my $self_url = $q->url( -full => 1 );
sub absolute_url($) {
    my $path = shift;
    return $self_url . $path;
}

sub check_book($) {
    my $data = shift;

    # We expect the data to be in YAML format
    unless ($q->content_type eq 'text/yaml') {
        barf 415, 'I Only Eat YAML', 
            'The correct format for a create request is text/yaml.';
    }

    # Try to load it and make sure it's valid YAML
    my $book = eval { YAML::Load($data) };
    
    # On error we need to complain
    barf 400, 'What? I Cannot Understand You', $@ if $@;

    # Make sure the data is the right kind of thing
    unless (ref $book and reftype $book eq 'HASH') {
        barf 400, 'I Only Do Hashes',
            'The submitted YAML data is not a HASH.';
    }

    # Make sure we have a title
    unless ($book->{title}) {
        barf 500, 'Missing Required Field',
            'All books must have a title, duh!';
    }

    return $book;
}

# Store the path into this variable for easy dispatch in a moment
#local $_ = $q->path_info;

sub GET($$) {
    my ($path, $code) = @_;
    return unless $q->request_method eq 'GET' or $q->request_method eq 'HEAD';
    return unless $q->path_info =~ $path;
    $code->();
    exit;
}

sub POST($$) {
    my ($path, $code) = @_;
    return unless $q->request_method eq 'POST';
    return unless $q->path_info =~ $path;
    $code->();
    exit;
}

sub PUT($$) {
    my ($path, $code) = @_;
    return unless $q->request_method eq 'PUT';
    return unless $q->path_info =~ $path;
    $code->();
    exit;
}

sub DELETE($$) {
    my ($path, $code) = @_;
    return unless $q->request_method eq 'DELETE';
    return unless $q->path_info =~ $path;
    $code->();
    exit;
}

eval {

    barf 403, "Go Away!", "I only talk to localhost!"
        unless $q->remote_host eq 'localhost'
            or $q->remote_host eq '127.0.0.1';

    # Provide some nice documentation
    GET qr{^/=$} => sub {
        print $q->header('text/html');

        print $q->h1('REST API Documentation');

        print $q->p('Here is a list of what you can do:');

        print $q->dl(
            $q->dt('GET /=/model/book/id'),
            $q->dd('Returns a list of available book IDs.'),

            $q->dt('GET /=/model/book/id/[ID]'),
            $q->dd('ID may be a number or the ISBN. Returns the book.'),

            $q->dt('POST /=/model/book'),
            $q->dd('Create a new book record. Returns the new URL to fetch with.'),

            $q->dt('PUT /=/model/book/id/[ID]'),
            $q->dd('Update a book by posting a complete book file.'),

            $q->dt('DELETE /=/model/book/id/[ID]'),
            $q->dd('Delete a book.'),
        );

        print $q->p('All book resources are stored or fetched in YAML format. The list of books will be fetched in HTML with each LI in the returned listing containing a link to a book resource.');

        print $q->p('Here is a sample book. The "title" field is the only required field for books. The "isbn" field should be equal to the "id" field, if the "isbn" is present. The "id" field should be the [ID] used to fetch, updated, or delete the record.');

        print $q->pre(q{isbn: 0-7852-1155-1
title: "The New Strong's Exhaustive Concordance of the Bible"
author: James Strong, LL.D., S.T.D.
publisher: Thomas Nelson Publishers
city: Nashville, Tennessee
year: 1995});
    };

    # Get a whole list of available documents
    GET qr{^/=/model/book/id$} => sub {
        print $q->header('text/html');

        # Find all the files available
        my @items;
        for my $filename (glob get_local_path('*')) {
            my ($id) = $filename =~ m{([\d-]+)\.yaml$};
            next unless defined $id;

            push @items, $q->li(
                $q->a({ href => absolute_url('/=/model/book/id/'.$id) }, $id),
            );
        }

        # List the items
        print $q->ul( @items );
    };

    # Look up and read a resource
    GET qr{^/=/model/book/id/([\d-]+)$} => sub {
        my $id = $1;

        # Look up the resource file
        my $filename = get_local_path($id);
        if (-f $filename) {

            # Open and slurp up the file and output the resource
            open my $bookfh, $filename 
                or barf 500, "I Am Broke", "Cannot open $filename: $!";

            print $q->header('text/yaml');
            print do { local $/; <$bookfh> };
        }

        # No such resource exists
        else {
            barf 404, "Where is What?", "Book for $id does not exist.";
        }
    };

    # Handle the creation of new books
    POST qr{^/=/model/book$} => sub {

        # Check to make sure the input book is sane
        my $book = check_book( $q->param('POSTDATA') );

        # If we have an ISBN (some books don't!), then die if we already have
        # it because we don't permit POST cannot for updates!
        if ($book->{isbn} and -f get_local_path($book->{isbn})) {
            barf 500, 'Not Gonna Do It',
                'A POST may not be used to update an existing book.';
        } 

        # Our data is sane!

        # Figure out an ID, this is either the ISBN or a generated ID
        my $id = $book->{isbn} ? $book->{isbn} : next_id;

        # Store the ID for reference within the record
        $book->{id} = $id;

        # Save the resource
        eval { YAML::DumpFile(get_local_path($id), $book) };
        barf 500, 'I Am Broke', $@ if $@;

        # Note the success to the end-user
        my $resource_url = absolute_url('/=/model/book/id/'.$id);
        print $q->header( 
            -status   => 201, 
            -type     => 'text/html',
            -location => $resource_url,
        );
        print $q->h1("Created $book->{title}");
        print $q->ul(
            $q->li(
                $q->a({ href => $resource_url }, $resource_url)
            )
        );
    };

    # Handle updates to books
    PUT qr{^/=/model/book/id/([\d-]+)$} => sub {
        my $id = $1;

        # Check to make sure the input book is sane
        my $book = check_book( $q->param('PUTDATA') );

        # Make sure the book already exists or barf
        my $resource_path = get_local_path($id);
        unless (-f $resource_path) {
            barf 500, 'Not Gonna Do It',
                'Cannot use PUTs for creating a new resource.';
        }

        # Make sure the ID is set
        $book->{id} = $id;

        # Save the resource
        eval { YAML::DumpFile($resource_path, $book) };
        barf 500, 'I Am Broke', $@ if $@;

        # Note the success to the end-user
        print $q->header('text/html');
        print $q->h1("Updated $book->{title}");
    };

    DELETE qr{^/=/model/book/id/([\d-]+)$} => sub {
        my $id = $1;

        # Make sure the book actually exists
        my $resource_path = get_local_path($id);
        unless (-f $resource_path) {
            barf 404, 'Where is What?',
                'Nothing here to delete.';
        }

        # Baleted!
        unlink $resource_path;

        # Tell me about it.
        print $q->header('text/html');
        print $q->h1("Deleted $id");
    };
};

if ($@) {

    # Handle barfing
    if (ref $@ and reftype $@ eq 'HASH') {
        my $ERROR = $@;
        print $q->header( -status => $ERROR->{status}, -type => 'text/html' );
        print $q->h1( $ERROR->{title} );
        print $q->p( $ERROR->{message} ) if $ERROR->{message};
    }

    # Handle anything else
    else {
        my $ERROR = $@;
        print $q->header( -status => 500, -type => 'text/html' );
        print $q->title('Server Error');
        print $q->p( $ERROR );
    }

    exit;
}

# Nothing handles this, throw back a standard 404
print $q->header(-status => 404, -type => 'text/html');
print $q->h1('Resource Not Found');