From: Javier Sagredo Date: Tue, 23 Jun 2026 23:50:06 +0000 (+0200) Subject: Multiple improvements X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=46cc8ea5cf6499e67e5722d2a4c853bb1e94ef91;p=sula.git Multiple improvements --- diff --git a/dcgs/gemini_uri.pl b/dcgs/gemini_uri.pl index 2f5f547..2121d55 100644 --- a/dcgs/gemini_uri.pl +++ b/dcgs/gemini_uri.pl @@ -43,7 +43,7 @@ digits([]) --> []. path(Path) --> "/", path_abempty(Chars), - { atom_chars(Path, ['/'|Chars]) }. + { Path = ['/'|Chars] }. path('/') --> []. path_abempty([C|Cs]) --> ( pchar(C) ; "/" , { C = (/)} ), !, path_abempty(Cs). diff --git a/request.pl b/request.pl index d87c976..eaefdec 100644 --- a/request.pl +++ b/request.pl @@ -1,19 +1,38 @@ :- 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, @@ -26,3 +45,8 @@ request(uri(Host, Port, Path, Query)) --> crlf. crlf --> "\r\n". + +is_absolute(Path) :- + path_segments(Path, Segs), + \+ member("..", Segs), + \+ member(".", Segs). diff --git a/serve.pl b/serve.pl index be0c69e..80bbbb2 100644 --- a/serve.pl +++ b/serve.pl @@ -4,7 +4,6 @@ :- 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)). @@ -16,31 +15,21 @@ %% 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), @@ -59,7 +48,7 @@ serve_binary(S, Mime, File) :- 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", []) @@ -67,11 +56,12 @@ serve_binary(S, Mime, File) :- 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). diff --git a/sula.pl b/sula.pl index 29f3e25..93b52a1 100755 --- a/sula.pl +++ b/sula.pl @@ -71,39 +71,21 @@ with_socket(Context, Kont, Kont2) :- ). 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. @@ -116,8 +98,15 @@ handle_conn_error(Error) :- 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]) + ) + ) + ). diff --git a/sys/tls_certs.pl b/sys/tls_certs.pl index 8cf4304..84e64d2 100644 --- a/sys/tls_certs.pl +++ b/sys/tls_certs.pl @@ -70,7 +70,9 @@ with_tls_connection(S0, Context, Kont) :- 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", []),