-:- 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).
:- use_module('./response').
:- use_module('./log').
:- use_module('./config').
+:- use_module('./mime').
% ------------------------------------------------------------------------------
).
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", []),
( 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).
),
!,
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) ->
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", [])
;
(
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)
)
.
-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),
--- /dev/null
+:- 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]).
projects / sula.git / commitdiff