/[RFID]/cpr-m02.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 /cpr-m02.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 45 by dpavlin, Tue Jun 23 13:29:10 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    
# Line 38  sub meteor { Line 39  sub meteor {
39          }          }
40  }  }
41    
42    my $listen_port = 9000;                  # pick something not in use
43    sub http_server {
44    
45            my $server = IO::Socket::INET->new(
46                    Proto     => 'tcp',
47                    LocalPort => $listen_port,
48                    Listen    => SOMAXCONN,
49                    Reuse     => 1
50            );
51                                                                      
52            die "can't setup server" unless $server;
53    
54            print "Server $0 accepting clients at http://localhost:$listen_port/\n";
55    
56            sub static {
57                    my ($client,$path) = @_;
58    
59                    $path = "www/$path";
60    
61                    return unless -e $path;
62    
63                    my $type = 'text/plain';
64                    $type = 'text/html' if $path =~ m{\.htm};
65                    $type = 'application/javascript' if $path =~ m{\.js};
66    
67                    print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
68                    open(my $html, $path);
69                    while(<$html>) {
70                            print $client $_;
71                    }
72                    close($html);
73    
74                    return $path;
75            }
76    
77            while (my $client = $server->accept()) {
78                    $client->autoflush(1);
79                    my $request = <$client>;
80    
81                    warn "<< $request\n";
82    
83                    if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
84                            my $method = $1;
85                            if ( my $path = static( $client,$1 ) ) {
86                                    warn ">> $path";
87                            } elsif ( $method =~ m{/scan} ) {
88                                    my $callback = $1 if $method =~ m{\?callback=([^&;]+)};
89                                    my $tags = scan_for_tags();
90                                    my $json;
91                                    map {
92                                            my $d = decode_tag($_);
93                                            $d->{sid} = $_;
94                                            push @{ $json->{tags} },  $d;
95                                    } keys %$tags;
96                                    print $client "HTTP/1.0 200 OK\r\nContent-Type: application/x-javascript\r\n\r\n$callback(", to_json($json), ")\r\n";
97                            } else {
98                                    print $client "HTTP/1.0 404 Unkown method\r\n";
99                            }
100                    } else {
101                            print $client "HTTP/1.0 500 No method\r\n";
102                    }
103                    close $client;
104            }
105    
106            die "server died";
107    }
108    
109  my $debug = 0;  my $debug = 0;
110    
111  my $device    = "/dev/ttyUSB0";  my $device    = "/dev/ttyUSB0";
# Line 50  my $handshake = "none"; Line 118  my $handshake = "none";
118  my $program_path = './program/';  my $program_path = './program/';
119  my $secure_path = './secure/';  my $secure_path = './secure/';
120    
121    # http server
122    my $http_server = 1;
123    
124    # 3M defaults: 8,4
125    my $max_rfid_block = 16;
126    my $read_blocks = 8;
127    
128  my $response = {  my $response = {
129          'd500090400110a0500027250'                              => 'version?',          'd500090400110a0500027250'                              => 'version?',
130          'd60007fe00000500c97b'                                  => 'no tag in range',          'd60007fe00000500c97b'                                  => 'no tag in range',
# Line 71  GetOptions( Line 146  GetOptions(
146          'stopbits=i'  => \$stopbits,          'stopbits=i'  => \$stopbits,
147          'handshake=s' => \$handshake,          'handshake=s' => \$handshake,
148          'meteor=s'    => \$meteor_server,          'meteor=s'    => \$meteor_server,
149            'http-server!' => \$http_server,
150  ) or die $!;  ) or die $!;
151    
152  my $verbose = $debug > 0 ? $debug-- : 0;  my $verbose = $debug > 0 ? $debug-- : 0;
# Line 157  cmd( 'D5 00  05   04 00 11 Line 233  cmd( 'D5 00  05   04 00 11
233  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?',
234       '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() }  );
235    
236  # start scanning for tags  sub scan_for_tags {
237    
238  cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",          my @tags;
239           'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8  
240                  my $rest = shift || die "no rest?";          cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
241                  my $nr = ord( substr( $rest, 0, 1 ) );                   'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
242                            my $rest = shift || die "no rest?";
243                  if ( ! $nr ) {                          my $nr = ord( substr( $rest, 0, 1 ) );
244                          print "no tags in range\n";  
245                          update_visible_tags();                          if ( ! $nr ) {
246                          meteor( 'info-none-in-range' );                                  print "no tags in range\n";
247                          $tags_data = {};                                  update_visible_tags();
248                  } else {                                  meteor( 'info-none-in-range' );
249                                    $tags_data = {};
250                            } else {
251    
252                          my $tags = substr( $rest, 1 );                                  my $tags = substr( $rest, 1 );
253    
254                          my $tl = length( $tags );                                  my $tl = length( $tags );
255                          die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;                                  die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
256    
257                          my @tags;                                  push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
258                          push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );                                  warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
259                          warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;                                  print "$nr tags in range: ", join(',', @tags ) , "\n";
                         print "$nr tags in range: ", join(',', @tags ) , "\n";  
260    
261                          meteor( 'info-in-range', join(' ',@tags));                                  meteor( 'info-in-range', join(' ',@tags));
262    
263                          update_visible_tags( @tags );                                  update_visible_tags( @tags );
264                            }
265                  }                  }
266          }          );
 ) while(1);  
 #) foreach ( 1 .. 100 );  
267    
268            warn "## tags: ",dump( @tags );
269            return $tags_data;
270    
271    }
272    
273    # start scanning for tags
274    
275    if ( $http_server ) {
276            http_server;
277    } else {
278            scan_for_tags while 1;
279    }
280    
281    die "over and out";
282    
283  sub update_visible_tags {  sub update_visible_tags {
284          my @tags = @_;          my @tags = @_;
# Line 235  my $tag_data_block; Line 324  my $tag_data_block;
324  sub read_tag_data {  sub read_tag_data {
325          my ($start_block,$rest) = @_;          my ($start_block,$rest) = @_;
326          die "no rest?" unless $rest;          die "no rest?" unless $rest;
327    
328            my $last_block = 0;
329    
330          warn "## DATA [$start_block] ", dump( $rest ) if $debug;          warn "## DATA [$start_block] ", dump( $rest ) if $debug;
331          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));          my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
332          my $blocks = ord(substr($rest,8,1));          my $blocks = ord(substr($rest,8,1));
# Line 244  sub read_tag_data { Line 336  sub read_tag_data {
336                  warn "## block ",as_hex( $block ) if $debug;                  warn "## block ",as_hex( $block ) if $debug;
337                  my $ord   = unpack('v',substr( $block, 0, 2 ));                  my $ord   = unpack('v',substr( $block, 0, 2 ));
338                  my $expected_ord = $nr + $start_block;                  my $expected_ord = $nr + $start_block;
339                  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;
340                  my $data  = substr( $block, 2 );                  my $data  = substr( $block, 2 );
341                  die "data payload should be 4 bytes" if length($data) != 4;                  die "data payload should be 4 bytes" if length($data) != 4;
342                  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;
343                  $tag_data_block->{$tag}->[ $ord ] = $data;                  $tag_data_block->{$tag}->[ $ord ] = $data;
344                    $last_block = $ord;
345          }          }
346          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });          $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
347    
348          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));          my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
349          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";
350    
351            return $last_block + 1;
352    }
353    
354    sub decode_tag {
355            my $tag = shift;
356    
357            my $data = $tags_data->{$tag} || die "no data for $tag";
358    
359            my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
360            my $hash = {
361                    u1 => $u1,
362                    u2 => $u2,
363                    set => ( $set_item & 0xf0 ) >> 4,
364                    total => ( $set_item & 0x0f ),
365    
366                    type => $type,
367                    content => $content,
368    
369                    branch => $br_lib >> 20,
370                    library => $br_lib & 0x000fffff,
371    
372                    custom => $custom,
373            };
374    
375            return $hash;
376  }  }
377    
378  sub read_tag {  sub read_tag {
# Line 263  sub read_tag { Line 382  sub read_tag {
382    
383          print "read_tag $tag\n";          print "read_tag $tag\n";
384    
385          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, @_ );  
                 },  
         );  
386    
387          cmd(          while ( $start_block < $max_rfid_block ) {
388                  "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",  
389                  "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00                    cmd(
390                          read_tag_data( 3, @_ );                           sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
391                  }                                  "read $tag offset: $start_block blocks: $read_blocks",
392          );                          "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";
393                                    $start_block = read_tag_data( $start_block, @_ );
394                                    warn "# read tag upto $start_block\n";
395                            },
396                            "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
397                                    print "FIXME: tag $tag ready? (expected block read instead)\n";
398                            },
399                    );
400    
401            }
402    
403          my $security;          my $security;
404    
# Line 294  sub read_tag { Line 414  sub read_tag {
414                  }                  }
415          );          );
416    
417          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";  
   
418  }  }
419    
420  sub write_tag {  sub write_tag {
# Line 319  sub write_tag { Line 432  sub write_tag {
432    
433                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );                  $data .= "\0" x ( 4 - ( length($data) % 4 ) );
434    
435                  my $max_len = 7 * 4;                  my $max_len = $max_rfid_block * 4;
436    
437                  if ( length($data) > $max_len ) {                  if ( length($data) > $max_len ) {
438                          $data = substr($data,0,$max_len);                          $data = substr($data,0,$max_len);
# Line 440  sub skip_assert { Line 553  sub skip_assert {
553  sub assert {  sub assert {
554          my ( $from, $to ) = @_;          my ( $from, $to ) = @_;
555    
         return unless $assert->{expect};  
   
556          $from ||= 0;          $from ||= 0;
557          $to = length( $assert->{expect} ) if ! defined $to;          $to = length( $assert->{expect} ) if ! defined $to;
558    
# Line 491  sub checksum { Line 602  sub checksum {
602  our $dispatch;  our $dispatch;
603    
604  sub readchunk {  sub readchunk {
605          sleep 1;        # FIXME remove  #       sleep 1;        # FIXME remove
606    
607          # read header of packet          # read header of packet
608          my $header = read_bytes( 2, 'header' );          my $header = read_bytes( 2, 'header' );
# Line 519  sub readchunk { Line 630  sub readchunk {
630          } sort { length($a) <=> length($b) } keys %$dispatch;          } sort { length($a) <=> length($b) } keys %$dispatch;
631          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;          warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
632    
633          if ( defined $to && $payload ) {          if ( defined $to ) {
634                  my $rest = substr( $payload, length($to) );                  my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
635                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;                  warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
636                  $dispatch->{ $to }->( $rest );                  $dispatch->{ $to }->( $rest );
637          } else {          } else {
Legend:
Removed from v.40  
changed lines
  Added in v.45
  ViewVC Help
Powered by ViewVC 1.1.26