ikiwiki-hosting-common 0.20170622ubuntu1 / usr / share / perl5 / IkiWiki / Customer.pm

#!/usr/bin/perl
# Handles access to customer data.
package IkiWiki::Customer;
use warnings;
use strict;
use IkiWiki;
use IkiWiki::Hosting;
use Fcntl qw{:flock};
use File::Path qw{mkpath};
use Memoize;

# Currently, customer data is stored in a customersite.
# It could just as easily be a database.
#
# The customersite's repo is checked out into ~/customersite. Assuming
# that directory exists, or if a checkout is successfully done, returns the
# directory.
memoize("basedir");
sub basedir (;$) {
	my $nocheckout=shift;

	IkiWiki::Hosting::readconfig();
	my $customersite=$IkiWiki::Hosting::config{customersite};
	if (! defined $customersite || ! length $customersite) {
		return;
	}
	
	my $dir=(getpwuid($<))[7]."/customersite";
	return $dir if -d $dir;

	return if $nocheckout;
	# Try to checkout a copy of the customersite's git repo,
	# using ssh transport.
	my $username=IkiWiki::Hosting::getshell("ikisite", "username", 
		$customersite);
	return unless defined $username && length $username;
	my $gitsshurl="ssh://$username\@$customersite/";
	my $origumask=umask(077);
	eval {IkiWiki::Hosting::shell("git", "clone", $gitsshurl, $dir)};
	umask($origumask);
	if ($@ || ! -d $dir) {
		# This is bad, try to make the admins aware of the problem.
		IkiWiki::Hosting::syslog("failed to clone $gitsshurl to $dir",
			"IkiWiki::Customer");
		return;
	}
	else {
		return $dir;
	}
}

# Locks a given directory inside the customersite and executes the passed sub.
sub dir_lock ($$$) {
	my $locktype=shift;
	my $dir=shift;
	my $sub=shift;

	if ($dir eq ".") {
		# To operate on the top directory, must take a global lock.
		globallock($locktype, $sub);
	}
	else {
		my $base=basedir();
		return unless defined $base;

		# First take shared global lock, then individual
		# Directory lock.
		globallock(LOCK_SH, sub {
			_dolock($locktype, "$base/$dir", $sub);
		});
	}
}

# Locks a directory for reading and executes the passed sub.
sub dir_lock_read ($$) {
	my $dir=shift;
	my $sub=shift;

	dir_lock(LOCK_SH, $dir, $sub);
}

# Locks a directory for writing and executes the passed sub.
sub dir_lock_write ($$) {
	my $dir=shift;
	my $sub=shift;

	dir_lock(LOCK_EX, $dir, $sub);
}

# Takes a global lock of the whole customersite. This is used to
# block things like git pushes that cannot respect per-customer locks.
sub globallock ($$) {
	my $locktype=shift;
	my $sub=shift;

	my $base=basedir();
	return unless defined $base;

	_dolock($locktype, $base, $sub);
}

my %locks;
sub _dolock ($$$) {
	my $locktype=shift;
	my $dir=shift;
	my $sub=shift;

	# Taking an exclusive lock when a shared lock is already held would
	# deadlock.
	if ($locktype == LOCK_EX && exists $locks{$dir}[LOCK_SH]) {
		die "_dolock: deadlock detected while locking $dir for LOCK_EX";
	}

	# Avoid taking a lock if an equivilant one is already held.
	my $lock;
	if (! exists $locks{$dir}[$locktype] &&
	    ! exists $locks{$dir}[LOCK_EX]) {
		mkpath($dir);
		open ($lock, ">", "$dir/lock") || die $!;
		flock($lock, $locktype) || die $!;
		$locks{$dir}[$locktype]=$lock;
	}

	my $ret=eval { $sub->() };
	my $fail=$@;

	if ($lock) {
		close $lock;
		delete $locks{$dir}[$locktype];
	}

	if ($fail) {
		die $fail;
	}
	return $ret;
}

# Returns a field from a specified directory of the customersite.
sub dir_get ($$) {
	my $dir=shift;
	my $field=shift;

	my @ret;
	dir_lock(LOCK_SH, $dir, sub {
		my $base=basedir();
		return unless defined $base;

		if (open (my $fh, "<", "$base/$dir/$field")) {
			@ret=map { chomp $_; $_ } <$fh>;
			close $fh;
		}
	});
	
	return wantarray ? @ret : $ret[0];			
}

# Sets a field in a specified directory of the customersite.
sub dir_set ($$@) {
	my $dir=shift;
	my $field=shift;
	my @value=@_;
	
	dir_lock(LOCK_EX, $dir, sub {
		my $base=basedir();
		return unless defined $base;

		open (my $fh, ">", "$base/$dir/$field") || die $!;
		print $fh join("\n", @value)."\n";
		close $fh || die $!;
	});
}

# Commits all changes made to a directory of the customersite 
# into the git repository.
sub dir_commit ($;$) {
	my $dir=shift;
	my $message=shift;
	
	my $base=basedir();
	return unless defined $base;

	eval q{use Cwd};
	die $@ if $@;
	my $origdir=getcwd();
	chdir("$base/$dir") || die $!;

	dir_lock(LOCK_EX, $dir, sub {
		IkiWiki::Hosting::shell("git", "add", ".");
		# empty commits needed in case no changes were really made
		IkiWiki::Hosting::shell("git", "commit", "--allow-empty",
			"-m", "updated $dir".
				(defined $message ? "\n\n$message" : ""));
	});

	# Pushing is done in the background. Do not chdir daemon to /
	my $pid=IkiWiki::Hosting::daemonize(1);
	if ($pid) {
		chdir($origdir);
		return;
	}

	# To avoid deadlocks, this background process needs to drop all
	# possible locks.
	# Drop all existing locks on the customerdb.
	foreach my $key (keys %locks) {
		foreach my $lock (@{$locks{$key}}) {
			close $lock if defined $lock;
		}
	}
	# Drop all ikiwiki locks.
	IkiWiki::enable_commit_hook();
	IkiWiki::unlockwiki();

	eval {IkiWiki::Hosting::shell("git", "push", "origin", "master")};
	if ($@) {
		# A push is most likely to fail due to being diverged from
		# origin. Or it could be a network problem. Try to update.
		if (update()) {
			# Update worked; try again to push.
			eval {IkiWiki::Hosting::shell("git", "push", "origin", "master")};
			if ($@) {
				IkiWiki::Hosting::syslog("git push origin master failed",
					"IkiWiki::Customer");
			}
		}
	}

	exit;
}

# Updates the whole customersite by doing a git pull.
# Avoids leaving the site in a conflicted state.
sub update () {
	my $base=basedir(1);
	return unless defined $base;
	
	eval q{use Cwd};
	die $@ if $@;
	my $origdir=getcwd();
	chdir($base) || die $!;

	# See if the origin can be contacted, by trying to fetch from it.
	eval {IkiWiki::Hosting::shell("git", "fetch", "origin")};
	if ($@) {
		# This is sorta bad, though it may be a transient
		# problem. Try to make the admins aware of the problem.
		IkiWiki::Hosting::syslog("failed to fetch customersite ($@)",
			"IkiWiki::Customer");
		chdir($origdir);
		return 0;
	}

	# Global lock, because git merge can touch any files.
	globallock(LOCK_EX, sub {
		eval {IkiWiki::Hosting::shell("git", "merge", "origin", "master")};
		if ($@) {
			# Blast! A conflict. For now, resolving it is
			# beyond us, so whine for mommy to help, and
			# for now, reset our working copy so conflict
			# markers don't screw things up!
			IkiWiki::Hosting::syslog("customersite is in a conflicted state, please fix ($@)",
				"IkiWiki::Customer");
			eval {IkiWiki::Hosting::shell("git", "reset", "--hard")};
			if ($@) {
				# Should never happen.
				IkiWiki::Hosting::syslog("failed to use git reset --hard; conflict markers present in customersite! ($@)",
					"IkiWiki::Customer");
			}
			chdir($origdir);
			return 0;
		}
		chdir($origdir);
		return 1;
	});
}

# Converts a username into a sha1 hash.
sub customerid ($) {
	my $username=shift;

	eval q{use Digest::SHA};
	die $@ if $@;

	return Digest::SHA::sha1_hex($username);
}

# Returns the directory used to store information about a particular customer,
# given their username.
#
# A directory matching the customerid of their username is preferred, but
# failing that, it searches for a directory with an openid_list or
# email_list containing the username.
memoize("customerdir");
sub customerdir ($) {
	my $username=shift;

	my $base=basedir();
	return unless defined $base;

	my $dir="customer/".customerid($username);
	return $dir if -d "$base/$dir";

	foreach my $d (glob("$base/customer/*")) {
		my @openids=read_list_file($d, "openid_list");
		my @emails=read_list_file($d, "email_list");
		if (grep { $_ eq $username } (@openids, @emails)) {
			$d=~s/^\Q$base\/\E//;
			return $d;
		}
	}

	return $dir;
}

# Finds accounts that contain a given field with the specified value.
sub accounts_by_field ($$;$) {
	my $field=shift;
	my $value=shift;
	my $ignorecase=shift;

	if ($ignorecase) {
		$value=lc $value;
	}
	
	my $base=basedir();
	return () unless defined $base;
	
	my @ret;
	foreach my $d (glob("$base/customer/*")) {
		my @vals=read_list_file($d, $field);
		if (grep { ($ignorecase ? lc $_ : $_) eq $value } @vals) {
			my @openids=read_list_file($d, "openid_list");
			if (@openids) {
				push @ret, $openids[0];
			}
			else {
				my @emails=read_list_file($d, "email_list");
				push @ret, $emails[0] if @emails;
			}
		}
	}

	return @ret;
}

# Reads a file as a list of multiple lines.
#
# XXX Currently the file is not locked, so there is a small potential
# for a race here. There is some potential for deadlock if locking the
# file here.
sub read_list_file ($$) {
	my $dir=shift;
	my $file=shift;

	my @list;
	if (open (my $fh, "<", "$dir/$file")) {
		@list=grep { length $_ } map { chomp $_; $_ } <$fh>;
		close $fh;
	}
	return @list;
}

# Locks a customer for reading and executes the passed sub.
sub customer_lock_read ($$) {
	my $username=shift;
	my $sub=shift;

	dir_lock(LOCK_SH, customerdir($username), $sub);
}

# Locks a customer for writing and executes the passed sub.
sub customer_lock_write ($$) {
	my $username=shift;
	my $sub=shift;

	dir_lock(LOCK_EX, customerdir($username), $sub);
}

# Returns a given field of a customer's data, given their username.
sub customer_get ($$) {
	my $username=shift;
	my $field=shift;
	
	dir_get(customerdir($username), $field);
}

# Sets a field of a customer's data.
sub customer_set ($$@) {
	my $username=shift;
	my $field=shift;
	my @value=@_;
		
	dir_set(customerdir($username), $field, @value);
}

# A customer may have multiple openids and emails; given one this returns
# the whole list.
sub account_list ($) {
	my $username=shift;
	my @os=read_list_file(basedir()."/".customerdir($username), "openid_list");
	my @es=read_list_file(basedir()."/".customerdir($username), "email_list");
	return (@os, @es, $username);
}

# Commits all changes made to a customer into the git repository.
sub customer_commit ($;$) {
	my $username=shift;
	my $message=shift;
	
	dir_commit(customerdir($username), $message);
}

# Sends an email to a customer (or to stdout in dry run mode).
# The message body is parsed for Subject and From lines. (Also optionally,
# for To, Bcc, and References lines.)
sub customer_sendmail ($$;$) {
	my $username=shift;
	my $message=shift;
	my $dry_run=shift;

	$message=~s/^(?:To: (.*))//m;
	my $to=$1;
	$message=~s/^(?:From: (.*))//m;
	my $from=$1;
	$message=~s/^(?:Bcc: (.*))//m;
	my $bcc=$1;
	$message=~s/^(?:Subject: (.*))//m;
	my $subject=$1;
	$message=~s/^(?:References: (.*))//m;
	my $references=$1;

	# avoid extra blank lines from HTML::Template
	$message=~s/\n\n\n/\n\n/sg; 
	$message=~s/^\n+//s;
	$message=~s/\n+$/\n/s;
	
	$to=customer_get($username, "email") if ! defined $to || ! length $to;
	return unless defined $to && length $to;

	if ($dry_run) {
		print "(Not sending email; in dry run mode.)\n";
		print "\n";
		print "To: $to\n";
		print "From: $from\n";
		print "Bcc: $bcc\n" if defined $bcc && length $bcc;
		print "References: $references\n" if defined $references && length $references;
		print "Subject: $subject\n";
		print "\n";
		print $message."\n\n";
	}
	else {
		eval q{use Mail::Sendmail};
		error $@ if $@;

		my $ret=sendmail(
			To => $to,
			From => $from,
			((defined $bcc && length $bcc) ? (Bcc => $bcc) : ()),
			((defined $references && length $references) ? (References => $references) : ()),
			Subject => $subject,
			Message => $message,
		);
		if (! $ret) {
			die "failed to send email: $!";
		}
	}
}

# Used by programs that must run as a user which has a 
# ~/customersite checkout.
sub assert_has_customersite () {
	my $base=basedir(1);
	if (! defined $base) {
		die "$0 requires ~/customersite checkout exist\n";
	}
}

1