~rjpcasalino/bss

ref: cd9b147616f7b5a5dd7228a28c353deb552b475c bss/lib/Web.pm -rw-r--r-- 2.9 KiB
cd9b1476rjpc update the Salinger stuff 6 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
# Core Web server rounties from:
# Chapter 15 of "Network Programming with Perl"
# Copyright Lincoln D. Stein, 2000 

package Web;

use vars '@ISA', '@EXPORT';
require Exporter;

@ISA = 'Exporter';
@EXPORT = qw(handle_connection docroot);

# hacky but whatever
my $DOCUMENT_ROOT = $ENV{'BSS_DOCROOT'};
my $CRLF = "\015\012";

sub handle_connection {
	my $c = shift; #socket
	my ($fh, $type, $length, $url, $method);
	local $/ = "$CRLF$CRLF"; # set end of line character
	my $request = <$c>; # read request header

	return invalid_request($c)
	 unless ($method, $url) = $request =~ m!^(GET|HEAD) (/.*) HTTP/1\.[01]!;
	return not_found($c) unless ($fh, $type, $length) = lookup_file($url);
	return redirect($c, "$url/") if $type eq 'directory';

	# print the header
	print $c "HTTP/1.0 200 OK$CRLF";
	print $c "Content-length: $length$CRLF";
	print $c "Content-type: $type$CRLF";
	print $c $CRLF;

	return unless $method eq 'GET';

	# print the content
	#STDIN->fdopen($c, "<", "/dev/null") or die "Can't reopen STDIN: $!";
	#STDOUT->fdopen($c, ">", "/dev/null") or die "Can't reopen STDIN: $!";
	#STDERR->fdopen($c, ">&", STDOUT) or die "Can't reopen STDIN: $!";
	my $buffer;
	while ( read($fh, $buffer, 1024) ) {
		print $c $buffer;
	}
	close $fh;
}

sub lookup_file {
	my $url = shift;
	my $path = $DOCUMENT_ROOT . $url; # turn into path
	$path =~ s/\?.*$//; # ger rid of query
	$path =~ s/\#.*$//; # get rid of fragment
	$path .= 'index.html' if $url =~ m!/$!; # get index.html if path ends in /
	return if $path =~ m!/\.\\./!; # don't allow relative paths (..)
	return (undef, 'directory', undef) if -d $path; # oops! a directory
	my $type = 'text/plain'; # default MIME type
	$type = 'text/html' if $path =~ /\.html?$/i; # HTML file?
	$type = 'text/gif' if $path =~ /\.gif?$/i; # gif file?
	$type = 'text/jpeg' if $path =~ /\.jpe?g$/i; # jpg file?
	return unless my $length = (stat(_))[7]; # file size
	return unless my $fh = IO::File->new($path, "<"); # try to open file
}

sub redirect {
	my ($c, $url) = @_;
	my $host = $c->sockhost;
	my $port = $c->sockport;
	my $moved_to = "http://$host:$port$url";
	print $c "HTTP/1.0 301 Moved permanently$CRLF";
	print $c "Location: $moved_to$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<html>
<head><title>301 Moved</title>
</head>
<body>
<h1>MOVED</h1>
<p> The requested document has moved <a href="$moved_to">here</a>.<.p>
</body>
</html>
END
}

sub invalid_request {
	my $c = shift;
	print $c "HTTP/1.0 400 Bad Request$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<html>
<head><title>400 Bad Request</title>
</head>
<body><h1>Bad Request</h1>
</body>
</html>
END
}

sub not_found {
	my $c = shift;
	print $c "HTTP/1.0 404 Not Found$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<html>
<head><title>404 Not Found</title>
</head>
<body>
<h1>404 Not Found</h1>
</body>
</html>
END
}

sub docroot {
	$DOCUMENT_ROOT = shift if @_;
	return $DOCUMENT_ROOT;
}

1; # perl programs end this way :-)