summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ctftilde/Makefile.am27
-rwxr-xr-xctftilde/bootstrap8
-rw-r--r--ctftilde/configure.ac35
-rwxr-xr-xctftilde/gen-config-scm14
-rwxr-xr-xctftilde/gen-pre-inst-config-scm20
-rwxr-xr-xctftilde/guix-devshell26
-rw-r--r--ctftilde/scripts/ctftilde3
-rw-r--r--ctftilde/src/guile/Makefile.am59
-rw-r--r--ctftilde/src/guile/ctftilde.scm195
-rw-r--r--ctftilde/src/guile/ctftilde/main-site.scm347
-rw-r--r--ctftilde/src/guile/ctftilde/password.scm19
-rw-r--r--ctftilde/src/guile/ctftilde/users.scm211
-rw-r--r--ctftilde/src/resources/Makefile.am34
-rw-r--r--ctftilde/src/resources/ctftilde.css100
-rw-r--r--gemini/index.gmi10
-rw-r--r--gmnisrv.ini12
-rw-r--r--good-dirsrv.scm237
-rw-r--r--vm-deploy.scm12
-rw-r--r--vm.scm364
19 files changed, 1733 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;
+}
diff --git a/gemini/index.gmi b/gemini/index.gmi
new file mode 100644
index 0000000..7536215
--- /dev/null
+++ b/gemini/index.gmi
@@ -0,0 +1,10 @@
+# Tildeverse on GNU Guix
+Welcome to ctftilde, a public tilde server.
+We provide free UNIX accounts for enthusiasts of free/libre software and minimalism. Besides this, you can run your own website or Gemini capsule.
+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!
+## What to do?
+If you're not yet sure you want to join, take time to browser 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.
+=> https://guix.gnu.org/ GNU Guix website
+=> https://ctftilde.koszko.org/registration Registration page
+## Our users' blogs
+=> ./~abdul ~abdul
diff --git a/gmnisrv.ini b/gmnisrv.ini
new file mode 100644
index 0000000..5edcafe
--- /dev/null
+++ b/gmnisrv.ini
@@ -0,0 +1,12 @@
+listen=0.0.0.0 [::]
+
+[:tls]
+store=/var/lib/gemini/certs
+organization=ctftilde tilde server
+
+[ctftilde.koszko.org]
+root=/srv/gemini
+
+[ctftilde.koszko.org~/~(?<username>[^./][^/]*|[.][^/.][^/]*|[.][.][^/]+)/?(?<rest>.*)]
+root=/srv/gemini-users
+rewrite=/\{username}/\{rest}
diff --git a/good-dirsrv.scm b/good-dirsrv.scm
new file mode 100644
index 0000000..2aa4ab0
--- /dev/null
+++ b/good-dirsrv.scm
@@ -0,0 +1,237 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2016, 2021 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017, 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2022 Marius Bakke <marius@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (gnu packages openldap)
+ (gnu packages autotools)
+ (gnu packages check)
+ (gnu packages compression)
+ (gnu packages cyrus-sasl)
+ (gnu packages dbm)
+ (gnu packages documentation)
+ (gnu packages gettext)
+ (gnu packages gnupg)
+ (gnu packages groff)
+ (gnu packages icu4c)
+ (gnu packages kerberos)
+ (gnu packages libevent)
+ (gnu packages linux)
+ (gnu packages networking)
+ (gnu packages nss)
+ (gnu packages password-utils)
+ (gnu packages pcre)
+ (gnu packages perl)
+ (gnu packages pkg-config)
+ (gnu packages python)
+ (gnu packages python-xyz)
+ (gnu packages rsync)
+ (gnu packages selinux)
+ (gnu packages time)
+ (gnu packages tls)
+ (gnu packages web)
+ (gnu packages)
+ ((guix licenses) #:select (openldap2.8 lgpl2.1+ gpl3+ psfl expat))
+ (guix packages)
+ (guix gexp)
+ (guix utils)
+ (guix download)
+ (guix build-system gnu)
+ (guix build-system python))
+
+ (package
+ (name "389-ds-base")
+ (version "1.4.4.17")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "https://github.com/389ds/389-ds-base/archive/"
+ "389-ds-base-" version ".tar.gz"))
+ (sha256
+ (base32
+ "0i8m4crbnjjhfb7cq758rd0fxyz36i291yq6fykkprjykz9s3zv4"))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:modules ((srfi srfi-1)
+ (guix build gnu-build-system)
+ ((guix build python-build-system)
+ #:select (add-installed-pythonpath python-version))
+ (guix build utils))
+ #:imported-modules ((guix build python-build-system)
+ ,@%gnu-build-system-modules)
+ #:configure-flags
+ (list (string-append "--with-db="
+ (assoc-ref %build-inputs "bdb"))
+ (string-append "--with-sasl="
+ (assoc-ref %build-inputs "cyrus-sasl"))
+ (string-append "--with-netsnmp="
+ (assoc-ref %build-inputs "net-snmp"))
+ (string-append "--with-pcre="
+ (assoc-ref %build-inputs "pcre"))
+ (string-append "--with-selinux="
+ (assoc-ref %build-inputs "libselinux"))
+ "--with-libldap-r=no"
+ "--localstatedir=/var"
+ "--with-instconfigdir=/etc/dirsrv"
+ ;; The Perl scripts are being removed in the 1.4.0 release.
+ ;; Building them would require packaging of the outdated Mozilla
+ ;; LDAP SDK (instead of OpenLDAP) and PerLDAP.
+ "--disable-perl")
+ #:phases
+ (modify-phases %standard-phases
+ (add-after 'unpack 'fix-references
+ (lambda _
+ (substitute* "include/ldaputil/certmap.h"
+ (("nss3/cert.h") "nss/cert.h"))
+ (substitute* "src/lib389/lib389/utils.py"
+ (("'/sbin/ip'")
+ (string-append "'" (which "ip") "'")))
+ (substitute* "src/lib389/lib389/nss_ssl.py"
+ (("'/usr/bin/certutil'")
+ (string-append "'" (which "certutil") "'"))
+ (("'/usr/bin/openssl'")
+ (string-append "'" (which "openssl") "'"))
+ (("'/usr/bin/c_rehash'")
+ (string-append "'" (which "perl") "', '"
+ (which "c_rehash") "'")))))
+ (add-after 'unpack 'overwrite-default-locations
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (substitute* "src/lib389/lib389/paths.py"
+ (("/usr/share/dirsrv/inf/defaults.inf")
+ (string-append out "/share/dirsrv/inf/defaults.inf")))
+ ;; This directory can only be specified relative to sysconfdir. This
+ ;; is used to determine where to look for installed directory
+ ;; servers, so in the absence of a search path it needs to be global.
+ (substitute* "ldap/admin/src/defaults.inf.in"
+ (("^initconfig_dir =.*")
+ "initconfig_dir = /etc/dirsrv/registry\n"))
+ ;; This is used to determine where to write certificate files
+ ;; when installing new directory server instances.
+ (substitute* '("src/lib389/lib389/instance/setup.py"
+ "src/lib389/lib389/instance/remove.py")
+ (("etc_dirsrv_path = .*")
+ "etc_dirsrv_path = '/etc/dirsrv/'\n")))))
+ (add-after 'unpack 'fix-install-location-of-python-tools
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (pythondir (string-append
+ out "/lib/python"
+ (python-version (assoc-ref inputs "python"))
+ "/site-packages/")))
+ ;; Install directory must be on PYTHONPATH.
+ (add-installed-pythonpath inputs outputs)
+ ;; Install directory must exist.
+ (mkdir-p pythondir)
+ (substitute* "src/lib389/setup.py"
+ (("/usr") out))
+ (substitute* "Makefile.am"
+ (("setup.py install --skip-build" m)
+ (string-append
+ m " --prefix=" out
+ " --root=/ --single-version-externally-managed"))))))
+ (add-after 'unpack 'dont-use-libldap-r
+ (lambda _
+ (substitute* "Makefile.am"
+ (("-lldap_r") "-lldap"))))
+ (add-after 'build 'build-python-tools
+ (lambda* (#:key make-flags #:allow-other-keys)
+ ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc
+ ;; files.
+ (setenv "DETERMINISTIC_BUILD" "1")
+ ;; Use deterministic hashes for strings, bytes, and datetime
+ ;; objects.
+ (setenv "PYTHONHASHSEED" "0")
+ (apply invoke "make" "lib389" make-flags)))
+ (add-after 'install 'install-python-tools
+ (lambda* (#:key make-flags #:allow-other-keys)
+ (apply invoke "make" "lib389-install" make-flags)))
+ (add-after 'install-python-tools 'wrap-python-tools
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (pythonpath (getenv "GUIX_PYTHONPATH")))
+ (for-each (lambda (file)
+ (wrap-program (string-append out file)
+ `("GUIX_PYTHONPATH" ":" prefix (,pythonpath))))
+ '("/sbin/dsconf"
+ "/sbin/dscreate"
+ "/sbin/dsctl"
+ "/sbin/dsidm"
+ "/bin/ds-logpipe.py"
+ "/bin/ds-replcheck"))))))))
+ (inputs
+ (list bdb
+ cracklib
+ cyrus-sasl
+ gnutls
+ httpd
+ icu4c
+ iproute
+ libevent
+ libselinux
+ linux-pam
+ mit-krb5
+ net-snmp
+ nspr
+ nss
+ (list nss "bin") ; for certutil
+ openldap
+ openssl ; #included by net-snmp
+ pcre
+ python
+ python-pyasn1
+ python-pyasn1-modules
+ python-pytest
+ python-dateutil
+ python-six
+ python-argcomplete
+ python-argparse-manpage
+ python-ldap))
+ (native-inputs
+ (list autoconf
+ automake
+ doxygen
+ gettext-minimal
+ libtool
+ perl
+ rsync
+ pkg-config))
+ (home-page "https://directory.fedoraproject.org")
+ (synopsis "Enterprise-class LDAP server")
+ (description "389ds is an enterprise-class LDAP server. It is hardened by
+real-world use, is full-featured, and supports multi-master replication.
+
+Other features include:
+
+@enumerate
+@item Online, zero downtime, LDAP-based update of schema, configuration, and
+ management including @dfn{Access Control Information} (ACIs);
+@item Asynchronous Multi-Master Replication, to provide fault tolerance and
+ high write performance;
+@item Extensive documentation;
+@item Secure authentication and transport (TLS, and SASL);
+@item LDAPv3 compliant server.
+@end enumerate\n")
+ ;; GPLv3+ with OpenSSL linking exception.
+ (license gpl3+))
diff --git a/vm-deploy.scm b/vm-deploy.scm
new file mode 100644
index 0000000..08dce6c
--- /dev/null
+++ b/vm-deploy.scm
@@ -0,0 +1,12 @@
+(define %os
+ (load (string-append (dirname (current-filename)) "/vm.scm")))
+
+(list (machine
+ (operating-system %os)
+ (environment managed-host-environment-type)
+ (configuration (machine-ssh-configuration
+ (host-name "localhost")
+ (system "x86_64-linux")
+ (port 22)
+ (host-key "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIN0aj062v8Mnxidud6DAyEN8XI8eCx+0fe6ad7QG1fXj")
+ (allow-downgrades? #t)))))
diff --git a/vm.scm b/vm.scm
new file mode 100644
index 0000000..aeae035
--- /dev/null
+++ b/vm.scm
@@ -0,0 +1,364 @@
+(use-modules ((srfi srfi-26) #:select (cut))
+
+ ((ice-9 match) #:select (match))
+ ((ice-9 popen) #:select (open-pipe* close-pipe))
+ ((ice-9 ports) #:select (OPEN_READ))
+ ((ice-9 regex) #:select (match:substring string-match))
+ ((ice-9 textual-ports) #:select (get-string-all))
+
+ ((gnu bootloader) #:select (bootloader-configuration))
+ ((gnu bootloader grub) #:select (grub-bootloader))
+ ((gnu packages) #:select (specifications->packages))
+ ((gnu packages admin) #:select (shadow))
+ ((gnu packages autotools) #:select
+ (autoconf automake lawrence-boilerplate))
+ ((gnu packages base) #:select (coreutils))
+ ((gnu packages guile) #:select (guile-3.0))
+ ((gnu packages guile-xyz) #:select (guile-cantius guile-lib))
+ ((gnu packages pkg-config) #:select (pkg-config))
+ ((gnu packages tls) #:select (openssl))
+ ((gnu packages web) #:select (httpd))
+ ((gnu services) #:select
+ (activation-service-type modify-services service-extension
+ service-type simple-service))
+ ((gnu services base) #:select
+ (guix-service-type guix-extension %base-services))
+ ((gnu services ldap) #:select
+ (backend-userroot-configuration
+ directory-server-instance-configuration
+ directory-server-service-type slapd-configuration))
+ ((gnu services mcron) #:prefix mc:)
+ ((gnu services networking) #:select (dhcp-client-service-type))
+ ((gnu services shepherd) #:select
+ (shepherd-root-service-type shepherd-service))
+ ((gnu services ssh) #:select
+ (openssh-service-type openssh-configuration))
+ ((gnu services web) #:prefix web:)
+ ((gnu system) #:select
+ (operating-system %base-packages))
+ ((gnu system accounts) #:select
+ (user-account user-extra-groups user-group))
+ ((gnu system file-systems) #:prefix fs:)
+ ((gnu system keyboard) #:select (keyboard-layout))
+ ((gnu system shadow) #:select (%base-groups %base-user-accounts))
+ ((guix build-system gnu)
+ #:select (%gnu-build-system-modules gnu-build-system))
+ ((guix gexp) #:select
+ (file-append gexp local-file with-imported-modules))
+ ((guix licenses) #:prefix license:)
+ ((guix packages) #:select (package)))
+
+(define %here (dirname (current-filename)))
+
+(define 389-ds-base
+ (load (string-append %here "/good-dirsrv.scm")))
+
+(define %ctftilde-phases
+ (with-imported-modules '((guix build guile-build-system))
+ #~(modify-phases %standard-phases
+ (add-after 'install 'patch-executable
+ (lambda* (#:key inputs #:allow-other-keys)
+ (use-modules ((guix build guile-build-system) #:select
+ (target-guile-effective-version)))
+
+ (define* (find-subdirs subdir #:optional
+ (dirs (cons #$output (map cdr inputs))))
+ (filter-map (lambda (pkg)
+ (let ((path (string-append pkg subdir)))
+ (and (file-exists? path) path)))
+ dirs))
+
+ (let* ((gver (target-guile-effective-version))
+ (scmdir (format #f "/share/guile/site/~a" gver))
+ (gobjdir (format #f "/lib/guile/~a/site-ccache" gver))
+ (executable (format #f "~a/bin/ctftilde" #$output))
+ (bin-pkgs (map (cut assoc-ref inputs <>)
+ '("coreutils" "guile" "openssl")))
+ (sbin-pkgs (list (assoc-ref inputs "shadow")))
+ (path (append (find-subdirs "/bin" bin-pkgs)
+ (find-subdirs "/sbin" sbin-pkgs)))
+ (load-path (find-subdirs scmdir))
+ (compiled-path (find-subdirs gobjdir)))
+
+ (patch-shebang executable)
+
+ (wrap-program executable
+ (list "PATH" 'prefix path)
+ (list "GUILE_LOAD_PATH" 'prefix load-path)
+ (list "GUILE_LOAD_COMPILED_PATH" 'prefix compiled-path)))))
+
+ (delete 'strip))))
+
+(define ctftilde
+ (package
+ (name "ctftilde")
+ (version "current")
+ (source (local-file (string-append %here "/ctftilde")
+ #:recursive? #t))
+ (build-system gnu-build-system)
+ (arguments
+ (list #:modules (cons* '(srfi srfi-1)
+ '(srfi srfi-26)
+ %gnu-build-system-modules)
+ #:phases %ctftilde-phases))
+ (native-inputs
+ (list autoconf
+ automake
+ guile-3.0
+ pkg-config
+ lawrence-boilerplate))
+ (inputs
+ (list coreutils guile-3.0 openssl shadow))
+ (propagated-inputs
+ (list guile-cantius guile-lib))
+ (home-page "https://ctftilde.koszko.org/")
+ (synopsis "Ctftilde website and user management.")
+ (description "Simple users management tool and website and built with
+Cantius, part of a CTF competition VM.")
+ (license license:cc0)))
+
+(define %services
+ %base-services)
+
+(define-syntax-rule (prepend list item)
+ (define list
+ (cons item list)))
+
+(prepend %services
+ (service dhcp-client-service-type))
+
+(define ds-root-password-hash
+ (let* ((password (call-with-input-file "ds-389.password" get-string-all))
+ (path (string-split (getenv "PATH") #\:))
+ (has-pwdhash? (search-path path "pwdhash"))
+ (command (list "pwdhash" "-s" "SHA256" password))
+ (command* (if has-pwdhash?
+ command
+ (cons* "guix" "shell" "389-ds-base" "--" command)))
+ (pipe (apply open-pipe* OPEN_READ command*))
+ (hash (get-string-all pipe)))
+ (close-pipe pipe)
+ (string-trim-right hash #\newline)))
+
+(format #t "directory server root password hash: ~A~%" ds-root-password-hash)
+
+(prepend %services
+ (simple-service 'cert-access-ctftilde activation-service-type
+ #~(let ((access-gid (group:gid (getgrnam "cert-ctftilde"))))
+ (for-each (lambda (file mode)
+ (let ((full-path (string-append "/etc/cert-ctftilde" file)))
+ (chown full-path 0 access-gid)
+ (chmod full-path mode)))
+ '("" "/fullchain.pem" "/privkey.pem")
+ '(#o750 #o640 #o640)))))
+
+(prepend %services
+ (service directory-server-service-type
+ (directory-server-instance-configuration
+ (package 389-ds-base)
+ (full-machine-name "ctftilde.koszko.org")
+ (slapd (slapd-configuration
+ (instance-name "ctftilde")
+ (root-dn "cn=CTF Manager")
+ (root-password ds-root-password-hash)
+ (run-dir "/var/run/dirsrv")))
+ (backend-userroot ((@@ (gnu services ldap) backend-userroot-configuration)
+ ;;(create-suffix-entry? #f)
+ (suffix "dc=ctftilde,dc=koszko,dc=org"))))))
+
+(prepend %services
+ (simple-service 'gemini-main-server-directory activation-service-type
+ #~(begin
+ (false-if-exception (delete-file "/srv/gemini"))
+ (symlink #$(local-file (string-append %here "/gemini")
+ #:recursive? #t)
+ "/srv/gemini"))))
+
+(prepend %services
+ (simple-service 'gemini-users-directory activation-service-type
+ #~(mkdir-p "/srv/gemini-users")))
+
+(prepend %services
+ (service web:gmnisrv-service-type
+ (web:gmnisrv-configuration
+ (config-file (local-file "gmnisrv.ini")))))
+
+(prepend %services
+ (simple-service 'guix-authorize-key guix-service-type
+ (guix-extension
+ (authorized-keys (list (local-file "guix-signing-key.pub"))))))
+
+(prepend %services
+ (simple-service 'http-users-directory activation-service-type
+ #~(mkdir-p "/srv/http-users")))
+
+(prepend %services
+ (service web:httpd-service-type
+ (web:httpd-configuration
+ (config
+ (web:httpd-config-file
+ (server-name "ctftilde.koszko.org")
+ (listen '("80" "443"))
+ (error-log "/var/log/httpd/error.log")
+ (modules (append
+ (map (lambda (name)
+ (let ((filename (format #f "/modules/mod_~a.so" name)))
+ (web:httpd-module
+ (name (string-append name "_module"))
+ (file (file-append httpd filename)))))
+ (list "cgid"
+ "headers"
+ "logio"
+ "proxy"
+ "proxy_http"
+ "rewrite"
+ "ssl"
+ "userdir"))
+ web:%default-httpd-modules))
+ (extra-config
+ (list "\
+ LogFormat \"%>s %u %t \\\"%r\\\" %I in %O out \
+\\\"%{Referer}i\\\" \\\"%{User-Agent}i\\\"\" combined
+ CustomLog /var/log/httpd/access.log combined
+ ScriptSock /var/run/cgid.sock
+ ")))))))
+
+(prepend %services
+ (simple-service 'http-virtualhost-ctftilde web:httpd-service-type
+ (map (lambda (port)
+ (web:httpd-virtualhost
+ (format #f "*:~a" port)
+ `("\
+ ServerName ctftilde.koszko.org
+ ServerAlias www.ctftilde.koszko.org
+ ServerAdmin webmaster@ctftilde.koszko.org
+
+ UserDir /srv/http-users
+
+ ProxyPassMatch ^/(([^~].*)?)$ http://127.0.0.1:8080/$1
+ ProxyPassReverse / http://127.0.0.1:8080/
+ "
+ . ,(if (= port 443)
+ '("\
+ SSLEngine on
+ SSLCertificateFile /etc/cert-ctftilde/fullchain.pem
+ SSLCertificateKeyFile /etc/cert-ctftilde/privkey.pem
+ ")
+ '()))))
+ '(80 443))))
+
+(prepend %services
+ (service mc:mcron-service-type
+ (mc:mcron-configuration
+ (/var-tabs? #t))))
+
+(prepend %services
+ (service openssh-service-type
+ (openssh-configuration
+ (permit-root-login 'prohibit-password)
+ (authorized-keys `(("root" ,(local-file "owner.pub"))))
+ (port-number 22))))
+
+(define %ctftilde-accounts
+ (list (user-group (name "ctftilde") (system? #t))
+ (user-account
+ (name "ctftilde")
+ (group "ctftilde")
+ (system? #t)
+ (comment "ctftilde http website server user")
+ (home-directory "/var/run/ctftilde")
+ (shell (file-append shadow "/sbin/nologin")))))
+
+(define %ctftilde-activation
+ #~(begin
+ (mkdir-p "/var/db")
+
+ (let ((old-umask (umask)))
+ (dynamic-wind
+
+ noop
+
+ (lambda _
+ (umask #o077)
+ (mkdir-p "/var/db/ctftilde/users")
+ (mkdir-p "/var/db/ctftilde/users-to-delete"))
+
+ (lambda _
+ (umask old-umask))))
+
+ (system* (string-append #$ctftilde "/bin/ctftilde") "--users-recreate"
+ "--log-file" "/var/log/ctftilde")))
+
+(define %ctftilde-shepherd-services
+ (list (shepherd-service
+ (requirement '(networking))
+ (provision '(ctftilde))
+ (start #~(make-forkexec-constructor
+ (list #$(file-append ctftilde "/bin/ctftilde")
+ "--site-host" "--log-file" "/var/log/ctftilde")))
+ (stop #~(make-kill-destructor))
+ (documentation
+ "ctftilde server daemon (user management & http site)."))))
+
+(define ctftile-service-type
+ (service-type (name 'ctftilde)
+ (description "Host ctftilde main website and manage users.")
+ (extensions
+ (list (service-extension account-service-type
+ (const %ctftilde-accounts))
+ (service-extension activation-service-type
+ (const %ctftilde-activation))
+ (service-extension shepherd-root-service-type
+ (const %ctftilde-shepherd-services))))
+ (default-value #f)))
+
+(prepend %services
+ (service ctftile-service-type))
+
+(define bootloader-target
+ (or (getenv "CTFTILDE_DISK_DEV") "/dev/sda"))
+
+(format #t "bootloader target: ~A~%" bootloader-target)
+
+(operating-system
+ (host-name "ctftilde")
+ (timezone "Europe/Warsaw")
+ (locale "en_US.utf8")
+
+ (keyboard-layout (keyboard-layout "pl"))
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list bootloader-target))))
+
+ (users %base-user-accounts)
+
+ (groups (cons* (user-group (name "cert-ctftilde") (system? #t))
+ (user-group (name "hackers"))
+ %base-groups))
+
+ (extra-groups (list (user-extra-groups
+ (user "httpd")
+ (groups '("cert-ctftilde")))))
+
+ (file-systems (cons* (fs:file-system
+ (device (fs:file-system-label "ctftilde-root"))
+ (mount-point "/")
+ (type "ext4"))
+ fs:%base-file-systems))
+
+ (packages (append (specifications->packages
+ '("file"
+ "net-tools"
+ "man-pages-posix"
+ "emacs"))
+ (list ctftilde
+ 389-ds-base)
+ %base-packages))
+
+ (services %services))
+
+;;; Local Variables:
+;;; eval: (put 'prepend 'scheme-indent-function 1)
+;;; eval: (put 'simple-service 'scheme-indent-function 2)
+;;; End:
generated by cgit