iob.pl

#!/usr/bin/env perl

#-------------------------------------------------------------------
# WebGUI is Copyright 2011 Plain Black Corporation.
#-------------------------------------------------------------------
# Please read the legal notices (docs/legal.txt) and the license
# (docs/license.txt) that came with this distribution before using
# this software.
#-------------------------------------------------------------------
# http://www.plainblack.com                     info@plainblack.com
#-------------------------------------------------------------------

=head1 NAME

iob.pl - Update the in/out board from the command line

=head1 SYNOPSIS

    iob.pl --username --password --in --message "Good morning!"

    iob.pl --username --password --out --message "Everyone, go home already"

=head1 DESCRIPTION

Clock in or out.

=head1 ARGUMENTS

=head2 --in

=head2 --out

=head2 --home

=head2 --lunch

=head2 --message

Text string.

=head2 --username

=head2 --password

This thing will remember your username and un-obscured password in your home directory.

=head2 --image

=head1 AUTHOR

Scott Walters; Copyright 2011 Plain Black Corporation.

=cut

use strict;
use warnings;

use IO::Handle;
use LWP::Simple 'get';
use Data::Dumper;
use HTTP::Cookies;
use WWW::Mechanize;
use Web::Scraper;
use List::MoreUtils 'zip';
use URI;
use Pod::Usage;
use Getopt::Long;
use Acme::State 'main';
use POSIX;
use MIME::Base64;

STDOUT->autoflush(1);

#
# init
#

# Get parameters here, including $help
GetOptions(
    'help'          => \my $help,
    'man'           => \my $man,
    'username=s'    => \our $username,
    'password=s'    => \our $password,
    'in'            => \my $in,
    'out'           => \my $out,
    'home'          => \my $home,
    'lunch'         => \my $lunch,
    'message=s'     => \my $message,
    'image=s',      => \my $image,
);

pod2usage( verbose => 1 ) if $help;
pod2usage( verbose => 2 ) if $man;

my $iob = 'http://www.plainblack.com/iob';

my $uriob = URI->new($iob) or die;
my $base_url = $uriob->scheme . '://' . $uriob->host;  $base_url .= ':' . $uriob->port if $uriob->port ne '80';

warn "using url: ``$iob''  base_url: ``$base_url''";

$LWP::Simple::ua->cookie_jar( {} );

my $mech = WWW::Mechanize->new( cookie_jar => $LWP::Simple::ua->cookie_jar() );

my $response;
my $request;
my $form;

#

our %hours_by_day;
our $last_clockin;

#
# login
#

$response = $mech->get($base_url) or die;

$form = $mech->form_with_fields('username', 'identifier') or blurp( $response->decoded_content, "couldn't find login form" );
warn "username: $username password: $password";
$form->value( username => $username );
$form->value( identifier => $password );

$response = $LWP::Simple::ua->request( $request = $form->click );
$mech->_update_page($request, $response);

# just a 302 Found
# die $response->status_line if ! $response->is_success;
# warn $response->decoded_content;

if($response->code == 302) {
   # XXX I think LWP can be set to automatically follow these redirects
   my $url = $response->header('Location') or die;
   warn "redirected to url $url";
   $response = $LWP::Simple::ua->get( $url );
   $response->code =~ m/^4/ and die $response->decoded_content;
   $mech->_update_page($request, $response);
}

$response->decoded_content =~ m/Hello / or blurp($response->decoded_content, "login didn't seem to have worked" );

# didn't get redirect back to /iob so fetch there again

$response = $mech->get($iob) or die "fetch iob failed";
$mech->_update_page($request, $response);

# for my $form ($mech->forms) { warn Data::Dumper::Dumper $form }; # XXX

$message ||= '';  $message .= image($image) if $image;

$form = $mech->form_with_fields('status', 'message') or blurp( $response->decoded_content, "couldn't find iob form" );
$form->value( status => 'in' ) if $in;
$form->value( status => 'out' ) if $out;
$form->value( status => 'home' ) if $home;
$form->value( status => 'lunch' ) if $lunch;
$form->value( message => $message ) if $message;
$response = $LWP::Simple::ua->request( $request = $form->click );
$mech->_update_page($request, $response);  # stuff our non-mech request/response back into mech

#

my $statuses = scraper {
    process 'span', 'names[]' => scraper {
        process 'span', 'inout' => '@class';
        process 'div.nameBlock' => 'users[]' => scraper {
            process 'div.user', 'name' => 'TEXT';
            process 'div.message', 'message' => 'TEXT';
            result 'name', 'message';
        };
        result 'users', 'inout';
    };
    result 'names';
}->scrape($response->decoded_content);

for my $status ( @$statuses ) {
    next unless $status->{inout};
    print $status->{inout}, " ------------------------\n";
    for my $user ( @{ $status->{users} } ) {
        printf "%-30s %-70s\n", $user->{name}, $user->{message}||'';
    }
}

#

print "------------------------------------------------\n";

my $day_identifier = strftime "%Y%m%d", localtime;
if( $last_clockin and ($home or $lunch or $out) ) {
    $hours_by_day{$day_identifier} += time - $last_clockin;
    $last_clockin = undef;
} elsif ( $in and ! $last_clockin ) {
    $last_clockin = time;
}

my @dates = sort { $b <=> $a } keys %hours_by_day;
@dates = @dates[0 .. 20] if @dates > 20;
for my $date (@dates) {
    printf "%8d: %2.2f hours\n", $date, $hours_by_day{ $date } / 3600;
}

# debug

sub blurp {
    my $page = shift;
    my $message = shift;
    warn $message if $message;
    open my $outf, '>', '/tmp/debug.html' or die $!;
    $outf->print($page) or die $!;
    $outf->close or die $!;
    # system 'lynx', '/tmp/debug.html';
}

# hullo

sub image {
    my $fn = shift;
    open my $fh, '<', $fn or die "reading image $fn: $!";
    read $fh, my $imgdata, -s $fh;
    my $excerpt = substr $imgdata, 0, 32;
    my $type;
    $type = 'image/gif' if $excerpt =~ m/GIF/;
    $type = 'image/png' if $excerpt =~ m/PNG/;
    $type = 'image/jpeg' if $excerpt =~ m/JFIF/;
    $type or die "Sorry, can't figure out what type of image that is or I got no data or no image data back.";
    my $str = qq{data:$type;base64,} . encode_base64($imgdata, '');
    $str =~ s{(.{80})}{$1 }g;
    return qq{<img src="$str">};
}