--- /dev/null
+:- 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)
+ )
+ ).
-:- 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").
load_config :-
install_defaults,
argv(Args),
+
phrase(options(Opts), Args),
apply_opts(Opts).
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) :-
--- /dev/null
+/*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),
+ !.
+++ /dev/null
-#!/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
+++ /dev/null
-
-:- 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).
-:- 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 `<mime> <ext> [<ext> ...]` 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]).
-:- 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),
-:- 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 --> " ".
projects / sula.git / commitdiff