# Copyright (c) 2004  Joshua Hoblitt
#
# $Id: Client.pm,v 1.34 2007-05-05 00:14:17 jhoblitt Exp $

package Nebulous::Client;

use strict;
use warnings FATAL => qw( all );

our $VERSION = '0.02';

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

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

$SOAP::Constants::PATCH_HTTP_KEEPALIVE = 1;
my $log;

# TODO remove most of the logdies

sub import {
    my $class = shift;

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

    Nebulous::Client::Log->init;
    $log = get_logger( "Nebulous::Client" );
    $log->level( $LEVELS{ lc $args{ 'trace' } } );

    # this has to be after the log level is set
    $log->debug( "args: @_" );

    return 1;
}

sub new {
    my $class = shift;

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

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

    my $lite = SOAP::Lite->new(
            proxy => $args{ 'proxy' },
            uri   => $args{ 'uri' } || "urn:Nebulous/Server/SOAP",
    );

    $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,
            optional    => 1,
        },
    );

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

    # 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;
    }

    my $res = $response->result;
    $log->debug( "server response: $res" );

    my $uri = URI->new($res);
    $log->debug( "URI is: $uri" );

    $log->debug( "leaving" );

    return $uri;
}

sub open_create {
    my $self = shift;

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

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

    # 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;
    }

    my $res = $response->result;
    $log->debug( "server response: $res" );

    my $uri = URI->new($res);
    $log->debug( "URI is: $uri" );

    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 - @_" );

    # We have to open the instance that we're going to copy from first.  If
    # we don't do this, it's possible that open will find & open the new
    # instance that we're in the process of creating
    my $fh  = $self->open( $key, 'read' );
    unless ( $fh ) {
        $log->debug( "can't open $key" );
        $log->debug( "leaving" );

        return;
    }

    # ask the server for a new instance attached to our key
    my $response = $self->{ 'server' }->replicate_object( $key, @params );
    if ( $response->fault ) {
        $log->error( $response->faultcode, " - ", $response->faultstring );
        $log->debug( "leaving" );

        return;
    }

    my $res = $response->result;
    $log->debug( "server response: $res" );

    my $uri = URI->new($res);
    $log->debug( "URI is: $uri" );

    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" );

    $log->debug( "leaving" );

    return $uri;
}

sub cull {
    my $self = shift;

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

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

    my $locations;
    # if vol_name is specified we need to stat the file to find out how many
    # instances there are on all volumes.  Otherwise we wouldn't know if it's
    # safe to remove the last instance on the specified volume.
    # XXX We need some way to determine which is the best instance to remove
    if (defined $vol_name) {
        my @stats = $self->stat($key);
        my $instances = $stats[6];
        if (defined $instances and $instances < 2) {
            $log->debug("can not cull - not enough instances");
            $log->debug("leaving");

            return;
        }

        $locations = $self->find_instances($key, $vol_name);
        unless (scalar @{ $locations }) {
            $log->debug( "no instances" );
            $log->debug( "leaving" );

            return;
        }
    } else {
        $locations = $self->find_instances($key);
        unless ($locations) {
            $log->debug("no instances");
            $log->debug("leaving");

            return;
        }

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

            return;
        }
    }

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

    $log->debug("leaving");

    return $uri;
}

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 - @_" );

    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;
            }

            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" );
    
    $locked ? return 1 : return;
}

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 - @_" );

    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;
    }

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

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

sub find_objects {
    my $self = shift;

    my ( $pattern ) = validate_pos( @_,
        {
            type        => SCALAR,
            optional    => 1,
        },
    );

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

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

        return;
    }

    my $keys = $response->result;

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

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

    $log->debug( "leaving" );

# aparently empty arrays are being turned into undef by SOAP::Lite so the
# behavior of this function is different then it's ::Server counter part

    return $keys;
}

sub find_instances {
    my $self = shift;

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

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

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

        return;
    }

    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 - @_" );

    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 - @_" );

    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->open_create( $key );

            $log->debug( "leaving" );

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

    if ( $type eq 'write' ) {
        my $num_instances = scalar @$locations;

        if ( $num_instances > 1 ) {
            $log->warn( "write not allowed with multiple instances" );
            $log->debug( "leaving" );
            return;
        }

        eval {
            $fh = _get_filehandle( $path, '+<' );
        };
        $log->logdie( $@ ) if $@;
    } elsif ( $type eq 'read' ) {
        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 - @_" );

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

    return undef unless $locations;
        
    # a lock is implicitly removed when the last storage object is deleted
    foreach my $uri ( @$locations ) {
        $self->delete_instance( $uri ) or return undef;
    }

    $log->debug( "leaving" );

    return 1;
}

sub copy {
    my $self = shift;

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

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

    my $fh      = $self->open( $key, 'read' );
    unless ( $fh ) {
        $log->debug( "can not open object" );
        $log->debug( "leaving" );

        return;
    }

    my $new_fh;
    if (defined $volume) {
        $new_fh  = $self->open_create( $new_key, $volume );
    } else {
        $new_fh  = $self->open_create( $new_key );
    }
    unless ( $new_fh ) {
        $log->debug( "can not open object" );
        $log->debug( "leaving" );

        return;
    }

    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" );

    $log->debug( "leaving" );

    return 1;
}

sub move {
    my $self = shift;

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

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

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

        return;
    }

    $log->debug( "leaving" );

    return 1;
}

sub delete_instance {
    my $self = shift;

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

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

    # 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;
    }

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

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

    $log->debug( "leaving" );

    return $uri;
}

sub stat {
    my $self = shift;

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

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

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

        return;
    }

    $log->debug( "server returned a stat" );

    my $stats = $response->result;

    $log->debug( "leaving" );

    return $stats;
}

sub err {
    my $self = shift;

    die "accepts no params" if @_;

    return $self->{ 'err' };
}

sub set_err {
    my $self = shift;

    $self->{ 'err' } = shift;

    return $self;
}

1;

__END__
