File Coverage

blib/lib/File/Dropbox.pm

Criterion	Covered	Total	%
statement	73	372	19.6
branch	8	108	7.4
condition	7	59	11.8
subroutine	22	35	62.8
pod	8	8	100.0
total	118	582	20.2

package File::Dropbox;
use strict;
use warnings;
use feature ':5.10';
use base qw{ Tie::Handle Exporter };
use Symbol;
use JSON;
use Errno qw{ ENOENT EISDIR EINVAL EPERM EACCES EAGAIN ECANCELED EFBIG };
use Fcntl qw{ SEEK_CUR SEEK_SET SEEK_END };
use Furl;
use IO::Socket::SSL;
use Net::DNS::Lite;

our $VERSION = 0.6;
our @EXPORT_OK = qw{ contents metadata putfile movefile copyfile createfolder deletefile };

my $hosts = {
	content => 'api-content.dropbox.com',
	api     => 'api.dropbox.com',
};

my $version = 1;

my $header1 = join ', ',
	'OAuth oauth_version="1.0"',
	'oauth_signature_method="PLAINTEXT"',
	'oauth_consumer_key="%s"',
	'oauth_token="%s"',
	'oauth_signature="%s&%s"';

my $header2 = 'Bearer %s';

sub new {
	my $self = Symbol::gensym;
	tie *$self, __PACKAGE__, my $this = { @_[1 .. @_ - 1] };

	*$self = $this;

	return $self;
} # new

sub TIEHANDLE {
	my $self = bless $_[1], ref $_[0] || $_[0];

	$self->{'chunk'}   //= 4 << 20;
	$self->{'root'}    //= 'sandbox';

	die 'Unexpected root value'
		unless $self->{'root'} =~ m{^(?:drop|sand)box$};

	$self->{'furl'} = Furl->new(
		timeout   => 10,
		inet_aton => \&Net::DNS::Lite::inet_aton,
		ssl_opts  => {
			SSL_verify_mode => SSL_VERIFY_PEER(),
		},

		%{ $self->{'furlopts'} //= {} },
	);

	$self->{'closed'}   = 1;
	$self->{'length'}   = 0;
	$self->{'position'} = 0;
	$self->{'mode'}     = '';
	$self->{'buffer'}   = '';

	return $self;
} # TIEHANDLE

sub READ {
	my ($self, undef, $length, $offset) = @_;

	undef $!;

	die 'Read is not supported on this handle'
		if $self->{'mode'} ne '<';

	substr($_[1] //= '', $offset // 0) = '', return 0
		if $self->EOF();

	my $furl = $self->{'furl'};

	my $url = 'https://';
	$url .= join '/', $hosts->{'content'}, $version;
	$url .= join '/', '/files', $self->{'root'}, $self->{'path'};

	my $response = $furl->get($url, [
		Range => sprintf('bytes=%i-%i', $self->{'position'}, $self->{'position'} + ($length || 1)),

		@{ &__headers__ },
	]);

	given ($response->code()) {
		when (206) { 1 }

		when ([401, 403]) {
			$! = EACCES;
			return 0;
		}

		when (500) {
			continue unless $response->content() =~ m{\A(?:Cannot|Failed)};

			$! = ECANCELED;
			return 0;
		}

		when (503) {
			$self->{'meta'} = { retry => $response->header('Retry-After') };
			$! = EAGAIN;
			return 0;
		}

		default {
			die join ' ', $_, $response->decoded_content();
		}
	}

	my $meta  = $response->header('X-Dropbox-Metadata');
	my $bytes = $response->header('Content-Length');

	$self->{'position'} += $bytes > $length? $length : $bytes;

	substr($_[1] //= '', $offset // 0) = substr $response->content(), 0, $length;

	return $bytes;
} # READ

sub READLINE {
	my ($self) = @_;
	my $length;

	undef $!;

	die 'Readline is not supported on this handle'
		if $self->{'mode'} ne '<';

	if ($self->EOF()) {
		return if wantarray;

		# Special case: slurp mode + scalar context + empty file
		# return '' for first call and undef for subsequent
		return ''
			unless $self->{'eof'} or defined $/;

		$self->{'eof'} = 1;
		return undef;
	}

	{
		$length = length $self->{'buffer'};

		if (not wantarray and $length and defined $/) {
			my $position = index $self->{'buffer'}, $/;

			if (~$position) {
				$self->{'position'} += ($position += length $/);
				return substr $self->{'buffer'}, 0, $position, '';
			}
		}

		local $self->{'position'} = $self->{'position'} + $length;

		my $bytes = $self->READ($self->{'buffer'}, $self->{'chunk'}, $length);

		return if $!;
		redo   if not $length or $bytes;
	}

	$length = length $self->{'buffer'};

	if ($length) {
		# Multiline
		if (wantarray and defined $/) {
			$self->{'position'} += $length;

			my ($position, $length) = (0, length $/);
			my @lines;

			foreach ($self->{'buffer'}) {
				while (~(my $offset = index $_, $/, $position)) {
					$offset += $length;
					push @lines, substr $_, $position, $offset - $position;
					$position = $offset;
				}

				push @lines, substr $_, $position
					if $position < length;

				$_ = '';
			}

			return @lines;
		}

		# Slurp or last chunk
		$self->{'position'} += $length;
		return substr $self->{'buffer'}, 0, $length, '';
	}

	return undef;
} # READLINE

sub SEEK {
	my ($self, $position, $whence) = @_;

	undef $!;

	die 'Seek is not supported on this handle'
		if $self->{'mode'} ne '<';

	$self->{'buffer'} = '';

	delete $self->{'eof'};

	given ($whence) {
		when (SEEK_SET) {
			$self->{'position'} = $position
		}

		when (SEEK_CUR) {
			$self->{'position'} += $position
		}

		when (SEEK_END) {
			$self->{'position'} = $self->{'length'} + $position
		}

		default {
			$! = EINVAL;
			return 0;
		}
	}

	$self->{'position'} = 0
		if $self->{'position'} < 0;

	return 1;
} # SEEK

sub TELL {
	my ($self) = @_;

	die 'Tell is not supported on this handle'
		if $self->{'mode'} ne '<';

	return $self->{'position'};
} # TELL

sub WRITE {
	my ($self, $buffer, $length, $offset) = @_;

	undef $!;

	die 'Write is not supported on this handle'
		if $self->{'mode'} ne '>';

	die 'Append-only writes supported'
		if $offset and $offset != $self->{'offset'} + $self->{'length'};

	$self->{'offset'} //= $offset;
	$self->{'buffer'}  .= $buffer;
	$self->{'length'}  += $length;

	$self->__flush__() or return 0
		while $self->{'length'} >= $self->{'chunk'};

	return 1;
} # WRITE

sub CLOSE {
	my ($self) = @_;

	undef $!;

	return 1
		if $self->{'closed'};

	my $mode = $self->{'mode'};

	if ($mode eq '>') {
		if ($self->{'length'} or not $self->{'upload_id'}) {
			do {
				@{ $self }{qw{ closed mode }} = (1, '') and return 0
					unless $self->__flush__();
			} while length $self->{'buffer'};
		}
	}

	$self->{'closed'} = 1;
	$self->{'mode'}   = '';

	return $self->__flush__()
		if $mode eq '>';

	return 1;
} # CLOSE

sub OPEN {
	my ($self, $mode, $file) = @_;

	undef $!;

	($mode, $file) = $mode =~ m{^([<>]?)(.*)$}s
		unless $file;

	given ($mode ||= '<') {
		when (['>', '<']) { 1 }

		when ('r') {
			$mode = '<';
		}

		when (['a', 'w']) {
			$mode = '>';
		}

		default {
			die 'Unsupported mode';
		}
	}

	$self->CLOSE()
		unless $self->{'closed'};

	$self->{'length'}   = 0;
	$self->{'position'} = 0;
	$self->{'buffer'}   = '';

	delete $self->{'offset'};
	delete $self->{'revision'};
	delete $self->{'upload_id'};
	delete $self->{'meta'};
	delete $self->{'eof'};

	$self->{'path'} = $file
		or die 'Path required';

	return 0
		if $mode eq '<' and not $self->__meta__();

	$self->{'mode'}   = $mode;
	$self->{'closed'} = 0;

	return 1;
} # OPEN

sub EOF {
	my ($self) = @_;

	die 'Eof is not supported on this handle'
		if $self->{'mode'} ne '<';

	return $self->{'position'} >= $self->{'length'};
} # EOF

sub BINMODE { 1 }

sub __headers__ {
	return [
		'Authorization',
		$_[0]->{'oauth2'}?
			sprintf $header2, $_[0]->{'access_token'}:
			sprintf $header1, @{ $_[0] }{qw{ app_key access_token app_secret access_secret }},
	];
}

sub __flush__ {
	my ($self) = @_;
	my $furl = $self->{'furl'};
	my $url;

	$url  = 'https://';
	$url .= join '/', $hosts->{'content'}, $version;

	$url .= join '/', '/commit_chunked_upload', $self->{'root'}, $self->{'path'}
		if $self->{'closed'};

	$url .= '/chunked_upload'
		unless $self->{'closed'};

	$url .= '?';

	$url .= join '=', 'upload_id', $self->{'upload_id'}
		if $self->{'upload_id'};

	$url .= '&'
		if $self->{'upload_id'};

	$url .= join '=', 'offset', $self->{'offset'} || 0
		unless $self->{'closed'};

	my $response;

	unless ($self->{'closed'}) {
		use bytes;

		my $buffer = substr $self->{'buffer'}, 0, $self->{'chunk'}, '';
		my $length = length $buffer;

		$self->{'length'} -= $length;
		$self->{'offset'} += $length;

		$response = $furl->put($url, &__headers__, $buffer);
	} else {
		$response = $furl->post($url, &__headers__);
	}

	given ($response->code()) {
		when (400) {
			$! = EINVAL;
			return 0;
		}

		when ([401, 403]) {
			$! = EACCES;
			return 0;
		}

		when (500) {
			continue unless $response->content() =~ m{\A(?:Cannot|Failed)};

			$! = ECANCELED;
			return 0;
		}

		when (503) {
			$self->{'meta'} = { retry => $response->header('Retry-After') };
			$! = EAGAIN;
			return 0;
		}

		when (507) {
			$! = EFBIG;
			return 0;
		}

		when (200) {
			$self->{'meta'} = from_json($response->content())
				if $self->{'closed'};
		}

		default {
			die join ' ', $_, $response->decoded_content();
		}
	}

	unless ($self->{'upload_id'}) {
		$response = from_json($response->content());
		$self->{'upload_id'} = $response->{'upload_id'};
	}

	return 1;
} # __flush__

sub __meta__ {
	my ($self) = @_;
	my ($url, $meta);

	my $furl = $self->{'furl'};

	$url  = 'https://';
	$url .= join '/', $hosts->{'api'}, $version;
	$url .= join '/', '/metadata', $self->{'root'}, $self->{'path'};

	$url .= '?hash='. delete $self->{'hash'}
		if $self->{'hash'};

	my $response = $furl->get($url, &__headers__);

	given ($response->code()) {
		when ([401, 403]) {
			$! = EACCES;
			return 0;
		}

		when (404) {
			$! = ENOENT;
			return 0;
		}

		when (406) {
			$! = EPERM;
			return 0;
		}

		when (500) {
			continue unless $response->content() =~ m{\A(?:Cannot|Failed)};

			$! = ECANCELED;
			return 0;
		}

		when (503) {
			$self->{'meta'} = { retry => $response->header('Retry-After') };
			$! = EAGAIN;
			return 0;
		}

		when (200) {
			$meta = $self->{'meta'} = from_json($response->content());

			# XXX: Dropbox returns metadata for recently deleted files
			if ($meta->{'is_deleted'}) {
				$! = ENOENT;
				return 0;
			}
		}

		when (304) { 1 }

		default {
			die join ' ', $_, $response->decoded_content();
		}
	}

	$! = EISDIR, return 0
		if $meta->{'is_dir'};

	$self->{'revision'} = $meta->{'rev'};
	$self->{'length'}   = $meta->{'bytes'};

	return 1;
} # __meta__

sub __fileops__ {
	my ($type, $handle, $source, $target) = @_;

	my $self = *$handle{'HASH'};
	my $furl = $self->{'furl'};
	my ($url, @arguments);

	$url  = 'https://';
	$url .= join '/', $hosts->{'api'}, $version;
	$url .= join '/', '/fileops', $type;

	given ($type) {
		when (['move', 'copy']) {
			@arguments = (
				from_path => $source,
				to_path   => $target,
			);
		}

		default {
			@arguments = (
				path => $source,
			);
		}
	}

	push @arguments, root => $self->{'root'};

	my $response = $furl->post($url, $self->__headers__(), \@arguments);

	given ($response->code()) {
		when (200) {
			$self->{'meta'} = from_json($response->content());
		}

		when ([401, 403]) {
			$! = EACCES;
			return 0;
		}

		when (404) {
			$! = ENOENT;
			return 0;
		}

		when (406) {
			$! = EPERM;
			return 0;
		}

		when (500) {
			continue unless $response->content() =~ m{\A(?:Cannot|Failed)};

			$! = ECANCELED;
			return 0;
		}

		when (503) {
			$self->{'meta'} = { retry => $response->header('Retry-After') };
			$! = EAGAIN;
			return 0;
		}

		default {
			die join ' ', $_, $response->decoded_content();
		}
	}

	return 1;
} # __fileops__

sub contents ($;$$) {
	my ($handle, $path, $hash) = @_;

	die 'GLOB reference expected'
		unless ref $handle eq 'GLOB';

	*$handle->{'hash'} = $hash
		if $hash;

	if (open $handle, '<', $path || '/' or $! != EISDIR) {
		delete *$handle->{'meta'};
		return;
	}

	undef $!;
	return @{ *$handle->{'meta'}{'contents'} };
} # contents

sub putfile ($$$) {
	my ($handle, $path, $data) = @_;

	die 'GLOB reference expected'
		unless ref $handle eq 'GLOB';

	close $handle or return 0;

	my $self = *$handle{'HASH'};
	my $furl = $self->{'furl'};
	my ($url, $length);

	$url  = 'https://';
	$url .= join '/', $hosts->{'content'}, $version;
	$url .= join '/', '/files_put', $self->{'root'}, $path;

	{
		use bytes;
		$length = length $data;
	}

	my $response = $furl->put($url, $self->__headers__(), $data);

	given ($response->code()) {
		when (400) {
			$! = EINVAL;
			return 0;
		}

		when ([401, 403]) {
			$! = EACCES;
			return 0;
		}

		when (500) {
			continue unless $response->content() =~ m{\A(?:Cannot|Failed)};

			$! = ECANCELED;
			return 0;
		}

		when (503) {
			$self->{'meta'} = { retry => $response->header('Retry-After') };
			$! = EAGAIN;
			return 0;
		};

		when (507) {
			$! = EFBIG;
			return 0;
		}

		when (200) {
			$self->{'path'} = $path;
			$self->{'meta'} = from_json($response->content());
		}

		default {
			die join ' ', $_, $response->decoded_content();
		}
	}

	return 1;
} # putfile

sub movefile    ($$$) { __fileops__('move', @_) }
sub copyfile    ($$$) { __fileops__('copy', @_) }
sub deletefile   ($$) { __fileops__('delete', @_) }
sub createfolder ($$) { __fileops__('create_folder', @_) }

sub metadata ($) {
	my ($handle) = @_;

	die 'GLOB reference expected'
		unless ref $handle eq 'GLOB';

	my $self = *$handle{'HASH'};

	die 'Meta is unavailable for incomplete upload'
		if $self->{'mode'} eq '>';

	return $self->{'meta'};
} # metadata

=head1 NAME

File::Dropbox - Convenient and fast Dropbox API abstraction

=head1 SYNOPSIS

    use File::Dropbox;
    use Fcntl;

    # Application credentials
    my %app = (
        app_key       => 'app key',
        app_secret    => 'app secret',
        access_token  => 'access token',
        access_secret => 'access secret',
    );

    my $dropbox = File::Dropbox->new(%app);

    # Open file for writing
    open $dropbox, '>', 'example' or die $!;

    while (<>) {
        # Upload data using 4MB chunks
        print $dropbox $_;
    }

    # Commit upload (optional, close will be called on reopen)
    close $dropbox or die $!;

    # Open for reading
    open $dropbox, '<', 'example' or die $!;

    # Download and print to STDOUT
    # Buffered, default buffer size is 4MB
    print while <$dropbox>;

    # Reset file position
    seek $dropbox, 0, Fcntl::SEEK_SET;

    # Get first character (unbuffered)
    say getc $dropbox;

    close $dropbox;

=head1 DESCRIPTION

C provides high-level Dropbox API abstraction based on L. Code required to get C and
C for signed OAuth 1.0 requests or C for OAuth 2.0 requests is not included in this module.
To get C and C you need to register your application with Dropbox.

At this moment Dropbox API is not fully supported, C covers file read/write and directory listing methods. If you need full
API support take look at L. C main purpose is not 100% API coverage,
but simple and high-performance file operations.

Due to API limitations and design you can not do read and write operations on one file at the same time. Therefore handle can be in read-only
or write-only state, depending on last call to L. Supported functions for read-only state are: L,
L, L, L, L, L,
L, L, L. For write-only state: L, L,
L, L, L, L.

All API requests are done using L module. For more accurate timeouts L is used, as described in L. Furl settings
can be overriden using C.

=head1 METHODS

=head2 new

    my $dropbox = File::Dropbox->new(
        access_secret => 'secret',
        access_token  => 'token',
        app_secret    => 'app secret',
        app_key       => 'app key',
        chunk         => 8 * 1024 * 1024,
        root          => 'dropbox',
        furlopts      => {
            timeout => 20
        }
    );

    my $dropbox = File::Dropbox->new(
        access_token => 'token',
        oauth2       => 1
    );

Constructor, takes key-value pairs list

=over

=item access_secret

OAuth 1.0 access secret

=item access_token

OAuth 1.0 access token or OAuth 2.0 access token

=item app_secret

OAuth 1.0 app secret

=item app_key

OAuth 1.0 app key

=item oauth2

OAuth 2.0 switch, defaults to false.

=item chunk

Upload chunk size in bytes. Also buffer size for C. Optional. Defaults to 4MB.

=item root

Access type, C for app-folder only access and C for full access.

=item furlopts

Parameter hash, passed to L constructor directly. Default options

    timeout   => 10,
    inet_aton => \&Net::DNS::Lite::inet_aton,
    ssl_opts  => {
        SSL_verify_mode => SSL_VERIFY_PEER(),
    }

=back

=head1 FUNCTIONS

All functions are not exported by default but can be exported on demand.

    use File::Dropbox qw{ contents metadata putfile };

First argument for all functions should be GLOB reference, returned by L.

=head2 contents

Arguments: $dropbox [, $path]

Function returns list of hashrefs representing directory content. Hash fields described in L
docs|https://www.dropbox.com/developers/core/docs#metadata>. C<$path> defaults to C. If there is
unfinished chunked upload on handle, it will be commited.

    foreach my $file (contents($dropbox, '/data')) {
        next if $file->{'is_dir'};
        say $file->{'path'}, ' - ', $file->{'bytes'};
    }

=head2 metadata

Arguments: $dropbox

Function returns stored metadata for read-only handle, closed write handle or after
call to L or L.

    open $dropbox, '<', '/data/2013.dat' or die $!;

    my $meta = metadata($dropbox);

    if ($meta->{'bytes'} > 1024) {
        # Do something
    }

=head2 putfile

Arguments: $dropbox, $path, $data

Function is useful for uploading small files (up to 150MB possible) in one request (at least
two API requests required for chunked upload, used in open-write-close sequence). If there is
unfinished chunked upload on handle, it will be commited.

    local $/;
    open my $data, '<', '2012.dat' or die $!;

    putfile($dropbox, '/data/2012.dat', <$data>) or die $!;

    say 'Uploaded ', metadata($dropbox)->{'bytes'}, ' bytes';

    close $data;

=head2 copyfile

Arguments: $dropbox, $source, $target

Function copies file or directory from one location to another. Metadata for copy
can be accessed using L function.

    copyfile($dropbox, '/data/2012.dat', '/data/2012.dat.bak') or die $!;

    say 'Created backup with revision ', metadata($dropbox)->{'revision'};

=head2 movefile

Arguments: $dropbox, $source, $target

Function moves file or directory from one location to another. Metadata for moved file
can be accessed using L function.

    movefile($dropbox, '/data/2012.dat', '/data/2012.dat.bak') or die $!;

    say 'Created backup with size ', metadata($dropbox)->{'size'};

=head2 deletefile

Arguments: $dropbox, $path

Function deletes file or folder at specified path. Metadata for deleted item
is accessible via L function.

    deletefile($dropbox, '/data/2012.dat.bak') or die $!;

    say 'Deleted backup with last modification ', metadata($dropbox)->{'modification'};

=head2 createfolder

Arguments: $dropbox, $path

Function creates folder at specified path. Metadata for created folder
is accessible via L function.

    createfolder($dropbox, '/data/backups') or die $!;

    say 'Created folder at path ', metadata($dropbox)->{'path'};

=head1 SEE ALSO

L, L, L, L

=head1 AUTHOR

Alexander Nazarov

=head1 COPYRIGHT AND LICENSE

Copyright 2013, 2014 Alexander Nazarov

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;