14 files changed, 1098 insertions, 0 deletions
diff --git a/ctftilde/Makefile.am b/ctftilde/Makefile.am
new file mode 100644
index 0000000..99d7ddd
--- /dev/null
+++ b/ctftilde/Makefile.am
@@ -0,0 +1,27 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>
+
+SUBDIRS = src/guile src/resources
+
+dist_bin_SCRIPTS = scripts/ctftilde
+
+.PHONY: guile-objects
+guile-objects:
+	$(MAKE) --directory src/guile
+
+EXTRA_DIST = \
+	guix-devshell \
+	bootstrap \
+	gen-config-scm
+# 	LICENSES/CC0-1.0.txt \
+# 	LICENSES/GPL-3.0-or-later.txt \
+# 	.reuse/dep5 \
+# 	.dir-locals.el \
+# 	.gitignore \
+# 	README.md.license
+
+MAKEFILE_INS = \
+	Makefile.in \
+	src/guile/Makefile.in \
+	src/resources/Makefile.in
diff --git a/ctftilde/bootstrap b/ctftilde/bootstrap
new file mode 100755
index 0000000..0040cd3
--- /dev/null
+++ b/ctftilde/bootstrap
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+cd "$(dirname "$0")"
+autoreconf --install
diff --git a/ctftilde/configure.ac b/ctftilde/configure.ac
new file mode 100644
index 0000000..13ce183
--- /dev/null
+++ b/ctftilde/configure.ac
@@ -0,0 +1,35 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+AC_INIT([ctftilde], [0.1], [koszko@koszko.org])
+
+AC_CONFIG_SRCDIR([src/guile/ctftilde.scm])
+
+m4_pattern_forbid([^GUILE_])
+m4_pattern_allow([^GUILE_PKG_ERRORS$])
+
+GUILE_PKG([3.0])
+GUILE_PROGS
+
+GUILE_MODULE_REQUIRED([cantius])
+GUILE_MODULE_REQUIRED([htmlprag])
+
+AC_PATH_PROG([CONVERT], [convert])
+AC_ARG_VAR([CONVERT], [Convert tool from ImageMagick suite]
+[(default: search for `convert' in PATH)])
+
+AC_PATH_PROG([INKSCAPE], [inkscape])
+AC_ARG_VAR([INKSCAPE], [Inkscape vector graphics program command]
+[(default: search for `inkscape' in PATH)])
+
+AC_CONFIG_AUX_DIR([autotools-aux])
+
+AM_INIT_AUTOMAKE([-Wall -Werror foreign])
+
+AC_CONFIG_FILES([Makefile src/guile/Makefile src/resources/Makefile])
+AX_ADD_GUILE_PRE_INST_ENV()
+
+[cp "$srcdir"/gen-pre-inst-config-scm .]
+
+AC_OUTPUT
diff --git a/ctftilde/gen-config-scm b/ctftilde/gen-config-scm
new file mode 100755
index 0000000..8897437
--- /dev/null
+++ b/ctftilde/gen-config-scm
@@ -0,0 +1,14 @@
+#!/bin/sh
+
+printf '%s' '
+(define-module ('"$1"' config)
+  #:export (config))
+
+(define pre-inst-module
+  `('"$1"' pre-inst-config))
+
+(define config
+  (or (false-if-exception (module-ref (resolve-module pre-inst-module)
+                                      `config))
+      `((datarootpath . ("'"$datarootdir/$1"'")))))
+'
diff --git a/ctftilde/gen-pre-inst-config-scm b/ctftilde/gen-pre-inst-config-scm
new file mode 100755
index 0000000..85b3220
--- /dev/null
+++ b/ctftilde/gen-pre-inst-config-scm
@@ -0,0 +1,20 @@
+#!/bin/sh
+
+builddir="$(cd "$(dirname "$0")" && pwd -P)"
+cd "$builddir"
+
+eval "$(awk '/^srcdir=/ {print $0; exit(0);}' "$builddir"/config.status)"
+srcdir="$(cd "$srcdir" && pwd -P)"
+
+printf '%s' '
+(define-module ('"$1"' pre-inst-config)
+  #:export (config))
+
+(define datarootpath
+  (map (lambda (base)
+         (string-append base "/src/resources"))
+       `("'"$builddir"'" "'"$srcdir"'")))
+
+(define config
+  `((datarootpath . ,datarootpath)))
+'
diff --git a/ctftilde/guix-devshell b/ctftilde/guix-devshell
new file mode 100755
index 0000000..547f313
--- /dev/null
+++ b/ctftilde/guix-devshell
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org>
+
+set -e
+
+# Guile and its libraries
+PACKAGES="guile guile-lib guile-cantius"
+# build system dependencies
+PACKAGES="$PACKAGES make reuse autoconf automake pkg-config gettext"
+PACKAGES="$PACKAGES lawrence-boilerplate"
+# tools for compiling auxiliary resource files
+PACKAGES="$PACKAGES imagemagick inkscape"
+# documentation viewers — for developer's convenience
+PACKAGES="$PACKAGES texinfo man-db"
+
+if test 0 = "$#"
+then :
+     printf 'guix shell %s\n' "$PACKAGES"
+     guix shell $PACKAGES
+else :
+     printf 'guix shell %s -- %s\n' "$PACKAGES" "$*"
+     guix shell $PACKAGES -- "$@"
+fi
diff --git a/ctftilde/scripts/ctftilde b/ctftilde/scripts/ctftilde
new file mode 100644
index 0000000..6e72478
--- /dev/null
+++ b/ctftilde/scripts/ctftilde
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec guile -c '(exit (apply (@ (ctftilde) main) (command-line)))' "$@"
diff --git a/ctftilde/src/guile/Makefile.am b/ctftilde/src/guile/Makefile.am
new file mode 100644
index 0000000..e23eb70
--- /dev/null
+++ b/ctftilde/src/guile/Makefile.am
@@ -0,0 +1,59 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>
+
+DIST_GUILE_SOURCE_FILES = \
+	$(PACKAGE).scm \
+	$(PACKAGE)/main-site.scm \
+	$(PACKAGE)/password.scm \
+	$(PACKAGE)/users.scm
+
+NODIST_NOINST_GUILE_SOURCE_FILES = \
+	$(PACKAGE)/pre-inst-config.scm
+NODIST_INST_GUILE_SOURCE_FILES = \
+	$(PACKAGE)/config.scm
+
+NODIST_GUILE_SOURCE_FILES = \
+	$(NODIST_NOINST_GUILE_SOURCE_FILES) \
+	$(NODIST_INST_GUILE_SOURCE_FILES)
+
+INST_GUILE_SOURCE_FILES = \
+	$(DIST_GUILE_SOURCE_FILES) \
+	$(NODIST_INST_GUILE_SOURCE_FILES)
+
+GUILE_SOURCE_FILES = \
+	$(DIST_GUILE_SOURCE_FILES) \
+	$(NODIST_GUILE_SOURCE_FILES)
+
+INST_GUILE_OBJECT_FILES = $(INST_GUILE_SOURCE_FILES:.scm=.go)
+GUILE_OBJECT_FILES = $(GUILE_SOURCE_FILES:.scm=.go)
+
+gobjdir = $(libdir)/guile/@GUILE_EFFECTIVE_VERSION@/site-ccache
+nobase_gobj_DATA = $(INST_GUILE_OBJECT_FILES)
+nodist_gobj_DATA = $(NODIST_GUILE_SOURCE_FILES:.scm=.go)
+
+scmdir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@
+
+nobase_dist_scm_DATA = $(DIST_GUILE_SOURCE_FILES)
+nobase_scm_DATA = $(NODIST_INST_GUILE_SOURCE_FILES)
+
+MOSTLYCLEANFILES = \
+	$(GUILE_OBJECT_FILES) \
+	$(NODIST_GUILE_SOURCE_FILES)
+
+$(PACKAGE)/pre-inst-config.scm: $(top_builddir)/gen-pre-inst-config-scm
+	mkdir $(PACKAGE) 2>/dev/null || true
+	$< $(PACKAGE) > $@
+
+$(PACKAGE)/config.scm: $(top_srcdir)/gen-config-scm
+	mkdir $(PACKAGE) 2>/dev/null || true
+	datarootdir="$(datarootdir)" $< $(PACKAGE) > $@
+
+.scm.go:
+	$(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $<
+
+$(GUILE_OBJECT_FILES): $(PACKAGE)/config.scm $(PACKAGE)/pre-inst-config.scm
+
+uninstall-hook:
+	rm -rf $(DESTDIR)/$(scmdir)/$(PACKAGE)
+	rm -rf $(DESTDIR)/$(gobjdir)/$(PACKAGE)
diff --git a/ctftilde/src/guile/ctftilde.scm b/ctftilde/src/guile/ctftilde.scm
new file mode 100644
index 0000000..e42fdb9
--- /dev/null
+++ b/ctftilde/src/guile/ctftilde.scm
@@ -0,0 +1,195 @@
+(define-module (ctftilde)
+  #:use-module ((srfi srfi-26) #:select (cut))
+
+  #:use-module ((ice-9 control) #:select (let/ec))
+  #:use-module ((ice-9 exceptions) #:select
+                (raise-exception with-exception-handler))
+  #:use-module ((ice-9 format) #:select (format))
+  #:use-module ((ice-9 getopt-long) #:select (getopt-long option-ref))
+  #:use-module ((ice-9 match) #:select (match match-lambda match-let))
+  #:use-module ((ice-9 textual-ports) #:prefix tp:)
+
+  #:use-module ((system repl debug) #:select (terminal-width))
+
+  #:use-module ((ctftilde main-site) #:select (run-website))
+  #:use-module ((ctftilde password) #:select (encrypt-password))
+  #:use-module ((ctftilde users) #:prefix cu:)
+
+  #:export (main))
+
+
+
+(define %ctftilde-exit
+  (make-parameter (lambda _
+                    (raise-exception
+                     "%ctftilde-exit called while not parameterized."))))
+
+(define (error-exit fmt . format-args)
+  (apply format (current-error-port)
+         fmt format-args)
+  ((%ctftilde-exit) EXIT_FAILURE))
+
+(define (require-option options option-sym)
+  (match (option-ref options option-sym #f)
+
+    (#f
+     (error-exit "--~a is required for this action.~%" option-sym))
+
+    (value
+     value)))
+
+(define %option-spec
+  '((site-host      (single-char #\h) (value #f))
+    (user-delete    (single-char #\d) (value #f))
+    (user-make      (single-char #\m) (value #f))
+    (users-recreate (single-char #\r) (value #f))
+
+    (password-file (single-char #\p) (value #t))
+    (username      (single-char #\u) (value #t))
+
+    (log-file      (single-char #\l) (value #t))))
+
+(define (site-host options)
+  (match-let (((sock-child . sock-parent) (socketpair AF_UNIX SOCK_STREAM 0)))
+
+    (force-output (current-output-port))
+    (force-output (current-error-port))
+
+    (match (primitive-fork)
+
+      (0
+       (let ((user (getpwnam "ctftilde")))
+         (close-port sock-parent)
+         (setgid (passwd:gid user))
+         (setuid (passwd:uid user))
+         (run-website sock-child sock-child)
+
+         ;; Likely unreachable.
+         (close-port sock-child)))
+
+      (child-pid
+       (close-port sock-child)
+       (cu:make-users-from-port sock-parent sock-parent)
+
+       ;; Other side should be closed already.
+       (close-port sock-parent)
+
+       (let ((status (cdr (waitpid child-pid))))
+         (when (> status 0)
+           (error-exit
+            "HTTP server child process terminated with error.  Stopping daemon.~%"))
+         status)))))
+
+(define (user-delete options)
+  (define username
+    (require-option options 'username))
+
+  (cu:delete-user username))
+
+(define (user-make options)
+  (define username
+    (require-option options 'username))
+
+  (define password
+    (call-with-input-file (require-option options 'password-file)
+      tp:get-string-all))
+
+  (define encrypted-password
+    (encrypt-password password))
+
+  (call-with-output-file "/dev/null"
+    (cut cu:make-user <> username encrypted-password)))
+
+(define (users-recreate options)
+  (cu:delete-users-from-dir)
+  (cu:make-users-from-dir))
+
+(define %actions
+  ;; global args
+  (map (cut append <> '(log-file))
+       ;; handler         action         allowed args
+       `((,site-host      site-host      . ())
+         (,user-delete    user-delete    . (username))
+         (,user-make      user-make      . (password-file username))
+         (,users-recreate users-recreate . ()))))
+
+(define (*main options)
+  (define chosen-actions
+    (filter (match-lambda ((_ action-sym . _)
+                           (option-ref options action-sym #f)))
+            %actions))
+
+  (match chosen-actions
+
+    (()
+     (error-exit "You need to choose one of the following actions: ~{--~a~^, ~}.~%"
+                 (map cadr %actions)))
+
+    (((action-handler . (and action-allowed-args
+                             (action-sym . _)))
+      . _)
+     (match (filter (lambda (option-sym)
+                      (and (not (memq option-sym action-allowed-args))
+                           (option-ref options option-sym #f)))
+                    (map car %option-spec))
+
+       ((illegal-option-sym . _)
+        (error-exit "You cannot use --~a with --~a.~%"
+                    illegal-option-sym action-sym))
+
+       (()
+        (action-handler options))))))
+
+(define (with-log-output-file path thunk)
+  (call-with-output-file path
+    (lambda (port)
+      ;; There're some issues with log messages not going to the right fd but I
+      ;; cba to investigate in more depth.
+      (parameterize ((current-output-port port)
+                     (current-error-port port))
+        (thunk)))))
+
+(define (call-with-logging-to-file path thunk)
+  (define logging-port
+    (open-file path "a"))
+
+  (setvbuf logging-port 'line)
+
+  (dynamic-wind
+
+    noop
+
+    (lambda _
+      (parameterize ((current-output-port logging-port)
+                     (current-error-port logging-port))
+        (thunk)))
+
+    (cut close-port logging-port)))
+
+(define (main . cli-args)
+  (define options
+    (getopt-long cli-args %option-spec))
+
+  (define (with-log-output thunk)
+    (match (option-ref options 'log-file #f)
+
+      (#f
+       (thunk))
+
+      (path
+       (call-with-logging-to-file path thunk))))
+
+  (with-log-output
+   (lambda _
+     (let/ec escape
+       (start-stack 'ctftilde
+         (parameterize ((%ctftilde-exit escape))
+           (with-exception-handler (lambda (ex)
+                                     (terminal-width 80)
+                                     (let ((err (current-error-port)))
+                                       (display-backtrace (make-stack #t) err 2)
+                                       (format err "~%~a~%~%" ex)
+                                       (escape EXIT_FAILURE)))
+             (lambda _
+               (*main options)
+               0))))))))
diff --git a/ctftilde/src/guile/ctftilde/main-site.scm b/ctftilde/src/guile/ctftilde/main-site.scm
new file mode 100644
index 0000000..1598ff3
--- /dev/null
+++ b/ctftilde/src/guile/ctftilde/main-site.scm
@@ -0,0 +1,347 @@
+(define-module (ctftilde main-site)
+  #:use-module ((rnrs bytevectors) #:select (utf8->string))
+
+  #:use-module ((srfi srfi-1) #:select (append-map filter-map fold last))
+  #:use-module ((srfi srfi-26) #:select (cut))
+  #:use-module ((srfi srfi-45) #:select (delay force))
+
+  #:use-module ((ice-9 binary-ports) #:prefix bp:)
+  #:use-module ((ice-9 match) #:select
+                (match match-lambda match-lambda* match-let))
+  #:use-module ((ice-9 regex) #:select (match:substring))
+
+  #:use-module ((web request) #:prefix wr:)
+  #:use-module ((web uri) #:prefix wu:)
+
+  #:use-module ((htmlprag) #:select (write-shtml-as-html))
+  #:use-module ((cantius) #:prefix cant:)
+
+  #:use-module ((ctftilde password) #:select (encrypt-password))
+  #:use-module ((ctftilde config) #:select (config))
+
+  #:export (run-website))
+
+
+
+(define %resources
+  (assq-ref config 'datarootpath))
+
+(define %daemon-read-port
+  (make-parameter *unspecified*))
+
+(define %daemon-write-port
+  (make-parameter *unspecified*))
+
+(define (choose-content-type filepath)
+  (cond
+   ((string-suffix? ".css" filepath)
+    '(text/css (charset . "utf-8")))
+
+   ((string-suffix? ".ico" filepath)
+    '(image/x-icon))
+
+   ((string-suffix? ".svg" filepath)
+    '(image/svg+xml (charset . "utf-8")))
+
+   (else
+    '(application/octet-stream))))
+
+;; Next time we'll spend more time and write code to issue a proper CSRF token.
+(define (referrer-legit? request)
+  (define headers
+    (wr:request-headers request))
+
+  (define referrer
+    (assq-ref headers 'referer))
+
+  (false-if-exception
+   (and (string= (wu:uri-host referrer) "ctftilde.koszko.org")
+        (eq? (wu:uri-port referrer) #f))))
+
+(define (serialize-html-doc sxml)
+  (call-with-output-string
+    (lambda (port)
+      (display "<!DOCTYPE html>\n" port)
+      (write-shtml-as-html sxml port))))
+
+(define (contents->html contents)
+  (serialize-html-doc
+   `(html
+     (head
+      (meta (@ (http-equiv "Content-Type")
+               (content "text/html; charset=UTF-8")))
+      (meta (@ (name "viewport")
+               (content "width=device-width, initial-scale=1")))
+      (link (@ (href "resources/ctftilde.css")
+               (rel "stylesheet"))))
+     (body
+      (main . ,contents)))))
+
+(define %endset
+  (cant:endset
+   (parameters `((,cant:%default-headers
+                  . ((content-type . (text/html (charset . "utf-8")))))))))
+
+(cant:define-endpoint %endset main-page
+  () '()
+  (contents->html
+   '((h1 "Tildeverse on GNU\xa0Guix")
+     (p "Welcome to ctftilde, a public tilde server.")
+     (p "We provide free UNIX accounts for enthusiasts of free/libre software
+and minimalism.  Besides this, you can run your own website or Gemini capsule.")
+     (p "What makes this ~ special?  It is powered by GNU Guix functional
+package manager & operating system.  And it lets the users benefit from this
+tooling as well!")
+
+     (h2 "What to do?")
+     (p "If you're not yet sure you want to join, take time to browse other
+ user's tilde websites/capsules and see how they spend time here.  You might
+also want to familiarize yourself with GNU Guix.  Once you're ready, jump to our
+registration page.")
+     (ul
+      (li (a (@ (href "https://guix.gnu.org/"))
+             "GNU Guix website"))
+      (li (a (@ (href "https://ctftilde.koszko.org/registration"))
+             "Registration page")))
+
+     (h2 "Our users' blogs")
+     (ul
+      (li (a (@ (href "./~abdul"))
+             "~abdul"))))))
+
+(define query-param-regex
+  (make-regexp "^([^=]+)(=(.*))?"))
+
+(define (decode-x-www-form-urlencoded body)
+  (filter-map (match-lambda
+
+                ((= (cut regexp-exec query-param-regex <>)
+                    (and (= (cut match:substring <> 1)
+                            (and (not #f) param-name))
+                         (= (cut match:substring <> 3)
+                            param-value)))
+                 (cons (wu:uri-decode param-name)
+                       (or (and=> param-value wu:uri-decode) "")))
+
+                (_
+                 #f))
+
+              (reverse (string-split (utf8->string body) #\&))))
+
+(define start-with-lowercase-regex
+  (make-regexp "^[a-z]"))
+
+(define allowed-username-chars-regex
+  (make-regexp "^[-a-z0-9]+$"))
+
+(define min-password-len
+  14)
+
+;; https://stackoverflow.com/questions/201323/how-can-i-validate-an-email-address-using-a-regular-expression#answer-201378
+;; The (marginally mistaken, btw) `\x53-\x7f' part has been replaced with
+;; `\x5b-\x7e\x7f' to make things work in Guile.
+(define email-regex
+  (make-regexp "^([a-z0-9!#$%&'*+/=?^_`{|}~-]+(\\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*|\"([\x01-\x08\x0b\x0c\x0e-\x1f\x21\x23-\x5b\x5d-\x7f]|\\\\[\x01-\x09\x0b\x0c\x0e-\x7f])*\")@(([a-z0-9]([a-z0-9-]*[a-z0-9])?\\.)+[a-z0-9]([a-z0-9-]*[a-z0-9])?|\\[(((2(5[0-5]|[0-4][0-9])|1[0-9][0-9]|[1-9]?[0-9]))\\.){3}((2(5[0-5]|[0-4][0-9])|1[0-9][0-9]|[1-9]?[0-9])|[a-z0-9-]*[a-z0-9]:([\x01-\x08\x0b\x0c\x0e-\x1f\x21-\x5a\x5b-\x7e\x7f]|\\\\[\x01-\x09\x0b\x0c\x0e-\x7f])+)\\])$"))
+
+(define (validate-registration form-values)
+  (define username
+    (assoc-ref form-values "username"))
+
+  (define password
+    (assoc-ref form-values "password"))
+
+  (define password-repeat
+    (assoc-ref form-values "password-repeat"))
+
+  (define email
+    (assoc-ref form-values "email"))
+
+  (fold (match-lambda*
+          (((field-name . checkers) acc)
+           (or (and=> (or-map (cut apply <> (list acc))
+                              checkers)
+                      (compose (cut cons <> acc)
+                               (cut cons field-name <>)))
+               acc)))
+        '()
+        `(("username"
+           . (,(lambda _
+                 (and (not (regexp-exec allowed-username-chars-regex username))
+                      "Username must consist purely of lowercase letters, numbers and hyphens."))
+              ,(lambda _
+                 (and (not (regexp-exec start-with-lowercase-regex username))
+                      "Username must start with a lowercase letter."))
+              ,(lambda _
+                 (and (false-if-exception (getpwnam username))
+                      "This username is unavailable."))))
+
+          ("password"
+           . (,(lambda _
+                 (and (< (string-length password) min-password-len)
+                      (format #f "Password must be at least ~a characters long."
+                              min-password-len)))))
+
+          ("password-repeat"
+           . (,(lambda (mistakes)
+                 (and (not (assoc-ref mistakes "password"))
+                      (not (string= password password-repeat))
+                      "Passwords do not match."))))
+
+          ("email"
+           . (,(lambda _
+                 (and (not (regexp-exec email-regex email))
+                      "Provided email is not valid.")))))))
+
+(cant:define-endpoint %endset main-page
+  ("registration") '()
+
+  (define legal-POST?
+    (and (eq? 'POST (wr:request-method request))
+         (referrer-legit? request)))
+
+  (define params
+    (if legal-POST?
+        (decode-x-www-form-urlencoded body)
+        '()))
+
+  (define params-mistakes
+    (if legal-POST?
+        (validate-registration params)
+        '()))
+
+  (define password-to-reuse
+    (delay (and (not (assoc-ref params-mistakes "password"))
+                (not (assoc-ref params-mistakes "password-repeat"))
+                (assoc-ref params "password"))))
+
+  (cond
+   ((and legal-POST? (eq? '() params-mistakes))
+    (write (list (format #f "ctftilde-~a" (assoc-ref params "username"))
+                 (encrypt-password (assoc-ref params "password")))
+           (%daemon-write-port))
+
+    (contents->html
+     (match (read (%daemon-read-port))
+
+       ('(ok)
+        `((h1 "Done")
+          (p ,(format #f "Try connecting via ssh to ~a@ctftilde.koszko.org."
+                      (assoc-ref params "username")))))
+
+       (_
+        `((h1 "Ooops!")
+          (p "Something went wrong X("))))))
+
+   (else
+    (contents->html
+     `((form (@ (method "POST"))
+             (h1 "ctftilde registration form")
+
+             ,@(append-map
+                (match-lambda
+                  ((field-name label-text field)
+                   `((label (@ (for ,field-name))
+                            ,label-text)
+
+                     ,@(or (and=> (assoc-ref params-mistakes field-name)
+                                  (lambda (mistake-text)
+                                    `((aside (@ (class "error"))
+                                             ,mistake-text))))
+                           '())
+
+                     ,field)))
+
+                `(("username" "Username"
+                   (input (@ (name "username")
+                             ,@(or (and=> (assoc-ref params "username")
+                                          (compose list (cut list 'value <>)))
+                                   '()))))
+                  ("password" "Password"
+                   (input (@ (name "password")
+                             (type "password")
+                             ,@(or (and=> (force password-to-reuse)
+                                          (compose list (cut list 'value <>)))
+                                   '()))))
+                  ("password-repeat" "Repeat password"
+                   (input (@ (name "password-repeat")
+                             (type "password")
+                             ,@(or (and=> (force password-to-reuse)
+                                          (compose list (cut list 'value <>)))
+                                   '()))))
+                  ("email" "Email"
+                   (input (@ (name "email")
+                             ,@(or (and=> (assoc-ref params "email")
+                                          (compose list (cut list 'value <>)))
+                                   '()))))))
+
+             (button "Register"))
+
+       (ul
+        (li (a (@ (href ".."))
+               "Back to the main page"))))))))
+
+(cant:define-endpoint %endset debug-page
+  ("debug") '()
+
+  (define headers
+    (wr:request-headers request))
+
+  (define referrer
+    (assq-ref headers 'referer))
+
+  (define host
+    (assq-ref headers 'host))
+
+  (contents->html
+   `((style "div {margin: 20px;}")
+     (div
+      ,(format #f "~a" headers))
+     (div
+      ,(format #f "~s" (false-if-exception
+                        (decode-x-www-form-urlencoded body))))
+     (div
+      ,(format #f "~s" (false-if-exception
+                        (validate-registration
+                         (decode-x-www-form-urlencoded body)))))
+     (div
+      ,(format #f "~s" (%daemon-read-port)))
+     (div
+      ,(format #f "host: ~s" host))
+     (div
+      ,(format #f "referrer host: ~s"
+               (false-if-exception (wu:uri-host referrer))))
+     (div
+      ,(format #f "referrer port: ~s"
+               (false-if-exception (wu:uri-port referrer))))
+     (div
+      ,(format #f "~s"
+               (equal? (cons (false-if-exception (wu:uri-host referrer))
+                             (false-if-exception (wu:uri-port referrer)))
+                       host)))
+     (div
+      ,(format #f "~s" (list (wr:request-method request))))
+     (div
+      ,(format #f "legal referer: ~s"
+               (false-if-exception (referrer-legit? request)))))))
+
+(cant:define-endpoint %endset resources
+  ("resources" . file-path) '()
+  (values (let ((content-type (choose-content-type (last file-path))))
+            (cant:build-response* #:headers `((content-type . ,content-type))))
+          (call-with-input-file
+              (cant:find-resource-file (string-join file-path "/") %resources)
+            bp:get-bytevector-all)))
+
+(define (run-website daemon->site:read site->daemon:write . args)
+  (define endset
+    (cant:endset
+     #:<- %endset
+     (parameters #:=> (cut append `((,%daemon-read-port . ,daemon->site:read)
+                                    (,%daemon-write-port . ,site->daemon:write))
+                           <>))))
+
+  (apply cant:run-cantius endset args))
+
+;;; Local Variables:
+;;; eval: (put 'cant:define-endpoint 'scheme-indent-function 2)
+;;; End:
diff --git a/ctftilde/src/guile/ctftilde/password.scm b/ctftilde/src/guile/ctftilde/password.scm
new file mode 100644
index 0000000..b3aa7dc
--- /dev/null
+++ b/ctftilde/src/guile/ctftilde/password.scm
@@ -0,0 +1,19 @@
+(define-module (ctftilde password)
+  #:use-module ((srfi srfi-8) #:select (receive))
+
+  #:use-module ((ice-9 popen) #:prefix po:)
+  #:use-module ((ice-9 textual-ports) #:prefix tp:)
+
+  #:export (encrypt-password))
+
+
+
+(define (encrypt-password password)
+  (receive (in-port out-port pids)
+      (po:pipeline '(("openssl" "passwd" "-5" "-stdin")))
+    (tp:put-string out-port password)
+    (close-port out-port)
+    (for-each waitpid pids)
+    (let ((pipe-output (tp:get-string-all in-port)))
+      (close-port in-port)
+      (string-trim-right pipe-output))))
diff --git a/ctftilde/src/guile/ctftilde/users.scm b/ctftilde/src/guile/ctftilde/users.scm
new file mode 100644
index 0000000..3d17362
--- /dev/null
+++ b/ctftilde/src/guile/ctftilde/users.scm
@@ -0,0 +1,211 @@
+(define-module (ctftilde users)
+  #:use-module ((srfi srfi-1) #:prefix s1:)
+  #:use-module ((srfi srfi-26) #:select (cut))
+
+  #:use-module ((ice-9 control) #:select (let/ec))
+  #:use-module ((ice-9 exceptions) #:select
+                (raise-exception with-exception-handler))
+  #:use-module ((ice-9 match) #:select (match))
+
+  #:use-module ((system repl debug) #:select (terminal-width))
+
+  #:export (delete-user
+            delete-users-from-dir
+
+            make-user
+            make-users-from-port
+            make-users-from-dir))
+
+
+
+(define (call-with-lock thunk)
+  (define lockport
+    (open "/var/lock/ctftilde-make-user.lock" (logior O_RDONLY O_CREAT)))
+
+  (dynamic-wind
+
+    noop
+
+    (lambda _
+      (cut flock lockport LOCK_EX)
+      (thunk))
+
+    (cut close lockport)))
+
+(define (call-with-backtrace stack-id thunk)
+  (let/ec escape
+    (start-stack stack-id
+      (with-exception-handler (lambda (ex)
+                                (terminal-width 80)
+                                (let ((err (current-error-port)))
+                                  (display-backtrace (make-stack #t) err 2)
+                                  (format err "~%~a~%~%" ex)
+                                  (escape *unspecified*)))
+        thunk))))
+
+(define (call-with-files-from-dir path proc)
+  (letrec* ((dir (opendir path))
+            (loop (lambda _
+                    (match (readdir dir)
+
+                      ((? eof-object?)
+                       *unspecified*)
+
+                      (filename
+                       (call-with-backtrace 'call-with-file-from-dir
+                         (lambda _
+                           (let ((file-path (format #f "~a/~a" path filename)))
+                             (unless (file-is-directory? file-path)
+                               (proc filename file-path)))))
+                       (loop))))))
+
+    (dynamic-wind noop loop (cut closedir dir))))
+
+
+
+(define (*delete-user username)
+  (let ((creation-file
+         (string-append "/var/db/ctftilde/users/" username))
+        (deletion-file
+         (string-append "/var/db/ctftilde/users-to-delete/" username)))
+
+    (call-with-output-file deletion-file
+      fsync)
+
+    (false-if-exception (delete-file creation-file))
+    (system* "userdel" "-rf" username)
+    (system* "rm" "-rf" (string-append "/srv/gemini-users/" username))
+    (system* "rm" "-rf" (string-append "/srv/http-users/" username))
+    (sync)
+    (false-if-exception (delete-file deletion-file))
+    (sync)))
+
+(define (delete-user . args)
+  (call-with-lock (cut apply *delete-user args)))
+
+(define (delete-users-from-dir)
+  (call-with-files-from-dir "/var/db/ctftilde/users-to-delete"
+    (lambda (filename _)
+      (delete-user filename))))
+
+
+
+(define %username-regex
+  (make-regexp "^[a-zA-Z][a-zA-Z0-9-]*$"))
+
+(define* (*make-user username encrypted-password #:optional recreated-user-uid)
+  (define (add-user)
+    (when (> (apply system*
+                    `("useradd"
+                      "--shell" "/run/current-system/profile/bin/bash"
+                      "--home-dir" ,(string-append "/home/ctftilde/" username)
+                      "--create-home"
+                      ,@(or (and=> recreated-user-uid
+                                   (compose (cut list "--uid" <>)
+                                            number->string))
+                            '())
+                      "--gid" "hackers"
+                      "-p" ,encrypted-password
+                      ,username))
+             0)
+      (raise-exception "User could not be added.")))
+
+  (define (add-user-files)
+    (define user
+      (getpwnam username))
+
+    (define (make-user-file path-format what)
+      (define path
+        (format #f path-format username))
+
+      (unless (file-exists? path)
+        (match what
+          ('dir
+           (mkdir path #o755))
+          (text
+           (call-with-output-file path
+             (lambda (port)
+               (chmod port #o644)
+               (display text port))))))
+
+      (chown path (passwd:uid user) (passwd:gid user)))
+
+    (define files
+      `(("/srv/gemini-users/~a"
+         dir)
+        ("/srv/gemini-users/~a/index.gmi"
+         "This user directory hasn't been configured yet.")
+        ("/srv/http-users/~a"
+         dir)
+        ("/srv/http-users/~a/index.html"
+         "<!DOCTYPE html><link rel='stylesheet' href='/resources/ctftilde.css'>This user directory hasn't been configured yet.")))
+
+    (apply for-each make-user-file ((compose list s1:unzip2) files))
+
+    (call-with-output-file (string-append "/var/db/ctftilde/users/" username)
+      (cut write (list username encrypted-password (passwd:uid user)) <>)))
+
+  (define deletion-file
+    (string-append "/var/db/ctftilde/users-to-delete/" username))
+
+  (unless (regexp-exec %username-regex username)
+    (raise-exception "Invalid username."))
+
+  (define unix-user-exists?
+    (false-if-exception (getpw username)))
+
+  (when (and (not recreated-user-uid)
+             unix-user-exists?)
+    (raise-exception "User exists."))
+
+  (when (and (not recreated-user-uid)
+             (file-exists? (string-append "/var/db/ctftilde/users/" username)))
+    (raise-exception "User creation already pending.  Can be committed with `--users-recreate'."))
+
+  (unless unix-user-exists?
+    (with-exception-handler (lambda (ex)
+                              (call-with-backtrace
+                                  'delete-user-when-making-failed
+                                (cut delete-user username))
+                              (raise-exception ex))
+      (lambda _
+        (call-with-output-file deletion-file
+          fsync)
+        (add-user)
+        (add-user-files)
+        (sync)
+        (delete-file deletion-file)
+        (sync)))))
+
+(define (make-user out-port . args)
+  (with-exception-handler (lambda (ex)
+                            (write '(fail) out-port)
+                            (raise-exception ex))
+    (lambda _
+      (call-with-lock (cut apply *make-user args))
+      (write '(ok) out-port))))
+
+(define (make-users-from-port in-port out-port)
+  (letrec ((loop (lambda _
+                   (match (read in-port)
+
+                     ((? eof-object?)
+                      *unspecified*)
+
+                     (args
+                      (apply make-user out-port args)
+                      (loop))))))
+    (loop)))
+
+(define (make-users-from-dir)
+  (call-with-output-file "/dev/null"
+    (lambda (null-port)
+      (call-with-files-from-dir "/var/db/ctftilde/users"
+        (lambda (_ file-path)
+          (call-with-input-file file-path
+            (cut make-users-from-port <> null-port)))))))
+
+;;; Local Variables:
+;;; eval: (put 'call-with-backtrace 'scheme-indent-function 1)
+;;; eval: (put 'call-with-files-from-dir 'scheme-indent-function 1)
+;;; End:
diff --git a/ctftilde/src/resources/Makefile.am b/ctftilde/src/resources/Makefile.am
new file mode 100644
index 0000000..c173935
--- /dev/null
+++ b/ctftilde/src/resources/Makefile.am
@@ -0,0 +1,34 @@
+# SPDX-License-Identifier: CC0-1.0
+#
+# Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>
+
+RESOURCE_FILES = \
+	$(PACKAGE).css
+# 	$(PACKAGE).ico
+# 	$(PACKAGE).svg.license
+#	$(PACKAGE).svg
+
+resourcedir = $(datarootdir)/$(PACKAGE)
+nobase_dist_resource_DATA = $(RESOURCE_FILES)
+
+# EXTRA_DIST = \...
+
+MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES)
+
+# CLEANFILES = $(PACKAGE).ico
+
+.scm.go:
+	$(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $<
+
+# # If ImageMagick isn't compiled with librsvg (and by default in Guix it isn't),
+# # it fails to understand gradients in svg inputs. As a workaround let's do
+# # svg->png conversion with Inkscape and then png->ico conversion with
+# # ImageMagick's convert tool.
+# .svg.png:
+# 	$(INKSCAPE) "$<" --export-filename="$@" -w 256 -h 256
+
+# .png.ico:
+# 	$(CONVERT) "$<" -define icon:auto-resize=256,64,48,32,16 "$@"
+
+uninstall-hook:
+	rm -rf $(DESTDIR)/$(resourcedir)
diff --git a/ctftilde/src/resources/ctftilde.css b/ctftilde/src/resources/ctftilde.css
new file mode 100644
index 0000000..9ee148e
--- /dev/null
+++ b/ctftilde/src/resources/ctftilde.css
@@ -0,0 +1,100 @@
+/*
+ * SPDX-License-Identifier: CC0-1.0
+ * Copyright (C) 2024 W. Kosior <koszko@koszko.org>
+ */
+
+html {
+    font-size: 16px;
+    line-height: 1.6;
+    color: #5D6166;
+    background-color: #D3DAE1;
+    --width: calc(100vw - 20px);
+    --height: calc(100vh - 20px);
+    width: var(--width);
+    height: var(--height);
+    border: #B3BAC1 solid 10px;
+    overflow-y: hidden;
+}
+    
+body {
+    padding: 10px;
+    margin: 0 auto;
+    max-width: calc(var(--width) - 20px);
+    max-height: calc(var(--height) - 20px);
+    overflow-y: scroll;
+}
+
+main {
+    max-width: 700px;
+    padding: 1rem 2rem;
+}
+
+form {
+    display: flex;
+    flex-direction: column;
+}
+    
+pre {
+    background-color: #eee;
+    margin: 0 -1rem;
+    padding: 1rem;
+    overflow-x: auto;
+}
+    
+a {
+    color: #AA2E00;
+}
+    
+a:visited {
+    color: #802200;
+}
+
+h1 {
+    margin-top: 10px;
+    margin-bottom: 10px;
+}
+
+label, aside, input {
+    margin-top: 4px;
+    margin-bottom: 4px;
+}
+
+label {
+    font-weight: bold;
+    font-style: italic;
+}
+
+input {
+    display: block;
+    border: none;
+    border-radius: 0;
+    border-left: 4px solid #5D6166;
+    padding: 4px;
+    margin-bottom: 8px;
+}
+
+aside {
+    padding: 8px;
+}
+
+aside.error{
+    border-left: 4px solid red;
+    background-color: #eed2d2;
+}
+
+button {
+    padding: 8px;
+    font-weight: bold;
+    color: white;
+    background-color: #5D6166;
+    border: none;
+}
+
+button {
+    margin-top: 8px;
+    margin-bottom: 8px;
+}
+
+button:active, button:hover {
+    background-color: #3d4146;
+}