/[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 46 by dpavlin, Tue Jun 23 13:50:13 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          warn ">> meteor ",dump( @a );          if ( $meteor_fh ) {
37          print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;                  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                            my $param;
86                            if ( $method =~ s{\?(.+)}{} ) {
87                                    foreach my $p ( split(/[&;]/, $1) ) {
88                                            my ($n,$v) = split(/=/, $p, 2);
89                                            $param->{$n} = $v;
90                                    }
91                                    warn "<< param: ",dump( $param );
92                            }
93                            if ( my $path = static( $client,$1 ) ) {
94                                    warn ">> $path";
95                            } elsif ( $method =~ m{/scan} ) {
96                                    my $tags = scan_for_tags();
97                                    my $json = {};
98                                    map {
99                                            my $d = decode_tag($_);
100                                            $d->{sid} = $_;
101                                            push @{ $json->{tags} },  $d;
102                                    } keys %$tags;
103                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
104                                            $param->{callback}, "(", to_json($json), ")\r\n";
105                            } else {
106                                    print $client "HTTP/1.0 404 Unkown method\r\n";
107                            }
108                    } else {
109                            print $client "HTTP/1.0 500 No method\r\n";
110                    }
111                    close $client;
112            }
113    
114            die "server died";
115  }  }
116    
117  my $debug = 0;  my $debug = 0;
# Line 41  my $stopbits  = "1"; Line 124  my $stopbits  = "1";
124  my $handshake = "none";  my $handshake = "none";
125    
126  my $program_path = './program/';  my $program_path = './program/';
127    my $secure_path = './secure/';
128    
129    # http server
130    my $http_server = 1;
131    
132    # 3M defaults: 8,4
133    my $max_rfid_block = 16;
134    my $read_blocks = 8;
135    
136  my $response = {  my $response = {
137          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
# Line 63  GetOptions( Line 154  GetOptions(
154          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
155          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
156          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
157            'http-server!' => \$http_server,
158  ) or die $!;  ) or die $!;
159    
160  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 101  it under the same terms ans Perl itself. Line 193  it under the same terms ans Perl itself.
193  my $tags_data;  my $tags_data;
194  my $visible_tags;  my $visible_tags;
195    
196    my $item_type = {
197            1 => 'Book',
198            6 => 'CD/CD ROM',
199            2 => 'Magazine',
200            13 => 'Book with Audio Tape',
201            9 => 'Book with CD/CD ROM',
202            0 => 'Other',
203    
204            5 => 'Video',
205            4 => 'Audio Tape',
206            3 => 'Bound Journal',
207            8 => 'Book with Diskette',
208            7 => 'Diskette',
209    };
210    
211    warn "## known item type: ",dump( $item_type ) if $debug;
212    
213  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";
214  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
215  $handshake=$port->handshake($handshake);  $handshake=$port->handshake($handshake);
# Line 132  cmd( 'D5 00  05   04 00 11 Line 241  cmd( 'D5 00  05   04 00 11
241  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?',
242       '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() }  );
243    
244  # start scanning for tags  sub scan_for_tags {
245    
246  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @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 ) {  
                         print "no tags in range\n";  
                         update_visible_tags();  
                         meteor( 'info-none-in-range' );  
                         $tags_data = {};  
                 } else {  
247    
248                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
249                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
250                            my $rest = shift || die "no rest?";
251                            my $nr = ord( substr( $rest, 0, 1 ) );
252    
253                            if ( ! $nr ) {
254                                    print "no tags in range\n";
255                                    update_visible_tags();
256                                    meteor( 'info-none-in-range' );
257                                    $tags_data = {};
258                            } else {
259    
260                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
                         die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;  
261    
262                          my @tags;                                  my $tl = length( $tags );
263                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
                         warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;  
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
264    
265                          meteor( 'info-in-range', join(' ',@tags));                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
266                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
267                                    print "$nr tags in range: ", join(',', @tags ) , "\n";
268    
269                          update_visible_tags( @tags );                                  meteor( 'info-in-range', join(' ',@tags));
270    
271                                    update_visible_tags( @tags );
272                            }
273                  }                  }
274          }          );
275  ) while(1);  
276  #) foreach ( 1 .. 100 );          warn "## tags: ",dump( @tags );
277            return $tags_data;
278    
279    }
280    
281    # start scanning for tags
282    
283    if ( $http_server ) {
284            http_server;
285    } else {
286            scan_for_tags while 1;
287    }
288    
289    die "over and out";
290    
291  sub update_visible_tags {  sub update_visible_tags {
292          my @tags = @_;          my @tags = @_;
# Line 190  sub update_visible_tags { Line 312  sub update_visible_tags {
312                                  meteor( 'write', $tag );                                  meteor( 'write', $tag );
313                                  write_tag( $tag );                                  write_tag( $tag );
314                  }                  }
315                    if ( -e "$secure_path/$tag" ) {
316                                    meteor( 'secure', $tag );
317                                    secure_tag( $tag );
318                    }
319          }          }
320    
321          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
# Line 206  my $tag_data_block; Line 332  my $tag_data_block;
332  sub read_tag_data {  sub read_tag_data {
333          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
334          die "no rest?" unless $rest;          die "no rest?" unless $rest;
335    
336            my $last_block = 0;
337    
338          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
339          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
340          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 215  sub read_tag_data { Line 344  sub read_tag_data {
344                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
345                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
346                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
347                  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;
348                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
349                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
350                  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;
351                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
352                    $last_block = $ord;
353          }          }
354          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
355          print "DATA $tag ",dump( $tags_data ), "\n";  
356            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
357            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
358    
359            return $last_block + 1;
360    }
361    
362    sub decode_tag {
363            my $tag = shift;
364    
365            my $data = $tags_data->{$tag} || die "no data for $tag";
366    
367            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
368            my $hash = {
369                    u1 => $u1,
370                    u2 => $u2,
371                    set => ( $set_item & 0xf0 ) >> 4,
372                    total => ( $set_item & 0x0f ),
373    
374                    type => $type,
375                    content => $content,
376    
377                    branch => $br_lib >> 20,
378                    library => $br_lib & 0x000fffff,
379    
380                    custom => $custom,
381            };
382    
383            return $hash;
384  }  }
385    
386  sub read_tag {  sub read_tag {
# Line 232  sub read_tag { Line 390  sub read_tag {
390    
391          print "read_tag $tag\n";          print "read_tag $tag\n";
392    
393          cmd(          my $start_block = 0;
394                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",  
395                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {          while ( $start_block < $max_rfid_block ) {
396                          print "FIXME: tag $tag ready?\n";  
397                  },                  cmd(
398                  "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 ),
399                          read_tag_data( 0, @_ );                                  "read $tag offset: $start_block blocks: $read_blocks",
400                  },                          "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";
401          );                                  $start_block = read_tag_data( $start_block, @_ );
402                                    warn "# read tag upto $start_block\n";
403                            },
404                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
405                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
406                            },
407                    );
408    
409            }
410    
411            my $security;
412    
413          cmd(          cmd(
414                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",                  "D6 00 0B 0A $tag 1234", "check security $tag",
415                  "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 {
416                          read_tag_data( 3, @_ );                          my $rest = shift;
417                            my $from_tag;
418                            ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
419                            die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
420                            $security = as_hex( $security );
421                            warn "# SECURITY $tag = $security\n";
422                  }                  }
423          );          );
424    
425            print "TAG $tag ", dump(decode_tag( $tag ));
426  }  }
427    
428  sub write_tag {  sub write_tag {
# Line 257  sub write_tag { Line 431  sub write_tag {
431          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
432    
433          my $data = read_file( $path );          my $data = read_file( $path );
434            my $hex_data;
435    
436          print "write_tag $tag = $data\n";          if ( $data =~ s{^hex\s+}{} ) {
437                    $hex_data = $data;
438                    $hex_data =~ s{\s+}{}g;
439            } else {
440    
441                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
442    
443                    my $max_len = $max_rfid_block * 4;
444    
445                    if ( length($data) > $max_len ) {
446                            $data = substr($data,0,$max_len);
447                            warn "strip content to $max_len bytes\n";
448                    }
449    
450                    $hex_data = unpack('H*', $data);
451            }
452    
453            my $len = length($hex_data) / 2;
454            # pad to block size
455            $hex_data .= '00' x ( 4 - $len % 4 );
456            my $blocks = sprintf('%02x', length($hex_data) / 4);
457    
458            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
459    
460          cmd(          cmd(
461                  "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",
462                  "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },                  "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
463          ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!          ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
464    
465          my $to = $path;          my $to = $path;
466          $to .= '.' . time();          $to .= '.' . time();
# Line 271  sub write_tag { Line 468  sub write_tag {
468          rename $path, $to;          rename $path, $to;
469          print ">> $to\n";          print ">> $to\n";
470    
471            delete $tags_data->{$tag};      # force re-read of tag
472    }
473    
474    sub secure_tag {
475            my ($tag) = @_;
476    
477            my $path = "$secure_path/$tag";
478            my $data = substr(read_file( $path ),0,2);
479    
480            cmd(
481                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
482                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
483            );
484    
485            my $to = $path;
486            $to .= '.' . time();
487    
488            rename $path, $to;
489            print ">> $to\n";
490  }  }
491    
492  exit;  exit;
# Line 305  sub writechunk Line 521  sub writechunk
521  {  {
522          my $str=shift;          my $str=shift;
523          my $count = $port->write($str);          my $count = $port->write($str);
524            my $len = length($str);
525            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
526          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
527  }  }
528    
# Line 371  sub crcccitt { Line 589  sub crcccitt {
589  sub checksum {  sub checksum {
590          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
591    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
592          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
593          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
594    
595          if ( $len_real != $len ) {          if ( $len_real != $len ) {
596                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
597                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
598          }          }
599    
600            my $xor = crcccitt( substr($bytes,1) ); # skip D6
601            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
602    
603          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
604                  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";
605                  return $bytes . $xor;                  return $bytes . $xor;
# Line 392  sub checksum { Line 610  sub checksum {
610  our $dispatch;  our $dispatch;
611    
612  sub readchunk {  sub readchunk {
613          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
614    
615          # read header of packet          # read header of packet
616          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 421  sub readchunk { Line 639  sub readchunk {
639          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
640    
641          if ( defined $to ) {          if ( defined $to ) {
642                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
643                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
644                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
645          } else {          } else {
Legend:
Removed from v.29  
changed lines
  Added in v.46
  ViewVC Help
Powered by ViewVC 1.1.26