--- 3m-810.pl 2009/03/28 03:47:10 23
+++ 3m-810.pl 2009/06/23 13:50:13 46
@@ -7,15 +7,111 @@
use Data::Dump qw/dump/;
use Carp qw/confess/;
use Getopt::Long;
+use File::Slurp;
+use JSON;
use IO::Socket::INET;
-my $meteor = IO::Socket::INET->new( '192.168.1.13:4671' ) || die "can't connect to meteor: $!";
+my $meteor_server = '192.168.1.13:4671';
+my $meteor_fh;
sub meteor {
- my ( $item, $html ) = @_;
- warn ">> meteor $item $html\n";
- print $meteor "ADDMESSAGE test $item|" . localtime() . "
$html\n";
+ my @a = @_;
+ push @a, scalar localtime() if $a[0] =~ m{^info};
+
+ if ( ! defined $meteor_fh ) {
+ 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;
+ }
+ }
+
+ if ( $meteor_fh ) {
+ warn ">> meteor ",dump( @a );
+ print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
+ }
+}
+
+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;
+ my $param;
+ if ( $method =~ s{\?(.+)}{} ) {
+ foreach my $p ( split(/[&;]/, $1) ) {
+ my ($n,$v) = split(/=/, $p, 2);
+ $param->{$n} = $v;
+ }
+ warn "<< param: ",dump( $param );
+ }
+ if ( my $path = static( $client,$1 ) ) {
+ warn ">> $path";
+ } 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 $debug = 0;
@@ -27,6 +123,16 @@
my $stopbits = "1";
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?',
'd60007fe00000500c97b' => 'no tag in range',
@@ -47,6 +153,8 @@
'parity=s' => \$parity,
'stopbits=i' => \$stopbits,
'handshake=s' => \$handshake,
+ 'meteor=s' => \$meteor_server,
+ 'http-server!' => \$http_server,
) or die $!;
my $verbose = $debug > 0 ? $debug-- : 0;
@@ -85,6 +193,23 @@
my $tags_data;
my $visible_tags;
+my $item_type = {
+ 1 => 'Book',
+ 6 => 'CD/CD ROM',
+ 2 => 'Magazine',
+ 13 => 'Book with Audio Tape',
+ 9 => 'Book with CD/CD ROM',
+ 0 => 'Other',
+
+ 5 => 'Video',
+ 4 => 'Audio Tape',
+ 3 => 'Bound Journal',
+ 8 => 'Book with Diskette',
+ 7 => 'Diskette',
+};
+
+warn "## known item type: ",dump( $item_type ) if $debug;
+
my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
$handshake=$port->handshake($handshake);
@@ -110,44 +235,58 @@
'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
print "hardware version $hw_ver\n";
- meteor( -1, "Found reader $hw_ver" );
+ meteor( 'info', "Found reader hardware $hw_ver" );
});
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( -1, "No tags in range" );
- } else {
+ my @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 ) );
- my $tags = substr( $rest, 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;
- update_visible_tags( @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 $html = join('', map { "$_" } @tags);
- meteor( 0, "Tags:" );
+ meteor( 'info-in-range', join(' ',@tags));
+
+ update_visible_tags( @tags );
+ }
}
- }
-) foreach ( 1 .. 1000 );
+ );
+
+ 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 = @_;
@@ -157,72 +296,197 @@
foreach my $tag ( @tags ) {
if ( ! defined $last_visible_tags->{$tag} ) {
- read_tag( $tag );
+ if ( defined $tags_data->{$tag} ) {
+# meteor( 'in-range', $tag );
+ } else {
+ meteor( 'read', $tag );
+ read_tag( $tag );
+ }
$visible_tags->{$tag}++;
} else {
warn "## using cached data for $tag" if $debug;
}
delete $last_visible_tags->{$tag}; # leave just missing tags
+
+ if ( -e "$program_path/$tag" ) {
+ meteor( 'write', $tag );
+ write_tag( $tag );
+ }
+ if ( -e "$secure_path/$tag" ) {
+ meteor( 'secure', $tag );
+ secure_tag( $tag );
+ }
}
foreach my $tag ( keys %$last_visible_tags ) {
my $data = delete $tags_data->{$tag};
print "removed tag $tag with data ",dump( $data ),"\n";
+ meteor( 'removed', $tag );
}
warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
}
+my $tag_data_block;
+
+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));
+ $rest = substr($rest,9); # leave just data blocks
+ foreach my $nr ( 0 .. $blocks - 1 ) {
+ my $block = substr( $rest, $nr * 6, 6 );
+ warn "## block ",as_hex( $block ) if $debug;
+ my $ord = unpack('v',substr( $block, 0, 2 ));
+ my $expected_ord = $nr + $start_block;
+ 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;
+ $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'" ), "\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 {
my ( $tag ) = @_;
confess "no tag?" unless $tag;
- return if defined $tags_data->{$tag};
-
print "read_tag $tag\n";
+ my $start_block = 0;
+
+ 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;
+
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";
- my $rest = shift || die "no rest?";
- warn "## DATA ", dump( $rest ) if $debug;
- my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
- my $blocks = ord(substr($rest,8,1));
- $rest = substr($rest,9); # leave just data blocks
- my @data;
- foreach my $nr ( 0 .. $blocks - 1 ) {
- my $block = substr( $rest, $nr * 6, 6 );
- warn "## block ",as_hex( $block ) if $debug;
- my $ord = unpack('v',substr( $block, 0, 2 ));
- die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
- my $data = substr( $block, 2 );
- die "data payload should be 4 bytes" if length($data) != 4;
- warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
- $data[ $ord ] = $data;
- }
- $tags_data->{ $tag } = join('', @data);
- print "DATA $tag ",dump( $tags_data ), "\n";
+ "D6 00 0B 0A $tag 1234", "check security $tag",
+ "D6 00 0D 0A 00", sub {
+ my $rest = shift;
+ my $from_tag;
+ ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
+ die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
+ $security = as_hex( $security );
+ warn "# SECURITY $tag = $security\n";
}
);
- # D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4
-if (0) {
- cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
-
- # D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
- # $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
- warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
+ print "TAG $tag ", dump(decode_tag( $tag ));
}
- warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
- my $item = unpack('H*', substr($tag,-8) ) % 100000;
- meteor( $item, "Loading $item" );
+sub write_tag {
+ my ($tag) = @_;
+
+ my $path = "$program_path/$tag";
+
+ my $data = read_file( $path );
+ my $hex_data;
+
+ if ( $data =~ s{^hex\s+}{} ) {
+ $hex_data = $data;
+ $hex_data =~ s{\s+}{}g;
+ } else {
+
+ $data .= "\0" x ( 4 - ( length($data) % 4 ) );
+ my $max_len = $max_rfid_block * 4;
+
+ 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 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();
+
+ rename $path, $to;
+ print ">> $to\n";
+
+ 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;
@@ -257,6 +521,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;
}
@@ -276,6 +542,7 @@
my $data = '';
while ( length( $data ) < $len ) {
my ( $c, $b ) = $port->read(1);
+ die "no bytes on port: $!" unless defined $b;
#warn "## got $c bytes: ", as_hex($b), "\n";
$data .= $b;
}
@@ -322,17 +589,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;
@@ -343,7 +610,7 @@
our $dispatch;
sub readchunk {
- sleep 1; # FIXME remove
+# sleep 1; # FIXME remove
# read header of packet
my $header = read_bytes( 2, 'header' );
@@ -372,7 +639,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 {