package Bio::Graphics::Browser2::RemoteSet;
# API for handling a set of remote annotation sources

use strict;
use base 'Bio::Graphics::Browser2::ExternalData';

use Bio::Graphics::Browser2::Util 'shellwords';
use IO::File;
use File::Path 'mkpath';
use CGI 'cookie','param','unescape';
use Digest::MD5 'md5_hex';
use File::Spec;

use constant URL_FETCH_TIMEOUT    => 20;  #  seconds max!
use constant URL_FETCH_MAX_SIZE   => 50_000_000;  # don't accept any files larger than 50 Meg

use constant DEBUG=>0;

sub new {
  my $package = shift;
  my $config   = shift;
  my $state    = shift;
  my $lang     = shift;
  my $uploadid = shift;
  my $self = bless {
      config        => $config,
      language      => $lang,
      state         => $state,
      uploadid      => $uploadid,
      sources       => {},
  },ref $package || $package;
  $self;
}

sub uploadid { shift->{uploadid} }

sub add_files_from_state {
    my $self  = shift;
    my $state = $self->state;
    my $config = $self->config;

    for my $track (@{$state->{tracks}||[]}) {

	if ($track =~ /^(http|ftp|das):/) {
	    warn "adding remote track $track" if DEBUG;
	    $self->add_source($track,$track);
	    next;
	}

	my $remote_url = $config->setting($track=>'remote feature') or next;
	$remote_url    = &$remote_url() 
	    if ref $remote_url && ref $remote_url eq 'CODE';
	warn "adding remote_url = $remote_url" if DEBUG;
	$self->add_source($track,$remote_url);
    }
}

sub language      { shift->{language}         }
sub state         { shift->{state}            }
sub config        { shift->{config}           }
sub sources       { keys %{shift->{sources}}  }
sub source2url    { shift->{sources}{shift()} }

sub add_source {
  my $self   = shift;
  my ($label,$source) = @_;
  $self->{sources}{$label}=$source;
}

sub delete_source {
  my $self   = shift;
  my $label = shift;
  delete $self->{sources}{$label};
}

sub set_sources {
  my $self     = shift;
  my $sources  = shift;

  my $state = $self->state;
  for (@$sources) {
    next if $_ eq '';
    $self->add_source($_,$_);
    $state->{features}{$_}{visible}++ unless exists $state->{features}{$_};
  }

  # remove unused tracks
  my $adjusted;
  for my $track (keys %{$state->{features}}) {
     next unless $track =~ /^(http|ftp|das):/;
     next if $self->{sources}{$track};
     delete $state->{features}{$track};
     $adjusted++;
   }
}

sub feature_file {
  my $self = shift;
  my ($label,$segment,$rel2abs,$slow_mapper,$overview,$region) = @_;

  my $config   = $self->config;
  my $state = $self->state;

  warn "feature_file(): fetching $label" if DEBUG;

  # DAS handling
  my $url = $self->source2url($label);
  my $feature_file;

  if ($url =~ m!^(http://.+/das)/([^?]+)(?:\?(.+))?$!) { # DAS source!
    warn "getting DAS segment for $url" if DEBUG;
    $feature_file = $self->get_das_segment($1,$2,$3,$segment);
  }
  else {
    warn "getting featurefile for $url" if DEBUG;
    $feature_file = $self->get_remote_upload($url,$rel2abs,$slow_mapper,$segment,$label,$overview,$region);
  }
  return unless $feature_file;

  # Tell the feature file what its name is, so that it can be formatted
  # nicely in the user interface.
  my $name = $feature_file->setting('name') if $feature_file->can('setting');
  $feature_file->name($name||$url) if $feature_file->can('name');

  return $feature_file;
}

sub transform_url {
    my $self = shift;
    my ($url,$segment,$overview_segment,$region_segment) = @_;

    my ($seqid,$start,$end) = ref $segment 
	                          ? ($segment->seq_id,$segment->start,$segment->end)
                                  : $segment =~ /^([^:]+):(.+)(?:\.\.|,)(.+)$/;

    # do certain substitutions on the URL
    # for DAS
    $url =~ s!(http:.+/das/\w+)(?:\?(.+))?$!$1/features?segment=$seqid:$start..$end;$2!;

    # for gbgff and the like
    $url =~ s/\$segment/$seqid:$start..$end/g;
    $url =~ s/\$overview/"$seqid:".$overview_segment->start.'..'.$overview_segment->end/ge if $overview_segment;
    $url =~ s/\$region/"$seqid:".$region_segment->start.'..'.$region_segment->end/ge       if $region_segment;
    $url =~ s/\$ref/$seqid/g;
    $url =~ s/\$start/$start/e;
    $url =~ s/\$end/$end/e;
 
    return $url;
}

sub get_remote_upload {
  my $self = shift;
  my ($url,$rel2abs,$slow_mapper,$segment,$label,$overview,$region) = @_;
  my $config = $self->config;

  # do certain substitutions on the URL
  $url = $self->transform_url($url,$segment,$overview,$region);

  my (undef,$filename) = $self->name_file($url,0);
  my $response         = $self->mirror($url,$filename);
  if ($response->is_error) {
      # error($self->language->tr('Fetch_failed',$url,$response->message));
      warn "$url: ",$response->message;
      return;
  }
  my $fh = IO::File->new("<$filename") or return;
  my $in_overview    = $rel2abs ne $slow_mapper && $self->probe_for_overview_sections($fh);
  my $feature_file   =
    Bio::Graphics::FeatureFile->new(-file           => $fh,
			    # this is broken
#				    -map_coords     => $in_overview ? $slow_mapper : $rel2abs,
				    -smart_features => 1,
				    -safe_world     => 
				       $self->config->global_setting('allow remote callbacks')||0,
    );
  warn "get_remote_feature_data(): got $feature_file" if DEBUG;
 
  # let proximal configuration override remote
  if ($config->setting($label => 'remote feature')) {

    # local track name may not correspond to the
    # FeatureFile types
    my ($types) = $url =~ /type=([^;&]+)/;
    my @types = split(/\+|\s+/, $types);

    for my $option ($config->config->_setting($label)) {
      my $val = $config->setting($label => $option);
      for my $type (@types) {
	$feature_file->set($type,$option,$val);
      }
    }
  }

  return $feature_file;
}

# We override name_file() so as to place all remote data
# into one "remote" directory. This avoids replicating data.
sub name_file {
  my $self      = shift;
  my $filename  = shift;
  my $strip     = shift;

  my $state     = $self->state;
  my $config    = $self->config;
  my $hex       = md5_hex($filename);
  my ($a,$b)    = $hex =~ /^(.{2})(.{2})/;
  my $id        = File::Spec->catfile('shared_remote_tracks',$a,$b);

  my ($url,$path) = $self->file2path($config,$id,$filename,$strip);
  warn "name_file() returns => ($url,$path)" if DEBUG;
  return ($url,$path);
}

sub get_das_segment {
  my $self = shift;
  my ($src,$dsn,$cgi_args,
      $segment) = @_;
  my $config   = $self->config;

  unless (eval "require Bio::Das; 1;") {
      Bio::Graphics::Browser2::Util::error($self->language->tr('NO_DAS'));
      return;
  }

  my @aggregators = shellwords($config->setting('aggregators') ||'');
  my (@types,@categories);

  if ($cgi_args) {
    my @a = split /[;&]/,$cgi_args;
    foreach (@a) {
      my ($arg,$val) = split '=';
      push @types,unescape($val)      if $arg eq 'type';
      push @categories,unescape($val) if $arg eq 'category';
    }
  }
  my @args = (-source     => $src,
	      -dsn        => $dsn,
	      -aggregators=> \@aggregators);
  push @args,(-types => \@types)           if @types;
  push @args,(-categories => \@categories) if @categories;
  my $das      =  Bio::Das->new(@args);

  return unless $das;

  # set up proxy
  my $http_proxy = $self->http_proxy;
  $das->proxy($http_proxy) if $http_proxy && $http_proxy ne 'none';

  my $seg = $das->segment($segment->abs_ref,
			  $segment->abs_start,
			  $segment->abs_end);
  return $seg;
}

sub mirror {
  my $self            = shift;
  my ($url,$filename) = @_;

  my $config = $self->config;

  # Uploaded feature handling
  unless (LWP::UserAgent->can('new')) {
      unless (eval "require LWP") {
	  Bio::Graphics::Browser2::Util::error($self->language->tr('NO_LWP'));
	  return;
      }
  }
  my $ua = LWP::UserAgent->new(agent    => "Generic-Genome-Browser/$main::VERSION",
				timeout  => URL_FETCH_TIMEOUT,
				max_size => URL_FETCH_MAX_SIZE,
      );
  my $http_proxy = $self->http_proxy;
  my $ftp_proxy  = $self->ftp_proxy;

  $ua->proxy(http => $http_proxy) if $http_proxy && $http_proxy ne 'none';
  $ua->proxy(ftp => $http_proxy)  if $ftp_proxy  && $ftp_proxy  ne 'none';

  my $request = HTTP::Request->new(GET => $url);
  if (-e $filename) {
      my($mtime) = (stat($filename))[9];
      if($mtime) {
	  $request->header('If-Modified-Since' =>
			   HTTP::Date::time2str($mtime));
      }
  }

  my ($volume,$dirs,$file) = File::Spec->splitpath($filename);
  $file = "$file-$$";
  my $tmpfile  = File::Spec->catfile($volume,$dirs,$file);

  mkpath($dirs) unless -e $dirs && -d _;
  my $response = $ua->request($request,$tmpfile);

  if ($response->is_success) {  # we got a new file, so need to process it
      my $fh     = IO::File->new($tmpfile);

      # handle possible un-gzipping
      my $dummy_name = $url;
      $dummy_name   .= ".gz" if $response->header('Content-Type') =~ /gzip/;

      my $infh       = $self->maybe_unzip($dummy_name,$fh) || $fh;
      $infh or die "Couldn't open $tmpfile: $!";
      my $outfh  = IO::File->new(">$filename") or die "Couldn't open $filename: $!";
      $self->process_uploaded_file($infh,$outfh);
      if (my $lm = $response->last_modified) {
	  utime($lm,$lm,$filename);
      }
  }
  unlink $tmpfile;  # either way, this file is no longer needed
  return $response;
}

sub annotate {
  my $self = shift;
  my $segment                = shift;
  my $feature_files          = shift || {};
  my $fast_mapper            = shift;  # fast mapper filters out features that are outside cur segment
  my $slow_mapper            = shift;  # slow mapper doesn't
  my $max_segment            = shift;  # ignored
  my $whole_segment          = shift;
  my $region_segment         = shift;
  my $state                  = $self->state;

  for my $url ($self->sources) {
      next unless $state->{features}{$url}{visible};
      
      # check to see whether URL includes the magic $segment and/or $ref 
      # parameters. If so, then it is safe to use the coordinate remapper
      # which remaps all coordinates. Otherwise, this is probably just a GFF
      # file and we need to filter out features that are outside the range of
      # the current segment.
      my $mapper             = $url =~ m!\$(segment|ref|overview|region)!
                                     ? $fast_mapper
                                     : $slow_mapper;
      my $feature_file       = eval {$self->feature_file($url,$segment,
							 $mapper,$slow_mapper,
							 $whole_segment,$region_segment)
      };
      $self->error($url=>$@) if $@;
      $feature_files->{$url} = $feature_file;
  }
}

sub error {
    my $self = shift;
    my $url = shift;
    $self->{error}{$url} = shift if @_;
    return $self->{error}{$url};
}

1;

__END__

=head1 NAME

Bio::Graphics::Browser2::PluginSet -- A set of plugins

=head1 SYNOPSIS

None.  Used internally by gbrowse & gbrowse_img.

=head1 METHODS

=over 4

=item $plugin_set = Bio::Graphics::Browser2::PluginSet->new($config,$state,@search_path)

Initialize plugins according to the configuration, page settings and
the plugin search path.  Returns an object.

=item $plugin_set->configure($database)

Configure the plugins given the database.

=item $plugin_set->annotate($segment,$feature_files,$rel2abs)

Run plugin annotations on the $segment, adding the resulting feature
files to the hash ref in $feature_files ({track_name=>$feature_list}).
The $rel2abs argument holds a coordinate mapper callback, but is
currently unused.

=back

=head1 SEE ALSO

L<Bio::Graphics::Browser>

=head1 AUTHOR

Lincoln Stein E<lt>lstein@cshl.orgE<gt>.

Copyright (c) 2005 Cold Spring Harbor Laboratory

This package and its accompanying libraries is free software; you can
redistribute it and/or modify it under the terms of the GPL (either
version 1, or at your option, any later version) or the Artistic
License 2.0.  Refer to LICENSE for the full license text. In addition,
please see DISCLAIMER.txt for disclaimers of warranty.

=cut