#!/usr/bin/perl -w

# UPedit.pl - read and write Active Directory userParameter binary blob
# (c) 2008 Christian Herzog <daduke@daduke.org>
# distributed under the terms of the GNU General Public License version 2 or any later version.

use strict;
use Net::LDAP;
use Net::LDAP::Entry;

#AD credentials
our ($adHost, $adAdmin, $adPass);
require "/etc/ldap/adcreds.inc";

die "\n\ninsufficient data given!\n\nRun with: $0 login command value\n\n" unless (defined $ARGV[2]);
# login is AD's samAccountName
# command is 'g' to read, 's' to write
# value is: 0 for binary dump, 1 for text dump in read mode, and 1 to really write in write mode

my $login = $ARGV[0];
my $command = $ARGV[1];
my $value = $ARGV[2];

#bind to Active Directory
my $adURI = "ldaps://$adHost";
my $basedn = "dc=ad,dc=phys,dc=ethz,dc=ch";	#change this
my $ldaps = Net::LDAP-> new($adURI) or die "$@";
my $mesg = $ldaps-> bind($adAdmin, password =>$adPass);
$mesg->code && die "failed to bind to AD: ", $mesg->error ;


#now search for account
my @attrs = qw(cn sn givenname samAccountName uid mail unicodePwd userParameters);
my $query = "(samAccountName=$login)";

$mesg = $ldaps->search (
 base => $basedn,
 scope => 'sub',
 filter => $query,
 attrs => \@attrs
);
$mesg->code && die "AD search failed: ", $mesg->error ;

while (my $entry = $mesg->shift_entry()) {
	 if ($command eq 'g') {
				my $up = $entry->get_value('userParameters');
				die "no userParameters found in AD for user $login.\n" unless ($up);
				if ($value) {
					showUP($up);
				} else {
					print "$up";
				}
	 } elsif ($command eq 's' and $value) {
				my $profilePath = "\\\\winprofile\\profiles\\$login\\profile.ts";
				my $newUP = createUP($profilePath, $login);
				$entry->replace('userParameters' => $newUP);
				$entry->update($ldaps);
	 } else {
				die "command not known!!\n";
	 }
}
$mesg->code && die "failed to perform action: ", $mesg->error ;


$ldaps-> unbind; #we're done!

################## subs
sub showUP {
	my $up = shift;

	my $lineSep = "\x{01}Ctx";	#fields seem to be separated by this string

	my @fields = split /$lineSep/, $up;	# -> split 'em

	foreach my $field (@fields) {
		my ($key, $value) = $field =~ /([0-9a-zA-Z]+)([^0]*)/;	#key are human readable, values are not
		if (!(length($value) % 3)) {				#so far we can only handle 3*n hex values
			print "$key => ";
			print hexcrap2string($value) . "\n";
		}
	}
}

sub createUP {
		  my ($profilePath, $login) = @_;
		  chomp $profilePath;
		  chomp $login;
		  my $hexcrap;
		  my $len = 2*(length $login) + 68;
		  $hexcrap = profilePathTemplate($len);
		  chomp $hexcrap;
		  $hexcrap .= string2hexcrap($profilePath) . "0";
		  return $hexcrap;
}

sub bintodec {
        unpack("c", pack("B8", substr("0" x 8 . shift, -8)));
}

sub dectobin {
        substr unpack("B8", pack("c", shift)), 4, 4;
}

sub hexcrap2string {
		  my $value = shift;
		  my $valueAscii;
		  for my $i (0..length($value)/3-1) {		#for each triplet of $value
					 my $tripletStr;
					 for my $n (0..2) {			#for each byte in the triplet
								my $char = substr $value, $i*3+$n, 1;	#get the hex 
								my $str = unpack("B8", $char);		#convert to bits
								$tripletStr = $tripletStr . $str;	#append to 3-byte bit stream
					 }
					 my @part;					#string array for the two relavant nibbles
					 my @values;					#their hex values

					 $part[1] = substr $tripletStr, 4, 10;	#part one starts at bit 5
					 $part[2] = substr $tripletStr, 14, 10;	#part two starts at bit 15

					 for my $i (1..2) {	#for both of them
								my $bitStr = $part[$i];
								my $modeBit = (substr($bitStr, 1, 1) eq '1')?1:0;	#bit 2 determines encoding mode
								my $value = substr $bitStr, 6, 4;						#last four bits hold the value

								if ($modeBit) {	#sick offset - why??
										  $values[$i] = dectobin(bintodec($value) + 9);
								} else {
										  $values[$i] = $value;
								}
					 }

					 my $resultStr = $values[2].$values[1];	#reverse nibbles and
					 my $result = pack("B8", $resultStr);		#convert back to character
					 $valueAscii .= $result;						#append to string
		  }
		  return $valueAscii;
}

sub string2hexcrap {
		  my $string = shift;
		  my $header = '1110';		#fixed header nibble
		  my $hexStr;
		  my $result;
		  my %prefixes = ( '1'  => { '9' => '001011', '10' => '011010'},
							  '2'  => { '9' => '001110', '10' => '011010'});
				#don't ask

		  for my $n (0..length($string)- 1) {		#for each character in string
					 my $char = substr $string, $n, 1;
					 my $charStr = unpack("B8", $char);	#convert to bits
					 my @part;
					 my @prefix;
					 my @values;
					 $part[1] = substr $charStr, 0, 4;	#first nibble
					 $part[2] = substr $charStr, 4, 4;	#second nibble
					 for my $i (1..2) {	#for both of them
								my $bitStr = $part[$i];
								my $value = bintodec($bitStr);	#convert to decimal
								if ($value > 9) {						#apply sick offset (see above)
										  $value -= 9;
										  $prefix[$i] = $prefixes{"$i"}{'10'};	#pick proper prefix nibble
								} else {
										  $prefix[$i] = $prefixes{"$i"}{'9'};
								}
								$values[$i] = $prefix[$i].dectobin($value);	#glue them together
					 }
					 $charStr = $header.$values[2].$values[1];				#assemble 24 bit string
					 $result .= pack("B8", substr($charStr, 0, 8))			#convert to characters
					 	.pack("B8", substr($charStr, 8, 8))
						.pack("B8", substr($charStr, 16, 8));
		  }
		  return $result;
}

sub profilePathTemplate {	#userParameters binary blob header
		  my $len = shift;
		  return "\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20".
		  "\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20".
		  "\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20\x20".
		  "\x20\x20\x20\x50\x05\x1A\x08\x01\x43\x74\x78\x43\x66\x67\x50".
		  "\x72\x65\x73\x65\x6E\x74\xE3\x94\xB5\xE6\x94\xB1\xE6\x88\xB0".
		  "\x62\x18\x08\x01\x43\x74\x78\x43\x66\x67\x46\x6C\x61\x67\x73".
		  "\x31\xE3\x80\xB0\xE3\x81\xA6\xE3\x80\xB2\x39\x12\x08\x01\x43".
		  "\x74\x78\x53\x68\x61\x64\x6F\x77\xE3\x84\xB0\xE3\x80\xB0\xE3".
		  "\x80\xB0\x30\x2A\x02\x01\x43\x74\x78\x4D\x69\x6E\x45\x6E\x63".
		  "\x72\x79\x70\x74\x69\x6F\x6E\x4C\x65\x76\x65\x6C\x30\x20".chr($len).
		  "\x01\x43\x74\x78\x57\x46\x50\x72\x6F\x66\x69\x6C\x65\x50\x61".
		  "\x74\x68";
}