# Author: Alan Ruttenberg. alanruttenberg@gmail.com
# Date: February, 2007
# Serve tiles of the Allen Brain Atlas for use with google maps mashup
# Serve the same image paths, but make sure that we always return 256x256 tiles.
# Cache to reduce load on ABA.
#
# Apache setup (using mod_perl 2)
#     PerlRequire /export/cgi/startup.pl
#     PerlModule Apache::Reload
#     PerlInitHandler Apache::Reload
#     <Location /pyramid>
#       SetHandler perl-script
#       PerlHandler SC::ABATiler
#     </Location>

package SC::ABATiler;
  
use strict;
use warnings;
use Apache::RequestRec ();
use Apache::RequestIO ();
use Image::Size qw(imgsize);
use LWP::UserAgent ();
use GD;
use HTTP::Date;
use APR::Table ();
use Apache::Const -compile => qw(OK);
use Digest::MD5 qw(md5 md5_hex md5_base64);

my  $userAgent = LWP::UserAgent->new;
my  $tile = new GD::Image(255,255,1);
my  $imagecache = "/export/abacache/";

# for debugging
my  $u = "/pyramid/production10/Accn2_05-2650_22031/zoomify/primary/0205032816/Accn2_76_0205032816_B.aff/TileGroup/1-1-0.jpg";

# compute the cache file name. MD5 of the url, in hex. 3 levels of directories taken
# from the first 3 characters of the MD5.

sub cacheFileName
{ my $uri = shift;
  my $md5 = md5_hex($uri);
  my $cachedir = $imagecache.substr($md5,0,1)."/".substr($md5,1,1)."/".substr($md5,2,1)."/";
  if (! -e $cachedir)
    { system("mkdir","-p",$cachedir);}
  my $cachefile = $cachedir.$md5.".jpg";
}
 
# save an image in the cache
sub cacheImage
{ my $uri = shift;
  my $data = shift;
  my $file = cacheFileName($uri);
  open F, ">$file";
  print F $$data;
  close F
}

# Background fill is white for normal image, black for expression image.
sub background 
{ my $uri = shift;
  if ($uri =~/express/)
  { $tile->filledRectangle(0,0,255,255,$tile->colorAllocate(0,0,0)); }
  else
  { $tile->filledRectangle(0,0,255,255,$tile->colorAllocate(255,255,255));}
  $tile
}

# in: jpeg, out jpeg (maybe same) that is padded to 256x256. 
sub maybePad
{ my $content = shift;
  my $uri = shift;
  my ($x, $y) = imgsize($content);
  if (($x < 255) || ($y < 255)) 
  { my $tile = background($uri);
    $tile->copy(newFromJpegData GD::Image($$content),0,0,0,0,$x,$y);
    return(\$tile->jpeg)
  }
  $content
}

sub fetchFromBrainMapOrg
{ my $uri = shift;
  my $request = HTTP::Request->new("GET", "http://www.brain-map.org".$uri);
  my $response = $userAgent->request($request);
  for (my $i=0;$i<5;$i++) 
  { last if $response->code == 200;
    sleep(.2+.2*rand(6));
    $response = $userAgent->request($request);
  }
  return($response->code,\$response->content)
}

# return two values:
# success 0 if ABA refused us 1, if it didn't. Note that 0 length jpegs are
# returned if we ask for an out of bound tile.

sub getABATile
{ my $uri = shift;
  # First check if we have a local cache and return that if so.
  my $cachefile = cacheFileName($uri);
  if (-e $cachefile)
  { open F, "<$cachefile";
    my $content;
    read(F,$content,-s $cachefile);
    close F;
    return(1,\$content)
  }
  # otherwise get it from brain-map.org. 0-length jpegs become background.
  else
  { my ($code,$content) = fetchFromBrainMapOrg($uri);
    if ($code == 200) 
    { if (length($$content)==0) 
      { return(1,\background($uri)->jpeg) }
      # we've got a live one. If it isn't 256x256 then pad it, then cache it.
      else 
      { my $content = maybePad($content,$uri);
	cacheImage($uri,$content);
	return(1,$content)
      } 
    }
    # here we've actually received an error :(
    else 
    { return(0,\background($uri)->jpeg) }
  }}


sub handler 
{ my $r = shift;
  my $uri = $r->uri;

  # success means that we were not refused.
  my ($success,$content) = getABATile($uri);
  if ($success)
  { $r->headers_out->{'Expires'}=HTTP::Date::time2str(time + 14*24*60*60); # two weeks
    $r->headers_out->{'Last-Modified'}="Sun, 18 Feb 2005 09:00:17 GMT"; # some time in the past
    print $$content;
  }
  else
  { $r->headers_out->{'Cache-Control'}="no-cache";
    print($$content);
  }
  return Apache::OK;
}

$DB::single=1;
1;
1;