File Coverage

blib/lib/WebService/DailyConnect.pm

Criterion	Covered	Total	%
statement	17	76	22.3
branch	0	30	0.0
condition	0	9	0.0
subroutine	6	17	35.2
pod	7	7	100.0
total	30	139	21.5

package WebService::DailyConnect;

use strict;
use warnings;
use 5.010;
use Moose;
use URI;
use Carp ();

# ABSTRACT: Web client to download events from Daily Connect
our $VERSION = '0.02'; # VERSION


has ua => (
  is      => 'ro',
  isa     => 'HTTP::AnyUA',
  lazy    => 1,
  default => sub {
    require HTTP::AnyUA;
    require LWP::UserAgent;
    my $ua = LWP::UserAgent->new(
      cookie_jar => {},
    );
    $ua->env_proxy;
    HTTP::AnyUA->new(
      ua => $ua,
    );
  },
);


has base_url => (
  is      => 'ro',
  isa     => 'URI',
  lazy    => 1,
  default => sub {
    URI->new('https://www.dailyconnect.com/');
  },
);


has req => (
  is => 'rw',
);


has res => (
  is => 'rw',
);

around BUILDARGS => sub {
  my($orig, $class, %args) = @_;

  if(defined $args{ua} && ! eval { $args{ua}->isa('HTTP::AnyUA') })
  {
    require HTTP::AnyUA;
    HTTP::AnyUA->new(ua => $args{ua});
  }

  return $class->$orig(%args);
};

sub _url
{
  my($self, $path) = @_;
  URI->new_abs($path, $self->base_url);
}


sub login
{
  my($self, $email, $pass) = @_;
  Carp::croak("Usage: \$dc->login(\$email, \$pass)") unless $email && $pass;
  my $res = $self->_post('Cmd?cmd=UserAuth', { email => $email, pass => $pass });
  $res->{status} == 302;
}

sub _post
{
  my($self, $path, $form) = @_;
  my $url = $self->_url($path)->as_string;
  my $req = [ $url, $form ];
  $self->req([ 'POST', @$req ]);
  my $res = $self->ua->post_form(@$req);
  $self->res($res);
}

sub _json
{
  my(undef, $json) = @_;
  require JSON::MaybeXS;
  JSON::MaybeXS::decode_json($json);
}

sub _today
{
  my($year,$month,$day) = (localtime(time))[5,4,3];
  $month++;
  $year = $year + 1900 - 2000;
  join('', map { sprintf "%02d", $_ } $year, $month, $day);
}


sub user_info
{
  my($self) = @_;
  my $res = $self->_post('CmdW', { cmd => 'UserInfoW'});
  $res->{status} == 200 ? $self->_json($res->{content}) : ();
}


sub kid_summary
{
  my($self, $kid_id) = @_;
  Carp::croak("Usage: \$dc->kid_summary_by_date(\$kid_id)") unless $kid_id;
  $self->kid_summary_by_date($kid_id, $self->_today);
}


sub kid_summary_by_date
{
  #date: yymmdd
  my($self, $kid_id, $date) = @_;
  Carp::croak("Usage: \$dc->kid_summary_by_date(\$kid_id, \$date)") unless $kid_id && $date;
  my $res = $self->_post('CmdW', { cmd => 'KidGetSummary', Kid => $kid_id, pdt => $date });
  $res->{status} == 200 ? $self->_json($res->{content}) : ();
}


sub kid_status
{
  my($self, $kid_id) = @_;
  Carp::croak("Usage: \$dc->kid_status_by_date(\$kid_id)") unless $kid_id;
  $self->kid_status_by_date($kid_id, $self->_today);
}


sub kid_status_by_date
{
  #date: yymmdd
  my($self, $kid_id, $date) = @_;
  Carp::croak("Usage: \$dc->kid_status_by_date(\$kid_id, \$date)") unless $kid_id && $date;
  my $res = $self->_post('CmdListW', { cmd => 'StatusList', Kid => $kid_id, pdt => $date, fmt => 'long' });
  $res->{status} == 200 ? $self->_json($res->{content}) : ();
}


sub photo
{
  my($self, $photo_id, $dest) = @_;
  Carp::croak("Usage: \$dc->photo(\$photo_id)") unless $photo_id;
  my $url = $self->_url('GetCmd')->clone;
  $url->query_form(cmd => 'PhotoGet', id => $photo_id, thumb => 0);
  $url = $url->as_string;
  $self->req([ 'GET', $url ]);
  my $res = $self->ua->get($url);
  $self->res($res);
  return unless $res->{headers}->{'content-type'} eq 'image/jpg';
  if(defined $dest)
  {
    if(ref($dest))
    {
      if(eval { $dest->isa('Path::Tiny') })
      {
        $dest->spew_raw($res->{content});
      }
      elsif(eval { $dest->isa('Path::Class::File') })
      {
        $dest->spew(iomode => '>:raw', $res->{content});
      }
      elsif(ref($dest) eq 'SCALAR')
      {
        $$dest = $res->{content};
      }
      else
      {
        Carp::croak("unknown destination type.  Must be one of: scalar, reference to scalar, Path::Tiny, Path::Class::File");
      }
    }
    else
    {
      require Path::Tiny;
      Path::Tiny->new($dest)->spew_raw($res->{content});
    }
    1;
  }
  else
  {
    return $res->{content};
  }
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

WebService::DailyConnect - Web client to download events from Daily Connect

=head1 VERSION

version 0.02

=head1 SYNOPSIS

 use WebService::DailyConnect;
 use Term::Clui qw( ask ask_password );
 use Path::Tiny qw( path );

 my $user = ask("email:");
 my $pass = ask_password("pass :");

 my $dc = WebService::DailyConnect->new;
 $dc->login($user, $pass) || die "bad email/pass";

 my $user_info = $dc->user_info;

 foreach my $kid (@{ $dc->user_info->{myKids} })
 {
   my $kid_id = $kid->{Id};
   my $name   = lc $kid->{Name};
   foreach my $photo_id (map { $_->{Photo} || () } @{ $dc->kid_status($kid_id)->{list} })
   {
     my $dest = path("~/Pictures/dc/$name-$photo_id.jpg");
     next if -f $dest;
     print "new photo: $dest\n";
     $dest->parent->mkpath;
     $dc->photo($photo_id, $dest);
   }
 }

=head1 DESCRIPTION

Interface to DailyConnect, which is a service that can provide information about
your kids at daycare.  This is more or less a port of a node API that I found here:

https://github.com/Flet/dailyconnect

I wrote this module for more or less the same reasons as that author, although I
wanted to be able to use it in perl.

It uses L<HTTP::AnyUA>, so should work with any Perl user agent supported by that
layer.

=head1 ATTRIBUTES

=head2 ua

An instance of L<HTTP::AnyUA>.  If a user agent supported by L<HTTP::AnyUA>
(such as L<HTTP::Tiny> or L<LWP::UserAgent>) is provided, a new instance of
L<HTTP::AnyUA> will wrap around that user agent instance.  The only requirement
is that the underlying user agent must support cookies.

If a C<ua> attribute is not provided, then an instance of L<HTTP::AnyUA> will
be created wrapped around a L<LWP::UserAgent> using the default proxy and a
cookie jar.

=head2 base_url

The base URL for daily connect.  The default should be correct.

=head2 req

The most recent request.  The format of the request object is subject to change, and therefore should only be used for debugging.

=head2 res

The most recent response.  The format of the response object is subject to change, and therefore should only be used for debugging.

=head2 METHODS

Beside login, methods typically return a hash or file content depending on the type of object requested.
On error they return C<undef>.  Further details for the failure can be deduced from the response object
stored in C<res> above.

=head2 login

 my $bool = $dc->login($email, $pass);

Login to daily connect using the given email and password.  The remaining methods only work once you have successfully logged in.

=head2 user_info

 my $hash = $dc->user_info;

Get a hash of the user information.

=head2 kid_summary

 my $hash = $dc->kid_summary($kid_id);

Get today's summary for the given kid.

=head2 kid_summary_by_date

 my $hash = $dc->kid_summary_by_date($kid_id, $date);

Get the summary for the given kid on the given day.  C<$date> is in the form YYMMDD.

=head2 kid_status

 my $hash = $dc->kid_status($kid_id);

Get today's status for the given kid.

=head2 kid_status_by_date

 my $hash = $dc->kid_status_by_date($kid_id, $date);

Get the status for the given kid on the given date.  C<$date> is in the form YYMMDD.

=head2 photo

 $dc->photo($photo_id);
 $dc->photo($photo_id, $dest);

Get the photo with the given C<$photo_id>.  If C<$dest> is not provided then the content of the photo in
JPEG format will be returned.  If C<$dest> is a scalar reference, then the content will be stored in that
scalar.  If C<$dest> is a string, then that string will be assumed to be a file, and the photo will be saved
there.  If a L<Path::Tiny> or L<Path::Class::File> object are passed in, then the content will be written
to the files at that location.

=head1 CAVEATS

DailyConnect does not provide a standard RESTful API, so it is entirely possible
they might change the interface of their app, and break this module.

My kiddo is an only child so I haven't been able to test this for more than one
kiddo.  May be a problem if you have twins or septuplets.

=head1 AUTHOR

Graham Ollis <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2018,2019 by Graham Ollis.

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

=cut