package Mdclient;

use IO::Socket::INET qw(SOCK_STREAM IPPROTO_TCP TCP_NODELAY MSG_PEEK);

use Net::SSLeay qw(die_now die_if_ssl_error) ;
Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();


sub new {
        my $class  = shift;
        my $self      = {};
        bless($self, $class);
        $self->__init(@_);
        return $self;
}


sub __init {
        my $self = shift;
	my %opts = @_;
	
	die "Please set Host and Port options to Mdclient->new()\n" unless (defined($opts{Host}) and defined($opts{Port}));
        $self->{connected} = 0;
        $self->{host} = $opts{Host};
        $self->{port} = $opts{Port};
        $self->{login} = defined($opts{Login}) ? $opts{Login} : 'anonymous';
        $self->{password} = defined($opts{Password}) ? $opts{Password} : '';
	$self->{debug} = defined($opts{Debug}) ? $opts{Debug} : 0;
        $self->{buffer} = '';
        $self->{reqSSL} = 0;
        $self->{sslSock} = 0;
	$self->{sslOptions} = '';
	$self->{sessionID} = 0;
        $self->{session} = '';
        $self->{greetings} = '';
        $self->{protocolVersion} = 0;
        $self->{currentCommand} = "";
	$self->{errorMsg} = "";
}


sub requireSSL {
        my $self = shift;
        my ($key, $cert) = @_;

        $self->{reqSSL} = 1;
        $self->{keyFile} = $key;
        $self->{certFile} = $cert;
}


sub __doSSLHandshake {
	my ($self,$session) = @_;

	$self->{ctx} = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
        Net::SSLeay::CTX_set_options($self->{ctx}, &Net::SSLeay::OP_ALL) and die_if_ssl_error("ssl ctx set options");
	unless ($session) {
		print "Doing SSL handshake\n" if $self->{debug};
#		Net::SSLeay::set_cert_and_key($self->{ctx}, $self->{certFile}, $self->{keyFile}) and die_if_ssl_error("ssl ctx set cert and key");
                Net::SSLeay::CTX_use_PrivateKey_file($self->{ctx}, $self->{keyFile}, &Net::SSLeay::FILETYPE_PEM) and die_if_ssl_error("ssl ctx set key failed");
                Net::SSLeay::CTX_use_certificate_chain_file($self->{ctx}, $self->{certFile}) and die_if_ssl_error("ssl ctx set cert failed");  
	}

	$self->{sslSock} = Net::SSLeay::new($self->{ctx}) or die_now("Failed to create SSL $!");
        Net::SSLeay::set_fd($self->{sslSock}, $self->{S}->fileno);

	if ($session) {
                print "Doing SSL resuming session \n" if $self->{debug};
                Net::SSLeay::set_session($self->{sslSock}, $session);
	}
	
	Net::SSLeay::connect($self->{sslSock}) and die_if_ssl_error("Error: ssl connect failed.");
}

sub connect {
	my $self = shift;
	$self->{S} = IO::Socket::INET->new(  
		PeerAddr => $self->{host},
      		PeerPort => $self->{port},
       		Proto    => 'tcp',
      		Type     => SOCK_STREAM
   		) or die "Error: $@";

	$self->{S}->setsockopt (IPPROTO_TCP, TCP_NODELAY, 1) or warn "Can't do setsockopt: $!\n";
	select  ($self->{S}->fileno); $| = 1; select (STDOUT);   # Eliminate STDIO buffering
	# The network connection is now open, lets fire up SSL

	$self->{greetings} = "";
	while ($self->{greetings} !~ /(.*\n){3,}/s) {
        	my $line;
        	$self->{S}->recv($line, 1024);
        	die "Cannot connect"  unless  $line;
        	$self->{greetings} .= $line;
	}

	$self->{protocolVersion} = $1 if ( $self->{greetings} =~ /\nProtokol (\d+)/s);
	if ($self->{sessionID}) {
        	print "Trying to resume session " . $self->{sessionID} . "\n" if ($DEBUG);
            	# Do reconnect
            	if ($self->{reqSSL}) {
               		$self->{S}->send('resumeSSL' . $self->{sessionID} . "\n\n");
                	$self->{S}->recv($line,1024); # OK from server
                	$self->__doSSLHandshake($self->{session});
		} else {
                	$self->{S}->send('resume' . $self->{sessionID} . "\n\n");
                	$self->{connected} = 1;
                	$self->{buffer} = '';
                	$self->{attr} = 0;
                	return 0;
		}
	} else {
		print "No session to resume\n" if ($DEBUG);
        	if ($self->{reqSSL}) {
                	$self->{S}->send("ssl\n\n");
                	$self->{S}->recv($line, 1024); # OK from server
                	$self->__doSSLHandshake;
	        } else {
                	$self->{S}->send("plain\n\n");
               		$self->{S}->recv($line, 1024); # OK from server
        	}
	}

	# From here on we could be talking SSL
        # Send login information if not doing reconnect

	my $context = '0 ' . $self->{login} . "\n5 " . $self->{password} . "\n\n";
	unless ($self->{sessionID}) {
        	if ($self->{sslSock}) {
                	Net::SSLeay::write($self->{sslSock}, $context);
        	} else {
                	$self->{S}->send($context);
        	}
	}

        $self->{connected} = 1;
        $self->{buffer} = '';
        $self->{attr} = 0;
}


sub disconnect {
	# $mode == 1 -> save session
	# $mode == 2 -> call exit to destroy session on server site
	# else -> don't save session or call exit
	my ($self, $mode) = @_;

	my $saveSession = 0 unless (defined($mode) and $mode == 1);
	$self->{session} = Net::SSLeay::get_session($self->{sslSock}) if ($saveSession and $self->{sslSock});
	if ($self->{connected}) {
		if ($self->{sslSock}) {
			$self->exit if ($mode and $mode == 2);
   			Net::SSLeay::free($self->{sslSock});    # Tear down connection
		}
		$self->{sslSock} = undef;
        	Net::SSLeay::CTX_free ($self->{ctx});
        	$self->{S}->close;
		$self->{connected} = 0;
	}
}


sub __sendCommand {
        my ($self,$command) = @_;
        if ($self->{sslSock}) {
                Net::SSLeay::write($self->{sslSock}, $command . "\n");
		warn "$errs\n" if ($errs = Net::SSLeay::print_errs());
                die_if_ssl_error("Error: ssl write failed.");
        } else {
                $self->{S}->send($command . "\n");
        }
}

# Returns silently if the command executes successfully,
# throws an exception otherwise
sub execute {
	my ($self, $command) = @_;

	print "[Sending] $command\n" if $self->{debug};
        $self->{currentCommand} = $command;
        $self->{buffer} = "";
	$self->connect unless $self->{connected};
        $self->__sendCommand($command);
        return $self->retrieveResult;
}

sub retrieveResult {
	my $self = shift;
	my $retValue;

	print "Retrieving result\n" if $self->{debug};
	$self->{EOT} = 0;
	my $line = $self->__fetchRow;
	die "Server sent empty response\n" unless (defined($line));
	$self->{errorMsg} = "";
	if ($line =~ /(\d+) (.*$)/s) {
		$retValue = $1;
		$self->{errorMsg} = $2;
	} elsif ($line =~ /(\d+)/) {
		$retValue = $1;	
	} else {
		die "Unexpected response from server: $line";
	}

	if ($retValue != 0) {
		# The command did not execute properly. Clear
            	# the input buffer and raise an exception
		while (! $self->{EOT}) {
			last if ($self->__fetchData < 0);
		}

		$self->{buffer} = "";
		$self->{errorMsg} .= ". Command was: " . $self->{currentCommand};
	}
	return $retValue;
}            	


sub executeNoWait {
	my ($self, $command) = @_;
	# Returns silently if the command executes,	
	# returns error code and sets $self->{errMsg} if an error occours
	# Does not wait for any return condition of the remote command

	print "[Sending] $command\n" if $self->{debug};
	$self->{currentCommand} = $command;
	$self->{buffer} = "";
	$self->connect unless $self->{connected};
	$self->__sendCommand($command);
	return $self->retrieveResult if $self->__dataArrived;
	return 0;
}

sub  fetchRow {
	my $self = shift;
        return $self->__fetchRow;
}

sub exit {
	my $self = shift;
	return $self->executeNoWait('exit');
}


sub __fetchRow {
	my $self = shift;
	my $line;

	if ($self->{buffer} =~ /^(.*?)\n(.*)$/s) {
		$line = $1;
		$self->{buffer} = $2;
		if (! length($self->{buffer}) and ! $self->{EOT}) {
			return if ($self->__fetchData < 0);
		}
		return $line;
	} 
	return if ($self->{EOT});
	return if ($self->__fetchData <= 0);
	return $self->__fetchRow;
}
				

sub __fetchData {
	my $self = shift;
	my $line;
        while (1) {
		my $errs;
		if ($self->{buffer} =~ /\004/s) {
			my $b = $self->{buffer};
			while ($self->{protocolVersion} > 1 and ($b =~ tr/\004//s) < 2) {
				if ($self->{sslSock}) {
					$line = Net::SSLeay::read($self->{sslSock},1024);
					warn "$errs\n" if ($errs = Net::SSLeay::print_errs('SSL_read'));
				} else {
					$self->{S}->recv($line,1024);
				}
				last (! defined($line) or $line eq '' or $errs);
			}
			last;
		}
		
		last if ($self->{buffer} =~ /\n(.*)$/s and length($1) > 0);
		if ($self->{sslSock}) {
			$line = Net::SSLeay::read($self->{sslSock},1024);
			warn "$errs\n" if ($errs = Net::SSLeay::print_errs('SSL_read'));
		} else {
			$self->{S}->recv($line,1024);
		}
		last if (! defined($line) or $line eq '');
		$self->{buffer} .= $line;
	}

	my $b = $self->{buffer};
	if ($b =~ /\004/gs) {	
		$self->{sessionID} = 0;
		my $pos = pos($b) - 1;
		if ($pos - 1 < (length($b) - 8) and substr($b,$pos+1,7) eq 'session') { 
			$b =~ /\004/gs;
			$self->{sessionID} = substr($b,$pos+8,pos($b) - 1 - $pos - 7);
			$self->disconnect(1);
		}

		print "Session ID " . $self->{sessionID} . "\n" if $self->{debug};
		$self->{buffer} = substr($b,0,$pos);
		$self->{EOT} = 1;
	}

	return -1 unless $line;
	return length($line);
}


sub __dataArrived {
	my $self = shift;
	my $buf = '';

	$self->{S}->blocking(0);
	if ($self->{sslSock}) {
		my $errs;
		$buf = Net::SSLeay::read($self->{sslSock},1);		
		warn "$errs\n" if ($errs = Net::SSLeay::print_errs('SSL_read'));
		$self->{buffer} .= $buf if (defined($buf) and length($buf));
	} else {
		$self->{S}->recv($buf, 1, MSG_PEEK);
	}

	$self->{S}->blocking(1);
	return 1 if (defined($buf) and length($buf));
	return 0;
}

sub eot {
	my $self = shift;
	return 0 if length($self->{buffer});
	return 1 if $self->{EOT};
	return 1 if ($self->__fetchData <= 0);
	return ! length($self->{buffer});
} 

sub getErrorMsg {
	my $self = shift;
	return $self->{errorMsg};
}	

sub getAttr {
	my ($self, $file, @attributes) = @_;
	$command = 'getattr ' . $file;
	for $i (@attributes) {
		$command .= ' ' . $i;
	}
	$self->{nattrs} = $#attributes;
	return $self->execute($command);
}

sub getEntry {
	my $self = shift;
	$file = $self->__fetchRow;
	my @values = ();
	for $i (0..$self->{nattrs}) {
		push @values, $self->__fetchRow;
	}
	return $file, @values;
}

sub setAttr {
	my ($self, $file, %attr) = @_;
        $command = 'setattr ' . $file;
        for $key (keys %attr) {
                $command .= ' ' . $key . ' ' . $attr{$key};
        }
        return $self->execute($command);
}

sub addEntry {
	my ($self, $file, %attr) = @_;
	$command = 'addentry ' . $file;
	for $key (keys %attr) {
                $command .= ' ' . $key . ' ' . $attr{$key};
        }
	return $self->execute($command);
}
	
sub addEntries {
	my ($self, @entries) = @_;
        my $command = 'addentries';

	for $e (@entries) {
		$command .= ' ' . $e;
	}
	return $self->execute($command);
}

sub addAttr {
	my ($self, $file, $name, $t) = @_;
        my $command = 'addattr ' . $file . ' ' . $name . ' ' . $t;
        return $self->execute($command);
}

sub removeAttr {
        my ($self, $file, $name) = @_;
        my $command = 'removeattr ' . $file . ' ' . $name;
        return $self->execute($command);
}

sub clearAttr {
	my ($self, $file, $name) = @_;
        my $command = 'clearattr ' . $file . ' ' . $name;
	return $self->execute($command);
}

sub listEntries {
	my ($self, $pattern) = @_;
        my $command = 'dir ' . $pattern;
	my $code = $self->execute($command);
	$self->{nattrs} = 1;
	return $code;
} 

sub pwd {
        my $self = shift;
        return $self->execute('pwd'), $self->__fetchRow;
}

sub listAttr {
	my ($self, $file) = @_;
        my $command = 'listattr ' . $file; 
	my $code = $self->execute($command);
	my %res = ();

	while (! $self->eot) {
		my $attr = $self->__fetchRow;
		my $typ = $self->__fetchRow;
		$res{$attr} = $typ;
	}
	return $code, %res; 	
}

sub createDir {
	my ($self, $dir) = @_;
	my $command = 'createdir ' . $dir;
	return $self->execute($command);
}

sub schemaCreate {
	my ($self, $dir, %attr) = @_;
        my $command = 'schema_create ' . $dir;
        for $key (keys %attr) {
                $command .= ' ' . $key . ' ' . $attr{$key};
        }
        return $self->execute($command);
}

sub removeDir {
	my ($self, $dir) = @_;
        my $command = 'rmdir ' . $dir;
	return $self->execute($command);
}

sub rm {
        my ($self, $path) = @_;
        my $command = 'rm ' . $path;
	return $self->execute($command);
}

sub find {
	my ($self, $pattern, $query) = @_;
        my $command = "find " . $pattern . " '" . $query . "'";
	return $self->execute($command);
}
 
sub selectAttr {
        my ($self, $query, @attributes) = @_;
        my $command = "selectattr ";

	for $i (@attributes) {
		$command .= $i . " ";
	}
	$command .= " '" . $query . "'";
	my $code = $self->execute($command);
	$self->{nattr} = $#attributes;
	return $code;
}

sub getSelectAttrEntry {
	my $self = shift;
	@attr = ();

	for $i (0..$self->{nattr}) {
		push @attr, $self->__fetchRow; 
	}
	return @attr;
}

sub updateAttr {
	my ($self, $pattern, $condition, %updateExpr) = @_;
	my $command = "updateattr " . $pattern;

	for $key (keys %updateExpr) {
#		my ($var, $exp) = $self->splitUpdateClause($i);
		$command .= ' ' . $key . ' ' . $updateExpr{$key};
	}
	$command .= " '" . $condition . "'";
	return $self->execute($command);
}

sub upload {
	my ($self, $collection, @attributes) = @_;
        my $command = 'upload ' . $collection;

        for $i  (@attributes) {
        	$command .= ' ' . $i;
	}
        $self->{nattrs} = $#attributes;
        return $self->executeNoWait($command);
}

sub put {
	my ($self, $file, @values) = @_;
	my $command = 'put ' . $file;
	if ($#values != $self->{nattrs}) {
		$self->{errorMsg} = "Error 3: Illegal command";
		return 3;
	}

	for $i  (@values) {
		$command .= ' ' . $i;
	}
	return $self->executeNoWait($command);
}
	
sub abort {
	my $self = shift;
	my $command = 'abort';
	return $self->execute($command);
}

sub commit {
        my $self = shift;
        my $command = 'commit';
        return $self->execute($command);
}

sub sequenceCreate {
	my ($self, $name, $directory, $increment, $start) = @_;
	$increment = 1 unless defined($increment);
	$start = 1 unless defined($start);
	$command = 'sequence_create ' . $name . " " . $directory . " " . $increment . " " . $start;
	return $self->execute($command);
}

sub sequenceNext {
	my ($self, $name) = @_;
	$command = 'sequence_next ' . $name;
	return $self->execute($command), $self->fetchRow;
}

sub sequenceRemove {
	my ($self, $name) = @_;
        $command = 'sequence_remove ' . $name;
	return $self->execute($command);
}

sub cd {
	my ($self, $dir) = @_;
	$dir = "" unless defined $dir;
	my $command = 'cd ' . $dir;
	return $self->execute($command);
}

sub dir {
        my ($self, $dir) = @_;
	$dir = '' unless defined $dir;
        my $command = 'dir ' . $dir;
        return $self->execute($command);
}

sub stat {
        my ($self, $path) = @_;
        $path = '' unless defined $path;
        my $command = 'stat ' . $path;
        return $self->execute($command);
}

  
sub splitUpdateClause {
	my ($self, $clause) = @_;
	#skip leading white space
        my $i = 0;

	while ($i < length($clause) and substr($clause,$i,1) =~ /^ |\t$/) {
		$i++;
	}
	$clause = substr($clause,$i);

	my $espcaped = 0;
	my $quoted = 0;
	$i = 0;

	while ($i < length($clause)) {
		$quoted = !$quoted if (substr($clause,$i,1) eq "'" and ! $espcaped);	
		$escaped = !$escaped if (substr($clause,$i,1) eq "/" and !$quoted);
		last if (substr($clause,$i,1) =~ /^ |\t$/);
		$i++;
	}
	die "Error 3: Invalid update statement" if ($i == 0 or $i > length($clause) -1);
	my $var = substr($clause,0,$i);
	my $exp = substr($clause,$i+1);
	$i = 0;

	while ($i < length($exp) and substr($exp,$i,1) =~ /^ |\t$/) {
		$i++;
        }
	$exp = substr($exp,$i);
	$var = "'" . $var . "'" if (substr($var,0,1) ne "'");
	$exp = "'" . $exp . "'" if (substr($exp,0,1) ne "'");
	return $var, $exp;
}

1;
__END__

=head1 NAME

Mdclient - Perl API to AMGA metadata service

=head1 DESCRIPTION

The Mdclient.pm Perl module contains the Mdclient class which supports X509
certificate, grid proxy or password based authentication to a AMGA server 
over SSL as well as operation without SSL. 

To use the Mdclient class include a

use Mdclient;

statement. A script B<mdtest> with usage examples for most methods is 
shipped with the module.

=head1 PREREQUISITES

Mdclient uses the Net::SSLeay and IO::Socket::INET modules as the APIs to
openssl and sockets. Mdclient was tested with Net::SSLeay version 1.26. 

=head1 METHODS 

B<new> - constructor

 $cl = Mdclient->new(   Host => <host>,
                        Port => <port>,
                        Login => <user name>,
			[Password => <password>,]
                        [Debug => 1,]
                    );

B<requireSSL> - use SSL

 $cl->requireSSL(<key file path>, <cert file path>);
 In case of grid proxy based authentication both arguments of requireSSL
 must point to the grid proxy file.

B<addAttr> -  add attribute to collection
  
 $code = $cl->addAttr(<dir path>, <attr name>, <attr type>);

B<addEntries> - add entries 

 $code = $cl->addEntries(<list of entry paths>);

B<addEntry> - add entry with attributes

 $code = $cl->addEntry(<entry path>, %attr);
 %attr hash: the keys are attribute names, the values are attribute values.

B<cd> - change working directory 

 $code = $cl->cd(<dir path>);

B<clearAttr> - clear attributes

 $code = $cl->clearAttr(<entry path>, <attribute name>);

B<commit> - commit upload

 $code = $cl->commit;

B<createDir> - create directory 

 $code = $cl->createDir(<dir path>);

B<dir> - list directory 

 $code = $cl->dir(<directory path>);

B<disconnect> - disconnect from AMGA server.

 $cl->disconnect(<mode>);
 If <mode> is 1 saves current SSL session. If <mode> is 2 calls exit 
 method to ensure destruction of session by server. If <mode> is not set
 session will not be saved and exit will not be called (useful, when 
 server does not allow sessions or exit was called before).

B<eot> - used with the iterator methods getEntry, getSelectAttrEntry
 and fetchRow. Returns true when no entries/rows are left. 

 while($cl->eot) {..}

B<fetchRow> - used to fetch next line of output from AMGA server (streaming).

 $line = $cl->fetchRow;
 $line will contain next line of output from AMGA server.

B<find> - list entry names matching path pattern and fulfilling the query
 with their attributes

 $code = $cl->find(<path pattern>, <query>);

B<getAttr> - get attributes of entries

 $code = $cl->getAttr(<path pattern>, @attr);
 @attr is a list of attribute names.

B<getEntry> - get one entry requested by getAttr method

 ($entry, @values) = $cl->getEntry;
 @values list: contains values corresponding to @attr from getAttr method.

B<getErrorMsg> - get last error message 

 $msg = $cl->getErrorMsg;

B<getSelectAttrEntry> - retrieve one entry requested by selectAttr method.

 @values = $cl->getSelectAttrEntry;
 @values list: contains values corresponding to @attr from selectAttr method.

B<listAttr> - list attributes 

 ($code, %res) = $cl->listAttr(<directory path>);
 %res hash: the keys are attribute names, the values are attribute types. 

B<put> - inserts a new entry during upload. Errors are returned by the
 call immediately, OK is delayed until upload is commited.

 $code = $cl->put(<entry>, @values);
 <entry> is the name of the entry to be inserted, @values is a list of 
 attribute values.

B<pwd> - print working directory 

 ($code, $directory) = $cl->pwd;
 $directory will contain the working directory.

B<removeAttr> - remove attribute from collection
 $code = $cl->removeAttr(<directory path>, <attribute name>); 

B<removeDir> - remove directory 

 $code = $cl->removeDir(<directory path>);

B<rm> -	remove entries 

 $code = $cl->rm(<pattern string>);

B<schemaCreate> - create collection with attributes

 $code = $cl->schemaCreate(<directory path>, %attr);
 %attr hash: the keys are attribute names, the values are attribute types.

B<selectAttr> - select attributes from several collections based on a 
 condition doing an inner join on the collections based on a join 
 condition

 $code = $cl->selectAttr(<query>, @attr);
 @attr is a list of attribute names.

B<setAttr> - set attributes

 $code = $cl->setAttr(<entry path>, %attr);
 %attr hash: the keys are attribute names, the values are attribute values.

B<stat> - return information on a given entry or directory

 $code = $cl->stat(<path>);

B<updateAttr> - update attributes 

 $code = $cl->updateAttr(<path pattern>, <query>, %attr);
 %attr hash: the keys are attribute names, the values are attribute values.

B<upload> - upload entries in transaction

 $code = $cl->upload(<directory path>, @attr);
 @attr is a list of attribute names.

B<put> - insert a new entry during upload

 $code = $cl->put(<entry name>, @values);
 @values is a list of attribute values;

=head1 FILES

mdtest

=cut