sserver.pl

   1 #!/usr/bin/perl
   2 #sserver.pl:
   3
   4 # openssl s_client -connect localhost:11211
   5 #
   6 # a test server for "New Gopher"
   7 #
   8 use strict;
   9 use warnings;
  10
  11 use TLSGopher;
  12 use File::MimeInfo; # CPAN
  13
  14 if (!$ARGV[0]) {
  15         die "Usage: ./sslserver.pl CONFIG-FILE";
  16 }
  17
  18 sub read_config {
  19         my $filename = shift;
  20         my %defaults = (
  21                 'Host'=>'localhost',
  22                 'Port'=>32070,
  23                 'Root'=>undef,
  24                 'Debug'=>1,
  25                 'TLSoff'=>0,
  26                 'TLSkey'=>'server.key',
  27                 'TLScert'=>'server.crt',
  28                 'TLSpassphrase'=>''
  29         );
  30         my $fh;
  31         open $fh, $filename;
  32         while (<$fh>) { my $line = $_;
  33                 if ($line =~ /^#/) { next; } #comments
  34                 $line =~ /(\S+)\s+(.+)/;
  35                 my ($key, $val) = ($1, $2);
  36                 if (exists $defaults{$key}) {
  37                         $defaults{$key} = $val;
  38                 } else {
  39                         warn "Unknown config entry '".$key."'";
  40                 }
  41         }
  42         close $fh;
  43         if (!($defaults{'Root'} =~ /\/$/)) { $defaults{'Root'} .= '/'; }
  44         return %defaults;
  45 }
  46
  47 my %config = read_config($ARGV[0]);
  48
  49 (my $server = new TLSGopher::server \%config)
  50         ||
  51         die "unable to create socket: ", TLSGopher::server::errstr, "\n";
  52
  53 $server->register(
  54         accept  => \&cb_accept,
  55         close   => \&cb_close,
  56         request => \&cb_request,
  57 #       read    => \&cb_read,
  58 );
  59
  60         print "Waiting for connections.\n";
  61
  62 $server->listen();
  63
  64 sub cb_accept {
  65         print "Connection accepted\n";
  66 }
  67
  68 sub cb_close {
  69         print "Connection closed\n\n";
  70 }
  71
  72 sub cb_request {
  73         my ($conn, $resp, $req) = @_;
  74
  75         my $selector = safer_selector($req->{selector});
  76
  77         print "Responding to request '$selector'\n";
  78
  79         my $path = $config{'Root'} . $selector;
  80
  81         if (-e $path && !-r $path) {
  82                 respond_with_error($resp, "Access denied", "You requested '".$resp->{selector}."'");
  83             return 0;
  84         }
  85
  86         if (-f $path) {
  87                 if (-x $path) {
  88                         # CGI script
  89                         print "Running script '$path'\n";
  90                         exec_cgi($path, $resp, $req);
  91                 } else {
  92                         # FS file
  93                         print "Sending file '$path'\n";
  94                         my $size = -s $path;
  95                         my $mimetype = mimetype $path;
  96                         open(FILE, $path);
  97                         binmode(FILE);
  98                         $resp->raw(1);
  99                         $resp->write($size."\t".$mimetype."\r\n");
 100                         $resp->read_from(*FILE);
 101             }
 102             return 0;
 103         }
 104         if (-d $path) {
 105                 print "Generating menu '$path'\n";
 106                 $resp->type('text/x-menu');
 107             $resp->write( ng_menu_from_dir($path) );
 108             write_banner($resp);
 109             return 0;
 110         }
 111
 112         respond_with_error($resp, "File not found", "You requested '".$resp->{selector}."'");
 113         return 0;
 114 }
 115
 116 sub cb_read {
 117         my ($conn, $data, $n) = @_;
 118 #       print "RAW data being read: ($n) $data";
 119 }
 120
 121 sub ng_menu_from_dir {
 122         my $path = shift;
 123         my $buf = "";
 124         $path =~ s/\/$//;
 125     my @files = glob $path."/*";
 126     $buf .= "i\tListing [".$path."]\r\n";
 127     $buf .= "m\t..\t..\r\n";
 128     my $l = length $path;
 129     my $sl = length $config{'Root'};
 130     foreach my $file (@files) {
 131                 my $name = substr($file, $l + 1);
 132                 my $selector = substr($file, $sl);
 133                 my $type = 'b';
 134                 if (-x $file) { $type = 's'; }
 135                 if (-d $file) { $type = 'm'; }
 136                 $buf .= $type."\t".$name."\t".$selector."\r\n";
 137     }
 138         return $buf;
 139 }
 140
 141 sub safer_selector {
 142         my $selector = shift;
 143         if (!defined $selector) { $selector = ''; }
 144         # Make selector 'safe' :(
 145         $selector = '/'.$selector;
 146         $selector =~ s/\/\.+//;
 147         $selector =~ s/\.\///;
 148         $selector =~ s/^\/+//;
 149         $selector =~ s/\/$//;
 150         $selector =~ s/\r//;
 151         $selector =~ s/\n//m;
 152         return $selector;
 153 }
 154
 155 sub respond_with_error {
 156         my $r = shift;
 157         $r->error( @_ );
 158         $r->write("m\tReturn to root\t/\r\n");
 159         write_banner($r);
 160         print "Responding with error: " . $_[0]."\n";
 161 }
 162 sub write_banner {
 163         $_[0]->write("i\t________________________________\r\n");
 164         $_[0]->write("i\t_generated by_[blahblah uname]__\r\n");
 165 }
 166
 167 sub exec_cgi {
 168         my ($path, $resp, $req) = @_;
 169
 170 #    use IO::Handle;               # thousands of lines just for autoflush :-(
 171     pipe(PARENT_RDR, CHILD_WTR);  # XXX: check failure?
 172     pipe(CHILD_RDR,  PARENT_WTR); # XXX: check failure?
 173 #    CHILD_WTR->autoflush(1);
 174 #    PARENT_WTR->autoflush(1);
 175         my $pid = fork;
 176
 177         if (!defined $pid) {    # Fork failed, return error
 178                 print "FAILED TO FORK, FATAL ERROR\n";
 179                 close CHILD_RDR;
 180         close CHILD_WTR;
 181                 close PARENT_RDR;
 182         close PARENT_WTR;
 183                 return 1;
 184         }
 185
 186         if ($pid == 0) {        # Child
 187         close CHILD_RDR;
 188         close CHILD_WTR;
 189         open STDOUT, '>&'.'PARENT_WTR' || die "can't reopen stdout\n";
 190                 open STDIN, '<&'.'PARENT_RDR' || die "can't reopen stdin\n";
 191                 open STDERR, '> '.'/dev/null' || die "can't reopen stderr\n";
 192
 193                 $ENV{"PATH_INFO"} = $req->{selector};   # HTTP/1.1 compatibility
 194                 $ENV{"SELECTOR"} = $req->{selector};    # varied old gopher compatibility
 195
 196                 $ENV{"GOPHER_SELECTOR"} = $req->{selector};
 197                 $ENV{"QUERY_STRING"} = $req->{search};
 198                 $ENV{'CONTENT_SIZE'} = $req->{post_size};
 199                 $ENV{'CONTENT_TYPE'} = $req->{post_type};
 200                 $ENV{"SCRIPT_NAME"} = $path;
 201
 202                 exec $path;
 203         }
 204
 205         else { # Parent
 206                 $SIG{PIPE} = "IGNORE";
 207 #               print "Forked a CHILD\n";
 208         close PARENT_RDR;
 209         close PARENT_WTR;
 210         $req->write_to(*CHILD_WTR);
 211         $resp->raw(1);
 212         $resp->read_from(*CHILD_RDR);
 213         $resp->track_pid($pid); # Do not unqueue $resp until child process is finished
 214         }
 215         return 0;
 216 }