diff options
Diffstat (limited to 'ctftilde/src/guile')
| -rw-r--r-- | ctftilde/src/guile/Makefile.am | 59 | ||||
| -rw-r--r-- | ctftilde/src/guile/ctftilde.scm | 195 | ||||
| -rw-r--r-- | ctftilde/src/guile/ctftilde/main-site.scm | 347 | ||||
| -rw-r--r-- | ctftilde/src/guile/ctftilde/password.scm | 19 | ||||
| -rw-r--r-- | ctftilde/src/guile/ctftilde/users.scm | 211 |
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: |