/[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 41 by dpavlin, Thu Jun 4 13:36:20 2009 UTC revision 61 by dpavlin, Tue Feb 9 13:55:18 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  # 3M defaults: 8,4
173  my $max_rfid_block = 16;  my $max_rfid_block = 16;
174  my $read_blocks = 8;  my $read_blocks = 8;
# Line 75  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 110  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 138  $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 161  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          }          );
 ) while(1);  
 #) foreach ( 1 .. 100 );  
311    
312            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 202  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 209  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 261  sub read_tag_data { Line 393  sub read_tag_data {
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;          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 301  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 451  sub skip_assert { Line 611  sub skip_assert {
611  sub assert {  sub assert {
612          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
613    
         return unless $assert->{expect};  
   
614          $from ||= 0;          $from ||= 0;
615          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
616    
# Line 502  sub checksum { Line 660  sub checksum {
660  our $dispatch;  our $dispatch;
661    
662  sub readchunk {  sub readchunk {
663          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
664    
665          # read header of packet          # read header of packet
666          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 530  sub readchunk { Line 688  sub readchunk {
688          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
689          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
690    
691          if ( defined $to && $payload ) {          if ( defined $to ) {
692                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
693                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
694                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
695          } else {          } else {
696                  print "NO DISPATCH for ",dump( $full ),"\n";                  print "NO DISPATCH for ",as_hex( $full ),"\n";
697          }          }
698    
699          return $data;          return $data;
Legend:
Removed from v.41  
changed lines
  Added in v.61
  ViewVC Help
Powered by ViewVC 1.1.26