From: Javier Sagredo Date: Mon, 8 Jun 2026 23:07:20 +0000 (+0200) Subject: More features X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=90cae19ec4f02da6089831aba5abf5aee0c0ef6a;p=sula.git More features --- diff --git a/.gitignore b/.gitignore index 5efcf51..9a7264b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,6 @@ cert.pem key.pem -site \ No newline at end of file +site +*.bak +clients_db.pl +site.pl \ No newline at end of file diff --git a/README.md b/README.md index 0bb23e9..13f4e3c 100644 --- a/README.md +++ b/README.md @@ -109,7 +109,8 @@ banner.pl Reads banner.txt and emits it line-by-line via display_banner/1. - [x] Use key and cert instead of identity.p12 - [x] Client certificates -- [ ] Load configuration from a configuration file +- [x] Load configuration from a configuration file +- [x] Save and load users - [ ] Run CGI scripts - [ ] All status codes - [ ] Rate limiting diff --git a/banner.pl b/banner.pl index b9ae7a4..2dd689b 100644 --- a/banner.pl +++ b/banner.pl @@ -1,15 +1,14 @@ -:- module(banner, [display_banner/1]). +:- module(banner, [display_banner/0]). :- use_module(library(dcgs)). :- use_module(library(lists)). +:- use_module(library(lambda)). :- use_module(library(pio)). +:- use_module(log). -:- meta_predicate(display_banner(1)). - -display_banner(F_1) :- +display_banner :- phrase_from_file(lines(Ls), "banner.txt"), - maplist(F_1, Ls), - call(F_1, ""). + maplist(\S^log_msg("system", "~s~n", [S]), Ls). lines([]) --> call(eos), !. lines([L|Ls]) --> line(L), lines(Ls). diff --git a/clients.pl b/clients.pl new file mode 100644 index 0000000..df66a3f --- /dev/null +++ b/clients.pl @@ -0,0 +1,45 @@ +:- module(clients, [save_client/1, load_clients/0]). + +:- use_module(log). +:- use_module(library(files)). +:- use_module(library(pio)). +:- use_module(library(iso_ext)). + +:- dynamic(known_client/1). + +load_clients :- + log_msg("clients", "Loading client database~n", []), + catch( + setup_call_cleanup( + open("clients_db.pl", read, S), + read_clients(S), + close(S) + ), + error(existence_error(source_sink,"clients_db.pl"),open/4), + (open("clients_db.pl", write, S), + close(S)) + ). + +read_clients(Stream) :- + read_term(Stream, Term, []), + ( Term == end_of_file + -> true + ; assertz(Term), + read_clients(Stream) + ). + +save_client(none). +save_client(ClientCert) :- + known_client(ClientCert), + log_msg("clients", "Known client ~q~n", [ClientCert]) + ; + log_msg("clients", "Registering new client with cert ~q~n", [ClientCert]), + setup_call_cleanup( + open("clients_db.pl", append, S), + (write(S, known_client(ClientCert)), + put_char(S, (.)), + put_char(S, '\n') + ), + close(S) + ), + assertz(known_client(ClientCert)). diff --git a/config.pl b/config.pl index 8abbe1d..d11e13f 100644 --- a/config.pl +++ b/config.pl @@ -1,14 +1,22 @@ -:- module(config, [cert/1, key/1, addr/1, port/1, content/1, hostname/1]). +:- module(config, [load_config/0, + cert/1, + key/1, + addr/1, + port/1, + content/1, + hostname/1 + ]). :- use_module(library(os)). :- use_module(library(iso_ext)). :- use_module(library(dcgs)). +:- use_module(library(files)). :- use_module(library(lists)). +:- use_module(library(si)). +:- use_module(log). :- dynamic(cfg/2). -:- initialization(load_config). - %% Defaults — applied first, then overridden by any CLI args. default(cert, "./cert.pem"). default(key, "./key.pem"). @@ -28,8 +36,9 @@ 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: +% Reads configuration file `site.pl`. Then 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 @@ -38,16 +47,19 @@ hostname(V) :- cfg(hostname, V). % % Unrecognised arguments are ignored. load_config :- - install_defaults, - argv(Args), - - phrase(options(Opts), Args), - apply_opts(Opts). + once(install_defaults), + once(load_config_file), + once(load_cli_args). install_defaults :- retractall(cfg(_, _)), forall(default(K, V), assertz(cfg(K, V))). +load_cli_args :- + argv(Args), + phrase(options(Opts), Args), + apply_opts(Opts). + options([]) --> []. options([Opt|Opts]) --> option(Opt), options(Opts). @@ -78,3 +90,34 @@ parse_addr_port(Chars, Addr, Port) :- !, atom_chars(Addr, AddrChars), number_chars(Port, PortChars). + +%% Loading the configuration file + +load_config_file :- + ( file_exists("site.pl") + -> log_msg("conf", "Reading config from ~s~n", ["site.pl"]), + open("site.pl", read, Stream), + read_config_terms(Stream), + close(Stream) + ; true + ). + +read_config_terms(Stream) :- + read_term(Stream, Term, []), + ( Term == end_of_file + -> true + ; ( valid_cfg_opt(Term) + -> apply_opt(Term) + ; true + ), + read_config_terms(Stream) + ). + +valid_cfg_opt(Term) :- + Term =.. [Functor, Value], + ( Functor = addr, atom_si(Value) + ; Functor = port, integer_si(Value) + ; Functor = hostname, chars_si(Value) + ; Functor = content, chars_si(Value) + ; Functor = certs, chars_si(Value) + ). diff --git a/response.pl b/response.pl index a4acf3c..7497785 100644 --- a/response.pl +++ b/response.pl @@ -1,64 +1,6 @@ -:- module(response, [serve/3]). +:- module(response, [response//1, response//2]). -:- 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 --> " ". diff --git a/serve.pl b/serve.pl new file mode 100644 index 0000000..87f5329 --- /dev/null +++ b/serve.pl @@ -0,0 +1,67 @@ +:- module(serve, [serve/3]). + +:- use_module(library(dcgs)). +:- use_module(config). +:- 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). +:- use_module(response). + +%% 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!"), 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_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) + ). diff --git a/sula.pl b/sula.pl index 14dcbba..7ce3d32 100755 --- a/sula.pl +++ b/sula.pl @@ -13,6 +13,7 @@ exit 1 :- module(sula, [run/0]). :- use_module(cert). +:- use_module(clients). :- use_module(banner). :- use_module(config). :- use_module(library(charsio)). @@ -23,21 +24,22 @@ exit 1 :- use_module(library(lists)). :- use_module(library(pio)). :- use_module(library(sockets)). -:- use_module(library(lambda)). :- use_module(library(tls)). :- use_module(log). :- use_module(mime). +:- use_module(serve). :- use_module(request). :- use_module(response). run :- - display_banner(\S^log_msg("system", "~s~n", [S])), + once(display_banner), + once(load_config), + once(load_clients), 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), - !, + once(load_certificate(Context)), catch( with_socket(Context, with_connection_loop, req_serve), Error, @@ -113,7 +115,8 @@ handle_conn_error(Error) :- % log_msg("debug", "Re-throwing from conn loop: ~q~n", [Error]), throw(Error). -req_serve(S, _ClientCert) :- +req_serve(S, ClientCert) :- read_request(S, Path, Query), + save_client(ClientCert), serve(S, Path, Query), !.