simple-server.pl 5.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190
  1. #!/usr/bin/env perl
  2. # server.pl
  3. #
  4. # Basic HTTP web server without installing any extra modules
  5. # Supports directory listing, mimetype handling etc.
  6. #
  7. # License: CC0 1.0 (https://creativecommons.org/publicdomain/zero/1.0/)
  8. # This is the first basic, simple version of the server.
  9. # A more advanced version with watch and possibly other features is available
  10. # in server.pl
  11. # Usage:
  12. # - Have Perl installed
  13. # - Run "perl server.pl"
  14. # - Visit "http://localhost:7777" on a web browser
  15. # Limitations:
  16. # - Does not handle POST (only GET for now)
  17. # Original (public domain):
  18. # https://renenyffenegger.ch/notes/development/languages/Perl/modules/IO/Socket/echo-server-client
  19. use warnings;
  20. use strict;
  21. use IO::Socket::INET;
  22. use Net::hostent; # for OO version of gethostbyaddr
  23. # To handle CLI parameters
  24. use Getopt::Long;
  25. use File::Basename;
  26. use Cwd qw( abs_path cwd );
  27. my $script_dir = abs_path(dirname($0));
  28. # Set $PWD/public as webroot
  29. my $webroot_dir = $script_dir . '/public';
  30. # Fallback to current directory in case $script_dir/public is not found
  31. unless ( -d $webroot_dir ) {
  32. $webroot_dir = cwd();
  33. }
  34. my $port_listen = 7777;
  35. $| = 1; # Autoflush
  36. # Shows up when --help or -h is passed
  37. sub help_text {
  38. print("usage: server.pl [-h] [-p PORT] [-d WEBROOT]
  39. A simple HTTP web server in Perl.
  40. optional arguments:
  41. -h, --help show this help message and exit
  42. -p PORT, --port PORT
  43. port to listen for requests [default:7777]
  44. -d WEBROOT, --directory WEBROOT
  45. directory of the files to serve [default:public or \$PWD]
  46. examples:
  47. start server in 7777 port and serve files in public or \$PWD:
  48. \$ ./server.pl
  49. start server in 3344 port and serve files in www/static directory
  50. \$ ./server.pl -p 3344 -d www/static\n");
  51. exit;
  52. }
  53. # Process CLI parameters and update config values as necessary
  54. GetOptions ("p|port=i" => \$port_listen,
  55. "d|directory=s" => \$webroot_dir,
  56. "h|help" => \&help_text)
  57. or die("Error in command line arguments. Please review and try again. Run with -h for help.\n");
  58. my $socket = IO::Socket::INET->new(
  59. LocalHost => '0.0.0.0',
  60. LocalPort => $port_listen,
  61. Proto => 'tcp',
  62. Listen => 5,
  63. Reuse => 1
  64. ) or die "Cannot create socket. The port $port_listen is probably already being used? Please pass -p PORT to set a different port or stop already running instances of this script.";
  65. print "> Server started\n";
  66. print "> Waiting for requests on http://localhost:${port_listen}\n";
  67. my $request_path;
  68. my $content='';
  69. my $host;
  70. while ( my $client = $socket->accept() ) {
  71. # Host related
  72. my $hostinfo = gethostbyaddr($client->peeraddr);
  73. $host = $client->peerhost();
  74. my $request;
  75. my $request_url = '';
  76. my $request_params = '';
  77. my $request_url_full;
  78. my $request_method;
  79. # Response related
  80. my $response_mimetype = 'text/plain';
  81. local $/ = Socket::CRLF;
  82. # Read request up to an empty line
  83. while ( <$client> ) {
  84. last unless /\S/;
  85. if (/(\S+) ([^\?]+)(\?.*)? HTTP\//) {
  86. $request_method = $1;
  87. $request_url = $2;
  88. $request_params = $3; # GET params. e.g. "?test=1"
  89. }
  90. }
  91. $request_url_full = $host . ':' . $port_listen . $request_url;
  92. $request_path = $webroot_dir . $request_url;
  93. if ( -d $request_path ) {
  94. if ( -f "${request_path}/index.html" ) {
  95. $request_path = "${request_path}/index.html";
  96. } elsif ( -f "${request_path}/index.htm" ) {
  97. $request_path = "${request_path}/index.htm";
  98. } else {
  99. opendir DIR, $request_path;
  100. my @dir = sort readdir(DIR);
  101. close DIR;
  102. # Indicate that we're outputting HTML for the page
  103. $response_mimetype = 'text/html';
  104. # Prepare the content for the file index
  105. $content = "<h1>${request_url_full}</h1>";
  106. $content .= "<ul>";
  107. foreach (@dir) {
  108. if ( -d $request_path . $_ ) {
  109. $content .= "<li><strong><a href=\"http://${request_url_full}/$_\">$_</a></strong></li>";
  110. } else {
  111. $content .= "<li><a href=\"http://${request_url_full}/$_\">$_</a></li>";
  112. }
  113. }
  114. $content .= "</ul>";
  115. }
  116. print "> Directory requested. Will serve index HTML instead if found or a directory file list.\n";
  117. }
  118. # File is there, so show its content.
  119. if ( -f $request_path ) {
  120. open my $CRF, '<', $request_path or die "Can't open cache file $!";
  121. $content = do { local $/; <$CRF> };
  122. close($CRF);
  123. # File does not exist and no directory index content is there to serve.
  124. # So show error.
  125. } elsif ( $content eq '' ) {
  126. print "> ${request_url_full} does not exist, so serving an error instead\n";
  127. $content = "ERROR: ${request_url_full} could not be found";
  128. }
  129. # Set mimetype
  130. if ( $request_path =~ /\.htm$/ or $request_path =~ /\.html$/ ) {
  131. $response_mimetype = 'text/html';
  132. } elsif ( $request_path =~ /\.js$/ ) {
  133. $response_mimetype = 'text/javascript';
  134. } elsif ( $request_path =~ /\.css$/ ) {
  135. $response_mimetype = 'text/css';
  136. } elsif ( $request_path =~ /\.png$/ ) {
  137. $response_mimetype = 'image/png';
  138. } elsif ( $request_path =~ /\.jpg$/ or $request_path =~ /\.jpeg$/ ) {
  139. $response_mimetype = 'image/jpeg';
  140. } elsif ( $request_path =~ /\.ico$/ ) {
  141. $response_mimetype = 'image/x-icon';
  142. } elsif ( $request_path =~ /\.gif$/ ) {
  143. $response_mimetype = 'image/gif';
  144. } elsif ( $request_path =~ /\.svg$/ ) {
  145. $response_mimetype = 'image/svg+xml';
  146. } elsif ( $request_path =~ /\.webp$/ ) {
  147. $response_mimetype = 'image/webp';
  148. } else {
  149. print "> Mimetype is not programmed in server for $request_url! Serving as ${response_mimetype}\n";
  150. }
  151. # Send header and content
  152. print $client "HTTP/1.0 200 OK", Socket::CRLF;
  153. print $client "Content-type: $response_mimetype", Socket::CRLF;
  154. print $client Socket::CRLF;
  155. $client->send( $content );
  156. # Close client and print a message on console
  157. close $client;
  158. print "> Request for ${request_url_full} has been answered\n";
  159. }