view release on metacpan or  search on metacpan

lib/Acme/Globus.pm  view on Meta::CPAN

=head3 B<status>

=head3 B<wait>

We do not do much with task management, so these are currently stubs.

=cut

sub cancel  { }
sub details { }
sub events  { }
sub modify  { }
sub status  { }
sub wait    { }

=head2 TASK CREATION

=head3 B<delete>

=head3 B<rm>

Currently stubs

=head3 B<scp>

=head3 B<transfer>

Both commands take a source, or from path (including endpoint),
a destination, or to path (includint endpoint), and a boolean indicating
whether you're copying recursively or not.

=cut 

sub delete { }
sub rm     { }

sub scp {
    my ( $self, $from_path, $to_path, $recurse ) = @_ ;
    $recurse = $recurse ? '-r' : '' ;
    my $command = qq{scp $recurse $from_path $to_path} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    return $result ;
    }

sub transfer {
    my ( $self, $from_path, $to_path, $recurse ) = @_ ;
    $recurse = $recurse ? '-r' : '' ;
    my $command = qq{transfer $from_path $to_path} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    return $result ;
    }

=head2 FILE MANAGEMENT

=head3 B<ls>

Works?

=head3 B<rename>

=head3 B<mkdir>

Stubs

=cut

sub ls {
    my ( $self, $file_path ) = @_ ;
    my $command = qq{ls $file_path} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    my @result = split m{\r?\n}, $result ;
    return wantarray ? @result : \@result ;
    }

sub mkdir  { }
sub rename { }

=head2 ENDPOINT MANAGEMENT

=head3 B<acl_add>

=head3 B<acl_list>

=head3 B<acl_remove>

acl-* is the way that Globus refers to permissions

By the interface, Globus supports adding shares by email address, 
by Globus username or by Globus group name. This module sticks to
using email address. acl_add() takes an endpoint, an email address 
you're sharing to, and a boolean indicating whether this share is
read-only or read-write. acl_add() returns a share id.

acl_remove() uses that share id to identify which shares are to be 
removed.

acl_list() returns an array of hashes containing the information about 
each user with access to an endpoint, including the share ID and permissions.

=cut

sub identity_details {
    my ( $self, $identity_id ) = @_ ;
    my $command = qq{identity-details $identity_id } ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    return {} unless $result =~ m{\w} ;
    my $obj = decode_json $result ;
    return wantarray ? %$obj : $obj ;
    }

sub acl_add {
    my ( $self, $endpoint, $email, $rw ) = @_ ;
    my $readwrite = 'rw' ;
    $readwrite = 'r' unless $rw ;
    my $command
        = qq{acl-add $endpoint --identityusername=${email} --perm $readwrite }
        ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    my ($id) = reverse grep {m{\w}} split m{\s}, $result ;
    return $id ;
    }

sub acl_list {
    my ( $self, $endpoint ) = @_ ;
    my $command = qq{acl-list $endpoint} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    my $slist = decode_json $result ;
    my @list = grep { $_->{permissions} ne 'rw' } @$slist ;
    return wantarray ? @list : \@list ;
    }

sub acl_remove {
    my ( $self, $endpoint_uuid, $share_uuid ) = @_ ;

lib/Acme/Globus.pm  view on Meta::CPAN

    return wantarray ? %result : \%result ;
    }

sub search_my_endpoints {
    my ( $self, $search ) = @_ ;
    my %result ;
    my $command = qq{endpoint-search $search --scope=my-endpoints} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    %result = map {
        my $hash ;
        %$hash = map {
            my ( $k, $v ) = split m{\s*:\s*} ;
            $k =~ s{\s+}{_}gmx ;
            $k = lc $k ;
            $k => $v
            }
            split m{\n} ;
        my $id
            = $hash->{display_name} ne 'n/a'
            ? $hash->{display_name}
            : $hash->{legacy_name} ;
        $id => $hash ;
        }
        split m{\n\n}, $result ;
    return wantarray ? %result : \%result ;
    }

sub endpoint_remove {
    my ( $self, $endpoint ) = @_ ;
    my $command = qq{endpoint-remove $endpoint} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    return $result ;
    }

# Sucks. Use endpoint_search instead
sub endpoint_details {
    my ( $self, $endpoint ) = @_ ;
    my $command = qq{endpoint-details $endpoint} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;

    my %result = map {
        chomp ;
        my ( $key, $value ) = split m{\s*:\s*}, $_ ;
        $key => $value
        } split m{\n}, $result ;

    return wantarray ? %result : \%result ;
    }

=head3 B<endpoint_activate>

=head3 B<endpoint_add>

=head3 B<endpoint_deactivate>

=head3 B<endpoint_modify>

=head3 B<endpoint_rename>

Stubs

=cut

sub endpoint_activate   { }
sub endpoint_add        { }
sub endpoint_deactivate { }
sub endpoint_modify     { }
sub endpoint_rename     { }

=head2 OTHER

=head3 B<help>   

=head3 B<history>

=head3 B<man>         

=head3 B<profile>

=head3 B<versions>

profile() returns information about the Globus user, including the email address 
and public key.

Otherwise stubs

=cut

sub profile {
    my ($self) = @_ ;
    my $command = qq{profile} ;
    my $result
        = _globus_action( $command, $self->{username}, $self->{key_path} ) ;
    my %output
        = map { my ( $k, $v ) = split m{:\s?}, $_ ; $k => $v } split m{\n},
        $result ;
    return wantarray ? %output : \%output ;
    }

sub help     { }
sub history  { }
sub man      { }
sub versions { }

sub _globus_action {
    my ( $command, $user, $key_path ) = @_ ;
    my $host = '@cli.globusonline.org' ;

    my $ssh = Net::OpenSSH->new(
        $user . $host,
        key_path => $key_path,
        async    => 0,
        ) ;

    $ssh->error
        and die "Couldn't establish SSH connection: " . $ssh->error ;

    my $debug = 0 ;

    say STDERR "\t" . '=' x 20 if $debug ;
    say STDERR "\t" . $command if $debug ;
    say STDERR "\t" . '-' x 20 if $debug ;

    my $response = $ssh->capture($command)
        or carp "remote command failed: " . $ssh->error ;

    return $response ;
    }