/[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 28 by dpavlin, Mon Apr 6 12:36:22 2009 UTC revision 58 by dpavlin, Sat Jul 4 08:33:56 2009 UTC
# Line 7  use warnings; Line 7  use warnings;
7  use Data::Dump qw/dump/;  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;
11    use JSON;
12    
13  use IO::Socket::INET;  use IO::Socket::INET;
14    
15  my $meteor_server = '192.168.1.13:4671';  my $debug = 0;
16    
17    my $tags_data;
18    my $tags_security;
19    my $visible_tags;
20    
21    my $meteor_server; # = '192.168.1.13:4671';
22  my $meteor_fh;  my $meteor_fh;
23    
24  sub meteor {  sub meteor {
# Line 18  sub meteor { Line 26  sub meteor {
26          push @a, scalar localtime() if $a[0] =~ m{^info};          push @a, scalar localtime() if $a[0] =~ m{^info};
27    
28          if ( ! defined $meteor_fh ) {          if ( ! defined $meteor_fh ) {
29                  warn "# open connection to $meteor_server";                  if ( $meteor_fh =
30                  $meteor_fh = IO::Socket::INET->new(                                  IO::Socket::INET->new(
31                                  PeerAddr => $meteor_server,                                          PeerAddr => $meteor_server,
32                                  Timeout => 1,                                          Timeout => 1,
33                  ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production                                  )
34                  $meteor_fh = 0; # don't try again                  ) {
35                            warn "# meteor connected to $meteor_server";
36                    } else {
37                            warn "can't connect to meteor $meteor_server: $!";
38                            $meteor_fh = 0;
39                    }
40          }          }
41    
42          warn ">> meteor ",dump( @a );          if ( $meteor_fh ) {
43          print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;                  warn ">> meteor ",dump( @a );
44                    print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"
45            }
46  }  }
47    
48  my $debug = 0;  my $listen_port = 9000;                  # pick something not in use
49    sub http_server {
50    
51            my $server = IO::Socket::INET->new(
52                    Proto     => 'tcp',
53                    LocalPort => $listen_port,
54                    Listen    => SOMAXCONN,
55                    Reuse     => 1
56            );
57                                                                      
58            die "can't setup server" unless $server;
59    
60            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
61    
62            sub static {
63                    my ($client,$path) = @_;
64    
65                    $path = "www/$path";
66                    $path .= 'rfid.html' if $path =~ m{/$};
67    
68                    return unless -e $path;
69    
70                    my $type = 'text/plain';
71                    $type = 'text/html' if $path =~ m{\.htm};
72                    $type = 'application/javascript' if $path =~ m{\.js};
73    
74                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
75                    open(my $html, $path);
76                    while(<$html>) {
77                            print $client $_;
78                    }
79                    close($html);
80    
81                    return $path;
82            }
83    
84            while (my $client = $server->accept()) {
85                    $client->autoflush(1);
86                    my $request = <$client>;
87    
88                    warn "WEB << $request\n" if $debug;
89    
90                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
91                            my $method = $1;
92                            my $param;
93                            if ( $method =~ s{\?(.+)}{} ) {
94                                    foreach my $p ( split(/[&;]/, $1) ) {
95                                            my ($n,$v) = split(/=/, $p, 2);
96                                            $param->{$n} = $v;
97                                    }
98                                    warn "WEB << param: ",dump( $param ) if $debug;
99                            }
100                            if ( my $path = static( $client,$1 ) ) {
101                                    warn "WEB >> $path" if $debug;
102                            } elsif ( $method =~ m{/scan} ) {
103                                    my $tags = scan_for_tags();
104                                    my $json = { time => time() };
105                                    map {
106                                            my $d = decode_tag($_);
107                                            $d->{sid} = $_;
108                                            $d->{security} = $tags_security->{$_};
109                                            push @{ $json->{tags} },  $d;
110                                    } keys %$tags;
111                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
112                                            $param->{callback}, "(", to_json($json), ")\r\n";
113                            } else {
114                                    print $client "HTTP/1.0 404 Unkown method\r\n";
115                            }
116                    } else {
117                            print $client "HTTP/1.0 500 No method\r\n";
118                    }
119                    close $client;
120            }
121    
122            die "server died";
123    }
124    
125    
126    my $last_message = {};
127    sub _message {
128            my $type = shift @_;
129            my $text = join(' ',@_);
130            my $last = $last_message->{$type};
131            if ( $text ne $last ) {
132                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
133                    $last_message->{$type} = $text;
134            }
135    }
136    
137    sub _log { _message('log',@_) };
138    sub diag { _message('diag',@_) };
139    
140  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
141  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 39  my $parity       = "none"; Line 144  my $parity       = "none";
144  my $stopbits  = "1";  my $stopbits  = "1";
145  my $handshake = "none";  my $handshake = "none";
146    
147    my $program_path = './program/';
148    my $secure_path = './secure/';
149    
150    # http server
151    my $http_server = 1;
152    
153    # 3M defaults: 8,4
154    my $max_rfid_block = 16;
155    my $read_blocks = 8;
156    
157  my $response = {  my $response = {
158          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
159          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 60  GetOptions( Line 175  GetOptions(
175          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
176          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
177          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
178            'http-server!' => \$http_server,
179  ) or die $!;  ) or die $!;
180    
181  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 95  it under the same terms ans Perl itself. Line 211  it under the same terms ans Perl itself.
211    
212  =cut  =cut
213    
214  my $tags_data;  my $item_type = {
215  my $visible_tags;          1 => 'Book',
216            6 => 'CD/CD ROM',
217            2 => 'Magazine',
218            13 => 'Book with Audio Tape',
219            9 => 'Book with CD/CD ROM',
220            0 => 'Other',
221    
222            5 => 'Video',
223            4 => 'Audio Tape',
224            3 => 'Bound Journal',
225            8 => 'Book with Diskette',
226            7 => 'Diskette',
227    };
228    
229    warn "## known item type: ",dump( $item_type ) if $debug;
230    
231  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";
232  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;  warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
# Line 106  $databits=$port->databits($databits); Line 236  $databits=$port->databits($databits);
236  $parity=$port->parity($parity);  $parity=$port->parity($parity);
237  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
238    
239  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
240    
241  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
242  $port->lookclear();  $port->lookclear();
# Line 129  cmd( 'D5 00  05   04 00 11 Line 259  cmd( 'D5 00  05   04 00 11
259  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?',
260       '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() }  );
261    
262  # start scanning for tags  sub scan_for_tags {
263    
264  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 {  
265    
266                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
267                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
268                            my $rest = shift || die "no rest?";
269                            my $nr = ord( substr( $rest, 0, 1 ) );
270    
271                            if ( ! $nr ) {
272                                    _log "no tags in range\n";
273                                    update_visible_tags();
274                                    meteor( 'info-none-in-range' );
275                                    $tags_data = {};
276                            } else {
277    
278                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
279                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
280                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
281    
282                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
283                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
284                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  _log "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
285    
286                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
287    
288                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
289                            }
290                  }                  }
291          }          );
292  ) while(1);  
293  #) foreach ( 1 .. 100 );          diag "tags: ",dump( @tags );
294            return $tags_data;
295    
296    }
297    
298    # start scanning for tags
299    
300    if ( $http_server ) {
301            http_server;
302    } else {
303            while (1) {
304                    scan_for_tags;
305                    sleep 1;
306            }
307    }
308    
309    die "over and out";
310    
311  sub update_visible_tags {  sub update_visible_tags {
312          my @tags = @_;          my @tags = @_;
# Line 170  sub update_visible_tags { Line 315  sub update_visible_tags {
315          $visible_tags = {};          $visible_tags = {};
316    
317          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
318                    $visible_tags->{$tag}++;
319                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
320                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
321  #                               meteor( 'in-range', $tag );  #                               meteor( 'in-range', $tag );
# Line 177  sub update_visible_tags { Line 323  sub update_visible_tags {
323                                  meteor( 'read', $tag );                                  meteor( 'read', $tag );
324                                  read_tag( $tag );                                  read_tag( $tag );
325                          }                          }
                         $visible_tags->{$tag}++;  
326                  } else {                  } else {
327                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
328                  }                  }
329                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
330    
331                    if ( -e "$program_path/$tag" ) {
332                                    meteor( 'write', $tag );
333                                    write_tag( $tag );
334                    }
335                    if ( -e "$secure_path/$tag" ) {
336                                    meteor( 'secure', $tag );
337                                    secure_tag( $tag );
338                    }
339          }          }
340    
341          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
# Line 198  my $tag_data_block; Line 352  my $tag_data_block;
352  sub read_tag_data {  sub read_tag_data {
353          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
354          die "no rest?" unless $rest;          die "no rest?" unless $rest;
355    
356            my $last_block = 0;
357    
358          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
359          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
360          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 207  sub read_tag_data { Line 364  sub read_tag_data {
364                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
365                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
366                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
367                  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;
368                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
369                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
370                  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;
371                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
372                    $last_block = $ord;
373          }          }
374          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
375          print "DATA $tag ",dump( $tags_data ), "\n";  
376            my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
377            print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";
378    
379            return $last_block + 1;
380    }
381    
382    sub decode_tag {
383            my $tag = shift;
384    
385            my $data = $tags_data->{$tag} || die "no data for $tag";
386    
387            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
388            my $hash = {
389                    u1 => $u1,
390                    u2 => $u2,
391                    set => ( $set_item & 0xf0 ) >> 4,
392                    total => ( $set_item & 0x0f ),
393    
394                    type => $type,
395                    content => $content,
396    
397                    branch => $br_lib >> 20,
398                    library => $br_lib & 0x000fffff,
399    
400                    custom => $custom,
401            };
402    
403            return $hash;
404  }  }
405    
406  sub read_tag {  sub read_tag {
# Line 224  sub read_tag { Line 410  sub read_tag {
410    
411          print "read_tag $tag\n";          print "read_tag $tag\n";
412    
413            my $start_block = 0;
414    
415            while ( $start_block < $max_rfid_block ) {
416    
417                    cmd(
418                             sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
419                                    "read $tag offset: $start_block blocks: $read_blocks",
420                            "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";
421                                    $start_block = read_tag_data( $start_block, @_ );
422                                    warn "# read tag upto $start_block\n";
423                            },
424                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
425                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
426                            },
427                    );
428    
429            }
430    
431            my $security;
432    
433          cmd(          cmd(
434                  "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",                  "D6 00 0B 0A $tag 1234", "check security $tag",
435                  "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {                  "D6 00 0D 0A 00", sub {
436                          print "FIXME: tag $tag ready?\n";                          my $rest = shift;
437                  },                          my $from_tag;
438                  "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";                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
439                          read_tag_data( 0, @_ );                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
440                  },                          $security = as_hex( $security );
441                            $tags_security->{$tag} = $security;
442                            warn "# SECURITY $tag = $security\n";
443                    }
444          );          );
445    
446          cmd(          print "TAG $tag ", dump(decode_tag( $tag ));
447                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  }
448                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00    
449                          read_tag_data( 3, @_ );  sub write_tag {
450            my ($tag) = @_;
451    
452            my $path = "$program_path/$tag";
453    
454            my $data = read_file( $path );
455            my $hex_data;
456    
457            if ( $data =~ s{^hex\s+}{} ) {
458                    $hex_data = $data;
459                    $hex_data =~ s{\s+}{}g;
460            } else {
461    
462                    $data .= "\0" x ( 4 - ( length($data) % 4 ) );
463    
464                    my $max_len = $max_rfid_block * 4;
465    
466                    if ( length($data) > $max_len ) {
467                            $data = substr($data,0,$max_len);
468                            warn "strip content to $max_len bytes\n";
469                  }                  }
470    
471                    $hex_data = unpack('H*', $data);
472            }
473    
474            my $len = length($hex_data) / 2;
475            # pad to block size
476            $hex_data .= '00' x ( 4 - $len % 4 );
477            my $blocks = sprintf('%02x', length($hex_data) / 4);
478    
479            print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
480    
481            cmd(
482                    "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
483                    "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
484            ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
485    
486            my $to = $path;
487            $to .= '.' . time();
488    
489            rename $path, $to;
490            print ">> $to\n";
491    
492            delete $tags_data->{$tag};      # force re-read of tag
493    }
494    
495    sub secure_tag {
496            my ($tag) = @_;
497    
498            my $path = "$secure_path/$tag";
499            my $data = substr(read_file( $path ),0,2);
500    
501            cmd(
502                    "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
503                    "d6 00  0c  09 00  $tag  1234", sub { assert() },
504          );          );
505    
506            my $to = $path;
507            $to .= '.' . time();
508    
509            rename $path, $to;
510            print ">> $to\n";
511  }  }
512    
513  exit;  exit;
# Line 275  sub writechunk Line 542  sub writechunk
542  {  {
543          my $str=shift;          my $str=shift;
544          my $count = $port->write($str);          my $count = $port->write($str);
545            my $len = length($str);
546            die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
547          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;          print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
548  }  }
549    
# Line 341  sub crcccitt { Line 610  sub crcccitt {
610  sub checksum {  sub checksum {
611          my ( $bytes, $checksum ) = @_;          my ( $bytes, $checksum ) = @_;
612    
         my $xor = crcccitt( substr($bytes,1) ); # skip D6  
         warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;  
   
613          my $len = ord(substr($bytes,2,1));          my $len = ord(substr($bytes,2,1));
614          my $len_real = length($bytes) - 1;          my $len_real = length($bytes) - 1;
615    
616          if ( $len_real != $len ) {          if ( $len_real != $len ) {
617                  print "length wrong: $len_real != $len\n";                  print "length wrong: $len_real != $len\n";
618                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);                  $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
619          }          }
620    
621            my $xor = crcccitt( substr($bytes,1) ); # skip D6
622            warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
623    
624          if ( defined $checksum && $xor ne $checksum ) {          if ( defined $checksum && $xor ne $checksum ) {
625                  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";
626                  return $bytes . $xor;                  return $bytes . $xor;
# Line 362  sub checksum { Line 631  sub checksum {
631  our $dispatch;  our $dispatch;
632    
633  sub readchunk {  sub readchunk {
634          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
635    
636          # read header of packet          # read header of packet
637          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 391  sub readchunk { Line 660  sub readchunk {
660          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
661    
662          if ( defined $to ) {          if ( defined $to ) {
663                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
664                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
665                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
666          } else {          } else {
667                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
668          }          }
669    
670          return $data;          return $data;
Legend:
Removed from v.28  
changed lines
  Added in v.58
  ViewVC Help
Powered by ViewVC 1.1.26