--- 3m-810.pl	2009/04/08 14:48:22	33
+++ 3m-810.pl	2009/06/24 10:13:23	51
@@ -8,9 +8,12 @@
 use Carp qw/confess/;
 use Getopt::Long;
 use File::Slurp;
+use JSON;
 
 use IO::Socket::INET;
 
+my $debug = 0;
+
 my $meteor_server = '192.168.1.13:4671';
 my $meteor_fh;
 
@@ -19,19 +22,114 @@
 	push @a, scalar localtime() if $a[0] =~ m{^info};
 
 	if ( ! defined $meteor_fh ) {
-		warn "# open connection to $meteor_server";
-		$meteor_fh = IO::Socket::INET->new(
-				PeerAddr => $meteor_server,
-				Timeout => 1,
-		) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
-		$meteor_fh = 0; # don't try again
+		if ( $meteor_fh =
+				IO::Socket::INET->new(
+					PeerAddr => $meteor_server,
+					Timeout => 1,
+				)
+		) {
+			warn "# meteor connected to $meteor_server";
+		} else {
+			warn "can't connect to meteor $meteor_server: $!";
+			$meteor_fh = 0;
+		}
 	}
 
-	warn ">> meteor ",dump( @a );
-	print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
+	if ( $meteor_fh ) {
+		warn ">> meteor ",dump( @a );
+		print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
+	}
 }
 
-my $debug = 0;
+my $listen_port = 9000;                  # pick something not in use
+sub http_server {
+
+	my $server = IO::Socket::INET->new(
+		Proto     => 'tcp',
+		LocalPort => $listen_port,
+		Listen    => SOMAXCONN,
+		Reuse     => 1
+	);
+								  
+	die "can't setup server" unless $server;
+
+	print "Server $0 accepting clients at http://localhost:$listen_port/\n";
+
+	sub static {
+		my ($client,$path) = @_;
+
+		$path = "www/$path";
+
+		return unless -e $path;
+
+		my $type = 'text/plain';
+		$type = 'text/html' if $path =~ m{\.htm};
+		$type = 'application/javascript' if $path =~ m{\.js};
+
+		print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
+		open(my $html, $path);
+		while(<$html>) {
+			print $client $_;
+		}
+		close($html);
+
+		return $path;
+	}
+
+	while (my $client = $server->accept()) {
+		$client->autoflush(1);
+		my $request = <$client>;
+
+		warn "WEB << $request\n" if $debug;
+
+		if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
+			my $method = $1;
+			my $param;
+			if ( $method =~ s{\?(.+)}{} ) {
+				foreach my $p ( split(/[&;]/, $1) ) {
+					my ($n,$v) = split(/=/, $p, 2);
+					$param->{$n} = $v;
+				}
+				warn "WEB << param: ",dump( $param ) if $debug;
+			}
+			if ( my $path = static( $client,$1 ) ) {
+				warn "WEB >> $path" if $debug;
+			} elsif ( $method =~ m{/scan} ) {
+				my $tags = scan_for_tags();
+				my $json = {};
+				map {
+					my $d = decode_tag($_);
+					$d->{sid} = $_;
+					push @{ $json->{tags} },  $d;
+				} keys %$tags;
+				print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
+					$param->{callback}, "(", to_json($json), ")\r\n";
+			} else {
+				print $client "HTTP/1.0 404 Unkown method\r\n";
+			}
+		} else {
+			print $client "HTTP/1.0 500 No method\r\n";
+		}
+		close $client;
+	}
+
+	die "server died";
+}
+
+
+my $last_message = {};
+sub _message {
+	my $type = shift @_;
+	my $text = join(' ',@_);
+	my $last = $last_message->{$type};
+	if ( $text ne $last ) {
+		warn $type eq 'diag' ? '# ' : '', $text, "\n";
+		$last_message->{$type} = $text;
+	}
+}
+
+sub _log { _message('log',@_) };
+sub diag { _message('diag',@_) };
 
 my $device    = "/dev/ttyUSB0";
 my $baudrate  = "19200";
@@ -41,6 +139,14 @@
 my $handshake = "none";
 
 my $program_path = './program/';
+my $secure_path = './secure/';
+
+# http server
+my $http_server = 1;
+
+# 3M defaults: 8,4
+my $max_rfid_block = 16;
+my $read_blocks = 8;
 
 my $response = {
 	'd500090400110a0500027250'				=> 'version?',
@@ -63,6 +169,7 @@
 	'stopbits=i'  => \$stopbits,
 	'handshake=s' => \$handshake,
 	'meteor=s'    => \$meteor_server,
+	'http-server!' => \$http_server,
 ) or die $!;
 
 my $verbose = $debug > 0 ? $debug-- : 0;
@@ -126,7 +233,7 @@
 $parity=$port->parity($parity);
 $stopbits=$port->stopbits($stopbits);
 
-print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
+warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
 
 # Just in case: reset our timing and buffers
 $port->lookclear();
@@ -149,39 +256,51 @@
 cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
      'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
 
-# start scanning for tags
+sub scan_for_tags {
 
-cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
-	 'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A	 # seen, serial length: 8
-		my $rest = shift || die "no rest?";
-		my $nr = ord( substr( $rest, 0, 1 ) );
-
-		if ( ! $nr ) {
-			print "no tags in range\n";
-			update_visible_tags();
-			meteor( 'info-none-in-range' );
-			$tags_data = {};
-		} else {
+	my @tags;
 
-			my $tags = substr( $rest, 1 );
+	cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
+		 'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A	 # seen, serial length: 8
+			my $rest = shift || die "no rest?";
+			my $nr = ord( substr( $rest, 0, 1 ) );
+
+			if ( ! $nr ) {
+				_log "no tags in range\n";
+				update_visible_tags();
+				meteor( 'info-none-in-range' );
+				$tags_data = {};
+			} else {
 
-			my $tl = length( $tags );
-			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
+				my $tags = substr( $rest, 1 );
+				my $tl = length( $tags );
+				die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 
-			my @tags;
-			push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
-			warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
-			print "$nr tags in range: ", join(',', @tags ) , "\n";
+				push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
+				warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
+				_log "$nr tags in range: ", join(',', @tags ) , "\n";
 
-			meteor( 'info-in-range', join(' ',@tags));
+				meteor( 'info-in-range', join(' ',@tags));
 
-			update_visible_tags( @tags );
+				update_visible_tags( @tags );
+			}
 		}
-	}
-) while(1);
-#) foreach ( 1 .. 100 );
+	);
+
+	diag "tags: ",dump( @tags );
+	return $tags_data;
+
+}
 
+# start scanning for tags
+
+if ( $http_server ) {
+	http_server;
+} else {
+	scan_for_tags while 1;
+}
 
+die "over and out";
 
 sub update_visible_tags {
 	my @tags = @_;
@@ -190,6 +309,7 @@
 	$visible_tags = {};
 
 	foreach my $tag ( @tags ) {
+		$visible_tags->{$tag}++;
 		if ( ! defined $last_visible_tags->{$tag} ) {
 			if ( defined $tags_data->{$tag} ) {
 #				meteor( 'in-range', $tag );
@@ -197,7 +317,6 @@
 				meteor( 'read', $tag );
 				read_tag( $tag );
 			}
-			$visible_tags->{$tag}++;
 		} else {
 			warn "## using cached data for $tag" if $debug;
 		}
@@ -207,6 +326,10 @@
 				meteor( 'write', $tag );
 				write_tag( $tag );
 		}
+		if ( -e "$secure_path/$tag" ) {
+				meteor( 'secure', $tag );
+				secure_tag( $tag );
+		}
 	}
 
 	foreach my $tag ( keys %$last_visible_tags ) {
@@ -223,6 +346,9 @@
 sub read_tag_data {
 	my ($start_block,$rest) = @_;
 	die "no rest?" unless $rest;
+
+	my $last_block = 0;
+
 	warn "## DATA [$start_block] ", dump( $rest ) if $debug;
 	my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
 	my $blocks = ord(substr($rest,8,1));
@@ -232,16 +358,43 @@
 		warn "## block ",as_hex( $block ) if $debug;
 		my $ord   = unpack('v',substr( $block, 0, 2 ));
 		my $expected_ord = $nr + $start_block;
-		die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
+		warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
 		my $data  = substr( $block, 2 );
 		die "data payload should be 4 bytes" if length($data) != 4;
-		warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
+		warn sprintf "## tag %9s %02d: %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
 		$tag_data_block->{$tag}->[ $ord ] = $data;
+		$last_block = $ord;
 	}
 	$tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
 
 	my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
-	print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
+	print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
+
+	return $last_block + 1;
+}
+
+sub decode_tag {
+	my $tag = shift;
+
+	my $data = $tags_data->{$tag} || die "no data for $tag";
+
+	my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
+	my $hash = {
+		u1 => $u1,
+		u2 => $u2,
+		set => ( $set_item & 0xf0 ) >> 4,
+		total => ( $set_item & 0x0f ),
+
+		type => $type,
+		content => $content,
+
+		branch => $br_lib >> 20,
+		library => $br_lib & 0x000fffff,
+
+		custom => $custom,
+	};
+
+	return $hash;
 }
 
 sub read_tag {
@@ -251,22 +404,23 @@
 
 	print "read_tag $tag\n";
 
-	cmd(
-		"D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
-		"D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
-			print "FIXME: tag $tag ready?\n";
-		},
-		"D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
-			read_tag_data( 0, @_ );
-		},
-	);
+	my $start_block = 0;
 
-	cmd(
-		"D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
-		"D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00   
-			read_tag_data( 3, @_ );
-		}
-	);
+	while ( $start_block < $max_rfid_block ) {
+
+		cmd(
+			 sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
+				"read $tag offset: $start_block blocks: $read_blocks",
+			"D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
+				$start_block = read_tag_data( $start_block, @_ );
+				warn "# read tag upto $start_block\n";
+			},
+			"D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
+				print "FIXME: tag $tag ready? (expected block read instead)\n";
+			},
+		);
+
+	}
 
 	my $security;
 
@@ -282,14 +436,7 @@
 		}
 	);
 
-	my $data = $tags_data->{$tag} || die "no data for $tag";
-	my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
-	my $set   = ( $set_item & 0xf0 ) >> 4;
-	my $total = ( $set_item & 0x0f );
-	my $branch  = $br_lib >> 20;
-	my $library = $br_lib & 0x000fffff;
-	print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom security: $security\n";
-
+	print "TAG $tag ", dump(decode_tag( $tag ));
 }
 
 sub write_tag {
@@ -298,17 +445,36 @@
 	my $path = "$program_path/$tag";
 
 	my $data = read_file( $path );
+	my $hex_data;
 
-	$data = substr($data,0,16);
+	if ( $data =~ s{^hex\s+}{} ) {
+		$hex_data = $data;
+		$hex_data =~ s{\s+}{}g;
+	} else {
+
+		$data .= "\0" x ( 4 - ( length($data) % 4 ) );
 
-	my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
+		my $max_len = $max_rfid_block * 4;
 
-	print "write_tag $tag = $data ",dump( $hex_data );
+		if ( length($data) > $max_len ) {
+			$data = substr($data,0,$max_len);
+			warn "strip content to $max_len bytes\n";
+		}
+
+		$hex_data = unpack('H*', $data);
+	}
+
+	my $len = length($hex_data) / 2;
+	# pad to block size
+	$hex_data .= '00' x ( 4 - $len % 4 );
+	my $blocks = sprintf('%02x', length($hex_data) / 4);
+
+	print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
 
 	cmd(
-		"D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
-		"D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
-	) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
+		"d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
+		"d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
+	); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
 
 	my $to = $path;
 	$to .= '.' . time();
@@ -319,6 +485,24 @@
 	delete $tags_data->{$tag};	# force re-read of tag
 }
 
+sub secure_tag {
+	my ($tag) = @_;
+
+	my $path = "$secure_path/$tag";
+	my $data = substr(read_file( $path ),0,2);
+
+	cmd(
+		"d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
+		"d6 00  0c  09 00  $tag  1234", sub { assert() },
+	);
+
+	my $to = $path;
+	$to .= '.' . time();
+
+	rename $path, $to;
+	print ">> $to\n";
+}
+
 exit;
 
 for ( 1 .. 3 ) {
@@ -351,6 +535,8 @@
 {
 	my $str=shift;
 	my $count = $port->write($str);
+	my $len = length($str);
+	die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
 	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
 }
 
@@ -417,17 +603,17 @@
 sub checksum {
 	my ( $bytes, $checksum ) = @_;
 
-	my $xor = crcccitt( substr($bytes,1) );	# skip D6
-	warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
-
 	my $len = ord(substr($bytes,2,1));
 	my $len_real = length($bytes) - 1;
 
 	if ( $len_real != $len ) {
 		print "length wrong: $len_real != $len\n";
-		$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
+		$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
 	}
 
+	my $xor = crcccitt( substr($bytes,1) );	# skip D6
+	warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
+
 	if ( defined $checksum && $xor ne $checksum ) {
 		print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
 		return $bytes . $xor;
@@ -438,7 +624,7 @@
 our $dispatch;
 
 sub readchunk {
-	sleep 1;	# FIXME remove
+#	sleep 1;	# FIXME remove
 
 	# read header of packet
 	my $header = read_bytes( 2, 'header' );
@@ -467,7 +653,7 @@
 	warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
 
 	if ( defined $to ) {
-		my $rest = substr( $payload, length($to) );
+		my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
 		warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
 		$dispatch->{ $to }->( $rest );
 	} else {