← Back to branch summary

~crc-x/+junk/old-forthlets

« back to all changes in this revision

Viewing changes to www-server.pl

  • Committer: Charles Childers
  • Date: 2010-01-15 05:00:22 UTC
  • Revision ID: git-v1:b06537131be8245b64ea534415ed85aae04ca1ef
rxweb merged into this repo

Show diffs side-by-side

added added

removed removed

Lines of Context:
www-server.pl
1
 
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2
 
# Lightweight WWW Server
3
 
#
4
 
# This is based on Tuari (http://github.com/crcx/tuari),
5
 
# but has been modified for use with the WWW framework I
6
 
# am playing with.
7
 
#
8
 
# It's not secure - don't use it on a system open to the
9
 
# public, unless you want to risk your box.
10
 
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
11
 
# As with most of my code, this is gifted to the public
12
 
# domain. Use, modify, and share freely.
13
 
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
14
 
 
15
 
################ Configuration  ##################################
16
 
 
17
 
use Cwd;
18
 
 
19
 
# Change the next line to let tuari know where it lives:
20
 
# This directory will also be the server root directory
21
 
 
22
 
our $version=0.04;
23
 
our $basdir = getcwd;
24
 
 
25
 
# The port on which tuari will listen:
26
 
 
27
 
our $port = 9812;
28
 
 
29
 
# Add your own MIME types here; text/plain is the default.
30
 
our %mime_types = (
31
 
      '\.html?'    => 'text/html',
32
 
      '\.gif'      => 'image/gif',
33
 
      '\.jpe?g'    => 'image/jpeg'
34
 
                  );
35
 
 
36
 
 
37
 
###################  no real need to edit below ##################
38
 
 
39
 
require 5.6.0;
40
 
package tuari; # keep namespace separate from CGI scripts
41
 
 
42
 
use Socket;
43
 
use strict;
44
 
 
45
 
our($localname);
46
 
 
47
 
initialise();
48
 
 
49
 
main_loop();
50
 
 
51
 
################################## Subroutines ###################
52
 
 
53
 
sub logerr($$); sub logmsg($); sub cat($$;$); # forward declarations
54
 
 
55
 
 
56
 
sub initialise {
57
 
   $tuari::basdir= $basdir; # make this variable visible for CGI scripts
58
 
}
59
 
 
60
 
 
61
 
sub main_loop {
62
 
  my $tcp = getprotobyname('tcp');
63
 
  socket(Server, PF_INET, SOCK_STREAM, $tcp)      or die "socket: $!";
64
 
  setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or warn "setsockopt: $!";
65
 
  bind(Server, sockaddr_in($port, INADDR_ANY))    or die "bind: $!";
66
 
  listen(Server,SOMAXCONN)                        or die "listen: $!";
67
 
  logmsg "server started on port $port";
68
 
 
69
 
 CONNECT:
70
 
  for ( ; accept(Client,Server); close Client) {
71
 
 
72
 
    *STDIN = *Client;
73
 
    *STDOUT = *Client;
74
 
 
75
 
    my $r;
76
 
    my $m;
77
 
 
78
 
    my $remote_sockaddr  = getpeername(STDIN);
79
 
    my (undef, $iaddr)   = sockaddr_in($remote_sockaddr);
80
 
    my $peername         = gethostbyaddr($iaddr, AF_INET) || "localhost";
81
 
    my $peeraddr         = inet_ntoa($iaddr) || "127.0.0.1";
82
 
 
83
 
    my $local_sockaddr   = getsockname(STDIN);
84
 
    my (undef, $iaddr)   = sockaddr_in($remote_sockaddr);
85
 
    $localname           = gethostbyaddr($iaddr, AF_INET) || "localhost";
86
 
    my $localaddr        = inet_ntoa($iaddr) || "127.0.0.1";
87
 
 
88
 
 
89
 
    chomp($_ = <STDIN>);
90
 
    my ($method, $url, $proto, undef) = split;
91
 
 
92
 
    $url =~ s#\\#/#g;
93
 
    logmsg "<- $peername: $_";
94
 
    my ($file, undef, $arglist) = ($url =~ /([^?]*)(\?(.*))?/); # split at ?
95
 
    my $file_escaped = $file;
96
 
    $file =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # %20 -> space
97
 
 
98
 
    if ( $method !~ /^(GET|POST|HEAD)$/ ) {
99
 
      logerr 400, "I don't understand method $method";
100
 
      next CONNECT;
101
 
    }
102
 
 
103
 
 
104
 
#    if (-d  "$basdir/$file" ) {
105
 
#      unless ($file =~ m#/$#) {
106
 
#          redirect ("$file/");
107
 
#          next CONNECT;
108
 
#         }
109
 
#       my $dir = "$basdir/$file";
110
 
#   if (-f "$dir/index.html") {
111
 
#         $file .= "/index.html";
112
 
#    } else {
113
 
#         directory_listing($file);
114
 
#         next CONNECT;
115
 
#      }
116
 
#    }
117
 
 
118
 
#    if ( not -r "$basdir/$file" ) {
119
 
#      logerr 404, "$file: $!";
120
 
#      next CONNECT;
121
 
#    }
122
 
 
123
 
#    my @env_vars = qw(USER_AGENT CONTENT_LENGTH CONTENT_TYPE);
124
 
#    foreach my $var (@env_vars) {
125
 
#               $ENV{$var} = ""; # delete $ENV{$var} will crash perl on Netbook :-(
126
 
#               }
127
 
#    while(<STDIN>) {
128
 
#         s/[\r\l\n\s]+$//;
129
 
#         /^User-Agent: (.+)/i and $ENV{USER_AGENT} = $1;
130
 
#         /^Content-length: (\d+)/i and $ENV{CONTENT_LENGTH} = $1;
131
 
#         /^Content-type: (.+)/i    and $ENV{CONTENT_TYPE} = $1;
132
 
#         last if (/^$/);
133
 
#       }
134
 
#
135
 
#
136
 
    print "HTTP/1.0 200 OK\n"; # probably OK by now
137
 
#
138
 
#
139
 
#
140
 
#    if ( $file =~ m/\.cgi$/i) {
141
 
#      $ENV{SERVER_PROTOCOL} = $proto;
142
 
#      $ENV{SERVER_PORT}     = $port;
143
 
#      $ENV{SERVER_NAME}     = $localname;
144
 
#      $ENV{SERVER_URL}      = "http://$localname:$port/";
145
 
#      $ENV{SCRIPT_NAME}            = $file;
146
 
#      $ENV{SCRIPT_FILENAME} = "$basdir/$file";
147
 
#      $ENV{REQUEST_URI}     = $url;
148
 
#      $ENV{REQUEST_METHOD}  = $method;
149
 
#      $ENV{REMOTE_ADDR}     = $peeraddr;
150
 
#      $ENV{REMOTE_HOST}     = $peername;
151
 
#      $ENV{QUERY_STRING}    = $arglist;
152
 
#      $ENV{SERVER_SOFTWARE} = "tuari/$version";
153
 
#
154
 
#      if ($method =~ /POST/) {
155
 
#           logmsg "<- Content-length: $ENV{CONTENT_LENGTH}, type: $ENV{CONTENT_TYPE}";
156
 
#      }
157
 
#      cgi_run ($file,$arglist);
158
 
#      next CONNECT;
159
 
#    }
160
 
#
161
 
#    my $mime_type =  "text/plain"; # default
162
 
#    foreach my $suffix (keys %mime_types) {
163
 
#       if ($file =~ /$suffix$/i) {
164
 
#           $mime_type = $mime_types{$suffix};
165
 
#           last;
166
 
#       }
167
 
#    }
168
 
#    cat $file, $mime_type, $method || logerr 500, "$file: $!";
169
 
 
170
 
open my $fh_echo, '-|' or exec "echo $file bye >foo" or die "echo failed: $!\n";
171
 
close $fh_echo;
172
 
 
173
 
#$r = "\Qecho render $file bye >foo";
174
 
#$m = `exec $r`;
175
 
 
176
 
$m = `./retro --with foo webApp`;
177
 
print  <<EOF;
178
 
HTTP/1.0
179
 
Content-type: text/html
180
 
 
181
 
$m
182
 
EOF
183
 
 
184
 
      next CONNECT;
185
 
  }
186
 
    die "Fatal error: accept failed: $!\n"; # This should never happen
187
 
  }
188
 
 
189
 
#################### other subroutines ####################
190
 
 
191
 
sub logmsg ($) {
192
 
    my $fulltime = localtime();
193
 
    my ($hms) = ($fulltime =~ /(\d\d:\d\d:\d\d)/);
194
 
    print STDERR  "$$ $hms @_\n";
195
 
}
196
 
 
197
 
sub logerr ($$) {
198
 
  my ($code, $detail) = @_;
199
 
  my %codes =
200
 
      ( 200  => 'OK',
201
 
        400  => 'Bad Request',
202
 
        404  => 'Not Found',
203
 
        500  => 'Internal Server Error',
204
 
        501  => 'Not Implemented',
205
 
      );
206
 
  my $msg = "$code " . $codes{$code};
207
 
  logmsg "-> $msg $detail";
208
 
  print  <<EOF;
209
 
HTTP/1.0 $msg
210
 
Content-type: text/html
211
 
 
212
 
<html><body>
213
 
<h1>$msg</h1>
214
 
<p>$detail</p>
215
 
<hr>
216
 
<p><I>tuari/$version server at $localname port $port</I></p>
217
 
</body></html>
218
 
EOF
219
 
}
220
 
 
221
 
 
222
 
 
223
 
sub cat($$;$){   # cat ($file, $mimetype) writes Content-type header and $file to STDOUT
224
 
  my ($file, $mimetype, $method) = @_;
225
 
  $method = "GET" unless $method;
226
 
  my $fullpath = "$basdir/$file";
227
 
 
228
 
  my ($x,$x,$x,$x,$x,$x,$x,$length,$x,$mtime) = stat($fullpath);
229
 
  $mtime = gmtime $mtime;
230
 
  my ($day, $mon, $dm, $tm, $yr) =
231
 
          ($mtime =~ m/(...) (...) (..) (..:..:..) (....)/);
232
 
 
233
 
  print "Content-length: $length\n";
234
 
  print "Last-Modified: $day, $dm $mon $yr $tm GMT\n";
235
 
  print "Content-type: $mimetype\n\n";
236
 
  my $sent=0;
237
 
  if ($method eq "GET") {
238
 
    local $/; undef $/; # gobble whole files
239
 
    open IN, "<$fullpath" || return 0;
240
 
    my $content = <IN>;
241
 
    close IN;
242
 
    $sent = length($content);
243
 
    print $content;
244
 
  }
245
 
  logmsg "-> 200 OK $file: $sent bytes sent as $mimetype";
246
 
  return 1;
247
 
}
248
 
 
249
 
 
250
 
sub cgi_run {
251
 
  my ($file,$arglist) = @_;
252
 
  my ($dir) = ($file =~ /^(.*\/)/);
253
 
  my $path = "$basdir/$file";
254
 
  chdir "$basdir/$dir" or return logerr 500, "Cannot chdir to $basdir/$dir: $!";
255
 
  $path=~s/[A-Z]://;
256
 
  logmsg "-> doing $path";
257
 
 
258
 
  {package main; do $path;} # or return logerr 500, "Cannot do $path: $!";
259
 
  $@ and logerr 500, "in $file:<br>  $@";
260
 
  chdir $basdir;
261
 
}
262
 
 
263
 
 
264
 
sub directory_listing {
265
 
  my ($dir) = @_;
266
 
  $dir =~ s#//#/#g;
267
 
  chdir "$basdir/$dir" or return logerr 500, "Cannot chdir to $basdir/$dir: $!";
268
 
  my @files = glob("*");
269
 
  print  <<EOF;
270
 
HTTP/1.0 200 OK
271
 
Content-type: text/html
272
 
 
273
 
<html>
274
 
<head><title>$dir</title></head>
275
 
<body>
276
 
<h1>$dir</h1>
277
 
EOF
278
 
  print "<p><a href=..>..</a></p>\n";
279
 
  foreach my $file (sort @files) {
280
 
    -d $file and $file .= "/";
281
 
    print "<p><a href=./$file>$file</a></p>\n";
282
 
  }
283
 
  print <<EOF;
284
 
<hr>
285
 
<p><I>tuari/$version server at $localname port $port</I>
286
 
</body></html>
287
 
EOF
288
 
logmsg "-> 200 OK listing $dir";
289
 
}
290
 
 
291
 
 
292
 
sub redirect {
293
 
        my ($redir) = @_;
294
 
        print "HTTP/1.0 301 Moved Permanently\nLocation: $redir\n\n";
295
 
    logmsg "-> 301 Moved Permanently to $redir"
296
 
}