package Bio::Graphics::Browser2::Session;

# $Id$

use strict;
use warnings;

use CGI::Session;
use CGI::Cookie;
use Fcntl 'LOCK_EX','LOCK_SH';
use File::Spec;
use File::Path 'mkpath';
use Digest::MD5 'md5_hex';
use Carp 'carp';
use constant LOCK_TIMEOUT => 10;
eval "require Time::HiRes;";

my $HAS_NFSLOCK;
my $HAS_MYSQL;

BEGIN {
    # Prevent CGI::Session from autoflushing. Only flush when we say to.
    undef *CGI::Session::DESTROY;
    $HAS_NFSLOCK = eval {require File::NFSLock;1           };
    $HAS_MYSQL   = eval {require DBI; require DBD::mysql; 1};
}

use constant DEBUG => 0;
use constant DEBUG_LOCK => DEBUG || 0;

sub new {
	my $class    = shift;
	my %args     = @_;
	my ($driver,$id,$session_args,$default_source,$lockdir,$locktype,$expire_time,$mode) 
	  = @args{'driver','id','args','source','lockdir','locktype','expires','mode'};

	$mode ||= 'exclusive';
	$CGI::Session::NAME = 'gbrowse_sess';     # custom cookie

	#Probably safe to uncomment, but must test exhaustively with mysql locking
	#to determine.
	#$CGI::Session::Driver::file::NoFlock = 1;; 

	unless ($id) {
	    my $cookie = CGI::Cookie->fetch();
	    $id        = $cookie->{$CGI::Session::NAME}->value 
		if $cookie && $cookie->{$CGI::Session::NAME};
	}
	my $self            = bless {
	    lockdir  => $lockdir,
	    locktype => $locktype,
	},$class;

	$self->session_argv($driver,$id,$session_args);
	$self->{session} = $mode eq 'exclusive' ? $self->lock_ex($id) : $self->lock_sh($id);
	warn "CGI::Session->new($driver,$id,$session_args)=>",$self->{session}->id if DEBUG;

	# never expire private (authenticated) sessions
	$expire_time = 0 if $self->private;
	$self->{session}->expire($expire_time) 
		if defined $expire_time;

	warn "[$$] session fetch for ",$self->id if DEBUG;
	$self->source($default_source) unless defined $self->source;
	$self->{pid} = $$;

	## DEBUG STARTS
	if (DEBUG_LOCK) {
	    my $state  = $self->page_settings;
	    my @tracks = sort grep {$state->{features}{$_}{visible}} keys %{$state->{features}};
	    warn '[',$self->time,'] ',"[$$] READING @tracks\n";
	}
	## DEBUG ENDS

	$self;
}

sub load_session {
    my $self = shift;
    $self->session_argv(@_);
    return CGI::Session->new($self->session_argv);
}

sub session_argv {
    my $self = shift;
    if (@_) {
	$self->{session_argv} = \@_;
    } else {
	return unless $self->{session_argv};
	return @{$self->{session_argv}};
    }
}

sub locktime {
    my $self = shift;
    my $d = $self->{locktime};
    $self->{locktime} = shift if @_;
    return $d; 
}

sub locktype {
    my $self = shift;
    if ($self->{locktype} eq 'default') {
	return 'flock';
    }
    return 'nfs'   if $self->{locktype} eq 'nfs'                     && $HAS_NFSLOCK;
    return 'mysql' if $self->{locktype} =~ /^(dbi:mysql|mysql):/    && $HAS_MYSQL;
    return 'flock' if $self->{locktype} eq 'flock';
}

sub lock {
    my $self    = shift;
    my $type    = shift;
    my $id      = shift;
    
    # no id, so we have to create a session and get an id
    # otherwise we lock before we make the session
    unless ($id) {
	$self->{session} ||= $self->load_session();
	$id = $self->id;
    }

    return if $self->lockobj; # don't double lock
    my $locktype = $self->locktype;
    my $start_time = $self->time();

    warn '[',$self->time,'] ',"[$$] waiting on $type session lock...\n" if DEBUG_LOCK;

    eval {
	local $SIG{ALRM} = sub {die "timeout\n"};
	# timeout lock to avoid some process from keeping process open
	# you may see some lock timeouts if a process is taking too long
	# to release its session.
	alarm(LOCK_TIMEOUT); 

	if ($locktype eq 'flock') {
	    $self->lock_flock($type,$id);
	}
	elsif ($locktype eq 'nfs') {
	    $self->lock_nfs($type,$id);
	}
	elsif ($locktype eq 'mysql') {
	    $self->lock_mysql($type,$id);
	}
	else {
	    die "unknown lock type $locktype";
	}
    };
    alarm(0);
    my $elapsed = sprintf("%5.3fs",$self->time()-$start_time);
    if ($@) {
	die $@ unless $@ eq "timeout\n";
	warn ("[$$] session lock timed out on request after $elapsed\n",
	      CGI::request_method(),': ',
	      CGI::url(-path=>1),' ',
	      CGI::query_string());
    } else {
	warn '[',$self->time,'] ',"[$$] ...$type lock obtained after $elapsed (action=",CGI::param('action'),')' if DEBUG_LOCK;
    }
    $self->locktime($self->time());
    return $self->{session} ||= $self->load_session();
}

sub lock_flock {
    my $self = shift;
    my ($type,$id) = @_;

    my $mode  = $type eq 'exclusive' ? LOCK_EX : LOCK_SH;

    my ($lockdir,$lockfile) = $self->lockfile($id);

    mkpath($lockdir) unless -e $lockdir;
    my $lockpath = File::Spec->catfile($lockdir,$lockfile);
    my $o_mode   = $type eq 'exclusive' ? '>'
	          :-e $lockpath ? "<" 
		  : "+>";

    open my $fh,$o_mode,$lockpath 
	or die "Couldn't open lockfile $lockpath: $!";
    flock ($fh,$mode);
    $self->lockobj($fh);
}

sub lock_nfs {
    my $self = shift;
    my ($type,$id) = @_;
    my ($lockdir,$lockfile) = $self->lockfile($id);
    mkpath($lockdir) unless -e $lockdir;
    my $lockpath = File::Spec->catfile($lockdir,$lockfile);
    my $lock     = File::NFSLock->new(
	{file               => $lockpath,
	 lock_type          => $type eq 'exclusive' ? LOCK_EX : LOCK_SH
	});
    $lock or warn  "[$$] ...couldn't get lock: $File::NFSLock::errstr";
    $self->lockobj($lock);

}

sub lock_mysql {
    my $self = shift;
    my ($type,$id) = @_;
    $SIG{PIPE} = 'IGNORE';
    return if $type eq 'shared';
    my $lock_name  = $self->mysql_lock_name($id);
    (my $dsn       = $self->{locktype}) =~ s/^mysql://;
    my $dbh        = $self->{mysql} ||= DBI->connect($dsn)
                     or die "Session has no dbh handle!";
    my $result     = $dbh->selectrow_arrayref("SELECT GET_LOCK('$lock_name',10)");
    warn "Could not get my lock on $id" unless $result->[0];
    $self->lockobj($dbh);
}

sub lock_sh {
    shift->lock('shared',@_);
}
sub lock_ex {
    shift->lock('exclusive',@_);
}

sub unlock {
    my $self     = shift;
    my $lock = $self->lockobj or return;
    warn '[',$self->time,'] ',"[$$] session unlock" if DEBUG_LOCK;
    if ($lock->isa('DBI::db')) {
	my $lock_name = $self->mysql_lock_name($self->id);
	my $result = $lock->do("SELECT RELEASE_LOCK('$lock_name')");
    }
    $self->lockobj(undef);
    warn "[$$] lock released after ",sprintf("%2.1f",$self->time() - $self->locktime)," s (action=",CGI::param('action'),')' if DEBUG;
}

sub lockfile {
    my $self   = shift;
    my $id     = shift;
    my ($a) = $id =~ /^(.{2})/;
    return (File::Spec->catfile($self->{lockdir},$a),
	    $id);
}

sub mysql_lock_name {
    my $self = shift;
    my $id   = shift;
    return "gbrowse_session_lock.$id";
}

# handle the lock when forking occurs
sub was_forked {
    my $self  = shift;
    my $state = shift;
    my $obj  = $self->lockobj or return;
    ref $obj or return;
    if ($state eq 'child') {
	if ($obj->isa('File::NFSLock')) {
	    undef *File::NFSLock::DESTROY;
	}
	elsif ($obj->isa('DBI::db')) {
	    $obj->{InactiveDestroy} = 1;
	}
    }
}

sub delete {
    my $self = shift;
    $self->{session}->delete if $self->{session};
    $self->unlock;
}

sub flush {
  my $self = shift;
  return unless $$ == $self->{pid};
  carp "[$$] session flush" if DEBUG;

  ## DEBUG STARTS
  if (DEBUG_LOCK) {
      my $state  = $self->page_settings;
      my @tracks = sort grep {$state->{features}{$_}{visible}} keys %{$state->{features}};
      warn '[',$self->time,'] ',"[$$] WRITING @tracks\n";
  }
  ## DEBUG ENDS

  $self->{session}->flush if $self->{session};
#  $self->unlock;
  warn "[$$] SESSION FLUSH ERROR: ",$self->{session}->errstr 
      if $self->{session}->errstr;
}

sub time {
    return defined &Time::HiRes::time ? Time::HiRes::time() : time();
}

sub modified {
  my $self = shift;
  $self->{session}->_set_status(CGI::Session::STATUS_MODIFIED());
}

sub lockobj {
    my $self = shift;
    my $d    = $self->{lockobj};
    $self->{lockobj} = shift if @_;
    return $d;
}

sub id {
    shift->{session}->id;
}

sub session { shift->{session} }

sub page_settings {
  my $self        = shift;
  my $hash        = $self->config_hash;
  $hash->{page_settings}         ||= {};
  $hash->{page_settings}{userid} ||= $self->id;     # store the id in our state
  return $hash->{page_settings};
}

sub snapshots {
    my $self = shift;
    my $hash = $self->config_hash;
    return $hash->{snapshots}       ||= {};
}

sub plugin_settings {
  my $self = shift;
  my $plugin_base = shift;
  my $hash = $self->config_hash;
  return $hash->{plugins}{$plugin_base} ||= {};
}

sub source {
  my $self = shift;
  my $source = $self->{session}->param('.source');
  $self->{session}->param('.source' => shift()) if @_;
  return $source;
}

sub uploadsid {
  my $self = shift;
  $self->{session}->param('.uploadsid' => shift() ) if @_;
  my $id = $self->{session}->param('.uploadsid');
  unless ($id) {
      # uploadsid used to be stored in the settings, which was wrong
      $id = $self->page_settings->{uploadid} ||
	  Bio::Graphics::Browser2::Util->generate_id;
      $self->{session}->param('.uploadsid' => $id);
  }
  return $id;
}

sub private {
    my $self = shift;
    my $private = $self->{session}->param('.private');
    $self->{session}->param('.private' => shift()) if @_;
    return $private;
}

sub remember_auth {
    my $self = shift;
    my $ra = $self->{session}->param('.remember_auth');
    $self->{session}->param('.remember_auth' => shift()) if @_;
    return $ra;
}

sub username {
    my $self = shift;
    my $user = $self->{session}->param('.username');
    $self->{session}->param('.username' => shift()) if @_;
    return $user;
}

sub using_openid {
    my $self = shift;
    my $using = $self->{session}->param('.using_openid');
    $self->{session}->param('.using_openid' => shift()) if @_;
    return $using;
}

sub set_nonce {
    my $self = shift;
    my ($nonce,$salt,$remember) = @_;
    warn "id=",$self->id," writing nonce = ",md5_hex($nonce,$salt) if DEBUG;
    $self->{session}->param('.nonce' => md5_hex($nonce,$salt));

    # handle session expiration
    if ($remember) {
        $self->{session}->expire('.nonce' => '30d'); # remembers authorization for 30 days
	$self->remember_auth(1);
    } else {
        $self->{session}->expire('.nonce' => '1d');  # force reauthorization every day
	$self->remember_auth(0);
    }
    $self->private(1);
}

sub match_nonce {
    my $self  = shift;
    my ($new_nonce,$salt) = @_;
    $self->private || return;
    my $nonce = $self->{session}->param('.nonce');
    warn "id=",$self->id," matching $nonce against ",$new_nonce,"|",$salt if DEBUG;
    warn "$nonce eq ",md5_hex($new_nonce, $salt)                          if DEBUG;
    return $nonce eq md5_hex($new_nonce, $salt);
}

sub config_hash {
  my $self = shift;
  my $source  = $self->source;
  my $session = $self->{session};
  $session->param($source=>{}) unless $session->param($source);
  return $session->param($source);
}

# problem with explicit DESTROY is that it gets called in all child
# processes. Better to have the unlock happen when filehandle is truly
# destroyed.
#sub DESTROY {
#    my $self = shift;
#    $self->flush;
#    $self->unlock;
#}

1;