/[RFID]/3m-810.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /3m-810.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 29 by dpavlin, Mon Apr 6 13:10:40 2009 UTC revision 44 by dpavlin, Tue Jun 23 13:10:18 2009 UTC
# Line 8  use Data::Dump qw/dump/; Line 8  use Data::Dump qw/dump/;
8  use Carp qw/confess/;  use Carp qw/confess/;
9  use Getopt::Long;  use Getopt::Long;
10  use File::Slurp;  use File::Slurp;
11    use JSON;
12    
13  use IO::Socket::INET;  use IO::Socket::INET;
14    
# Line 19  sub meteor { Line 20  sub meteor {
20          push @a, scalar localtime() if $a[0] =~ m{^info};          push @a, scalar localtime() if $a[0] =~ m{^info};
21    
22          if ( ! defined $meteor_fh ) {          if ( ! defined $meteor_fh ) {
23                  warn "# open connection to $meteor_server";                  if ( $meteor_fh =
24                  $meteor_fh = IO::Socket::INET->new(                                  IO::Socket::INET->new(
25                                  PeerAddr => $meteor_server,                                          PeerAddr => $meteor_server,
26                                  Timeout => 1,                                          Timeout => 1,
27                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                                  )
28                  $meteor_fh = 0; # don't try again                  ) {
29                            warn "# meteor connected to $meteor_server";
30                    } else {
31                            warn "can't connect to meteor $meteor_server: $!";
32                            $meteor_fh = 0;
33                    }
34            }
35    
36            if ( $meteor_fh ) {
37                    warn ">> meteor ",dump( @a );
38                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
39            }
40    }
41    
42    my $listen_port = 9000;                  # pick something not in use
43    sub http_server {
44    
45            my $server = IO::Socket::INET->new(
46                    Proto     => 'tcp',
47                    LocalPort => $listen_port,
48                    Listen    => SOMAXCONN,
49                    Reuse     => 1
50            );
51                                                                      
52            die "can't setup server" unless $server;
53    
54            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
55    
56            sub static {
57                    my ($client,$path) = @_;
58    
59                    $path = "www/$path";
60    
61                    return unless -e $path;
62    
63                    my $type = 'text/plain';
64                    $type = 'text/html' if $path =~ m{\.htm};
65                    $type = 'application/javascript' if $path =~ m{\.js};
66    
67                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
68                    open(my $html, $path);
69                    while(<$html>) {
70                            print $client $_;
71                    }
72                    close($html);
73    
74                    return $path;
75            }
76    
77            while (my $client = $server->accept()) {
78                    $client->autoflush(1);
79                    my $request = <$client>;
80    
81                    warn "<< $request\n";
82    
83                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
84                            my $method = $1;
85                            if ( my $path = static( $client,$1 ) ) {
86                                    warn ">> $path";
87                            } elsif ( $method =~ m{/scan} ) {
88                                    my $callback = $1 if $method =~ m{\?callback=([^&;]+)};
89                                    my $tags = scan_for_tags();
90                                    my $json;
91                                    map {
92                                            my $d = decode_tag($_);
93                                            $d->{sid} = $_;
94                                            push @{ $json->{tags} },  $d;
95                                    } keys %$tags;
96                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n$callback(", to_json($json), ")\r\n";
97                            } else {
98                                    print $client "HTTP/1.0 404 Unkown method\r\n";
99                            }
100                    } else {
101                            print $client "HTTP/1.0 500 No method\r\n";
102                    }
103                    close $client;
104          }          }
105    
106          warn ">> meteor ",dump( @a );          die "server died";
         print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;  
107  }  }
108    
109  my $debug = 0;  my $debug = 0;
# Line 41  my $stopbits  = "1"; Line 116  my $stopbits  = "1";
116  my $handshake = "none";  my $handshake = "none";
117    
118  my $program_path = './program/';  my $program_path = './program/';
119    my $secure_path = './secure/';
120    
121    # http server
122    my $http_server = 1;
123    
124    # 3M defaults: 8,4
125    my $max_rfid_block = 16;
126    my $read_blocks = 8;
127    
128  my $response = {  my $response = {
129          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 101  it under the same terms ans Perl itself. Line 184  it under the same terms ans Perl itself.
184  my $tags_data;  my $tags_data;
185  my $visible_tags;  my $visible_tags;
186    
187    my $item_type = {
188            1 => 'Book',
189            6 => 'CD/CD ROM',
190            2 => 'Magazine',
191            13 => 'Book with Audio Tape',
192            9 => 'Book with CD/CD ROM',
193            0 => 'Other',
194    
195            5 => 'Video',
196            4 => 'Audio Tape',
197            3 => 'Bound Journal',
198            8 => 'Book with Diskette',
199            7 => 'Diskette',
200    };
201    
202    warn "## known item type: ",dump( $item_type ) if $debug;
203    
204  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";  my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
205  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
206  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 132  cmd( 'D5 00  05   04 00 11 Line 232  cmd( 'D5 00  05   04 00 11
232  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',  cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
233       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );       'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );
234    
235  # start scanning for tags  sub scan_for_tags {
236    
237  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
238           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
239                  my $rest = shift || die "no rest?";          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
240                  my $nr = ord( substr( $rest, 0, 1 ) );                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
241                            my $rest = shift || die "no rest?";
242                  if ( ! $nr ) {                          my $nr = ord( substr( $rest, 0, 1 ) );
243                          print "no tags in range\n";  
244                          update_visible_tags();                          if ( ! $nr ) {
245                          meteor( 'info-none-in-range' );                                  print "no tags in range\n";
246                          $tags_data = {};                                  update_visible_tags();
247                  } else {                                  meteor( 'info-none-in-range' );
248                                    $tags_data = {};
249                            } else {
250    
251                          my $tags = substr( $rest, 1 );                                  my $tags = substr( $rest, 1 );
252    
253                          my $tl = length( $tags );                                  my $tl = length( $tags );
254                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
255    
256                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
257                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
258                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  print "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
259    
260                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
261    
262                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
263                            }
264                  }                  }
265          }          );
266  ) while(1);  
267  #) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
268            return $tags_data;
269    
270    }
271    
272    # start scanning for tags
273    
274    if ( $http_server ) {
275            http_server;
276    } else {
277            scan_for_tags while 1;
278    }
279    
280    die "over and out";
281    
282  sub update_visible_tags {  sub update_visible_tags {
283          my @tags = @_;          my @tags = @_;
# Line 190  sub update_visible_tags { Line 303  sub update_visible_tags {
303                                  meteor( 'write', $tag );                                  meteor( 'write', $tag );
304                                  write_tag( $tag );                                  write_tag( $tag );
305                  }                  }
306                    if ( -e "$secure_path/$tag" ) {
307                                    meteor( 'secure', $tag );
308                                    secure_tag( $tag );
309                    }
310          }          }
311    
312          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
# Line 206  my $tag_data_block; Line 323  my $tag_data_block;
323  sub read_tag_data {  sub read_tag_data {
324          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
325          die "no rest?" unless $rest;          die "no rest?" unless $rest;
326    
327            my $last_block = 0;
328    
329          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
330          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
331          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 215  sub read_tag_data { Line 335  sub read_tag_data {
335                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
336                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
337                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
338                  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;
339                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
340                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
341                  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;
342                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
343                    $last_block = $ord;
344          }          }
345          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
346          print "DATA $tag ",dump( $tags_data ), "\n";  
347            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
348            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
349    
350            return $last_block + 1;
351    }
352    
353    sub decode_tag {
354            my $tag = shift;
355    
356            my $data = $tags_data->{$tag} || die "no data for $tag";
357    
358            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
359            my $hash = {
360                    u1 => $u1,
361                    u2 => $u2,
362                    set => ( $set_item & 0xf0 ) >> 4,
363                    total => ( $set_item & 0x0f ),
364    
365                    type => $type,
366                    content => $content,
367    
368                    branch => $br_lib >> 20,
369                    library => $br_lib & 0x000fffff,
370    
371                    custom => $custom,
372            };
373    
374            return $hash;
375  }  }
376    
377  sub read_tag {  sub read_tag {
# Line 232  sub read_tag { Line 381  sub read_tag {
381    
382          print "read_tag $tag\n";          print "read_tag $tag\n";
383    
384          cmd(          my $start_block = 0;
385                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
386                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {          while ( $start_block < $max_rfid_block ) {
387                          print "FIXME: tag $tag ready?\n";  
388                  },                  cmd(
389                  "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";                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
390                          read_tag_data( 0, @_ );                                  "read $tag offset: $start_block blocks: $read_blocks",
391                  },                          "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";
392          );                                  $start_block = read_tag_data( $start_block, @_ );
393                                    warn "# read tag upto $start_block\n";
394                            },
395                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
396                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
397                            },
398                    );
399    
400            }
401    
402            my $security;
403    
404          cmd(          cmd(
405                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",                  "D6 00 0B 0A $tag 1234", "check security $tag",
406                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    "D6 00 0D 0A 00", sub {
407                          read_tag_data( 3, @_ );                          my $rest = shift;
408                            my $from_tag;
409                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
410                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
411                            $security = as_hex( $security );
412                            warn "# SECURITY $tag = $security\n";
413                  }                  }
414          );          );
415    
416            print "TAG $tag ", dump(decode_tag( $tag ));
417  }  }
418    
419  sub write_tag {  sub write_tag {
# Line 257  sub write_tag { Line 422  sub write_tag {
422          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
423    
424          my $data = read_file( $path );          my $data = read_file( $path );
425            my $hex_data;
426    
427            if ( $data =~ s{^hex\s+}{} ) {
428                    $hex_data = $data;
429                    $hex_data =~ s{\s+}{}g;
430            } else {
431    
432                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
433    
434                    my $max_len = $max_rfid_block * 4;
435    
436                    if ( length($data) > $max_len ) {
437                            $data = substr($data,0,$max_len);
438                            warn "strip content to $max_len bytes\n";
439                    }
440    
441          print "write_tag $tag = $data\n";                  $hex_data = unpack('H*', $data);
442            }
443    
444            my $len = length($hex_data) / 2;
445            # pad to block size
446            $hex_data .= '00' x ( 4 - $len % 4 );
447            my $blocks = sprintf('%02x', length($hex_data) / 4);
448    
449            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
450    
451          cmd(          cmd(
452                  "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",                  "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
453                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
454          ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
455    
456          my $to = $path;          my $to = $path;
457          $to .= '.' . time();          $to .= '.' . time();
# Line 271  sub write_tag { Line 459  sub write_tag {
459          rename $path, $to;          rename $path, $to;
460          print ">> $to\n";          print ">> $to\n";
461    
462            delete $tags_data->{$tag};      # force re-read of tag
463    }
464    
465    sub secure_tag {
466            my ($tag) = @_;
467    
468            my $path = "$secure_path/$tag";
469            my $data = substr(read_file( $path ),0,2);
470    
471            cmd(
472                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
473                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
474            );
475    
476            my $to = $path;
477            $to .= '.' . time();
478    
479            rename $path, $to;
480            print ">> $to\n";
481  }  }
482    
483  exit;  exit;
# Line 305  sub writechunk Line 512  sub writechunk
512  {  {
513          my $str=shift;          my $str=shift;
514          my $count = $port->write($str);          my $count = $port->write($str);
515            my $len = length($str);
516            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
517          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
518  }  }
519    
# Line 371  sub crcccitt { Line 580  sub crcccitt {
580  sub checksum {  sub checksum {
581          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
582    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
583          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
584          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
585    
586          if ( $len_real != $len ) {          if ( $len_real != $len ) {
587                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
588                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
589          }          }
590    
591            my $xor = crcccitt( substr($bytes,1) ); # skip D6
592            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
593    
594          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
595                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";                  print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
596                  return $bytes . $xor;                  return $bytes . $xor;
# Line 392  sub checksum { Line 601  sub checksum {
601  our $dispatch;  our $dispatch;
602    
603  sub readchunk {  sub readchunk {
604          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
605    
606          # read header of packet          # read header of packet
607          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 421  sub readchunk { Line 630  sub readchunk {
630          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
631    
632          if ( defined $to ) {          if ( defined $to ) {
633                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
634                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
635                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
636          } else {          } else {
Legend:
Removed from v.29  
changed lines
  Added in v.44
  ViewVC Help
Powered by ViewVC 1.1.26