--- 3m-810.pl	2009/06/04 13:36:20	41
+++ 3m-810.pl	2009/06/23 13:10:18	44
@@ -8,6 +8,7 @@
 use Carp qw/confess/;
 use Getopt::Long;
 use File::Slurp;
+use JSON;
 
 use IO::Socket::INET;
 
@@ -38,6 +39,73 @@
 	}
 }
 
+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 "<< $request\n";
+
+		if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
+			my $method = $1;
+			if ( my $path = static( $client,$1 ) ) {
+				warn ">> $path";
+			} elsif ( $method =~ m{/scan} ) {
+				my $callback = $1 if $method =~ m{\?callback=([^&;]+)};
+				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$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 $debug = 0;
 
 my $device    = "/dev/ttyUSB0";
@@ -50,6 +118,9 @@
 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;
@@ -161,39 +232,52 @@
 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, 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 $tl = length( $tags );
-			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
+				my $tags = substr( $rest, 1 );
 
-			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";
+				my $tl = length( $tags );
+				die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
 
-			meteor( 'info-in-range', join(' ',@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";
 
-			update_visible_tags( @tags );
+				meteor( 'info-in-range', join(' ',@tags));
+
+				update_visible_tags( @tags );
+			}
 		}
-	}
-) while(1);
-#) foreach ( 1 .. 100 );
+	);
+
+	warn "## 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 = @_;
@@ -261,9 +345,33 @@
 	$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;
+	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 {
@@ -305,14 +413,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' library: $library branch: $branch custom: $custom security: $security\n";
-
+	print "TAG $tag ", dump(decode_tag( $tag ));
 }
 
 sub write_tag {
@@ -451,8 +552,6 @@
 sub assert {
 	my ( $from, $to ) = @_;
 
-	return unless $assert->{expect};
-
 	$from ||= 0;
 	$to = length( $assert->{expect} ) if ! defined $to;
 
@@ -502,7 +601,7 @@
 our $dispatch;
 
 sub readchunk {
-	sleep 1;	# FIXME remove
+#	sleep 1;	# FIXME remove
 
 	# read header of packet
 	my $header = read_bytes( 2, 'header' );
@@ -530,8 +629,8 @@
 	} sort { length($a) <=> length($b) } keys %$dispatch;
 	warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
 
-	if ( defined $to && $payload ) {
-		my $rest = substr( $payload, length($to) );
+	if ( defined $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 {