# Copyright (c) 2004  Joshua Hoblitt
#
# $Id: Client.pm,v 1.1.1.1 2004-12-22 02:16:23 jhoblitt Exp $

package PS::IPP::IData::Client;

use strict;
use warnings;

our $VERSION = '0.01';

use File::Copy qw();
use Log::Log4perl qw(get_logger :levels);
use PS::IPP::IData::Client::Log;
use PS::IPP::IData::Util qw( :standard );
use Params::Validate qw( validate validate_pos SCALAR );
use SOAP::Lite +trace => [qw( debug )];
use Time::HiRes qw( sleep );
use URI;

use constant LOCK_INTERVAL  => 1;
use constant LOCK_DEFAULT   => 10;    # default to a 10s lock timeout

my $log = get_logger( "PS::IPP::IData::Client" );

$SOAP::Constants::PATCH_HTTP_KEEPALIVE = 1;

# TODO remove most of the logdies

sub import {
    my $class = shift;

    $log->debug( "entered - args: @_" );

	my %args = validate( @_,
        {
            trace => {
                type        => SCALAR,
                default     => $ERROR,
                callbacks   => {
                    'is valid level' => sub {
                        defined $LEVELS{ lc $_[0] };
                    },
                },
            },
        },
    );

    $log->level( $LEVELS{ lc $args{ 'trace' } } );

    return 1;
}

sub new {
    my $class = shift;

    my %args = validate( @_,
        {
            proxy   => {
                type        => SCALAR,
            },
            uri     => {
                type        => SCALAR,
                optional    => 1,
            },
        },
    );

    $log->debug( "entered - args: @{[ %args ]}" );

    my $lite = SOAP::Lite->new(
            proxy => $args{ 'proxy' },
            uri   => $args{ 'uri' } || "http://pan-starrs.ifa.hawaii.edu/PS/IPP/IData/Server",
    );

    $log->logdie( "can not create SOAP::Lite object" ) unless $lite;

    my $self = bless( { server => $lite }, ref $class || $class );

    $log->debug( "leaving" );

    return $self;
}

sub create {
    my $self = shift;

    my ( $key, @params ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            type        => SCALAR,
            callbacks   => {
                'is + integer' => sub { $_[0] =~ /^\d+$/ },
            },
            default     => 0,
        },
        {
            type        => SCALAR,
            optional    => 1,
        },
        {
            type        => SCALAR,
            optional    => 1,
        },
    );

    $log->debug( "entered - key: $key, params: @params" );

    # how should already existing files be handled?

    my $response = $self->{ 'server' }->create_object( $key, @params );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return undef;
    }

    my $uri = $response->result;

    $log->debug( "server allocated $uri" );

#    unless( $self->lock( $key, "write"  )) {
#        $log->debug( "can not lock object" );
#        $log->debug( "leaving" );
#
#        return undef;
#    }

    my $fh;
    eval {
        $fh = _open_uri( $uri, '+<' );
    };
    $log->logdie( $@ ) if $@;

    $log->debug( "leaving" );

    return $fh;
}

sub replicate {
    my $self = shift;

    my ( $key, @params ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            # volume
            type        => SCALAR,
            optional    => 1,
        },
    );

    $log->debug( "entered - key: $key, params: @params" );

    my $response = $self->{ 'server' }->replicate_object( $key, @params );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return undef;
    }

    # don't let anybody start reading the new instance before it's fully
    # written
    my $fh  = $self->open( $key, 'write' );
    unless ( $fh ) {
        $log->debug( "can't open $key" );
        $log->debug( "leaving" );

        return undef;
    }

    $log->debug( "server allocated new instance" );

    my $uri = $response->result;

    my $new_fh;
    eval {
        $new_fh = _open_uri( $uri, '>' );
    };
    $log->logdie( $@ ) if $@;

    File::Copy::copy( $fh, $new_fh ) or $log->logdie( "can not copy instance $uri" );

    $log->debug( "copied instance" );

    close( $fh ) or $log->logdie( "can not close $key" );
    close( $new_fh ) or $log->logdie( "can not close $key" );

#    unless ($self->unlock( $key, "write" )) {
#        $log->debug( "can not lock object" );
#        $log->debug( "leaving" );
#
#        return undef;
#    }

    $log->debug( "leaving" );

    return $uri;
}

sub cull {
    my $self = shift;

    my ( $key ) = validate_pos( @_,
        {
            type => SCALAR,
        },
    );

    $log->debug( "entered - key: $key" );

    # need some way to determine which is the best instance to remove
    my $locations = $self->find_instances( $key );
    unless ( $locations ) {
            $log->debug( "no instances" );
            $log->debug( "leaving" );

            return undef;
    }

    if ( scalar @{ $locations } < 2 ) {
        $log->debug( "can not cull - not enough instances" );
        $log->debug( "leaving" );

        return undef;
    }

    # make sure nobody is reading while we are deleting
    unless ($self->lock( $key, "write" )) {
        $log->debug( "can not lock object" );
        $log->debug( "leaving" );

        return undef;
    }

    my $status = $self->delete_instance( $locations->[0] );

    unless ($self->unlock( $key, "write" )) {
        $log->debug( "can not lock object" );
        $log->debug( "leaving" );

        return undef;
    }

    $log->debug( "leaving" );

    return $status;
}

sub lock {
    my $self = shift;

    my ( $key, $type, $timeout ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            type        => SCALAR,
            callbacks   => {
                'is read or write' => sub { $_[0] =~ /^(?:read|write)$/ },
            },
        },
        {
            type        => SCALAR,
            default     => LOCK_DEFAULT,
            optional    => 1,
            callbacks   => {
                'is + integer' => sub { $_[0] =~ /^\d+$/ },
            },
        },
    );

    my $endtime = time() + $timeout;

    $log->debug( "entered - key: $key, type: $type, timeout: $timeout" );

    my $locked;

    while ( time() < $endtime ) {
        $log->debug( "trying to get a $type lock..." );

        my $response = $self->{ 'server' }->lock_object( $key, $type );
        if ( $response->fault ) {
            $log->error( $response->faultcode, " - ", $response->faultstring );
            $log->debug( "leaving" );
            
            # don't bother to spin lock if the object doesn't exist
            if ( $response->faultstring =~ /storage object does not exist/ ) {
                return undef;
            }

            next;
        }

        $locked = $response->result;
        if ( $locked ) {
            $log->debug( "got a $type lock" );
            last;
        }
    } continue {
        $log->debug( "sleeping..." );
        sleep LOCK_INTERVAL;
    }

    $log->debug( "can not get a lock" ) unless $locked;

    $log->debug( "leaving" );
    
    return $locked ? 1 : undef;
}

sub unlock {
    my $self = shift;

    my ( $key, $type ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            type        => SCALAR,
            callbacks   => {
                'is read or write' => sub { $_[0] =~ /^(?:read|write)$/ },
            },
        },
    );

    $log->debug( "entered - key: $key, type: $type" );

    my $unlocked;

    $log->debug( "trying to release a $type lock..." );

    my $response = $self->{ 'server' }->unlock_object( $key, $type );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return undef;
    }

    $unlocked = $response->result;
    if ( $unlocked ) {
        $log->debug( "released a $type lock" );
    } else {
        $log->debug( "can not release $type lock" );
    }

    $log->debug( "leaving" );
    
    return $unlocked ? 1 : undef;
}

sub find_instances {
    my $self = shift;

    my ( $key, @params ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            #volume
            type        => SCALAR,
            optional    => 1,
        },
    );

    $log->debug( "entered - key: $key" );

    my $response = $self->{ 'server' }->find_instances( $key, @params );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return undef;
    }

    my $uris = $response->result;

    $log->debug( "server found: @$uris" );

#    foreach my $path ( @{ $uris } ) {
#        $path = _get_file_path( $path );
#    }

    $log->debug( "leaving" );

    return $uris;
}

sub find {
    my $self = shift;

    my ( $key ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
    );

    $log->debug( "entered - key: $key" );

    my $locations = $self->find_instances( $key );

    my $path;
    eval {
        $path = _get_file_path( $locations->[0] );
    };
    $log->logdie( $@ ) if $@;

    $log->debug( "leaving" );

    return $path;
}

sub open {
    my $self = shift;

    my ( $key, $type ) = validate_pos( @_,
        {
            type        => SCALAR,
        },
        {
            type        => SCALAR,
            callbacks   => {
                'is read or write' => sub { $_[0] =~ /^(?:read|write)$/ },
            },
        },
    );

    $log->debug( "entered - key: $key, type: $type" );

    my $fh;

    # need to figure out which is the most optimal copy to open
    my $locations = $self->find_instances( $key );

    my $path;
    eval {
        $path = _get_file_path( $locations->[0] );
    };
    $log->logdie( $@ ) if $@;

    unless ( $path ) {
        $log->debug( "no instances" );

        if ( $type eq 'write' ) {
            $log->debug( "creating a new storage object" );

            my $ret = $self->create( $key );

            $log->debug( "leaving" );

            return $ret;
        } else {
            $log->debug( "leaving" );
            return undef;
        }
    }

    if ( $type eq 'write' ) {
#        unless ($self->lock( $key, $type )) {
#            $log->debug( "can not lock object" );
#            $log->debug( "leaving" );
#
#            return undef;
#        }

        eval {
            $fh = _get_filehandle( $path, '+<' );
        };
        $log->logdie( $@ ) if $@;
    } elsif ( $type eq 'read' ) {
#            unless ($self->lock( $key, $type )) {
#            $log->debug( "can not lock object" );
#            $log->debug( "leaving" );
#
#            return undef;
#        }

        eval {
            $fh = _get_filehandle( $path, '<' );
        };
        $log->logdie( $@ ) if $@;
    }

    $log->debug( "leaving" );

    return $fh;
}

sub delete {
    my $self = shift;

    my ( $key ) = validate_pos( @_,
        {
            type => SCALAR,
        },
    );

    $log->debug( "entered - key: $key" );

    unless ($self->lock( $key, "write" )) {
        $log->debug( "can not lock object" );
        $log->debug( "leaving" );

        return undef;
    }

    my $locations = $self->find_instances( $key );
        
    foreach my $uri ( @$locations ) {
        $self->delete_instance( $uri );
    }

    # lock is implicitly removed when the last storage object is deleted

    $log->debug( "leaving" );

    return 1;
}

sub copy {
    my $self = shift;

    my ( $key, $new_key ) = validate_pos( @_,
        {
            type => SCALAR,
        },
        {
            type => SCALAR,
        },
    );

    $log->debug( "entered - key: $key, new_key: $new_key" );

    my $fh      = $self->open( $key, 'read' );
    my $new_fh  = $self->create( $new_key );

    File::Copy::copy( $fh, $new_fh ) or $log->logdie( "can not copy object $key" );

    close( $fh ) or $log->logdie->( "can not close $key" );
    close( $new_fh ) or $log->logdie->( "can not close $new_key" );

    unless ($self->unlock( $key, "read" )) {
        $log->debug( "can not lock object" );
        $log->debug( "leaving" );

        return undef;
    }

    unless ($self->unlock( $new_key, "write" )) {
        $log->debug( "can not lock object" );
        $log->debug( "leaving" );

        return undef;
    }

    $log->debug( "leaving" );

    return 1;
}

sub move {
    my $self = shift;

    my ( $key, $new_key ) = validate_pos( @_,
        {
            type => SCALAR,
        },
        {
            type => SCALAR,
        },
    );

    $log->debug( "entered - key: $key, new_key: $new_key" );

    $self->copy( $key, $new_key );
    $self->delete( $key );

    $log->debug( "leaving" );

    return 1;
}

sub delete_instance {
    my $self = shift;

    my ( $uri ) = validate_pos( @_,
        {
            type => SCALAR,
        },
    );

    $log->debug( "entered - uri: $uri" );

    # it is being assumed here that it is better to have files on disk and not in
    # the database then the inverse.

    my $path;
    eval {
        $path = _get_file_path( $uri );
    };
    $log->logdie( $@ ) if $@;

    my $response = $self->{ 'server' }->delete_instance( $uri );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return undef;
    }

    $log->debug( "server deleted instance" );

    eval {
        _nuke_file( $path );
    };
    $log->logdie( $@ ) if $@;

    $log->debug( "leaving" );

    return $uri;
}

1;

__END__
