gemini - kennedy.gemi.dev

💾 Archived View for tozip.chickenkiller.com › nofer captured on 2023-05-24 at 18:01:04.
-=-=-=-=-=-=-
#!/usr/bin/env perl
# toy gopher server - from gemini
# for setup on FreeBSD, see nopher.gmi
# # You can run as a simple server: sudo ./nofer -s

# settings that you may need to change
my $USER = `whoami`;
chomp $USER;
my $HOME = "/home/$USER";
my $LOG = "$HOME/tmp/nofer.log";
my $PORT = 70;
my $FQDN = `hostname -f`; # fully qualified domain name
chomp $FQDN;
$HOST = "\t$FQDN\t$PORT";
my $SRCROOT = "/home/pi/repos/gemtext";

#use boolean;
use Cwd;
use Socket;
#use POSIX;
#use File::Spec;
use Text::Tabs;
use IO::Socket;

sub url_parts {
	# $scheme, $authority, $path, $query, $fragment
	return $_ =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
}

sub get_host {
	my $link = shift;
	my($scheme, $authority, $path, $query, $fragment) = url_parts($link);
	my ($host, $port) = split(/:/, $authority);
	return $host;
}

sub print_link {
	my ($fout, $link, $text) = @_;
	$text = Text::Tabs::expand $text;

	if ($link =~ /^(gemini:|http:|https:|spartan:)/) {
		my $host = get_host($link);
		print $fout "h$text\tURL:$link\t$host\t70\r\n";
		return;
	}

	if ($link =~ /.*\.gmi$/) {
		print $fout "1$text\t/$link$HOST\r\n";
		return;
	}


	if ($link =~ /^(gopher:\/\/)(.*)/ ) {
		my ($server, $path) = split /\// , $2 , 2;
		if ( $path =~ /^(1\/)(.*)/ ) { 
			$path = "/$2"; # eliminate stray "1/" at beginning
		}

		print $fout "1$text\t$path\t$server\t70\r\n"; # port of 70 assumed
		return;
	}


	# ensure link starts with a /
	if($link !~ /^\//) { $link = "/" . $link; }

	if($link =~ /\.(jpg|JPG)$/) {
		print $fout "I$text\t$link$HOST\r\n";
		return;
	}

	print $fout "0$text\t$link$HOST\r\n";
}

sub handle_mapfile {
	my $fout = shift;
	while(<FH>) {
		my $input = $_;
		$input =~ chomp $input;
		if( $_ =~ /^=>\s+(\S+)\s+(.*)/) {
			print_link($fout, $1, $2);
		} else {
			$input = Text::Tabs::expand $input;
			print $fout "i$input\t\tnull.host\t1\r\n";
		}

	}

	#print $fout "-------------------------- Served by nofer\r\n";
}

sub handle_nonmapfile {
	my $fout = shift;
	while(<FH>) { print $fout "$_"; }
}


sub mkresponse {
	my $request = shift;
	$request =~ s/\r//g;
	$request =~ s/\n//g;

	if($request eq "") { $request = "index.gmi"; }
	if($request eq "/") { $request = "index.gmi"; }

	#print "request is <$request>\n";
	# check that client is not trying to snoop around our filesystem
	my $path1 = "$SRCROOT/$request";
	#my $can_path = File::Spec->canonpath($requested_path);
	my $can_path = Cwd::abs_path($path1);
	my $rascal = substr($can_path, 0, length($SRCROOT)) ne $SRCROOT;
	#print "rascal is <$rascal>\n";

	my $output = "";
	open(my $fout, ">", \$output);
	if( $rascal || ! (-e $can_path)) {
		print $fout "3Error: File or directory not found!\n";
		return $output;
		#exit 1;
	}

	open(FH, "<", "$can_path");
	if($request  =~ m/\.gmi$/) {
		handle_mapfile($fout) ;
	} else {
		handle_nonmapfile($fout);
	}
	close FH;
	close $fout;

	# LOGGING
	# TODO : it doesn't yet log unfound files/directories
	open(FH, ">>", $LOG);
	my $dt = localtime();
	use Socket;
	my $rip = "STDIN"; # In case we invoke from command-line for testing purposes
	my $pname = getpeername(STDIN);
	if( $pname ) {
		my ($port,$iaddr) = sockaddr_in($pname);
		$rip = inet_ntoa($iaddr);
	} 

	print FH "$dt:$rip:$request\n";
	close FH;

	return $output;

}

sub via_stdio() {
	my $request = <>;
	print mkresponse($request);
}

sub via_socket1() {
	my $socket = new IO::Socket::INET->new (
		#LocalHost => 'localhost',
		LocalPort => 70,
		Proto => 'tcp',
		#Listen => 1,
		#Reuse => 1,
	);

	die "Could not create socket: $!n" unless $socket;

	print "Waiting for data from the client end\n";
	my $new_socket = $socket->accept();
	#my $request = <$new_socket>;
	$socket->recv(my $request, 180);
	print "Request is: $request";
	print $socket mkresponse($request);


	#while(<$new_socket>)
	#{
	#	print $_;
	#}


	close($socket);
}
sub via_socket() {
	print "Running as server\n";
	# cribbed from
	# https://www.tutorialspoint.com/perl/perl_socket_programming.htm
	my $port = $PORT;
	my $proto = getprotobyname('tcp');
	my $server = $FQDN;  # Host IP running the server

	# create a socket, make it reusable
	#socket(SOCKET, PF_INET, SOCK_STREAM, $proto) or die "Can't open socket $!\n";
	#setsockopt(SOCKET, SOL_SOCKET, SO_REUSEADDR, 1) or die "Can't set socket option to SO_REUSEADDR $!\n";
	socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die $!;
	setsockopt(SOCKET, SOL_SOCKET, SO_REUSEADDR, 1) or die "Can't set socket option to SO_REUSEADDR $!\n";
	my $sin = sockaddr_in(70, INADDR_ANY);

	# bind to a port, then listen
	#bind(SOCKET, pack_sockaddr_in($port, inet_aton($server))) or die "Can't bind to port $port! \n";
	bind(SOCKET, $sin) || die $!;
	listen(SOCKET, 5) or die "listen: $!";
	print "SERVER started on port $port\n";

	# accepting a connection
	#my $client_addr;
	my $id = 0;
	use IO::Handle;
	while (my $client_addr = accept(NEW_SOCKET, SOCKET)) {
		#$NEW_SOCKET->autoflush;
		# send them a message, close connection
		my $name = gethostbyaddr($client_addr, AF_INET );
		my $request = <NEW_SOCKET>; 
		$request =~ s/\r//g;
		$request =~ s/\n//g;
		#while(<NEW_SOCKET>) { $request += $_; }
		#recv(NEW_SOCKET, $request);
		print "\n", $id, ": Connection recieved from $name\n";
		print "Request is <$request>\n";
		#print NEW_SOCKET "Smile from the server";
		my $response = mkresponse($request);
		#print $response;
		print NEW_SOCKET $response;
		close NEW_SOCKET;
		$id++;
	}
}

sub main() {
	# example argument parsing from
	# https://codereview.stackexchange.com/questions/64753/parsing-command-line-arguments-in-perl
	my $server =0;
	while (@ARGV) {
		for(shift(@ARGV)) {
			($_ eq '-s' || $_ eq '--server') && do { $server = 1; }
		}
	}

	if($server) {
		via_socket();
	} else {
		via_stdio();
		#print "Run as stdio";
	}

}

main();
#######################################################