TLSGopher.pm

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use IO::Socket::SSL;
   7
   8 package TLSGopher;
   9 #  openssl s_client -connect localhost:11211
  10
  11 our $VERSION = '0.01';
  12
  13 use base 'Exporter';
  14 our @EXPORT = qw(ng_parse_uri ng_parse_menu ng_parse_response);
  15 #
  16 # UTILS
  17 #
  18 sub ng_parse_uri {
  19         my $uri = $_[0] || '';
  20         $uri =~ s/gopher:\/\///;
  21         chomp($uri);
  22         my ($long_host, $selector) = split /\//, $uri;
  23         my ($host, $port) = split /:/, $long_host;
  24         $port = $port || 32070; # default port
  25         undef $long_host;
  26         return ($host, $port, $selector);
  27 }
  28
  29 sub ng_parse_menu {
  30         my ($data, $host, $port) = @_;
  31         my @items = split /\r\n/, $data;
  32         my $i = 0;
  33         my @menu;
  34         foreach (@items) {
  35                 my ($mtype, $name, $selector, $_host, $_port) = split /\t/;
  36                 if (!$_port || !($_port =~ /\d+/)) { $_port = 0; }
  37                 $menu[$i] = {
  38                         'name' => $name,
  39                         'type' => ng_shorten_type($mtype),
  40                         'mimetype' => ng_expand_type($mtype),
  41                         'selector' => $selector,
  42                         'host' => ($_host ? $_host : $host),
  43                         'port' => ($_port ? int($_port) : $port),
  44                 };
  45                 $i++;
  46         }
  47         return @menu;
  48 }
  49
  50 sub ng_parse_response {
  51         my $data = $_[0];
  52         my $size = 0;
  53         my $mimetype = 'unknown';
  54         if ($data =~ /(-1|\d+)\t(.+)\r/) {
  55                 $size = $1;
  56                 $mimetype = $2;
  57         }
  58         $data =~ s/.+\r\n//;
  59         return ($size, $mimetype, $data);
  60 }
  61
  62 sub ng_expand_type {
  63         my $type = shift;
  64         return 'text/x-menu' if ($type eq 'm');
  65         return 'application/octet-stream' if ($type eq 'b');
  66         return '';
  67 }
  68
  69 sub ng_shorten_type {
  70         my $type = shift;
  71         return $type if ($type =~ /i|m|s|b|u/);
  72         return 'i' if ($type eq '');
  73         return 'm' if ($type eq 'text/x-menu');
  74         return 's' if ($type eq 'application/x-interactive');
  75         return 'b';
  76 }
  77
  78 #
  79 # REQUEST
  80 #
  81 {#<package>
  82 package TLSGopher::request;
  83
  84 sub new {
  85         my ($class, $host, $port, $selector) = @_;
  86         my $self = {};
  87         bless $self;
  88
  89         $self->{errstr} = '';
  90
  91         $self->{host} = $host;
  92         $self->{port} = $port;
  93         $self->{selector} = $selector;
  94
  95         $self->clear;
  96         $self->{post_fd} = undef;
  97
  98         $self->{ready} = 0;
  99         $self->{sent} = 0;
 100
 101         return $self;
 102 }
 103
 104 sub parse1 {
 105         my $self = shift;
 106         my $line = shift;
 107
 108         $self->{'buf'.'HEADER1'} = $line;
 109
 110         $line =~ s/\r\n//m;
 111
 112         ($self->{selector},
 113         $self->{search},
 114         $self->{range})  = split(/\t/, $line);
 115
 116         # Request is complex
 117         return 1 if ($line =~ /\t/);
 118         # Request is simple
 119         $self->{ready} = 1;
 120         return 0;
 121 }
 122
 123 sub parse2 {
 124         my ($self, $line) = @_;
 125
 126         $self->{'buf'.'HEADER2'} = $line;
 127
 128         if (!($line =~ /^(\d+)\t{0,1}(.*)/)) {
 129                 $self->{errstr} = 'Malformed request';
 130                 return 0;
 131         }
 132
 133         $self->clear;
 134
 135         $self->{post_size} = $1;
 136         $self->{post_type} = $2;
 137
 138         $self->{ready} = 1;
 139
 140         return $self->{post_size};
 141 }
 142
 143 sub parse3 {
 144         my ($self, $data, $n) = @_;
 145
 146         if ($self->{post_fd}) { # Connected to an output stream
 147                 # Write to it
 148                 my $fh = $self->{post_fd};
 149                 print $fh $data;
 150         } else {
 151                 # Buffer
 152                 $self->{'post_data'} .= $data;
 153         }
 154         $self->{'buf'.'SIZE'} += $n;
 155
 156         if ($self->{'buf'.'SIZE'} >= $self->{post_size}) {
 157                 $self->{ready} = $self->{ready} || 1;
 158                 $self->{sent} = 1;
 159                 $self->close;
 160         }
 161
 162         return $self->{sent};
 163 }
 164
 165 sub write_to {
 166         my ($self, $fh) = @_;
 167
 168         # Save filehandle
 169         $self->{post_fd} = $fh;
 170
 171         # Hack -- if we have something buffered, dump it
 172         print $fh $self->{'post_data'};
 173         $self->close if ($self->{sent});
 174 }
 175
 176 sub post_file {
 177         my ($self, $filename, $_type) = @_;
 178         if (!-r $filename) {
 179                 # Error
 180         }
 181
 182         my $size = -s $filename;
 183         my $type = mimetype $filename || $_type;
 184         my $data = '';
 185
 186         # Small file
 187         if ($size <= 1024) {
 188                 my $fh;
 189                 open $fh, $filename;
 190                 binmode $fh;
 191                 read $fh, $self->{post_data}, $size;
 192                 close $fh;
 193
 194                 $self->{post_size} = $size;
 195                 $self->{post_type} = $type;
 196
 197                 $self->{ready} = 1;
 198         }
 199         # Large file, stream it
 200         else {
 201                 my $fh;
 202                 open $fh, $filename;
 203                 binmode $fh;
 204
 205                 $self->{post_fd} = $fh;
 206                 $self->{post_offset} = 0;
 207                 $self->{post_size} = $size;
 208                 $self->{post_type} = $type;
 209
 210                 $self->{ready} = 1;
 211         }
 212 }
 213
 214 sub post_fd {
 215         my ($self, $fd, $size, $type) = @_;
 216
 217         $self->{post_fd} = $fd;
 218         $self->{post_offset} = 0;
 219         $self->{post_size} = $size;
 220         $self->{post_type} = $type || '';
 221
 222         $self->{ready} = 1;
 223 }
 224
 225 sub close {
 226         my $self = shift;
 227         if (defined $self->{post_fd}) {
 228                 close ($self->{post_fd});
 229                 undef $self->{post_fd};
 230         }
 231 }
 232
 233 sub clear {
 234         my $self = shift;
 235         $self->close();
 236         $self->{post_size} = 0;
 237         $self->{post_type} = '';
 238         $self->{post_data} = '';
 239 }
 240
 241 sub post {
 242         my ($self, $data, $size, $type) = @_;
 243
 244         $self->{post_type} = $type || $self->{post_type};
 245         $self->{post_size} = $size;
 246         $self->{post_data} = $data;
 247
 248         $self->{ready} = 1;
 249 }
 250
 251 sub print {
 252         my ($self, $fd) = @_;
 253         $fd = select if !defined $fd;
 254
 255         my $complex = ($self->{search} || $self->{range} || $self->{post_fd} || $self->{post_data});
 256
 257         # Request
 258         print $fd $self->{selector};
 259         print $fd $self->{search} . "\t" . $self->{range} if $complex;
 260         print $fd "\r\n";
 261
 262         # Connected to a stream
 263         if ($self->{post_fd}) {
 264                 # Header
 265                 print $fd $self->{post_size} . "\t";
 266                 print $fd $self->{post_type} ;
 267                 print $fd "\r\n";
 268
 269                 # Redirect it
 270                 my $buf = '';
 271                 while (read $fd, $buf, 1024) {
 272                         print $fd $buf;
 273                 }
 274         }
 275         # Has data buffered
 276         elsif ($self->{post_data}) {
 277                 # Header
 278                 print $fd $self->{post_size} . "\t";
 279                 print $fd $self->{post_type} ;
 280                 print $fd "\r\n";
 281
 282                 # Body
 283                 print $fd $self->{post_data};
 284         }
 285         # Need dummy
 286         elsif ($complex) {
 287                 # Header
 288                 print $fd $self->{post_size} . "\t";
 289                 print $fd "\r\n";
 290         }
 291
 292 }
 293
 294 sub DESTROY {
 295         $_[0]->close();
 296 }
 297
 298 }#</package>
 299
 300 #
 301 # RESPONSE
 302 #
 303 {#<package>
 304 package TLSGopher::response;
 305
 306 sub new {
 307         my $self = {};
 308
 309         $self->{selector} = '';
 310
 311         $self->{body_size} = 0;
 312         $self->{body_type} = '';
 313         $self->{body_data} = '';
 314
 315         $self->{raw} = 0;       # No need to apply header
 316
 317         $self->{ready} = 0;     # Ready to send
 318         $self->{header_sent} = 0; # Header sent
 319         $self->{sent} = 0; # Body sent
 320         $self->{is_error} = 0;
 321
 322         bless $self;
 323         return $self;
 324 }
 325
 326 sub read_from {
 327         my ($self, $fd) = @_;
 328         $self->{body_fd} = $fd;
 329
 330         # This could fail
 331         $fd->blocking(0);
 332 }
 333
 334 sub error {
 335         my $self = shift;
 336         if (@_ == 0) { return $self->{is_error}; }
 337         my $menu = "";
 338         my $c = 'e';
 339         for (@_) {
 340                 $menu .= $c."\t".$_."\r\n";
 341                 $c = 'i';
 342         }
 343         $self->{body_data} = $menu;
 344         $self->{body_type} = 'text/x-menu';
 345         $self->{body_size} = length $menu;
 346         $self->{ready} = 1;
 347         $self->{is_error} = 1;
 348 }
 349 sub size {
 350         my $self = shift;
 351         if (@_ == 0) { return $self->{body_size}; }
 352         $self->{body_size} = shift;
 353 }
 354 sub type {
 355         my $self = shift;
 356         if (@_ == 0) { return $self->{body_type}; }
 357         $self->{body_type} = shift;
 358 }
 359 sub write {
 360         my $self = shift;
 361         for (@_) {      $self->{body_data} .= $_; }
 362         $self->{body_size} = length $self->{body_data};
 363 }
 364
 365 sub print_header {
 366         my ($self, $fd) = @_;
 367         $fd = select if !defined $fd;
 368
 369         # Streams should handle their own errors.
 370         if (!$self->{raw}) {
 371                 print $fd $self->{body_size} . "\t";
 372                 print $fd $self->{body_type} ;
 373                 print $fd "\r\n";
 374         }
 375
 376         $self->{header_sent} = 1;
 377 }
 378
 379 sub print_body {
 380         my ($self, $fd) = @_;
 381         $fd = select if !defined $fd;
 382
 383         # Buffered body
 384         print $fd $self->{body_data};
 385
 386         # Connected to an input stream
 387         if ($self->{body_fd}) {
 388                 # Copy a portion of it
 389                 my $buf = '';
 390                 my $n;
 391                 if (($n = read $self->{body_fd}, $buf, 1024)) {
 392                         print $fd $buf;
 393                 }
 394                 if (!$n && !$!{EAGAIN}) {
 395                 #if (eof $self->{body_fd}) { # :(
 396                         $self->{sent} = 1;
 397                 }
 398                 # Hack -- clean buffered body
 399                 $self->{body_data} = '';
 400         }
 401         # Not connected
 402         else {
 403                 # All we had was buffered body
 404                 $self->{sent} = 1;
 405         }
 406
 407 }
 408
 409 sub print {
 410         my ($self, $fd) = @_;
 411 #       $fd = select if !defined $fd;
 412
 413         # Header
 414         $self->print_header($fd) unless $self->{header_sent};
 415
 416         # Body
 417         $self->print_body($fd) unless $self->{sent};
 418 }
 419
 420 sub sent {
 421         my ($self) = @_;
 422         if ($self->{track_pid} && $self->{sent}) {
 423                 warn "Waiting for child process to finish :(\n";
 424                 waitpid $self->{track_pid}, 0;
 425                 warn "Ok\n";
 426         }
 427         return $self->{sent};
 428 }
 429 sub raw {
 430         $_[0]->{raw} = $_[1] if (defined $_[1]);
 431         return $_[0]->{raw};
 432 }
 433
 434 sub track_pid {
 435         my ($self, $pid) = @_;
 436         $self->{track_pid} = $pid;
 437 }
 438
 439 sub DESTROY {
 440         my ($self) = @_;
 441         if ($self->{body_fd}) {
 442                 close $self->{body_fd};
 443         }
 444 }
 445
 446 }#</package>
 447
 448 #
 449 # CLIENT CONNECTION
 450 #
 451 {#<package>
 452 package TLSGopher::connection;
 453
 454 use constant {
 455     HEADER1     => 'Request',
 456     HEADER2     => 'Header',
 457     BINDATA     => 'Data',
 458     IGNORE      => 'Ignore',
 459 };
 460
 461 sub new {
 462
 463         my ($class, $sock) = @_;
 464         my $self = {};
 465
 466         $sock->blocking(0);
 467
 468         $self->{sock} = $sock;
 469         $self->{binmode} = 0;
 470         $self->{method} = HEADER1;
 471
 472         $self->{next_request} = undef;
 473
 474 #       warn "connection opened ($sock).\n";
 475
 476         $self->{queue} = ();
 477
 478         # Save cert meta-data
 479         my ($subject_name, $issuer_name);
 480         if (ref($sock) eq "IO::Socket::SSL") {
 481                 $subject_name = $sock->peer_certificate("subject");
 482                 $issuer_name = $sock->peer_certificate("issuer");
 483         }
 484         $self->{TLSsubject} = $subject_name;
 485         $self->{TLSissuer} = $issuer_name;
 486
 487         bless $self;
 488         return $self;
 489 }
 490
 491 sub cycle {
 492         my $self = shift;
 493
 494         $self->handle_queue;
 495
 496         if ($self->{binmode}) {
 497
 498                 my $need = 1024;
 499
 500                 if ($self->{binmode} > 0 && $self->{binmode} < $need) {
 501                         $need = $self->{binmode};
 502                 }
 503
 504                 # Read binary portion
 505                 my $data;
 506                 my $n = read $self->{sock}, $data, $need;
 507                 if (!$n && !$!{EAGAIN}) { return 0; } # Socket disconnected
 508
 509                 # React
 510                 if (defined $n) {
 511
 512                         $self->{read_cb}($self, $data, $n);
 513
 514                         if ($n >= 1) {
 515                                 # Old request, cont..
 516                                 $self->{binmode} -= $n;
 517                                 $self->{next_request}->parse3($data, $n);
 518                         }
 519                 }
 520
 521         } else {
 522                 # Read one line
 523                 my $sock = $self->{sock};
 524                 my $line = <$sock>;
 525                 if (!$line && !$!{EAGAIN}) { return 0; } # Socket disconnected
 526
 527                 # React
 528                 if ($line) {
 529
 530                         $self->{read_cb}($self, $line, length $line);
 531
 532                         if (!defined $self->{next_request}) {
 533                                 # New request
 534                                 $self->{next_request} = new TLSGopher::request;
 535                                 $self->{next_request}->parse1($line);
 536                         } else {
 537                                 # New request, cont..
 538                                 my $size = $self->{next_request}->parse2($line);
 539                                 $self->{binmode} = $size;
 540                         }
 541                 }
 542         }
 543
 544         # React to current request
 545         if (defined $self->{next_request}) {
 546
 547                 # Request has failed
 548                 if ($self->{next_request}->{errstr}) {
 549                         # Disconnect
 550                         $self->{sock}->close();
 551                 }
 552                 # Request is ready
 553                 elsif ($self->{next_request}->{ready} == 1) {
 554                         # Resolve
 555                         $self->handle_request( $self->{next_request} );
 556                         $self->{next_request}->{ready} = 2; # Hack, do not repeat
 557                 }
 558                 # Request is resolved
 559                 if ($self->{next_request}->{sent}) {
 560                         # Delete
 561                         undef $self->{next_request} ;
 562                 }
 563         }
 564
 565         return (defined $self->{sock}->connected() ? 1 : 0);
 566 }
 567
 568 sub handle_queue {
 569         my $self = shift;
 570
 571         # Queue is empty
 572         if ($#{$self->{queue}} <= -1) { return; }
 573
 574         # Get first response in queue
 575         my $resp = @{$self->{queue}}[0];
 576
 577         #print "Streaming $resp->{body_fd} > CLIENT\n";
 578
 579         # Advance it
 580         $resp->print( $self->{sock} );
 581
 582         # Remove it when done
 583         if ($resp->sent) {
 584                 shift (@{$self->{queue}});
 585         }
 586 }
 587
 588 sub handle_request {
 589         my ($self, $req) = @_;
 590
 591         my $resp = new TLSGopher::response;
 592
 593         $req->{response} = $resp;
 594         $resp->{request} = $req;
 595         $resp->{selector} = $req->{selector};
 596
 597         my $stop = $self->{request_cb}($self, $resp, $req);
 598
 599 # This allows user implementation to CANCEL response wholetogether.
 600 #       This is not recommended, as such behavior will break clients
 601 #       and a simple 0\r\n is always much better.
 602 #       if (!$stop) {
 603                 push @{$self->{queue}}, $resp;
 604 #       }
 605
 606 }
 607
 608 sub close {
 609         my $self = shift;
 610         close( $self->{sock} );
 611 #       warn "\t connection closed.\n";
 612 }
 613
 614 }#</package>
 615
 616 #
 617 # SERVER
 618 #
 619 {#<package>
 620 package TLSGopher::server;
 621
 622 my ($errstr) = ('');
 623
 624 sub new {
 625         my $self = {};
 626 # if 0
 627 #       my ($class, %cfg) = @_;
 628 # else
 629         my ($class, $cfg_ref) = @_;
 630         my %cfg = %{$cfg_ref};
 631         undef $cfg_ref;
 632 # endif
 633
 634         $self->{accept_cb} =
 635         $self->{request_cb} =
 636         $self->{read_cb} =
 637         $self->{close_cb} = sub { };
 638
 639         $self->{config} = %cfg;
 640         $self->{conns} = [];
 641
 642         $IO::Socket::SSL::DEBUG = $cfg{'Debug'} ? 1 : 0;
 643
 644         if ($cfg{'TLSoff'}) {
 645
 646                 warn "TLS is off!";
 647                 $self->{sock} = IO::Socket::INET->new(
 648
 649                         Listen  => 5,
 650                         LocalAddr => $cfg{'Host'},
 651                         LocalPort => $cfg{'Port'},
 652                         Proto     => 'tcp',
 653                         Reuse     => 1,
 654
 655                 );
 656                 if (!$self->{sock}) { $errstr = "Can't bind $cfg{'Host'} $cfg{'Port'} " }
 657         } else {
 658                 $self->{sock} = IO::Socket::SSL->new(
 659
 660                         Listen  => 5,
 661                         LocalAddr => $cfg{'Host'},
 662                         LocalPort => $cfg{'Port'},
 663                         Proto     => 'tcp',
 664                         Reuse     => 1,
 665                         #   SSL_verify_mode => 0x01,
 666                         SSL_passwd_cb => $cfg{'TLSpassphrase'} ?
 667                                         sub {return $cfg{'TLSpassphrase'}} : undef,
 668                         SSL_key_file => $cfg{'TLSkey'},
 669                         SSL_cert_file => $cfg{'TLScert'},
 670
 671                 );
 672                 if (!$self->{sock}) { $errstr = IO::Socket::SSL::errstr; }
 673         }
 674
 675         if (!$self->{sock}) {
 676                 return undef;
 677         }
 678
 679         $self->{sock}->blocking(0);
 680         $self->{stop} = 0;
 681
 682         bless $self;
 683         return $self;
 684 }
 685
 686 sub errstr { return $errstr; }
 687
 688 sub stop {
 689         my $self = shift;
 690         $self->{stop} = 1;
 691
 692         #warn "stopping server.\n";
 693 }
 694
 695 sub listen {
 696         my $self = shift;
 697
 698         #warn "waiting for connections.\n";
 699
 700         while (!$self->{stop}) {
 701
 702                 $self->cycle;
 703                 $self->wait;
 704
 705         }
 706
 707         $self->{sock}->close();
 708 }
 709
 710 sub cycle {
 711         my $self = shift;
 712
 713         while((my $s = $self->{sock}->accept())) {
 714
 715                 my $conn = new TLSGopher::connection $s;
 716
 717                 $self->{accept_cb}($conn, $self);
 718
 719                 $conn->{read_cb} = $self->{read_cb};
 720                 $conn->{request_cb} = $self->{request_cb};
 721
 722                 push @{$self->{conns}}, $conn;  # Add connection
 723         }
 724
 725         for (my $i = 0; $i < $#{$self->{conns}} + 1; $i++) {
 726                 my $conn = $self->{conns}[$i];
 727                 if (!$conn->cycle) {
 728                         $self->{close_cb}($@{$self->{conns}}[$i], $self);
 729                 splice @{$self->{conns}}, $i, 1;
 730                 $i--;
 731         }
 732     }
 733 }
 734
 735 sub wait {
 736
 737         # TODO: select on file descriptors
 738
 739 }
 740
 741 sub register {
 742         my ($self, %cfg) = @_;
 743         for (%cfg) {
 744                 $self->{$_.'_cb'} = $cfg{$_};
 745         }
 746 }
 747
 748 }#</package>
 749
 750 #
 751 # CLIENT
 752 #
 753 {#<package>
 754 package TLSGopher::client;
 755
 756 my ($sock);
 757
 758 sub new {
 759
 760 }
 761
 762 }#</package>
 763
 764 1;