#! /usr/bin/perl

use strict;
use warnings;

#use Proc::Daemon;
use Data::Dumper;
use XML::Simple;
use Sys::Syslog;
use File::Temp;
use POSIX;
use Errno;
use LWP;

### BEGIN CONFIG ###
our $model = 'HP_LaserJet_M2727nf_MFP';
our $scanner = '10.0.0.11';
our $hostid = '10.0.0.2-ares';
## Max dest length is like 16 characters
our %desttable = (
	## Flatbed scans (higher res)
	'bed jpg @ 150'  => { src => 'Flatbed', fmt => 'JPG', res => 150,  },
	'bed jpg @ 300'  => { src => 'Flatbed', fmt => 'JPG', res => 300,  },
	'bed jpg @ 600'  => { src => 'Flatbed', fmt => 'JPG', res => 600,  },
	'bed jpg @ 1200' => { src => 'Flatbed', fmt => 'JPG', res => 1200, },
	'bed pdf @ 75'   => { src => 'Flatbed', fmt => 'PDF', res => 75,   },
	'bed pdf @ 150'  => { src => 'Flatbed', fmt => 'PDF', res => 150,  },
	'bed pdf @ 300'  => { src => 'Flatbed', fmt => 'PDF', res => 300,  },
	'bed pdf @ 600'  => { src => 'Flatbed', fmt => 'PDF', res => 600,  },

	## Simplex ADF scans (lower res)
	'adf jpg @ 75'   => { src => 'ADF',     fmt => 'JPG', res => 75,   },
	'adf jpg @ 150'  => { src => 'ADF',     fmt => 'JPG', res => 150,  },
	'adf jpg @ 300'  => { src => 'ADF',     fmt => 'JPG', res => 300,  },
	'adf pdf @ 75'   => { src => 'ADF',     fmt => 'PDF', res => 75,   },
	'adf pdf @ 150'  => { src => 'ADF',     fmt => 'PDF', res => 150,  },
	'adf pdf @ 300'  => { src => 'ADF',     fmt => 'PDF', res => 300,  },

	## Duplex ADF scans (lower res)
	'dpx jpg @ 75'   => { src => 'Duplex',  fmt => 'JPG', res => 75,   },
	'dpx jpg @ 150'  => { src => 'Duplex',  fmt => 'JPG', res => 150,  },
	'dpx jpg @ 300'  => { src => 'Duplex',  fmt => 'JPG', res => 300,  },
	'dpx pdf @ 75'   => { src => 'Duplex',  fmt => 'PDF', res => 75,   },
	'dpx pdf @ 150'  => { src => 'Duplex',  fmt => 'PDF', res => 150,  },
	'dpx pdf @ 300'  => { src => 'Duplex',  fmt => 'PDF', res => 300,  },
);
our $destpath = '/home/MOFFETT.HOME/shared/Shared Documents/Scans';
our $user = 10000;
our $group = 10000;
our $umask = 0007;
#### END CONFIG ####

## URLs for use later
my $url_notify = "http://$scanner/hp/device/notifications.xml";
my $url_dests  = "http://$scanner/hp/device/info_scanto_destinations.xml";
my $url_config = "http://$scanner/hp/device/set_config.html";

## First switch to the specified user and group
unless (setgid $group) {
	print STDERR "setgid($group): $!\n";
	exit 1;
}
unless (setuid $user) {
	print STDERR "setuid($user): $!\n";
	exit 1;
}

## Set up our HTTP client and XML parser
my $ua = LWP::UserAgent->new;
my $xml = XML::Simple->new;

## Open up syslog
openlog 'hpscantod', 'ndelay,perror', 'LOCAL0';

###
## Bunch of utility functions
###

sub daemonize()
{
	## Create a pipe where we wait for our child process to be ready
	my($rd,$wr);
	unless (pipe $rd,$wr) {
		syslog('err', "pipe: $!");
		exit 1;
	}

	## Now create a child process and wait for it to be ready
	my $pid = fork;
	unless (defined $pid) {
		syslog('err', "fork: $!");
		exit 1;
	}
	if ($pid) {
		close $wr;
		my $code = <$rd>;
		exit $code if defined $code and $code =~ /^\d+$/;
		exit 255;
	}
	close $rd;

	## Reopen syslog inside the child process
	closelog;
	openlog 'hpscantod', 'ndelay', 'LOCAL0';

	## Now reopen stdin/stdout/stderr
	unless(open STDIN, '<', '/dev/null') {
		syslog('err', "/dev/null: $!");
		exit 1;
	}
	unless(open STDOUT, '>', '/dev/null') {
		syslog('err', "/dev/null: $!");
		exit 1;
	}
	unless(open STDERR, '>', '/dev/null') {
		syslog('err', "/dev/null: $!");
		exit 1;
	}

	## Now lose our controlling TTY... permanently...
	unless (POSIX::setsid) {
		syslog('err', "setsid: $!");
		exit 1;
	}
	$pid = fork;
	unless (defined $pid) {
		syslog('err', "fork: $!");
		exit 1;
	}
	exit 0 if $pid;

	## Tell our parent we succeeded and continue on
	print $wr "0";
	close $wr;
}

sub get_status ()
{
	my $resp  = $ua->get($url_notify);
	unless ($resp->is_success) {
		printf STDERR "Unable to get notify status: %s\n",
				$resp->status_line;
		return undef;
	}
	unless ($resp->content_type eq "text/xml") {
		printf STDERR "Bad notify content type '%s', wanted '%s'\n",
				$resp->content_type, "text/xml";
		return undef;
	}
	return $xml->parse_string($resp->content,
		SuppressEmpty => 1,
		ForceArray => 0,
		NoAttr => 1,
		GroupTags => {
			#ScanToDestinationList => 'ScanToDestination'
		},
		KeyAttr => {
			#ScanToDestination => 'DeviceDisplay'
		},
	);
}

sub get_destinfo ()
{
	my $resp  = $ua->get($url_dests);
	unless ($resp->is_success) {
		printf STDERR "Unable to get scanto list: %s\n",
				$resp->status_line;
		return undef;
	}
	unless ($resp->content_type eq "text/xml") {
		printf STDERR "Bad scanto content type '%s', wanted '%s'\n",
				$resp->content_type, "text/xml";
		return undef;
	}
	return $xml->parse_string($resp->content,
		SuppressEmpty => 1,
		ForceArray => [qw(ScanToDestination)],
		NoAttr => 1,
		GroupTags => {
			ScanToDestinationList => 'ScanToDestination'
		},
		KeyAttr => {
			ScanToDestination => 'DeviceDisplay'
		},
	);
}

sub add_dests ( @ )
{
	my $resp = $ua->post($url_config, [ map {
		'AddScanToDest_'.($_+1) => $hostid.'^'.$_[$_].'^DestFolder',
	} 0 .. $#_ ]);
	unless ($resp->is_success) {
		printf STDERR "Unable to register destinations: %s\n",
				$resp->status_line;
		return undef;
	}
	## Ignore the content result of that operation
	return 1;
}

sub del_dests ( @ )
{
	my $resp = $ua->post($url_config, [ map {
		'RemoveScanToDest_'.($_+1) => $_[$_],
	} 0 .. $#_ ]);
	unless ($resp->is_success) {
		printf STDERR "Unable to register destinations: %s\n",
				$resp->status_line;
		return undef;
	}
	## Ignore the content result of that operation
	return 1;
}

sub upd_dests ()
{
	my $destinfo = get_destinfo or return undef;
	#print Dumper($destinfo);
	#exit 0;
	my $destlist = $destinfo->{ScanToDestinationList} || {};

	my %missing = %desttable;
	my %extra;
	DEST:
	for my $dest (keys %$destlist) {
		#print Dumper($destlist);
		next DEST unless $destlist->{$dest}{HostID} eq $hostid;
		delete $missing{$dest};
		$extra{$dest} = 1 if not $desttable{$dest};
	}

	if (%missing) {
		$destlist->{$_} and $extra{$_} = 1 for keys %desttable;
	}

	if (%extra) {
		syslog('info', "Removing destinations...");
		syslog('info', "    %s", $_) for sort keys %extra;
		del_dests sort keys %extra or return undef;
	}

	if (%missing) {
		syslog('info', "Adding destinations...");
		syslog('info', "    %s", $_) for sort keys %missing;
		add_dests sort keys %missing or return undef;
	}
	return 1;
}

unless(chdir $destpath) {
	syslog('err', "Unable to chdir to \"$destpath\": $!");
	exit 1;
}

## Detach from the terminal
#daemonize;

## Set up a signal handler
my $keepgoing = 1;
sub cleanup()
{
	syslog('info', "Got signal, gracefully shutting down...");
	$keepgoing = 0;
}
sub reconfig()
{
	syslog('info', "Got SIGHUP, nothing to reconfigure");
}

$SIG{HUP}  = \&reconfig;
$SIG{INT}  = \&cleanup;
$SIG{QUIT} = \&cleanup;
$SIG{TERM} = \&cleanup;
$SIG{USR1} = \&cleanup;
$SIG{USR2} = \&cleanup;

sub scan_dest ( $$ )
{
	my($dest,$workdir) = @_;

	## This is a godawful hacked up patch to the hplip sources...
	## I should probably be shot for how bad this is...
	local $ENV{SANE_SCANID} = $dest;

	my @opts = qw( -p --mode Color );
	push @opts, '-d', "hpaio:/net/".$model."?ip=".$scanner;
	push @opts, '--resolution', $desttable{$dest}{res};
	push @opts, '--source', $desttable{$dest}{src};
	push @opts, '--batch='.$workdir.'/scan-%08d.pnm';
	push @opts, '--batch-count=1' if $desttable{$dest}{src} eq 'Flatbed';
	syslog('info', "SCAN: %s", join ' ', @opts);
	if (system {'scanimage'} 'scanimage', @opts) {
		if ($? == -1) {
			syslog('err', "scanimage: $!");
		} elsif ($? & 127) {
			syslog('err', "scanimage died with signal %d, ".
					"with%s coredump", ($? & 127),
					($? & 128)?'':'out');
		} else {
			syslog('err', "scanimage exited with code %d",
					($? >> 8));
		}
		return undef;
	}
	return 1;
}

sub conv_pdf ( $$@ )
{
	my($res,$finaldir,@files) = @_;

	my $destfile = "$finaldir/scan.pdf";
	my @opts = ( '-density', $res, '--' );
	if (system {'gm'} 'gm', 'convert', @opts, @files, $destfile) {
		if ($? == -1) {
			syslog('err', "gm convert: $!");
		} elsif ($? & 127) {
			syslog('err', "gm convert died with signal %d, ".
					"with%s coredump", ($? & 127),
					($? & 128)?'':'out');
		} else {
			syslog('err', "gm convert exited with code %d",
					($? >> 8));
		}
		return undef;
	}
	return 1;
}

sub conv_jpg ( $$$ )
{
	my($res,$dstfile,$srcfile) = @_;
	my @opts = ( '-density', $res, '--' );
	if (system {'gm'} 'gm', 'convert', @opts, $srcfile, $dstfile) {
		if ($? == -1) {
			syslog('err', "gm convert: $!");
		} elsif ($? & 127) {
			syslog('err', "gm convert died with signal %d, ".
					"with%s coredump", ($? & 127),
					($? & 128)?'':'out');
		} else {
			syslog('err', "gm convert exited with code %d",
					($? >> 8));
		}
		return undef;
	}
	return 1;
}

my $prev_bad;
while ($keepgoing) {
	unless (upd_dests) {
		syslog('err', "Sleeping 5 minutes and retrying...");
		sleep 5 * 60;
		next;
	}

	## Get the printer's button-status
	my $status = get_status;
	my $notify = $status->{ScanToNotifications} || {};

	## If they haven't picked a ScanTo option then just go around again
	unless ($notify->{ScanToHostID} and $notify->{ScanToDeviceDisplay}) {
		sleep 5;
		next;
	}
	print STDERR "Saw a ScanTo op:\n";
	print STDERR Dumper($status);

	## If they are scanning something that isn't for us then wait longer
	unless ($notify->{ScanToHostID} eq $hostid) {
		print STDERR "Isn't for us: ", $notify->{ScanToHostID}, " vs. ", $hostid, "\n";
		sleep 30;
		next;
	}

	## Make sure it exists in our destination table
	my $dest = $notify->{ScanToDeviceDisplay};
	unless ($desttable{$dest}) {
		syslog('warning', "Unknown destination '%s'", $dest)
				unless $prev_bad and $dest eq $prev_bad;
		$prev_bad = $dest;
		sleep 5;
		next;
	}

	## Create a temporary directory with the results of this scan
	my $workdir = File::Temp->newdir(".scanXXXXXXXX", DIR => $destpath);

	## Ok, we've got it... so run the scan
	unless (scan_dest $dest, $workdir) {
		sleep 30;
		next;
	}

	## Create a final directory for this scan's results
	my $fmt = '%Y-%m-%d %H:%M:%S';
	my $dirprefix = $destpath."/".POSIX::strftime($fmt, localtime);
	my $dirsuffix = "";
	my $iter = 0;
	until (mkdir $dirprefix.$dirsuffix) {
		unless ($!{EEXIST}) {
			syslog('err', "mkdir(\"%s\"): %s",
					$dirprefix.$dirsuffix, $!);
			sleep 5;
			next;
		}
		$dirsuffix = " (" . ++$iter . ")";
	}
	my $finaldir = $dirprefix.$dirsuffix;

	## Build a list of source files
	my $dirh;
	unless (opendir $dirh, $workdir) {
		syslog('err', "opendir(\"%s\"): %s", $workdir, $!);
		sleep 5;
		next;
	}
	my @files = sort {$a cmp $b} grep /^scan-\d{8}\.pnm$/, <$dirh>;

	## If there are no files then we're done
	unless (@files) {
		syslog('warning', "Scan produced no files");
		sleep 5;
		next;
	}

	my $res = $desttable{$dest}{res};

	## Handle according to image type
	if ($desttable{$dest}{fmt} eq 'PDF') {
		@files = map {"$workdir/$_"} @files;

		conv_pdf($res, $finaldir, @files);
		sleep 5;
		next;
	}

	if ($desttable{$dest}{fmt} eq 'JPG') {
		FILE:
		for my $file (@files) {
			my $srcfile = "$workdir/$file";
			my $dstfile = "$finaldir/$file";
			$dstfile =~ s/\.pnm$/.jpg/;
			conv_jpg($res, $dstfile, $srcfile);
		}
		sleep 5;
		next;
	}

	syslog('err', "Internal error, impossible condition!");
	sleep 5;
}

syslog('info', "Ceasing operations...");
undef %desttable;
upd_dests;

syslog('info', "All resources released, exiting...");

exit 0;