From: Javier Sagredo Date: Thu, 28 May 2026 22:25:58 +0000 (+0200) Subject: Updates X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=981fb256f68a8f1f218b61bb64bd46894b3662c5;p=sula.git Updates --- diff --git a/config.pl b/config.pl index e5837b4..3fc7192 100644 --- a/config.pl +++ b/config.pl @@ -1,6 +1,72 @@ -:- module(config, [cert/1, addr/1, port/1, site/1]). +:- module(config, [cert/1, addr/1, port/1, content/1, hostname/1, load_config/0]). -cert("identity.p12"). -addr('127.0.0.1'). -port(1965). -site("./site"). +:- use_module(library(os), [argv/1]). +:- use_module(library(iso_ext), [forall/2]). +:- use_module(library(dcgs)). +:- use_module(library(lists)). + +:- dynamic(cfg/2). + +%% Defaults — applied first, then overridden by any CLI args. +default(cert, "identity.p12"). +default(addr, '127.0.0.1'). +default(port, 1965). +default(content, "./site"). +default(hostname, "localhost"). + +% Public accessors are static rules over the dynamic cfg/2, so they remain +% importable via use_module/1 even as values get retracted/asserted. +cert(V) :- cfg(cert, V). +addr(V) :- cfg(addr, V). +port(V) :- cfg(port, V). +content(V) :- cfg(content, V). +hostname(V) :- cfg(hostname, V). + +%% load_config. +% +% Reads command-line arguments (everything after `--`) via os:argv/1 and +% updates the config facts. Recognised options, accepted in any order: +% +% --addr HOST:PORT bind address and port +% --hostname NAME server hostname +% --content DIR content root directory +% --certs DIR certificate directory (expects DIR/identity.p12) +% +% Unrecognised arguments are ignored. +load_config :- + install_defaults, + argv(Args), + phrase(options(Opts), Args), + apply_opts(Opts). + +install_defaults :- + retractall(cfg(_, _)), + forall(default(K, V), assertz(cfg(K, V))). + +options([]) --> []. +options([Opt|Opts]) --> option(Opt), options(Opts). + +option(addr_port(Addr, Port)) --> ["--addr", AP], { parse_addr_port(AP, Addr, Port) }. +option(hostname(H)) --> ["--hostname", H]. +option(content(C)) --> ["--content", C]. +option(certs(D)) --> ["--certs", D]. +option(unknown(X)) --> [X]. + +apply_opts([]). +apply_opts([Opt|Opts]) :- apply_opt(Opt), apply_opts(Opts). + +apply_opt(addr_port(A, P)) :- set_cfg(addr, A), set_cfg(port, P). +apply_opt(hostname(H)) :- set_cfg(hostname, H). +apply_opt(content(C)) :- set_cfg(content, C). +apply_opt(certs(D)) :- append(D, "/identity.p12", Cert), set_cfg(cert, Cert). +apply_opt(unknown(_)). + +set_cfg(Key, Value) :- + retractall(cfg(Key, _)), + assertz(cfg(Key, Value)). + +parse_addr_port(Chars, Addr, Port) :- + append(AddrChars, [':'|PortChars], Chars), + !, + atom_chars(Addr, AddrChars), + number_chars(Port, PortChars). diff --git a/main.pl b/main.pl index 2315579..1677d2f 100644 --- a/main.pl +++ b/main.pl @@ -13,6 +13,7 @@ :- use_module('./response'). :- use_module('./log'). :- use_module('./config'). +:- use_module('./mime'). % ------------------------------------------------------------------------------ @@ -37,13 +38,23 @@ with_socket(Context, Kont) :- ). loop(Context, Socket) :- - setup_call_cleanup( - socket_server_accept(Socket, _, S0, []), - with_tls_connection(S0, Context, req_serve), - close(S0) + catch( + setup_call_cleanup( + socket_server_accept(Socket, _, S0, []), + with_tls_connection(S0, Context, req_serve), + close(S0) + ), + Error, + handle_conn_error(Error) ), loop(Context, Socket). +handle_conn_error(error(permission_error(open, source_sink, _), tls_server_negotiate/3)) :- !, + log_msg("error", "TLS handshake failed~n", []). +handle_conn_error(error(existence_error(stream, _), _)) :- !, + log_msg("error", "Client disconnected~n", []). +handle_conn_error(Error) :- throw(Error). + with_tls_connection(S0, Context, Kont) :- setup_call_cleanup( ( log_msg("tls-conn", "Received connection, authenticating TLS~n", []), @@ -62,17 +73,15 @@ req_serve(S) :- ( serve(S, Path, Query) ; log_msg("error", "File not found~n", []), phrase(response(not_found, "File not found, sorry"), Response0), - format(S, "~s\r\n", [Response0]) + format(S, "~s", [Response0]) ), !. -load_mime :- - assertz(mime("gmi", "text/gemini")), - assertz(mime("xz", "application/x-xz")). - main :- log_msg("system", "Starting gemyer~n", []), + load_config, load_mime, + assertz(mime("gmi", "text/gemini")), load_certificate(Context), with_socket(Context, loop). @@ -88,7 +97,8 @@ serve(S, Path, _) :- ), !, log_msg("response", "Mime identified as ~s~n", [Mime]), - append("site", Chars, File), + content(Root), + append(Root, Chars, File), file_exists(File), log_msg("response", "File does exist~n", []), ( append("text/", _, Mime) -> @@ -96,7 +106,7 @@ serve(S, Path, _) :- phrase_from_file(seq(Body), File), log_msg("response", "Sending text response~n", []), phrase(response(success, Mime), Response0), - format(S, "~s\r\n", [Response0]), + format(S, "~s", [Response0]), format(S, "~s", [Body]), log_msg("response", "Sent text response~n", []) ; @@ -105,8 +115,11 @@ serve(S, Path, _) :- ( log_msg("response", "Sending binary response~n", []), phrase(response(success, Mime), Response0), - format(S, "~s\r\n", [Response0]), - stream_bytes(FileStream, S), + format(S, "~s", [Response0]), + open(stream(S), write, _, [type(binary)]), + 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) @@ -114,22 +127,14 @@ serve(S, Path, _) :- ) . -stream_bytes(FileStream, Socket) :- - BlockSize = 4096, - get_n_chars(FileStream, BlockSize, Chars), - ( Chars == [] -> - true - ; format(Socket, "~s", [Chars]), - stream_bytes(FileStream, Socket) - ). - path_gemtext(/, File) :- - site(Site), - append(Site, "/index.gmi", File). + content(Root), + append(Root, "/index.gmi", File). path_gemtext(Atom, File) :- atom_chars(Atom, Chars), append(_, ".gmi", Chars), - append("site", Chars, File). + content(Root), + append(Root, Chars, File). read_request(Stream, Chars) :- get_char(Stream, C), diff --git a/mime.pl b/mime.pl new file mode 100644 index 0000000..2410508 --- /dev/null +++ b/mime.pl @@ -0,0 +1,60 @@ +:- module(mime, [load_mime/0]). + +:- use_module(library(pio)). +:- use_module(library(dcgs)). +:- use_module(library(lists)). + +:- dynamic(mime/2). + +%% load_mime. +% +% Reads `/etc/mime.types` and assertz's `mime(Extension, MimeType)` (in the +% `user` module) for every (extension, mime-type) pair found in the file. +% Both arguments are lists of characters. Comment lines (starting with `#`), +% blank lines, and entries with no extensions are skipped. +load_mime :- + phrase_from_file(seq(Chars), "/etc/mime.types"), + lines(Chars, Lines), + load_entries(Lines). + +load_entries([]). +load_entries([Line|Lines]) :- + ( parse_entry(Line, Mime, Exts) + -> assert_exts(Exts, Mime) + ; true + ), + load_entries(Lines). + +assert_exts([], _). +assert_exts([Ext|Exts], Mime) :- + assertz(user:mime(Ext, Mime)), + assert_exts(Exts, Mime). + +parse_entry(['#'|_], _, _) :- !, fail. +parse_entry(Line, Mime, Exts) :- + tokens(Line, [Mime|Exts]), + Exts = [_|_]. + +tokens(Cs, Tokens) :- + skip_ws(Cs, Cs1), + ( Cs1 = [] + -> Tokens = [] + ; take_token(Cs1, Tok, Rest), + Tokens = [Tok|Rest1], + tokens(Rest, Rest1) + ). + +skip_ws([C|Cs], Rest) :- ws(C), !, skip_ws(Cs, Rest). +skip_ws(Cs, Cs). + +take_token([], [], []). +take_token([C|Cs], [], [C|Cs]) :- ws(C), !. +take_token([C|Cs], [C|Tok], Rest) :- take_token(Cs, Tok, Rest). + +ws(' '). +ws('\t'). +ws('\r'). + +lines([], [[]]). +lines(['\n'|Cs], [[]|Lines]) :- !, lines(Cs, Lines). +lines([C|Cs], [[C|Line]|Lines]) :- lines(Cs, [Line|Lines]).