From f066b86199d45c1f19e5e9b11c4ff072d682c35c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 29 May 2026 02:36:00 +0200 Subject: [PATCH] Several improvements --- cert.pl | 80 ++++++++++++++++++++++++++++ config.pl | 31 ++++++----- gemyer.pl | 92 ++++++++++++++++++++++++++++++++ launch | 14 ----- main.pl | 150 ---------------------------------------------------- mime.pl | 113 ++++++++++++++++++++++++--------------- request.pl | 22 +++++++- response.pl | 60 ++++++++++++++++++++- 8 files changed, 338 insertions(+), 224 deletions(-) create mode 100644 cert.pl create mode 100755 gemyer.pl delete mode 100755 launch delete mode 100644 main.pl diff --git a/cert.pl b/cert.pl new file mode 100644 index 0000000..082556b --- /dev/null +++ b/cert.pl @@ -0,0 +1,80 @@ +:- module(cert, [load_certificate/1, with_tls_connection/3]). + +:- use_module(config). +:- use_module(library(dcgs)). +:- use_module(library(tls)). +:- use_module(library(process)). +:- use_module(library(files)). +:- use_module(library(lists)). +:- use_module(library(iso_ext)). +:- use_module(library(debug)). +:- use_module(library(pio)). +:- use_module(log). + +load_certificate(Context) :- + load_existing_certificate(Context) + ; + create_new_certificate(Context). + +load_existing_certificate(Context) :- + cert(Cert), + hostname(Hostname), + log_msg("tls", "Loading certificate from `~s`~n", [Cert]), + file_exists(Cert), + ( cert_is_for_hostname(Cert, Hostname) ; + append(Cert, ".bak", Cert1), + log_msg("error", "Certificate `~s` is not for hostname `~s`. Renaming it to `~s`~n", [Cert, Hostname, Cert1]), + rename_file(Cert, Cert1), + fail + ), + phrase_from_file(seq(Chars), Cert, [type(binary)]), + tls_server_context(Context, [pcks12(Chars)]), + log_msg("tls", "Loaded certificate~n", []). + +cert_is_for_hostname(Cert, Hostname) :- + process_create("openssl", + ["pkcs12", "-in", Cert, "-nokeys", "-passin", "pass:"], + [stdin(null), stdout(pipe(S)), stderr(null), process(P)] + ), + process_wait(P, _), + phrase_from_stream(cn(Hostname), S). + +cn(Hostname) --> ... , "CN=", seq(Hostname), ... . + +create_new_certificate(Context) :- + hostname(Hostname), + log_msg("tls", "Generating new certificate for host `~s`~n", [Hostname]), + append("/CN=", Hostname, Hostname1), + process_create("openssl", + ["req", "-x509", "-newkey", "rsa:4096", "-nodes", "-keyout", "key.pem", "-out", "cert.pem", "-days", "365", "-subj", Hostname1], + [stdin(null), stdout(null), stderr(null), process(P0)] + ), + process_wait(P0, _), + + cert(Cert), + process_create("openssl", + ["pkcs12", "-export", "-out", Cert, "-inkey", "key.pem", "-in", "cert.pem", "-passout", "pass:"], + [stdin(null), stdout(null), stderr(null), process(P1)] + ), + process_wait(P1, _), + delete_file("key.pem"), + delete_file("cert.pem"), + log_msg("tls", "Generated new certificate: `~s`~n", [Cert]), + load_existing_certificate(Context). + + +:- meta_predicate(with_tls_connection(?, ?, 1)). + +%% with_tls_connection(+Stream, +Context, +F_1) +% +% Open a TLS connection on Stream with Context and pass it to F_1 +with_tls_connection(S0, Context, Kont) :- + setup_call_cleanup( + ( log_msg("tls-conn", "Received connection, authenticating TLS~n", []), + tls_server_negotiate(Context, S0, S) + ), + call(Kont, S), + ( log_msg("tls-conn", "Closing TLS stream~n", []), + close(S) + ) + ). diff --git a/config.pl b/config.pl index 3fc7192..fe60a4d 100644 --- a/config.pl +++ b/config.pl @@ -1,14 +1,16 @@ -:- module(config, [cert/1, addr/1, port/1, content/1, hostname/1, load_config/0]). +:- module(config, [cert/1, addr/1, port/1, content/1, hostname/1]). -:- use_module(library(os), [argv/1]). -:- use_module(library(iso_ext), [forall/2]). +:- use_module(library(os)). +:- use_module(library(iso_ext)). :- use_module(library(dcgs)). :- use_module(library(lists)). :- dynamic(cfg/2). +:- initialization(load_config). + %% Defaults — applied first, then overridden by any CLI args. -default(cert, "identity.p12"). +default(cert, "./identity.p12"). default(addr, '127.0.0.1'). default(port, 1965). default(content, "./site"). @@ -36,6 +38,7 @@ hostname(V) :- cfg(hostname, V). load_config :- install_defaults, argv(Args), + phrase(options(Opts), Args), apply_opts(Opts). @@ -46,19 +49,21 @@ install_defaults :- 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]. +option(addr(Addr)) --> ["--addr", A], { atom_chars(Addr, A) }. +option(port(Port)) --> ["--port", P], { number_chars(Port, P) }. +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(addr(A)) :- set_cfg(addr, A). +apply_opt(port(P)) :- 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) :- diff --git a/gemyer.pl b/gemyer.pl new file mode 100755 index 0000000..007b88a --- /dev/null +++ b/gemyer.pl @@ -0,0 +1,92 @@ +/*usr/bin/env true + +set -eu + +type scryer-prolog > /dev/null 2> /dev/null \ + && exec scryer-prolog -f -g "gemyer:run, halt" "$0" -- "$@" + +echo "No known supported Prolog implementation available in PATH." +echo "Try to install Scryer Prolog." +exit 1 +#*/ + +:- module(gemyer, [run/0]). + +:- use_module(cert). +:- use_module(config). +:- use_module(library(charsio)). +:- use_module(library(clpz)). +:- use_module(library(dcgs)). +:- use_module(library(files)). +:- use_module(library(iso_ext)). +:- use_module(library(lists)). +:- use_module(library(pio)). +:- use_module(library(sockets)). +:- use_module(library(tls)). +:- use_module(log). +:- use_module(mime). +:- use_module(request). +:- use_module(response). + +run :- + log_msg("system", "Starting gemyer~n", []), + content(Site), + log_msg("system", "Serving capsule at `~s`~n", [Site]), + hostname(Hostname), + log_msg("system", "Listening on hostname `~s`~n", [Hostname]), + load_certificate(Context), + !, + catch( + with_socket(Context, with_connection_loop, req_serve), + Error, + handle_top_level_error(Error) + ). + +handle_top_level_error(error('$interrupt_thrown', _)) :- !, + log_msg("system", "Shutting down~n", []), + log_msg("system", "Adios!~n", []), + halt(0). +handle_top_level_error(Error) :- + log_msg("error", "Unhandled top-level: ~q~n", [Error]), + halt(1). + +with_socket(Context, Kont, Kont2) :- + addr(Addr), + port(Port), + ( setup_call_cleanup( + (log_msg("tcp", "Opening socket ~q~n", [Addr:Port]), + socket_server_open(Addr:Port, Socket) + ), + call(Kont, Context, Socket, Kont2), + (log_msg("tcp", "Closing socket~n", []), + socket_server_close(Socket) + ) + ) + ; + log_msg("error", "Can't bind socket ~q~n", [Addr:Port]) + ). + +with_connection_loop(Context, Socket, Kont) :- + catch( + setup_call_cleanup( + socket_server_accept(Socket, _, S0, []), + with_tls_connection(S0, Context, Kont), + close(S0) + ), + Error, + handle_conn_error(Error) + ), + with_connection_loop(Context, Socket, Kont). + +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) :- + % log_msg("debug", "Re-throwing from conn loop: ~q~n", [Error]), + throw(Error). + +req_serve(S) :- + read_request(S, Path, Query), + serve(S, Path, Query), + !. diff --git a/launch b/launch deleted file mode 100755 index f680d18..0000000 --- a/launch +++ /dev/null @@ -1,14 +0,0 @@ -#!/bin/bash - -# 1. Al pulsar Ctrl+C, disparamos netcat para despertar al accept -# y luego matamos el proceso de Scryer que dejamos guardado en $SCRYER_PID -trap 'echo " Deteniendo servidor Gemini..."; nc -z localhost 1965 > /dev/null 2>&1; kill $SCRYER_PID 2>/dev/null; exit 0' INT - -# 2. Lanzamos Scryer Prolog en SEGUNDO PLANO (&) -scryer-prolog main.pl & - -# 3. Guardamos el ID del proceso (PID) de Scryer -SCRYER_PID=$! - -# 4. Nos quedamos esperando a que Scryer termine (wait mantiene el trap activo) -wait $SCRYER_PID diff --git a/main.pl b/main.pl deleted file mode 100644 index 1677d2f..0000000 --- a/main.pl +++ /dev/null @@ -1,150 +0,0 @@ - -:- use_module(library(charsio)). -:- use_module(library(dcgs)). -:- use_module(library(sockets)). -:- use_module(library(tls)). -:- use_module(library(pio)). -:- use_module(library(clpz)). -:- use_module(library(lists)). -:- use_module(library(files)). -:- use_module(library(iso_ext)). - -:- use_module('./request'). -:- use_module('./response'). -:- use_module('./log'). -:- use_module('./config'). -:- use_module('./mime'). - -% ------------------------------------------------------------------------------ - -load_certificate(Context) :- - cert(Cert), - log_msg("tls", "Loading certificate from ~s~n", [Cert]), - phrase_from_file(seq(Chars), Cert, [type(binary)]), - tls_server_context(Context, [pcks12(Chars)]), - log_msg("tls", "Loaded certificate~n", []). - -with_socket(Context, Kont) :- - addr(Addr), - port(Port), - setup_call_cleanup( - (log_msg("tcp", "Opening socket ~q~n", [Addr:Port]), - socket_server_open(Addr:Port, Socket) - ), - call(Kont, Context, Socket), - (log_msg("tcp", "Closing socket~n", []), - socket_server_close(Socket) - ) - ). - -loop(Context, Socket) :- - 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", []), - tls_server_negotiate(Context, S0, S) - ), - call(Kont, S), - ( log_msg("tls-conn", "Closing TLS stream~n", []), - close(S) - ) - ). - -req_serve(S) :- - read_request(S, RequestChars), - log_msg("request", "Received raw request: ~s", [RequestChars]), - phrase(request(uri(_, _, Path, Query)), RequestChars), - ( serve(S, Path, Query) - ; log_msg("error", "File not found~n", []), - phrase(response(not_found, "File not found, sorry"), Response0), - format(S, "~s", [Response0]) - ), - !. - -main :- - log_msg("system", "Starting gemyer~n", []), - load_config, - load_mime, - assertz(mime("gmi", "text/gemini")), - load_certificate(Context), - with_socket(Context, loop). - -serve(S, /, Q) :- - serve(S, '/index.gmi', Q). -serve(S, Path, _) :- - atom_chars(Path, Chars), - reverse(Chars, Chars1), - ( append([Ext0, ".", _], Chars1), - reverse(Ext0, Ext), - mime(Ext, Mime) ; - Mime = "application/octet-stream" - ), - !, - log_msg("response", "Mime identified as ~s~n", [Mime]), - content(Root), - append(Root, Chars, File), - file_exists(File), - log_msg("response", "File does exist~n", []), - ( append("text/", _, Mime) -> - - phrase_from_file(seq(Body), File), - log_msg("response", "Sending text response~n", []), - phrase(response(success, Mime), Response0), - format(S, "~s", [Response0]), - format(S, "~s", [Body]), - log_msg("response", "Sent text response~n", []) - ; - setup_call_cleanup( - open(File, read, FileStream, [type(binary)]), - ( - log_msg("response", "Sending binary response~n", []), - phrase(response(success, Mime), Response0), - 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) - ) - ) - . - -path_gemtext(/, File) :- - content(Root), - append(Root, "/index.gmi", File). -path_gemtext(Atom, File) :- - atom_chars(Atom, Chars), - append(_, ".gmi", Chars), - content(Root), - append(Root, Chars, File). - -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, - N1 #= N - 1, - get_char(Stream, Cnext), - read_request_(N1, Cnext, Stream, Cs). - -:- initialization(main). diff --git a/mime.pl b/mime.pl index 2410508..ba378af 100644 --- a/mime.pl +++ b/mime.pl @@ -1,60 +1,85 @@ -:- module(mime, [load_mime/0]). +:- module(mime, [load_mime/0, mime/2, guess_mime/2]). :- use_module(library(pio)). :- use_module(library(dcgs)). :- use_module(library(lists)). +:- use_module(log). :- dynamic(mime/2). +:- initialization(load_mime). + %% 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. +% Reads `/etc/mime.types` and assertz's `mime(Extension, MimeType)` 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). + phrase(mime_file(Entries), Chars), + assert_entries(Entries), + assertz(mime("gmi", "text/gemini")). + +assert_entries([]). +assert_entries([Mime-Exts|Rest]) :- + assert_exts(Exts, Mime), + assert_entries(Rest). assert_exts([], _). assert_exts([Ext|Exts], Mime) :- - assertz(user:mime(Ext, Mime)), + assertz(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]). +% ---------------------------------------------------------------------------- +% DCG for /etc/mime.types +% +% mime_file//1 walks the whole file one line at a time: +% * line//2 — a valid ` [ ...]` line; yields Mime-Exts. +% * skip_line// — anything else (comments, blanks, malformed lines). +% ---------------------------------------------------------------------------- + +mime_file([]) --> []. +mime_file([Mime-Exts|Es]) --> line(Mime, Exts), mime_file(Es). +mime_file(Es) --> skip_line, mime_file(Es). + +line(Mime, [E|Exts]) --> + token(Mime), + { Mime \= ['#'|_] }, + ws_plus, + token(E), + extensions(Exts), + line_end. + +extensions([]) --> ws_star. +extensions([E|Es]) --> ws_plus, token(E), extensions(Es). + +skip_line --> line_end. +skip_line --> [_], skip_line. + +line_end --> "\n". + +token([C|Cs]) --> [C], { non_ws(C) }, token_rest(Cs). +token_rest([]) --> []. +token_rest([C|Cs])--> [C], { non_ws(C) }, token_rest(Cs). + +ws_plus --> ws_char, ws_star. +ws_star --> []. +ws_star --> ws_char, ws_star. + +ws_char --> " ". +ws_char --> "\t". +ws_char --> "\r". + +non_ws(C) :- C \= ' ', C \= '\t', C \= '\n', C \= '\r'. + +% ---------------------------------------------------------------------------- + +guess_mime(Chars, Mime) :- + reverse(Chars, Chars1), + ( append([Ext0, ".", _], Chars1), + reverse(Ext0, Ext), + mime(Ext, Mime) + ; Mime = "application/octet-stream" + ), + log_msg("response", "Mime identified as ~s~n", [Mime]). diff --git a/request.pl b/request.pl index 630a9dc..00e1d90 100644 --- a/request.pl +++ b/request.pl @@ -1,7 +1,25 @@ -:- module(request, [request//1]). +:- module(request, [read_request/3]). +:- use_module(gemini_uri). +:- use_module(library(clpz)). :- use_module(library(dcgs)). -:- use_module('./gemini_uri'). +:- use_module(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), + log_msg("request", "Received raw request: ~s", [Chars]), + phrase(request(uri(_, _, Path, Query)), Chars). + +read_request_(N, '\n', _, ['\n']) :- N #> 0, !. % End of the request reached +read_request_(N, C, Stream, [C|Cs]) :- + N #> 0, + N1 #= N - 1, + get_char(Stream, Cnext), + read_request_(N1, Cnext, Stream, Cs). request(uri(Host, Port, Path, Query)) --> gemini_uri(Host, Port, Path, Query), diff --git a/response.pl b/response.pl index 7497785..a4acf3c 100644 --- a/response.pl +++ b/response.pl @@ -1,6 +1,64 @@ -:- module(response, [response//1, response//2]). +:- module(response, [serve/3]). +:- use_module(config). :- use_module(library(dcgs)). +:- use_module(library(files)). +:- use_module(library(iso_ext)). +:- use_module(library(lists)). +:- use_module(library(pio)). +:- use_module(library(sockets)). +:- use_module(log). +:- use_module(mime). + +%% serve(+Stream, +Path, +Query) +% +% Serve the file at Path to Stream +serve(S, /, Q) :- + serve(S, '/index.gmi', Q). +serve(S, Path, _) :- + atom_chars(Path, Chars), + ( is_absolute(Chars), + guess_mime(Chars, Mime), + content(Root), + append(Root, Chars, File), + file_exists(File), + log_msg("response", "File does exist~n", []), + ( serve_text(S, Mime, File) + ; serve_binary(S, Mime, File) + ) + ; + log_msg("error", "File not found~n", []), + phrase(response(not_found, "File not found, sorry"), Response0), + format(S, "~s", [Response0]) + ). + +is_absolute(Path) :- + \+ append([_, "..", _], Path). + +serve_text(S, Mime, File) :- + append("text/", _, Mime), + phrase_from_file(seq(Body), File), + log_msg("response", "Sending text response~n", []), + phrase(response(success, Mime), Response0), + format(S, "~s", [Response0]), + format(S, "~s", [Body]), + log_msg("response", "Sent text response~n", []). + +serve_binary(S, Mime, File) :- + setup_call_cleanup( + open(File, read, FileStream, [type(binary)]), + ( + log_msg("response", "Sending binary response~n", []), + phrase(response(success, Mime), Response0), + 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) + ). crlf --> "\r\n". sp --> " ". -- 2.54.0