/[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 40 by dpavlin, Mon Jun 1 21:17:12 2009 UTC revision 62 by dpavlin, Tue Feb 9 14:52:13 2010 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    use POSIX qw(strftime);
13    
14  use IO::Socket::INET;  use IO::Socket::INET;
15    
16  my $meteor_server = '192.168.1.13:4671';  my $debug = 0;
17    
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $meteor_server; # = '192.168.1.13:4671';
23  my $meteor_fh;  my $meteor_fh;
24    
25  sub meteor {  sub meteor {
# Line 38  sub meteor { Line 46  sub meteor {
46          }          }
47  }  }
48    
49  my $debug = 0;  my $listen_port = 9000;                  # pick something not in use
50    my $server_url  = "http://localhost:$listen_port";
51    
52    sub http_server {
53    
54            my $server = IO::Socket::INET->new(
55                    Proto     => 'tcp',
56                    LocalPort => $listen_port,
57                    Listen    => SOMAXCONN,
58                    Reuse     => 1
59            );
60                                                                      
61            die "can't setup server" unless $server;
62    
63            print "Server $0 ready at $server_url\n";
64    
65            sub static {
66                    my ($client,$path) = @_;
67    
68                    $path = "www/$path";
69                    $path .= 'rfid.html' if $path =~ m{/$};
70    
71                    return unless -e $path;
72    
73                    my $type = 'text/plain';
74                    $type = 'text/html' if $path =~ m{\.htm};
75                    $type = 'application/javascript' if $path =~ m{\.js};
76    
77                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
78                    open(my $html, $path);
79                    while(<$html>) {
80                            print $client $_;
81                    }
82                    close($html);
83    
84                    return $path;
85            }
86    
87            while (my $client = $server->accept()) {
88                    $client->autoflush(1);
89                    my $request = <$client>;
90    
91                    warn "WEB << $request\n" if $debug;
92    
93                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
94                            my $method = $1;
95                            my $param;
96                            if ( $method =~ s{\?(.+)}{} ) {
97                                    foreach my $p ( split(/[&;]/, $1) ) {
98                                            my ($n,$v) = split(/=/, $p, 2);
99                                            $param->{$n} = $v;
100                                    }
101                                    warn "WEB << param: ",dump( $param ) if $debug;
102                            }
103                            if ( my $path = static( $client,$1 ) ) {
104                                    warn "WEB >> $path" if $debug;
105                            } elsif ( $method =~ m{/scan} ) {
106                                    my $tags = scan_for_tags();
107                                    my $json = { time => time() };
108                                    map {
109                                            my $d = decode_tag($_);
110                                            $d->{sid} = $_;
111                                            $d->{security} = $tags_security->{$_};
112                                            push @{ $json->{tags} },  $d;
113                                    } keys %$tags;
114                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
115                                            $param->{callback}, "(", to_json($json), ")\r\n";
116                            } elsif ( $method =~ m{/program} ) {
117    
118                                    my $status = 501; # Not implementd
119    
120                                    foreach my $p ( keys %$param ) {
121                                            next unless $p =~ m/^tag_(\S+)/;
122                                            my $tag = $1;
123                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
124                                            $status = 302;
125    
126                                            warn "PROGRAM $tag $content\n";
127                                            write_tag( $tag, $content );
128                                    }
129    
130                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
131    
132                            } else {
133                                    print $client "HTTP/1.0 404 Unkown method\r\n";
134                            }
135                    } else {
136                            print $client "HTTP/1.0 500 No method\r\n";
137                    }
138                    close $client;
139            }
140    
141            die "server died";
142    }
143    
144    
145    my $last_message = {};
146    sub _message {
147            my $type = shift @_;
148            my $text = join(' ',@_);
149            my $last = $last_message->{$type};
150            if ( $text ne $last ) {
151                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
152                    $last_message->{$type} = $text;
153            }
154    }
155    
156    sub _log { _message('log',@_) };
157    sub diag { _message('diag',@_) };
158    
159  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
160  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 166  my $handshake = "none";
166  my $program_path = './program/';  my $program_path = './program/';
167  my $secure_path = './secure/';  my $secure_path = './secure/';
168    
169    # http server
170    my $http_server = 1;
171    
172    # 3M defaults: 8,4
173    my $max_rfid_block = 16;
174    my $read_blocks = 8;
175    
176  my $response = {  my $response = {
177          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
178          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 71  GetOptions( Line 194  GetOptions(
194          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
195          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
196          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
197            'http-server!' => \$http_server,
198  ) or die $!;  ) or die $!;
199    
200  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 106  it under the same terms ans Perl itself. Line 230  it under the same terms ans Perl itself.
230    
231  =cut  =cut
232    
 my $tags_data;  
 my $visible_tags;  
   
233  my $item_type = {  my $item_type = {
234          1 => 'Book',          1 => 'Book',
235          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 134  $databits=$port->databits($databits); Line 255  $databits=$port->databits($databits);
255  $parity=$port->parity($parity);  $parity=$port->parity($parity);
256  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
257    
258  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
259    
260  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
261  $port->lookclear();  $port->lookclear();
# Line 157  cmd( 'D5 00  05   04 00 11 Line 278  cmd( 'D5 00  05   04 00 11
278  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?',
279       '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() }  );
280    
281  # start scanning for tags  sub scan_for_tags {
282    
283  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 {  
284    
285                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
286                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
287                            my $rest = shift || die "no rest?";
288                            my $nr = ord( substr( $rest, 0, 1 ) );
289    
290                            if ( ! $nr ) {
291                                    _log "no tags in range\n";
292                                    update_visible_tags();
293                                    meteor( 'info-none-in-range' );
294                                    $tags_data = {};
295                            } else {
296    
297                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
298                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
299                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
300    
301                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
302                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
303                          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";  
304    
305                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
306    
307                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
308                            }
309                  }                  }
310          }          );
311  ) while(1);  
312  #) foreach ( 1 .. 100 );          diag "tags: ",dump( @tags );
313            return $tags_data;
314    
315    }
316    
317    # start scanning for tags
318    
319    if ( $http_server ) {
320            http_server;
321    } else {
322            while (1) {
323                    scan_for_tags;
324                    sleep 1;
325            }
326    }
327    
328    die "over and out";
329    
330  sub update_visible_tags {  sub update_visible_tags {
331          my @tags = @_;          my @tags = @_;
# Line 198  sub update_visible_tags { Line 334  sub update_visible_tags {
334          $visible_tags = {};          $visible_tags = {};
335    
336          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
337                    $visible_tags->{$tag}++;
338                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
339                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
340  #                               meteor( 'in-range', $tag );  #                               meteor( 'in-range', $tag );
# Line 205  sub update_visible_tags { Line 342  sub update_visible_tags {
342                                  meteor( 'read', $tag );                                  meteor( 'read', $tag );
343                                  read_tag( $tag );                                  read_tag( $tag );
344                          }                          }
                         $visible_tags->{$tag}++;  
345                  } else {                  } else {
346                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
347                  }                  }
# Line 235  my $tag_data_block; Line 371  my $tag_data_block;
371  sub read_tag_data {  sub read_tag_data {
372          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
373          die "no rest?" unless $rest;          die "no rest?" unless $rest;
374    
375            my $last_block = 0;
376    
377          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
378          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
379          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 244  sub read_tag_data { Line 383  sub read_tag_data {
383                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
384                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
385                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
386                  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;
387                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
388                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
389                  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;
390                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
391                    $last_block = $ord;
392          }          }
393          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
394    
395          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
396          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";
397    
398            return $last_block + 1;
399    }
400    
401    my $saved_in_log;
402    
403    sub decode_tag {
404            my $tag = shift;
405    
406            my $data = $tags_data->{$tag} || die "no data for $tag";
407    
408            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
409            my $hash = {
410                    u1 => $u1,
411                    u2 => $u2,
412                    set => ( $set_item & 0xf0 ) >> 4,
413                    total => ( $set_item & 0x0f ),
414    
415                    type => $type,
416                    content => $content,
417    
418                    branch => $br_lib >> 20,
419                    library => $br_lib & 0x000fffff,
420    
421                    custom => $custom,
422            };
423    
424            if ( ! $saved_in_log->{$tag}++ ) {
425                    open(my $log, '>>', 'rfid-log.txt');
426                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
427                    close($log);
428            }
429    
430            return $hash;
431  }  }
432    
433  sub read_tag {  sub read_tag {
# Line 263  sub read_tag { Line 437  sub read_tag {
437    
438          print "read_tag $tag\n";          print "read_tag $tag\n";
439    
440          cmd(          my $start_block = 0;
                 "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";  
                         read_tag_data( 0, @_ );  
                 },  
         );  
441    
442          cmd(          while ( $start_block < $max_rfid_block ) {
443                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
444                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
445                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
446                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
447          );                          "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";
448                                    $start_block = read_tag_data( $start_block, @_ );
449                                    warn "# read tag upto $start_block\n";
450                            },
451                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
452                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
453                            },
454                    );
455    
456            }
457    
458          my $security;          my $security;
459    
# Line 290  sub read_tag { Line 465  sub read_tag {
465                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
466                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );                          die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
467                          $security = as_hex( $security );                          $security = as_hex( $security );
468                            $tags_security->{$tag} = $security;
469                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
470                  }                  }
471          );          );
472    
473          my $data = $tags_data->{$tag} || die "no data for $tag";          print "TAG $tag ", dump(decode_tag( $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";  
   
474  }  }
475    
476  sub write_tag {  sub write_tag {
477          my ($tag) = @_;          my ($tag,$data) = @_;
478    
479          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
480            $data = read_file( $path ) if -e $path;
481    
482            die "no data" unless $data;
483    
         my $data = read_file( $path );  
484          my $hex_data;          my $hex_data;
485    
486          if ( $data =~ s{^hex\s+}{} ) {          if ( $data =~ s{^hex\s+}{} ) {
# Line 319  sub write_tag { Line 490  sub write_tag {
490    
491                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
492    
493                  my $max_len = 7 * 4;                  my $max_len = $max_rfid_block * 4;
494    
495                  if ( length($data) > $max_len ) {                  if ( length($data) > $max_len ) {
496                          $data = substr($data,0,$max_len);                          $data = substr($data,0,$max_len);
# Line 347  sub write_tag { Line 518  sub write_tag {
518          rename $path, $to;          rename $path, $to;
519          print ">> $to\n";          print ">> $to\n";
520    
521          delete $tags_data->{$tag};      # force re-read of tag          # force re-read of tag
522            delete $tags_data->{$tag};
523            delete $visible_tags->{$tag};
524  }  }
525    
526  sub secure_tag {  sub secure_tag {
# Line 440  sub skip_assert { Line 613  sub skip_assert {
613  sub assert {  sub assert {
614          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
615    
         return unless $assert->{expect};  
   
616          $from ||= 0;          $from ||= 0;
617          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
618    
# Line 491  sub checksum { Line 662  sub checksum {
662  our $dispatch;  our $dispatch;
663    
664  sub readchunk {  sub readchunk {
665          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
666    
667          # read header of packet          # read header of packet
668          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 519  sub readchunk { Line 690  sub readchunk {
690          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
691          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
692    
693          if ( defined $to && $payload ) {          if ( defined $to ) {
694                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
695                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
696                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
697          } else {          } else {
698                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
699          }          }
700    
701          return $data;          return $data;
Legend:
Removed from v.40  
changed lines
  Added in v.62
  ViewVC Help
Powered by ViewVC 1.1.26