cert.pem
key.pem
-site
\ No newline at end of file
+site
+*.bak
+clients_db.pl
+site.pl
\ No newline at end of file
- [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
-:- 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).
--- /dev/null
+:- 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)).
-:- 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").
%% 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
%
% 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).
!,
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)
+ ).
-:- 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 --> " ".
--- /dev/null
+:- 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)
+ ).
:- module(sula, [run/0]).
:- use_module(cert).
+:- use_module(clients).
:- use_module(banner).
:- use_module(config).
:- use_module(library(charsio)).
:- 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,
% 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),
!.
projects / sula.git / commitdiff