#!/usr/bin/perl =head1 NAME @SectionPush(Annotation Documents) The simple Annotation Server stores Annotation Documents in flat files. @SectionPush(Root Directory) @Var(\$AnnRoot) is the name of the root directory in which the files are stored. This directory must be writable by the user that the web server runs under. =cut $AnnRoot = "/tmp/Annotations"; =head1 NAME @Section(Document ID) Each document will be identified by a Document ID. For the purposes of this sample, the Document ID is simply a unique string. @DefPerlFunc{adFileName(\$id)} Return the filename of the Annotation Document with the Document ID @Var(\$id). =cut sub adFileName { my ($id) = @_; # Remove unsafe characters from the ID $id =~ s/[^a-zA-Z0-9\.,_]/_/g; # Map it to a file in the annotation directory qq{$AnnRoot/$id.data}; } =head1 NAME @DefPerlEnd @Section(Loading) To load an Annotation Document, we simply map the ID to a file and load the contents of the file. @DefPerlFunc{adLoad(\$id)} Return the annotation data for Document ID @Var(\$id). =cut sub adLoad { my ($id) = @_; # If the file can not be opened, return an empty annotation document. if(!open(FILE, adFileName($id))) { return qq{}; } # Read the file in binary mode under a non-exclusive lock binmode(FILE); flock(FILE, 1); my $data = join('', ); flock(FILE, 8); # Close the file and return the data close(FILE); $data; } =head1 NAME @DefPerlEnd @Section(Storing) To store an Annotation Document, we simply map the ID to a file and save the data to the file. @DefPerlFunc{adStore(\$id, \$xml)} Save @Var(\$xml) as the annotation data for the Document ID @Var(\$id). Returns 1 if the operation is successful; otherwise @Var(undef). =cut sub adStore { my ($id, $xml) = @_; # If the file can not be opened for writing, return an error. if(!open(FILE, ">".adFileName($id))) { return undef; } # Write the file in binary mode under an exclusive lock binmode(FILE); flock(FILE, 2); print FILE $xml; flock(FILE, 8); # Close the file and return no error close(FILE); 1; } =head1 NAME @DefPerlEnd @SectionPop @Section(CGI Interface) The following utilities are used to interface with the CGI host. @SectionPush(Parsing CGI Parameters) Per the CGI specification, the request URL parameters are supplied in @Var(\$ENV{QUERY_STRING}). @DefPerlFunc{cgiParse()} Parse the CGI parameters and store the name-value pairs into the @Var(CGI) hash. =cut sub cgiParse { # The name/value pairs are separated by '&'. foreach(split(/&/, $ENV{QUERY_STRING})) { # Convert plus's to spaces s/\+/ /g; # Split into name and value. The two fields are separated by '='. local($key, $val) = split(/=/,$_,2); # splits on the first =. # Convert hex escapes (%XX) to alphanumeric $key =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; $val =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; # Associate key and value $CGI{$key} = $val; } } =head1 NAME @DefPerlEnd @Section(Generating a Response) @DefPerlFunc{cgiRespond(\$code, \$mime, \$text)} Generate the HTTP response to a request. The response specifies a status code of @Var(\$code). The response data has a mime type of @Var(\$mime). @Var(\$text) is the data to send with the response. =cut sub cgiRespond { my ($code, $mime, $text) = @_; my $len = length($text); print qq{Content-Type: $mime Content-Length: $len Status: $code $text }; } =head1 NAME @DefPerlEnd @SectionPop @Section(The Server) The server merely parses the CGI parameters and reads or writes the specified annotations, depending on whether the request is a GET or a POST. =cut # The Document ID is specified as the @Var(ID) CGI parameter. Parse the CGI parameters into the @Var(CGI) hash cgiParse(); # If they did not specify an ID, return an error if(!$CGI{ID}) { cgiRespond(400, "text/plain", "There was no document specified"); } # If this is not a POST, load the XML data elsif($ENV{REQUEST_METHOD} ne "POST") { cgiRespond(200, "text/xml", adLoad($CGI{ID})); } # This is a POST operation. Store the XML data else { # Get the data to store my $xml; read(STDIN, $xml, $ENV{'CONTENT_LENGTH'}); # Store the new annotation data my $worked = adStore($CGI{ID}, $xml); if(!$worked) { cgiRespond(503, qq{Unable to update annotations}); } else { cgiRespond(200, "text/plain", "Update succeeded"); } } =head1 NAME @DefPerlEnd =cut