/[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 42 by dpavlin, Thu Jun 4 13:52:10 2009 UTC revision 64 by dpavlin, Thu Feb 11 12:33:19 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  my $meteor_fh;  
18    my $tags_data;
19    my $tags_security;
20    my $visible_tags;
21    
22    my $listen_port = 9000;                  # pick something not in use
23    my $server_url  = "http://localhost:$listen_port";
24    
25    sub http_server {
26    
27            my $server = IO::Socket::INET->new(
28                    Proto     => 'tcp',
29                    LocalPort => $listen_port,
30                    Listen    => SOMAXCONN,
31                    Reuse     => 1
32            );
33                                                                      
34            die "can't setup server" unless $server;
35    
36  sub meteor {          print "Server $0 ready at $server_url\n";
37          my @a = @_;  
38          push @a, scalar localtime() if $a[0] =~ m{^info};          sub static {
39                    my ($client,$path) = @_;
40          if ( ! defined $meteor_fh ) {  
41                  if ( $meteor_fh =                  $path = "www/$path";
42                                  IO::Socket::INET->new(                  $path .= 'rfid.html' if $path =~ m{/$};
43                                          PeerAddr => $meteor_server,  
44                                          Timeout => 1,                  return unless -e $path;
45                                  )  
46                  ) {                  my $type = 'text/plain';
47                          warn "# meteor connected to $meteor_server";                  $type = 'text/html' if $path =~ m{\.htm};
48                    $type = 'application/javascript' if $path =~ m{\.js};
49    
50                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
51                    open(my $html, $path);
52                    while(<$html>) {
53                            print $client $_;
54                    }
55                    close($html);
56    
57                    return $path;
58            }
59    
60            while (my $client = $server->accept()) {
61                    $client->autoflush(1);
62                    my $request = <$client>;
63    
64                    warn "WEB << $request\n" if $debug;
65    
66                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
67                            my $method = $1;
68                            my $param;
69                            if ( $method =~ s{\?(.+)}{} ) {
70                                    foreach my $p ( split(/[&;]/, $1) ) {
71                                            my ($n,$v) = split(/=/, $p, 2);
72                                            $param->{$n} = $v;
73                                    }
74                                    warn "WEB << param: ",dump( $param ) if $debug;
75                            }
76                            if ( my $path = static( $client,$1 ) ) {
77                                    warn "WEB >> $path" if $debug;
78                            } elsif ( $method =~ m{/scan} ) {
79                                    my $tags = scan_for_tags();
80                                    my $json = { time => time() };
81                                    map {
82                                            my $d = decode_tag($_);
83                                            $d->{sid} = $_;
84                                            $d->{security} = $tags_security->{$_};
85                                            push @{ $json->{tags} },  $d;
86                                    } keys %$tags;
87                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n",
88                                            $param->{callback}, "(", to_json($json), ")\r\n";
89                            } elsif ( $method =~ m{/program} ) {
90    
91                                    my $status = 501; # Not implementd
92    
93                                    foreach my $p ( keys %$param ) {
94                                            next unless $p =~ m/^tag_(\S+)/;
95                                            my $tag = $1;
96                                            my $content = "\x04\x11\x00\x01" . $param->{$p};
97                                            $content = "\x00" if $param->{$p} eq 'blank';
98                                            $status = 302;
99    
100                                            warn "PROGRAM $tag $content\n";
101                                            write_tag( $tag, $content );
102                                    }
103    
104                                    print $client "HTTP/1.0 $status $method\r\nLocation: $server_url\r\n\r\n";
105    
106                            } else {
107                                    print $client "HTTP/1.0 404 Unkown method\r\n";
108                            }
109                  } else {                  } else {
110                          warn "can't connect to meteor $meteor_server: $!";                          print $client "HTTP/1.0 500 No method\r\n";
                         $meteor_fh = 0;  
111                  }                  }
112                    close $client;
113          }          }
114    
115          if ( $meteor_fh ) {          die "server died";
116                  warn ">> meteor ",dump( @a );  }
117                  print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n"  
118    
119    my $last_message = {};
120    sub _message {
121            my $type = shift @_;
122            my $text = join(' ',@_);
123            my $last = $last_message->{$type};
124            if ( $text ne $last ) {
125                    warn $type eq 'diag' ? '# ' : '', $text, "\n";
126                    $last_message->{$type} = $text;
127          }          }
128  }  }
129    
130  my $debug = 0;  sub _log { _message('log',@_) };
131    sub diag { _message('diag',@_) };
132    
133  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
134  my $baudrate  = "19200";  my $baudrate  = "19200";
# Line 50  my $handshake = "none"; Line 140  my $handshake = "none";
140  my $program_path = './program/';  my $program_path = './program/';
141  my $secure_path = './secure/';  my $secure_path = './secure/';
142    
143    # http server
144    my $http_server = 1;
145    
146  # 3M defaults: 8,4  # 3M defaults: 8,4
147  my $max_rfid_block = 16;  my $max_rfid_block = 16;
148  my $read_blocks = 8;  my $read_blocks = 8;
# Line 74  GetOptions( Line 167  GetOptions(
167          'parity=s'    => \$parity,          'parity=s'    => \$parity,
168          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
169          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
170          'meteor=s'    => \$meteor_server,          'http-server!' => \$http_server,
171  ) or die $!;  ) or die $!;
172    
173  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 110  it under the same terms ans Perl itself. Line 203  it under the same terms ans Perl itself.
203    
204  =cut  =cut
205    
 my $tags_data;  
 my $visible_tags;  
   
206  my $item_type = {  my $item_type = {
207          1 => 'Book',          1 => 'Book',
208          6 => 'CD/CD ROM',          6 => 'CD/CD ROM',
# Line 138  $databits=$port->databits($databits); Line 228  $databits=$port->databits($databits);
228  $parity=$port->parity($parity);  $parity=$port->parity($parity);
229  $stopbits=$port->stopbits($stopbits);  $stopbits=$port->stopbits($stopbits);
230    
231  print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";  warn "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
232    
233  # Just in case: reset our timing and buffers  # Just in case: reset our timing and buffers
234  $port->lookclear();  $port->lookclear();
# Line 155  cmd( 'D5 00  05   04 00 11 Line 245  cmd( 'D5 00  05   04 00 11
245       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {       'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
246          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));          my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
247          print "hardware version $hw_ver\n";          print "hardware version $hw_ver\n";
         meteor( 'info', "Found reader hardware $hw_ver" );  
248  });  });
249    
250  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?',
251       '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() }  );
252    
253  # start scanning for tags  sub scan_for_tags {
254    
255  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 {  
256    
257                          my $tags = substr( $rest, 1 );          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags",
258                     'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
259                            my $rest = shift || die "no rest?";
260                            my $nr = ord( substr( $rest, 0, 1 ) );
261    
262                            if ( ! $nr ) {
263                                    _log "no tags in range\n";
264                                    update_visible_tags();
265                                    $tags_data = {};
266                            } else {
267    
268                          my $tl = length( $tags );                                  my $tags = substr( $rest, 1 );
269                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  my $tl = length( $tags );
270                                    die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
271    
272                                    push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
273                                    warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
274                                    _log "$nr tags in range: ", join(',', @tags ) , "\n";
275    
276                          my @tags;                                  update_visible_tags( @tags );
277                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                          }
278                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                  }
279                          print "$nr tags in range: ", join(',', @tags ) , "\n";          );
280    
281                          meteor( 'info-in-range', join(' ',@tags));          diag "tags: ",dump( @tags );
282            return $tags_data;
283    
284                          update_visible_tags( @tags );  }
                 }  
         }  
 ) while(1);  
 #) foreach ( 1 .. 100 );  
285    
286    # start scanning for tags
287    
288    if ( $http_server ) {
289            http_server;
290    } else {
291            while (1) {
292                    scan_for_tags;
293                    sleep 1;
294            }
295    }
296    
297    die "over and out";
298    
299  sub update_visible_tags {  sub update_visible_tags {
300          my @tags = @_;          my @tags = @_;
# Line 202  sub update_visible_tags { Line 303  sub update_visible_tags {
303          $visible_tags = {};          $visible_tags = {};
304    
305          foreach my $tag ( @tags ) {          foreach my $tag ( @tags ) {
306                    $visible_tags->{$tag}++;
307                  if ( ! defined $last_visible_tags->{$tag} ) {                  if ( ! defined $last_visible_tags->{$tag} ) {
308                          if ( defined $tags_data->{$tag} ) {                          if ( defined $tags_data->{$tag} ) {
309  #                               meteor( 'in-range', $tag );                                  warn "$tag in range\n";
310                          } else {                          } else {
                                 meteor( 'read', $tag );  
311                                  read_tag( $tag );                                  read_tag( $tag );
312                          }                          }
                         $visible_tags->{$tag}++;  
313                  } else {                  } else {
314                          warn "## using cached data for $tag" if $debug;                          warn "## using cached data for $tag" if $debug;
315                  }                  }
316                  delete $last_visible_tags->{$tag}; # leave just missing tags                  delete $last_visible_tags->{$tag}; # leave just missing tags
317    
318                  if ( -e "$program_path/$tag" ) {                  if ( -e "$program_path/$tag" ) {
                                 meteor( 'write', $tag );  
319                                  write_tag( $tag );                                  write_tag( $tag );
320                  }                  }
321                  if ( -e "$secure_path/$tag" ) {                  if ( -e "$secure_path/$tag" ) {
                                 meteor( 'secure', $tag );  
322                                  secure_tag( $tag );                                  secure_tag( $tag );
323                  }                  }
324          }          }
325    
326          foreach my $tag ( keys %$last_visible_tags ) {          foreach my $tag ( keys %$last_visible_tags ) {
327                  my $data = delete $tags_data->{$tag};                  my $data = delete $tags_data->{$tag};
328                  print "removed tag $tag with data ",dump( $data ),"\n";                  warn "$tag removed ", dump($data), $/;
                 meteor( 'removed', $tag );  
329          }          }
330    
331          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;          warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
# Line 266  sub read_tag_data { Line 363  sub read_tag_data {
363          return $last_block + 1;          return $last_block + 1;
364  }  }
365    
366    my $saved_in_log;
367    
368    sub decode_tag {
369            my $tag = shift;
370    
371            my $data = $tags_data->{$tag} || die "no data for $tag";
372    
373            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
374            my $hash = {
375                    u1 => $u1,
376                    u2 => $u2,
377                    set => ( $set_item & 0xf0 ) >> 4,
378                    total => ( $set_item & 0x0f ),
379    
380                    type => $type,
381                    content => $content,
382    
383                    branch => $br_lib >> 20,
384                    library => $br_lib & 0x000fffff,
385    
386                    custom => $custom,
387            };
388    
389            if ( ! $saved_in_log->{$tag}++ ) {
390                    open(my $log, '>>', 'rfid-log.txt');
391                    print $log strftime( "%Y-%m-%d %H:%M:%S", localtime ), ",$tag,$content\n";
392                    close($log);
393            }
394    
395            return $hash;
396    }
397    
398  sub read_tag {  sub read_tag {
399          my ( $tag ) = @_;          my ( $tag ) = @_;
400    
# Line 301  sub read_tag { Line 430  sub read_tag {
430                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );                          ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
431                          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 );
432                          $security = as_hex( $security );                          $security = as_hex( $security );
433                            $tags_security->{$tag} = $security;
434                          warn "# SECURITY $tag = $security\n";                          warn "# SECURITY $tag = $security\n";
435                  }                  }
436          );          );
437    
438          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";  
   
439  }  }
440    
441  sub write_tag {  sub write_tag {
442          my ($tag) = @_;          my ($tag,$data) = @_;
443    
444          my $path = "$program_path/$tag";          my $path = "$program_path/$tag";
445            $data = read_file( $path ) if -e $path;
446    
447            die "no data" unless $data;
448    
         my $data = read_file( $path );  
449          my $hex_data;          my $hex_data;
450    
451          if ( $data =~ s{^hex\s+}{} ) {          if ( $data =~ s{^hex\s+}{} ) {
# Line 358  sub write_tag { Line 483  sub write_tag {
483          rename $path, $to;          rename $path, $to;
484          print ">> $to\n";          print ">> $to\n";
485    
486          delete $tags_data->{$tag};      # force re-read of tag          # force re-read of tag
487            delete $tags_data->{$tag};
488            delete $visible_tags->{$tag};
489  }  }
490    
491  sub secure_tag {  sub secure_tag {
# Line 500  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 533  sub readchunk { Line 660  sub readchunk {
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";                  die "NO DISPATCH for ",as_hex( $full ),"\n";
664          }          }
665    
666          return $data;          return $data;
Legend:
Removed from v.42  
changed lines
  Added in v.64
  ViewVC Help
Powered by ViewVC 1.1.26