:- dynamic(known_client/1).
load_clients :-
- log_msg("clients", "Loading client database~n", []),
+ log_msg("clients", "Loading client database", []),
catch(
setup_call_cleanup(
open("clients_db.pl", read, S),
save_client(none).
save_client(ClientCert) :-
known_client(ClientCert),
- log_msg("clients", "Known client ~q~n", [ClientCert])
+ log_msg("clients", "Known client ~q", [ClientCert])
;
- log_msg("clients", "Registering new client with cert ~q~n", [ClientCert]),
+ log_msg("clients", "Registering new client with cert ~q", [ClientCert]),
setup_call_cleanup(
open("clients_db.pl", append, S),
(write(S, known_client(ClientCert)),
load_config_file :-
( file_exists("site.pl")
- -> log_msg("conf", "Reading config from ~s~n", ["site.pl"]),
+ -> log_msg("conf", "Reading config from ~s", ["site.pl"]),
open("site.pl", read, Stream),
read_config_terms(Stream),
close(Stream)
--- /dev/null
+:- module(constants, [version/1]).
+
+version(v(0, 1, 0)).
query(Query).
host(Host) -->
- reg_name(Chars),
+ reg_name(Host),
{
% IP addresses are disallowed on the host
- \+ phrase(ip_address, Chars),
- atom_chars(Host, Chars)
+ \+ phrase(ip_address, Host)
}.
% reg-name = *( unreserved / pct-encoded / sub-delims )
":",
digits(Chars),
{ number_chars_(Port, Chars) }.
-port_opt(none) --> [].
+port_opt(1965) --> [].
digits([C|Cs]) --> [C], { char_type(C, decimal_digit) }, !, digits(Cs).
digits([]) --> [].
-:- module(request, [read_request/3]).
+:- module(request, [read_request/2]).
:- use_module(config).
:- use_module(dcgs/gemini_uri).
%% read_request(+Stream, -Path, -Query)
%
% Read a request from Stream and get the Path and Query parts
-read_request(Stream, Path, Query) :-
+read_request(Stream, uri(Hostname, Port, Path, Query)) :-
read_request_(Stream, Chars),
log_msg("request", "Received raw request: ~s", [Chars]),
once( ( phrase(request(uri(Hostname, Port, Path, Query)), Chars)
- ; throw(gemini_error(bad_request, "Malformed request"))
+ ; log_msg("error", "Malformed request", []),
+ throw(gemini_error(bad_request, "Malformed request"))
)
),
once( ( is_absolute(Path)
- ; log_msg("error", "Non-absolute path requested~n", []),
+ ; log_msg("error", "Non-absolute path requested", []),
throw(gemini_error(bad_request, "Non-absolute paths are forbidden"))
)
),
( hostname(Hostname),
port(Port)
- ; log_msg("error", "Received request for an unknown hostname!~n", []),
+ ; log_msg("error", "Received request for an unknown hostname!", []),
throw(gemini_error(bad_request, "This request is not for me!"))
).
-:- module(serve, [serve/4]).
+:- module(serve, [serve/3]).
:- use_module(config).
:- use_module(dcgs/response).
:- use_module(sys/mime).
:- use_module(ui/log).
-%% serve(+Stream, +Root, +Path, -Query)
+%% 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, Path, _) :-
+serve(S, Root, uri(Hostname, Port, "/", Query)) :-
+ serve(S, Root, uri(Hostname, Port, "/index.gmi", Query)).
+serve(S, Root, uri(_, _, Path, _)) :-
guess_mime(Path, Mime),
append(Root, Path, File),
once( ( file_exists(File)
- ; log_msg("error", "File not found~n", []),
+ ; log_msg("error", "File not found", []),
throw(gemini_error(not_found, "File not found!"))
)
),
- log_msg("response", "File does exist~n", []),
+ log_msg("response", "File does exist", []),
once( ( serve_text(S, Mime, File)
; serve_binary(S, Mime, File)
)
serve_text(S, Mime, File) :-
append("text/", _, Mime),
phrase_from_file(seq(Body), File),
- log_msg("response", "Sending text response~n", []),
+ log_msg("response", "Sending text response", []),
phrase(response(success, Mime), Response0),
format(S, "~s", [Response0]),
format(S, "~s", [Body]),
- log_msg("response", "Sent text response~n", []).
+ log_msg("response", "Sent text response", []).
serve_binary(S, Mime, File) :-
setup_call_cleanup(
open(File, read, FileStream, [type(binary)]),
(
- log_msg("response", "Sending binary response~n", []),
+ log_msg("response", "Sending binary response", []),
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", [])
+ log_msg("response", "Client disconnected mid-stream", [])),
+ log_msg("response", "Sent binary response", [])
),
close(FileStream)
).
:- use_module(ui/banner).
:- use_module(ui/log).
+version(0, 1).
+
run :-
once(display_banner),
+ version(Major, Minor),
+ log_msg("system", "Version ~d.~d", [Major, Minor]),
once(load_config),
once(load_clients),
content(Site),
- log_msg("system", "Serving capsule at `~s`~n", [Site]),
+ log_msg("system", "Serving capsule at `~s`", [Site]),
hostname(Hostname),
- log_msg("system", "Listening on hostname `~s`~n", [Hostname]),
- once(load_certificate(Context)),
+ log_msg("system", "Listening on hostname `~s`", [Hostname]),
+ once(load_certificate(TlsContext)),
catch(
- with_socket(Context, with_connection_loop, req_serve),
+ with_socket(TlsContext, 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", []),
+ log_msg("system", "Shutting down", []),
+ log_msg("system", "Adios!", []),
halt(0).
handle_top_level_error(Error) :-
- log_msg("error", "Unhandled top-level: ~q~n", [Error]),
+ log_msg("error", "Unhandled top-level: ~q", [Error]),
halt(1).
-with_socket(Context, Kont, Kont2) :-
+with_socket(TlsContext, Kont, Kont2) :-
addr(Addr),
port(Port),
( setup_call_cleanup(
- (log_msg("socket", "Opening socket ~q~n", [Addr:Port]),
+ (log_msg("socket", "Opening socket ~q", [Addr:Port]),
socket_server_open(Addr:Port, Socket)
),
- call(Kont, Context, Socket, Kont2),
- (log_msg("socket", "Closing socket~n", []),
+ call(Kont, TlsContext, Socket, Kont2),
+ (log_msg("socket", "Closing socket", []),
socket_server_close(Socket)
)
)
;
- log_msg("error", "Can't bind socket ~q~n", [Addr:Port])
+ log_msg("error", "Can't bind socket ~q", [Addr:Port])
).
-with_connection_loop(Context, Socket, Kont) :-
+with_connection_loop(TlsContext, Socket, Kont) :-
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])
+ log_msg("tcp", "Accepting connections...", []),
+ socket_server_accept(Socket, TcpClient, S0, []),
+ log_msg("tcp", "Connected client ~q", [TcpClient])
),
- with_tls_connection(S0, Context, Kont),
+ with_tls_connection(S0, TlsContext, TcpClient, Kont),
( close(S0),
- log_msg("tcp", "Closed connection for client ~q~n", [Client])
+ log_msg("tcp", "Closed connection for client ~q", [Client])
)
),
Error,
fail.
handle_conn_error(error(permission_error(open, source_sink, _), tls_server_negotiate/3)) :- !,
- log_msg("error", "TLS handshake failed~n", []).
+ log_msg("error", "TLS handshake failed", []).
handle_conn_error(error(existence_error(stream, _), _)) :- !,
- log_msg("error", "Client disconnected~n", []).
+ log_msg("error", "Client disconnected", []).
handle_conn_error(Error) :-
- % log_msg("debug", "Re-throwing from conn loop: ~q~n", [Error]),
+ % log_msg("debug", "Re-throwing from conn loop: ~q", [Error]),
throw(Error).
-req_serve(S, ClientCert) :-
+req_serve(S, TcpClient, ClientCert) :-
once(catch(
- ( read_request(S, Path, Query),
+ ( read_request(S, Uri),
save_client(ClientCert),
content(Root),
- serve(S, Root, Path, Query)
+ serve(S, Root, Uri)
),
gemini_error(DCG, Msg),
( phrase(response(DCG, Msg), Response0),
mime(Ext, Mime)
; Mime = "application/octet-stream"
),
- log_msg("response", "Mime identified as ~s~n", [Mime]).
+ log_msg("response", "Mime identified as ~s", [Mime]).
-:- module(tls_certs, [load_certificate/1, with_tls_connection/3]).
+:- module(tls_certs, [load_certificate/1, with_tls_connection/4]).
:- use_module('../config').
:- use_module(library(dcgs)).
cert(Cert),
key(Key),
hostname(Hostname),
- log_msg("tls", "Loading certificate `~s` and key `~s`~n", [Cert, Key]),
+ log_msg("tls", "Loading certificate `~s` and key `~s`", [Cert, Key]),
file_exists(Cert),
( cert_is_for_hostname(Cert, Hostname) ;
append(Cert, ".bak", Cert1),
append(Key, ".bak", Key1),
- log_msg("error", "Certificate `~s` is not for hostname `~s`. Renaming it to `~s` (also `~s` to `~s`)~n", [Cert, Hostname, Cert1, Key, Key1]),
+ log_msg("error", "Certificate `~s` is not for hostname `~s`. Renaming it to `~s` (also `~s` to `~s`)", [Cert, Hostname, Cert1, Key, Key1]),
rename_file(Cert, Cert1),
rename_file(Key, Key1),
fail
phrase_from_file(seq(CharsCert), Cert, [type(binary)]),
phrase_from_file(seq(CharsKey), Key, [type(binary)]),
tls_server_context(Context, [certificate(CharsCert), key(CharsKey)]),
- log_msg("tls", "Loaded certificate~n", []).
+ log_msg("tls", "Loaded certificate", []).
cert_is_for_hostname(Cert, Hostname) :-
process_create("openssl",
create_new_certificate(Context) :-
hostname(Hostname),
- log_msg("tls", "Generating new certificate for host `~s`~n", [Hostname]),
+ log_msg("tls", "Generating new certificate for host `~s`", [Hostname]),
append("/CN=", Hostname, Hostname1),
process_create("openssl",
["req", "-x509", "-newkey", "rsa:4096", "-nodes", "-keyout", "key.pem", "-out", "cert.pem", "-days", "2900000", "-subj", Hostname1],
cert(Cert),
key(Key),
- log_msg("tls", "Generated new certificate `~s` and key `~s`~n", [Cert, Key]),
+ log_msg("tls", "Generated new certificate `~s` and key `~s`", [Cert, Key]),
load_existing_certificate(Context).
+:- meta_predicate(with_tls_connection(?, ?, ?, 3)).
-:- meta_predicate(with_tls_connection(?, ?, 1)).
-
-%% with_tls_connection(+Stream, +Context, +F_2)
+%% with_tls_connection(+Stream, +Context, +F_3)
%
-% Open a TLS connection on Stream with Context and pass it to F_2
-with_tls_connection(S0, Context, Kont) :-
+% Open a TLS connection on Stream with Context and pass it to F_3
+with_tls_connection(S0, Context, TcpClient, Kont) :-
setup_call_cleanup(
- ( log_msg("tls-conn", "Handshaking TLS~n", []),
+ ( log_msg("tls-conn", "Handshaking TLS", []),
tls_server_negotiate(Context, S0, S, [client_certificate(ClientCert)]),
- ( \+ ClientCert = none, log_msg("tls-conn", "Client cert ~q~n", [ClientCert])
+ ( \+ ClientCert = none, log_msg("tls-conn", "Client cert ~q", [ClientCert])
; true
)
),
- call(Kont, S, ClientCert),
- ( log_msg("tls-conn", "Closing TLS stream~n", []),
+ call(Kont, S, TcpClient, ClientCert),
+ ( log_msg("tls-conn", "Closing TLS stream", []),
close(S)
)
).
display_banner :-
phrase_from_file(lines(Ls), "ui/banner.txt"),
- maplist(\S^log_msg("system", "~s~n", [S]), Ls).
+ maplist(\S^log_msg("system", "~s", [S]), Ls).
lines([]) --> call(eos), !.
lines([L|Ls]) --> line(L), lines(Ls).
scope_color(Scope, Color),
Reset = "\x1b\[0m",
format("~s[~s]~s ", [Color, Scope, Reset]),
- format(Formato, Argumentos).
+ format(Formato, Argumentos),
+ format("~n", []).
projects / sula.git / commitdiff