/[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 54 by dpavlin, Wed Jun 24 13:39:43 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    
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 38  sub meteor { Line 45  sub meteor {
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    
67                    return unless -e $path;
68    
69                    my $type = 'text/plain';
70                    $type = 'text/html' if $path =~ m{\.htm};
71                    $type = 'application/javascript' if $path =~ m{\.js};
72    
73                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
74                    open(my $html, $path);
75                    while(<$html>) {
76                            print $client $_;
77                    }
78                    close($html);
79    
80                    return $path;
81            }
82    
83            while (my $client = $server->accept()) {
84                    $client->autoflush(1);
85                    my $request = <$client>;
86    
87                    warn "WEB << $request\n" if $debug;
88    
89                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
90                            my $method = $1;
91                            my $param;
92                            if ( $method =~ s{\?(.+)}{} ) {
93                                    foreach my $p ( split(/[&;]/, $1) ) {
94                                            my ($n,$v) = split(/=/, $p, 2);
95                                            $param->{$n} = $v;
96                                    }
97                                    warn "WEB << param: ",dump( $param ) if $debug;
98                            }
99                            if ( my $path = static( $client,$1 ) ) {
100                                    warn "WEB >> $path" if $debug;
101                            } elsif ( $method =~ m{/scan} ) {
102                                    my $tags = scan_for_tags();
103                                    my $json = { time => time() };
104                                    map {
105                                            my $d = decode_tag($_);
106                                            $d->{sid} = $_;
107                                            $d->{security} = $tags_security->{$_};
108                                            push @{ $json->{tags} },  $d;
109                                    } keys %$tags;
110                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
111                                            $param->{callback}, "(", to_json($json), ")\r\n";
112                            } else {
113                                    print $client "HTTP/1.0 404 Unkown method\r\n";
114                            }
115                    } else {
116                            print $client "HTTP/1.0 500 No method\r\n";
117                    }
118                    close $client;
119            }
120    
121            die "server died";
122    }
123    
124    
125    my $last_message = {};
126    sub _message {
127            my $type = shift @_;
128            my $text = join(' ',@_);
129            my $last = $last_message->{$type};
130            if ( $text ne $last ) {
131                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
132                    $last_message->{$type} = $text;
133            }
134    }
135    
136    sub _log { _message('log',@_) };
137    sub diag { _message('diag',@_) };
138    
139  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
140  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 146  my $handshake = "none";
146  my $program_path = './program/';  my $program_path = './program/';
147  my $secure_path = './secure/';  my $secure_path = './secure/';
148    
149    # http server
150    my $http_server = 1;
151    
152    # 3M defaults: 8,4
153    my $max_rfid_block = 16;
154    my $read_blocks = 8;
155    
156  my $response = {  my $response = {
157          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
158          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 71  GetOptions( Line 174  GetOptions(
174          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
175          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
176          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
177            'http-server!' => \$http_server,
178  ) or die $!;  ) or die $!;
179    
180  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 106  it under the same terms ans Perl itself. Line 210  it under the same terms ans Perl itself.
210    
211  =cut  =cut
212    
 my $tags_data;  
 my $visible_tags;  
   
213  my $item_type = {  my $item_type = {
214          1 => 'Book',          1 => 'Book',
215          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 134  $databits=$port->databits($databits); Line 235  $databits=$port->databits($databits);
235  $parity=$port->parity($parity);  $parity=$port->parity($parity);
236  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
237    
238  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
239    
240  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
241  $port->lookclear();  $port->lookclear();
# Line 157  cmd( 'D5 00  05   04 00 11 Line 258  cmd( 'D5 00  05   04 00 11
258  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?',
259       '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() }  );
260    
261  # start scanning for tags  sub scan_for_tags {
262    
263  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 {  
264    
265                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
266                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
267                            my $rest = shift || die "no rest?";
268                            my $nr = ord( substr( $rest, 0, 1 ) );
269    
270                            if ( ! $nr ) {
271                                    _log "no tags in range\n";
272                                    update_visible_tags();
273                                    meteor( 'info-none-in-range' );
274                                    $tags_data = {};
275                            } else {
276    
277                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
278                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
279                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
280    
281                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
282                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
283                          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";  
284    
285                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
286    
287                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
288                            }
289                  }                  }
290          }          );
291  ) while(1);  
292  #) foreach ( 1 .. 100 );          diag "tags: ",dump( @tags );
293            return $tags_data;
294    
295    }
296    
297    # start scanning for tags
298    
299    if ( $http_server ) {
300            http_server;
301    } else {
302            scan_for_tags while 1;
303    }
304    
305    die "over and out";
306    
307  sub update_visible_tags {  sub update_visible_tags {
308          my @tags = @_;          my @tags = @_;
# Line 198  sub update_visible_tags { Line 311  sub update_visible_tags {
311          $visible_tags = {};          $visible_tags = {};
312    
313          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
314                    $visible_tags->{$tag}++;
315                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
316                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
317  #                               meteor( 'in-range', $tag );  #                               meteor( 'in-range', $tag );
# Line 205  sub update_visible_tags { Line 319  sub update_visible_tags {
319                                  meteor( 'read', $tag );                                  meteor( 'read', $tag );
320                                  read_tag( $tag );                                  read_tag( $tag );
321                          }                          }
                         $visible_tags->{$tag}++;  
322                  } else {                  } else {
323                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
324                  }                  }
# Line 235  my $tag_data_block; Line 348  my $tag_data_block;
348  sub read_tag_data {  sub read_tag_data {
349          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
350          die "no rest?" unless $rest;          die "no rest?" unless $rest;
351    
352            my $last_block = 0;
353    
354          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
355          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
356          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 244  sub read_tag_data { Line 360  sub read_tag_data {
360                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
361                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
362                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
363                  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;
364                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
365                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
366                  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;
367                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
368                    $last_block = $ord;
369          }          }
370          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
371    
372          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
373          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";
374    
375            return $last_block + 1;
376    }
377    
378    sub decode_tag {
379            my $tag = shift;
380    
381            my $data = $tags_data->{$tag} || die "no data for $tag";
382    
383            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
384            my $hash = {
385                    u1 => $u1,
386                    u2 => $u2,
387                    set => ( $set_item & 0xf0 ) >> 4,
388                    total => ( $set_item & 0x0f ),
389    
390                    type => $type,
391                    content => $content,
392    
393                    branch => $br_lib >> 20,
394                    library => $br_lib & 0x000fffff,
395    
396                    custom => $custom,
397            };
398    
399            return $hash;
400  }  }
401    
402  sub read_tag {  sub read_tag {
# Line 263  sub read_tag { Line 406  sub read_tag {
406    
407          print "read_tag $tag\n";          print "read_tag $tag\n";
408    
409          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, @_ );  
                 },  
         );  
410    
411          cmd(          while ( $start_block < $max_rfid_block ) {
412                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
413                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
414                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
415                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
416          );                          "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";
417                                    $start_block = read_tag_data( $start_block, @_ );
418                                    warn "# read tag upto $start_block\n";
419                            },
420                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
421                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
422                            },
423                    );
424    
425            }
426    
427          my $security;          my $security;
428    
# Line 290  sub read_tag { Line 434  sub read_tag {
434                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
435                          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 );
436                          $security = as_hex( $security );                          $security = as_hex( $security );
437                            $tags_security->{$tag} = $security;
438                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
439                  }                  }
440          );          );
441    
442          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";  
   
443  }  }
444    
445  sub write_tag {  sub write_tag {
# Line 319  sub write_tag { Line 457  sub write_tag {
457    
458                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
459    
460                  my $max_len = 7 * 4;                  my $max_len = $max_rfid_block * 4;
461    
462                  if ( length($data) > $max_len ) {                  if ( length($data) > $max_len ) {
463                          $data = substr($data,0,$max_len);                          $data = substr($data,0,$max_len);
# Line 440  sub skip_assert { Line 578  sub skip_assert {
578  sub assert {  sub assert {
579          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
580    
         return unless $assert->{expect};  
   
581          $from ||= 0;          $from ||= 0;
582          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
583    
# Line 491  sub checksum { Line 627  sub checksum {
627  our $dispatch;  our $dispatch;
628    
629  sub readchunk {  sub readchunk {
630          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
631    
632          # read header of packet          # read header of packet
633          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 519  sub readchunk { Line 655  sub readchunk {
655          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
656          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
657    
658          if ( defined $to && $payload ) {          if ( defined $to ) {
659                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
660                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
661                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
662          } else {          } else {
663                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
664          }          }
665    
666          return $data;          return $data;
Legend:
Removed from v.40  
changed lines
  Added in v.54
  ViewVC Help
Powered by ViewVC 1.1.26