File Coverage

blib/lib/Net/Jifty.pm

Criterion	Covered	Total	%
statement	155	269	57.6
branch	42	98	42.8
condition	10	36	27.7
subroutine	25	38	65.7
pod	30	30	100.0
total	262	471	55.6

package Net::Jifty;
use Any::Moose;

our $VERSION = '0.14';

use LWP::UserAgent;
use URI;

use YAML;

use Encode;
use Fcntl qw(:mode);

has site => (
    is            => 'rw',
    isa           => 'Str',
    required      => 1,
    documentation => "The URL of your application",
    trigger       => sub {
        # this canonicalizes localhost to 127.0.0.1 because of an (I think)
        # HTTP::Cookies bug. cookies aren't sent out for localhost.
        my ($self, $site) = @_;

        if ($site =~ s/\blocalhost\b/127.0.0.1/) {
            $self->site($site);
        }
    },
);

has cookie_name => (
    is            => 'rw',
    isa           => 'Str',
    required      => 1,
    documentation => "The name of the session ID cookie. This can be found in your config under Framework/Web/SessinCookieName",
);

has appname => (
    is            => 'rw',
    isa           => 'Str',
    documentation => "The name of the application, as it is known to Jifty",
);

has email => (
    is            => 'rw',
    isa           => 'Str',
    documentation => "The email address to use to log in",
);

has password => (
    is            => 'rw',
    isa           => 'Str',
    documentation => "The password to use to log in",
);

has sid => (
    is  => 'rw',
    isa => 'Str',
    documentation => "The session ID, from the cookie_name cookie. You can use this to bypass login",
    trigger => sub {
        my $self = shift;

        my $uri = URI->new($self->site);
        $self->ua->cookie_jar->set_cookie(0, $self->cookie_name,
                                          $self->sid, '/',
                                          $uri->host, $uri->port,
                                          0, 0, undef, 1);
    },
);

has ua => (
    is      => 'rw',
    isa     => 'LWP::UserAgent',
    default => sub {
        my $args = shift;

        my $ua = LWP::UserAgent->new;

        $ua->cookie_jar({});
        push @{ $ua->requests_redirectable }, qw( POST PUT DELETE );

        # Load the user's proxy settings from %ENV
        $ua->env_proxy;

        return $ua;
    },
);

has config_file => (
    is            => 'rw',
    isa           => 'Str',
    default       => "$ENV{HOME}/.jifty",
    predicate     => 'has_config_file',
    documentation => "The place to look for the user's config file",
);

has use_config => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    documentation => "Whether or not to use the user's config",
);

has config => (
    is      => 'rw',
    isa     => 'HashRef',
    default => sub { {} },
    documentation => "Storage for the user's config",
);

has use_filters => (
    is            => 'rw',
    isa           => 'Bool',
    default       => 1,
    documentation => "Whether or not to use config files in the user's directory tree",
);

has filter_file => (
    is            => 'rw',
    isa           => 'Str',
    default       => ".jifty",
    documentation => "The filename to look for in each parent directory",
);

has strict_arguments => (
    is            => 'rw',
    isa           => 'Bool',
    default       => 0,
    documentation => "Check to make sure mandatory arguments are provided, and no unknown arguments are included",
);

has action_specs => (
    is            => 'rw',
    isa           => 'HashRef',
    default       => sub { {} },
    documentation => "The cache for action specifications",
);

has model_specs => (
    is            => 'rw',
    isa           => 'HashRef',
    default       => sub { {} },
    documentation => "The cache for model specifications",
);

sub BUILD {
    my $self = shift;

    $self->load_config
        if $self->use_config && $self->has_config_file;

    $self->login
        unless $self->sid;
}

sub login {
    my $self = shift;

    return if $self->sid;

    confess "Unable to log in without an email and password."
        unless $self->email && $self->password;

    confess 'Your email did not contain an "@" sign. Did you accidentally use double quotes?'
        if $self->email !~ /@/;

    my $result = $self->call(Login =>
                                address  => $self->email,
                                password => $self->password);

    confess "Unable to log in."
        if $result->{failure};

    $self->get_sid;
    return 1;
}

sub call {
    my $self    = shift;
    my $action  = shift;
    my %args    = @_;
    my $moniker = 'fnord';

    my $res = $self->ua->post(
        $self->site . "/__jifty/webservices/yaml",
        {   "J:A-$moniker" => $action,
            map { ( "J:A:F-$_-$moniker" => $args{$_} ) } keys %args
        }
    );

    if ( $res->is_success ) {
        return YAML::Load( Encode::decode_utf8($res->content) )->{$moniker};
    } else {
        confess $res->status_line;
    }
}

sub form_url_encoded_args {
    my $self = shift;

    my $uri = '';
    while (my ($key, $value) = splice @_, 0, 2) {
        $uri .= join('=', map { $self->escape($_) } $key, $value) . '&';
    }
    chop $uri;

    return $uri;
}

sub form_form_data_args {
    my $self = shift;

    my @res;
    while (my ($key, $value) = splice @_, 0, 2) {
        my $disposition = 'form-data; name="'. Encode::encode( 'MIME-Q', $key ) .'"';
        unless ( ref $value ) {
            push @res, HTTP::Message->new(
                ['Content-Disposition' => $disposition ],
                $value,
            );
            next;
        }

        if ( $value->{'filename'} ) {
            $value->{'filename'} = Encode::encode( 'MIME-Q', $value->{'filename'} );
            $disposition .= '; filename="'. delete ( $value->{'filename'} ) .'"';
        }
        push @res, HTTP::Message->new(
            [
                'Content-Type' => $value->{'content_type'} || 'application/octet-stream',
                'Content-Disposition' => $disposition,
            ],
            delete $value->{content},
        );
    }
    return @res;
}

sub method {
    my $self   = shift;
    my $method = lc(shift);
    my $url    = shift;
    my @args   = @_;

    $url = $self->join_url(@$url)
        if ref($url) eq 'ARRAY';

    # remove trailing /
    $url =~ s{/+$}{};

    my $uri = $self->site . '/=/' . $url . '.yml';

    my $res;

    if ($method eq 'get' || $method eq 'head') {
        $uri .= '?' . $self->form_url_encoded_args(@args)
            if @args;

        $res = $self->ua->$method($uri);
    }
    else {
        my $req = HTTP::Request->new(
            uc($method) => $uri,
        );

        if (@args) {
            if ( grep ref $_, @args ) {
                $req->header('Content-type' => 'multipart/form-data');
                $req->add_part( $_ ) foreach $self->form_form_data_args(@args);
            } else {
                $req->header('Content-type' => 'application/x-www-form-urlencoded');
                $req->content( $self->form_url_encoded_args(@args) );
            }
        }

        $res = $self->ua->request($req);

        # XXX Compensation for a bug in Jifty::Plugin::REST... it doesn't
        # remember to add .yml when redirecting after an update, so we will
        # try to do that ourselves... fixed in a Jifty coming to stores near
        # you soon!
        if ($res->is_success && $res->content_type eq 'text/html') {
            $req = $res->request->clone;
            $req->uri($req->uri . '.yml');
            $res = $self->ua->request($req);
        }
    }

    if ($res->is_success) {
        return YAML::Load( Encode::decode_utf8($res->content) );
    } else {
        confess $res->status_line;
    }
}

sub post {
    my $self = shift;
    $self->method('post', @_);
}

sub get {
    my $self = shift;
    $self->method('get', @_);
}

sub act {
    my $self   = shift;
    my $action = shift;

    $self->validate_action_args($action => @_)
        if $self->strict_arguments;

    return $self->post(["action", $action], @_);
}

sub create {
    my $self  = shift;
    my $model = shift;

    $self->validate_action_args([create => $model] => @_)
        if $self->strict_arguments;

    return $self->post(["model", $model], @_);
}

sub delete {
    my $self   = shift;
    my $model  = shift;
    my $key    = shift;
    my $value  = shift;

    $self->validate_action_args([delete => $model] => $key => $value)
        if $self->strict_arguments;

    return $self->method(delete => ["model", $model, $key, $value]);
}

sub update {
    my $self   = shift;
    my $model  = shift;
    my $key    = shift;
    my $value  = shift;

    $self->validate_action_args([update => $model] => $key => $value, @_)
        if $self->strict_arguments;

    return $self->method(put => ["model", $model, $key, $value], @_);
}

sub read {
    my $self   = shift;
    my $model  = shift;
    my $key    = shift;
    my $value  = shift;

    return $self->get(["model", $model, $key, $value]);
}

sub search {
    my $self  = shift;
    my $model = shift;
    my @args;

    while (@_) {
        if (@_ == 1) {
            push @args, shift;
        }
        else {
            # id => [1,2,3] maps to id/1/id/2/id/3
            if (ref($_[1]) eq 'ARRAY') {
                push @args, map { $_[0] => $_ } @{ $_[1] };
                splice @_, 0, 2;
            }
            else {
                push @args, splice @_, 0, 2;
            }
        }
    }

    return $self->get(["search", $model, @args]);
}

sub validate_action_args {
    my $self   = shift;
    my $action = shift;
    my %args   = @_;

    my $name;
    if (ref($action) eq 'ARRAY') {
        my ($operation, $model) = @$action;

        # drop MyApp::Model::
        $model =~ s/.*:://;

        confess "Invalid model operation: $operation. Expected 'create', 'update', or 'delete'." unless $operation =~ m{^(?:create|update|delete)$}i;

        $name = ucfirst(lc $operation) . $model;
    }
    else {
        $name = $action;
    }

    my $action_spec = $self->get_action_spec($name);

    for my $arg (keys %$action_spec) {
        confess "Mandatory argument '$arg' not given for action $name."
            if $action_spec->{$arg}{mandatory} && !defined($args{$arg});
        delete $args{$arg};
    }

    if (keys %args) {
        confess "Unknown arguments given for action $name: "
              . join(', ', keys %args);
    }

    return 1;
}

sub get_action_spec {
    my $self = shift;
    my $name = shift;

    unless ($self->action_specs->{$name}) {
        $self->action_specs->{$name} = $self->get("action/$name");
    }

    return $self->action_specs->{$name};
}

sub get_model_spec {
    my $self = shift;
    my $name = shift;

    unless ($self->model_specs->{$name}) {
        $self->model_specs->{$name} = $self->get("model/$name");
    }

    return $self->model_specs->{$name};
}

sub get_sid {
    my $self = shift;
    my $cookie = $self->cookie_name;

    my $sid;
    $sid = $1
        if $self->ua->cookie_jar->as_string =~ /\Q$cookie\E=([^;]+)/;

    $self->sid($sid);
}

sub join_url {
    my $self = shift;

    return join '/', map { $self->escape($_) } grep { defined } @_
}

sub escape {
    my $self = shift;

    return map { s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord $1)/eg; $_ }
           map { Encode::encode_utf8($_) }
           @_
}

sub load_date {
    my $self = shift;
    my $ymd  = shift;

    my ($y, $m, $d) = $ymd =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(?: 00:00:00)?$/
        or confess "Invalid date passed to load_date: $ymd. Expected yyyy-mm-dd.";

    require DateTime;
    return DateTime->new(
        time_zone => 'floating',
        year      => $y,
        month     => $m,
        day       => $d,
    );
}

sub email_eq {
    my $self = shift;
    my $a    = shift;
    my $b    = shift;

    # if one's defined and the other isn't, return 0
    return 0 unless (defined $a ? 1 : 0)
                 == (defined $b ? 1 : 0);

    return 1 if !defined($a) && !defined($b);

    # so, both are defined

    require Email::Address;

    for ($a, $b) {
        $_ = 'nobody@localhost' if $_ eq 'nobody' || //;
        my ($email) = Email::Address->parse($_);
        $_ = lc($email->address);
    }

    return $a eq $b;
}

sub is_me {
    my $self = shift;
    my $email = shift;

    return 0 if !defined($email);

    return $self->email_eq($self->email, $email);
}

sub load_config {
    my $self = shift;

    $self->config_permissions;
    $self->read_config_file;

    # allow config to override everything. this may need to be less free in
    # the future
    while (my ($key, $value) = each %{ $self->config }) {
        $self->$key($value)
            if $self->can($key);
    }

    $self->prompt_login_info
        unless $self->config->{email} || $self->config->{sid};

    # update config if we are logging in manually
    unless ($self->config->{sid}) {

        # if we have user/pass in the config then we still need to log in here
        unless ($self->sid) {
            $self->login;
        }

        # now write the new config
        $self->config->{sid} = $self->sid;
        $self->write_config_file;
    }

    return $self->config;
}

sub config_permissions {
    my $self = shift;
    my $file = $self->config_file;

    return if $^O eq 'MSWin32';
    return unless -e $file;
    my @stat = stat($file);
    my $mode = $stat[2];
    if ($mode & S_IRGRP || $mode & S_IROTH) {
        warn "Config file $file is readable by users other than you, fixing.";
        chmod 0600, $file;
    }
}

sub read_config_file {
    my $self = shift;
    my $file = $self->config_file;

    return unless -e $file;

    $self->config(YAML::LoadFile($self->config_file) || {});

    if ($self->config->{site}) {
        # Somehow, localhost gets normalized to localhost.localdomain,
        # and messes up HTTP::Cookies when we try to set cookies on
        # localhost, since it doesn't send them to
        # localhost.localdomain.
        $self->config->{site} =~ s/localhost/127.0.0.1/;
    }
}

sub write_config_file {
    my $self = shift;
    my $file = $self->config_file;

    YAML::DumpFile($file, $self->config);
    chmod 0600, $file;
}

sub prompt_login_info {
    my $self = shift;

    print << "END_WELCOME";
Before we get started, please enter your @{[ $self->site ]}
username and password.

This information will be stored in @{[ $self->config_file ]},
should you ever need to change it.

END_WELCOME

    local $| = 1; # Flush buffers immediately

    while (1) {
        print "First, what's your email address? ";
        $self->config->{email} = ;
        chomp($self->config->{email});

        my $read_mode = eval {
            require Term::ReadKey;
            \&Term::ReadKey::ReadMode;
        } || sub {};

        print "And your password? ";
        $read_mode->('noecho');
        $self->config->{password} = ;
        chomp($self->config->{password});
        $read_mode->('restore');

        print "\n";

        $self->email($self->config->{email});
        $self->password($self->config->{password});

        last if eval { $self->login };

        $self->email('');
        $self->password('');

        print "That combination doesn't seem to be correct. Try again?\n";
    }
}

sub filter_config {
    my $self = shift;

    return {} unless $self->use_filters;

    my $all_config = {};

    require Path::Class;
    require Cwd;
    my $dir = Path::Class::dir(shift || Cwd::getcwd());

    require Hash::Merge;
    my $old_behavior = Hash::Merge::get_behavior();
    Hash::Merge::set_behavior('RIGHT_PRECEDENT');

    while (1) {
        my $file = $dir->file( $self->filter_file )->stringify;

        if (-r $file) {
            my $this_config = YAML::LoadFile($file);
            $all_config = Hash::Merge::merge($this_config, $all_config);
        }

        my $parent = $dir->parent;
        last if $parent eq $dir;
        $dir = $parent;
    }

    Hash::Merge::set_behavior($old_behavior);

    return $all_config;
}

sub email_of {
    my $self = shift;
    my $id = shift;

    my $user = $self->read(User => id => $id);
    return $user->{email};
}

__PACKAGE__->meta->make_immutable;
no Any::Moose;

1;

__END__