path(Path) -->
"/",
path_abempty(Chars),
- { atom_chars(Path, ['/'|Chars]) }.
+ { Path = ['/'|Chars] }.
path('/') --> [].
path_abempty([C|Cs]) --> ( pchar(C) ; "/" , { C = (/)} ), !, path_abempty(Cs).
:- module(request, [read_request/3]).
+:- use_module(config).
:- use_module(dcgs/gemini_uri).
+:- use_module(dcgs/response).
:- use_module(library(clpz)).
:- use_module(library(dcgs)).
+:- use_module(library(files)).
+:- use_module(library(lists)).
:- use_module(ui/log).
%% read_request(+Stream, -Path, -Query)
%
% Read a request from Stream and get the Path and Query parts
read_request(Stream, Path, Query) :-
- get_char(Stream, C),
- read_request_(1023, C, Stream, Chars),
+ read_request_(Stream, Chars),
log_msg("request", "Received raw request: ~s", [Chars]),
- phrase(request(uri(_, _, Path, Query)), Chars).
+ once( ( phrase(request(uri(Hostname, Port, Path, Query)), Chars)
+ ; throw(gemini_error(bad_request, "Malformed request"))
+ )
+ ),
+ once( ( is_absolute(Path)
+ ; log_msg("error", "Non-absolute path requested~n", []),
+ throw(gemini_error(bad_request, "Non-absolute paths are forbidden"))
+ )
+ ),
+ ( hostname(Hostname),
+ port(Port)
+ ; log_msg("error", "Received request for an unknown hostname!~n", []),
+ throw(gemini_error(bad_request, "This request is not for me!"))
+ ).
+read_request_(Stream, Chars) :-
+ get_char(Stream, C),
+ read_request_(1023, C, Stream, Chars).
read_request_(N, '\n', _, ['\n']) :- N #> 0, !. % End of the request reached
read_request_(N, C, Stream, [C|Cs]) :-
N #> 0,
crlf.
crlf --> "\r\n".
+
+is_absolute(Path) :-
+ path_segments(Path, Segs),
+ \+ member("..", Segs),
+ \+ member(".", Segs).
:- use_module(dcgs/response).
:- use_module(library(charsio)).
:- use_module(library(dcgs)).
-:- use_module(library(debug)).
:- use_module(library(files)).
:- use_module(library(iso_ext)).
:- use_module(library(lists)).
%% serve(+Stream, +Root, +Path, -Query)
%
% Serve the file at Path to Stream
-serve(S, Root, /, Q) :-
- serve(S, Root, '/index.gmi', Q).
+serve(S, Root, "/", Q) :-
+ serve(S, Root, "/index.gmi", Q).
serve(S, Root, Path, _) :-
- atom_chars(Path, Chars),
- ( is_absolute(Chars)
- -> guess_mime(Chars, Mime),
- append(Root, Chars, File),
- ( file_exists(File)
- -> log_msg("response", "File does exist~n", []),
- ( serve_text(S, Mime, File)
+ guess_mime(Path, Mime),
+ append(Root, Path, File),
+ once( ( file_exists(File)
+ ; log_msg("error", "File not found~n", []),
+ throw(gemini_error(not_found, "File not found!"))
+ )
+ ),
+ log_msg("response", "File does exist~n", []),
+ once( ( serve_text(S, Mime, File)
; serve_binary(S, Mime, File)
)
- ; log_msg("error", "File not found~n", []),
- phrase(response(not_found, "File not found!"), Response0),
- format(S, "~s", [Response0])
- )
- ; log_msg("error", "Non-absolute path requested~n", []),
- phrase(response(bad_request, "Non-absolute paths are forbidden!"), Response0),
- format(S, "~s", [Response0])
- ).
-
-is_absolute(Path) :-
- path_segments(Path, Segs),
- \+ member("..", Segs),
- \+ member(".", Segs).
+ ).
serve_text(S, Mime, File) :-
append("text/", _, Mime),
phrase(response(success, Mime), Response0),
format(S, "~s", [Response0]),
open(stream(S), write, _, [type(binary)]),
- catch(src_dest(FileStream, S),
+ catch(copy_stream(FileStream, S),
error(existence_error(stream, _), _),
log_msg("response", "Client disconnected mid-stream~n", [])),
log_msg("response", "Sent binary response~n", [])
close(FileStream)
).
-src_dest(FileStream, DestStream) :-
+copy_stream(FileStream, DestStream) :-
get_n_chars(FileStream, 4096, Chars),
( Chars = [] -> true
; phrase_to_stream(seq(Chars), DestStream),
- false).
+ false
+ ).
-src_dest(FileStream, DestStream) :-
+copy_stream(FileStream, DestStream) :-
src_dest(FileStream, DestStream).
).
with_connection_loop(Context, Socket, Kont) :-
- % Failure-driven loop: Scryer has no heap GC and only reclaims the global
- % stack on backtracking. Handling each connection inside `repeat`/`fail`
- % means we backtrack to `repeat` after every request, which truncates the
- % heap (including the whole file slurped by phrase_from_file) back to a
- % fixed point. A plain recursive loop would never reclaim it and RSS would
- % grow without bound. The if-then-else commits the connection handler's
- % choicepoints whether it succeeds or fails, then `fail` triggers the
- % heap-reclaiming backtrack to `repeat`.
- %
- % NOTE: a small residual growth (~4-8 KB/request) remains and is expected.
- % Each connection allocates TCP + TLS stream objects in Scryer's arena,
- % which is append-only and only freed at process exit (no incremental
- % sweep, and backtracking does not reclaim it). This is a Scryer
- % limitation, not a bug here; mitigate operationally (periodic restart or
- % a systemd MemoryMax= with Restart=always).
repeat,
- ( catch(
- setup_call_cleanup(
- (
- log_msg("tcp", "Accepting connections...~n", []),
- socket_server_accept(Socket, Client, S0, []),
- log_msg("tcp", "Connected client ~q~n", [Client])
- ),
- with_tls_connection(S0, Context, Kont),
- ( close(S0),
- log_msg("tcp", "Closed connection for client ~q~n", [Client])
- )
+ catch(
+ setup_call_cleanup(
+ (
+ log_msg("tcp", "Accepting connections...~n", []),
+ socket_server_accept(Socket, Client, S0, []),
+ log_msg("tcp", "Connected client ~q~n", [Client])
),
- Error,
- handle_conn_error(Error)
- )
- -> true
- ; true
+ with_tls_connection(S0, Context, Kont),
+ ( close(S0),
+ log_msg("tcp", "Closed connection for client ~q~n", [Client])
+ )
+ ),
+ Error,
+ handle_conn_error(Error)
),
fail.
throw(Error).
req_serve(S, ClientCert) :-
- read_request(S, Path, Query),
- save_client(ClientCert),
- content(Root),
- serve(S, Root, Path, Query),
- !.
+ once(catch(
+ ( read_request(S, Path, Query),
+ save_client(ClientCert),
+ content(Root),
+ serve(S, Root, Path, Query)
+ ),
+ gemini_error(DCG, Msg),
+ ( phrase(response(DCG, Msg), Response0),
+ format(S, "~s", [Response0])
+ )
+ )
+ ).
setup_call_cleanup(
( log_msg("tls-conn", "Handshaking TLS~n", []),
tls_server_negotiate(Context, S0, S, [client_certificate(ClientCert)]),
- log_msg("tls-conn", "Client cert ~q~n", [ClientCert])
+ ( \+ ClientCert = none, log_msg("tls-conn", "Client cert ~q~n", [ClientCert])
+ ; true
+ )
),
call(Kont, S, ClientCert),
( log_msg("tls-conn", "Closing TLS stream~n", []),
projects / sula.git / commitdiff