Initial commit.

5 files changed, 831 insertions, 0 deletions

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: