;;; guix-forge --- Guix software forge meta-service ;;; Copyright © 2022, 2023 Arun Isaac ;;; ;;; This file is part of guix-forge. ;;; ;;; guix-forge 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. ;;; ;;; guix-forge 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 guix-forge. If not, see ;;; . (define-module (forge tissue) #:use-module (srfi srfi-1) #:use-module ((forge guile-git) #:select (guile-git)) #:use-module (forge socket) #:use-module (gnu build linux-container) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module ((gnu packages web) #:select (tissue) #:prefix guix:) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system file-systems) #:use-module (gnu system shadow) #:use-module (guix gexp) #:use-module (guix git-download) #:use-module (guix least-authority) #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix records) #:export (tissue-service-type tissue-configuration tissue-configuration? tissue-configuration-package tissue-configuration-socket tissue-configuration-state-directory tissue-configuration-hosts tissue-host tissue-host? tissue-host-name tissue-host-user tissue-host-upstream-repository)) ;; Run an updated version of tissue until the the 0.1.1 release is ;; out. (define-public tissue (let ((commit "0c3d6cb7d781fbc0c12eba1563cc7b7ebb370ba9") (revision "1")) (package (inherit guix:tissue) (name "tissue") (version (git-version "0.1.0" revision commit)) (source (origin (method git-fetch) (uri (git-reference (url "https://git.systemreboot.net/tissue") (commit commit))) (file-name (git-file-name name version)) (sha256 (base32 "0hdqa5n8dm2nc4ccx39xclgajv3ivwpb1hbz9kpbbv25iizqhnv2")))) (inputs (modify-inputs (package-inputs guix:tissue) (replace "guile-git" guile-git)))))) (define-record-type* tissue-configuration make-tissue-configuration tissue-configuration? (package tissue-configuration-package (default tissue)) (socket tissue-configuration-socket (default (forge-unix-socket (path "/var/run/tissue/socket")))) (state-directory tissue-configuration-state-directory (default "/var/lib/tissue")) (hosts tissue-configuration-hosts (default '()))) (define-record-type* tissue-host make-tissue-host tissue-host? (name tissue-host-name) (user tissue-host-user (default "tissue")) (upstream-repository tissue-host-upstream-repository)) (define %tissue-accounts (list (user-account (name "tissue") (group "tissue") (system? #t) (comment "tissue user") (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))) (user-group (name "tissue") (system? #t)))) (define (tissue-conf-gexp config) (match-record config (socket state-directory hosts) #~(begin (use-modules (ice-9 pretty-print)) (call-with-output-file #$output (lambda (port) (pretty-print '((listen . #$(cond ((forge-ip-socket? socket) (match-record socket (ip port) (string-append (if (ipv4-address? ip) ip (string-append "[" ip "]")) ":" (number->string port)))) ((forge-unix-socket? socket) (string-append "unix:" (forge-unix-socket-path socket))) (else (raise (condition (make-message-condition "Socket must be a or record") (make-irritants-condition socket)))))) (state-directory . #$state-directory) (hosts . #$(map (lambda (host) (match-record host (name upstream-repository) `(,name (upstream-repository . ,upstream-repository)))) hosts))) port)))))) ;; We cannot just pass the configuration file on the command-line ;; because we need future `tissue pull' invocations to find it. These ;; `tissue pull' invocations are beyond the scope of this service, and ;; will need to find the configuration at a standard location. (define (tissue-etc-files config) `(("tissue.conf" ,(computed-file "tissue.conf" (tissue-conf-gexp config))))) (define (tissue-activation config) (match-record config (socket state-directory hosts) (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils) (ice-9 match)) (let ((user (getpw "tissue"))) ;; Create socket directory if Unix socket. #$(and (forge-unix-socket? socket) #~(let ((socket-directory #$(dirname (forge-unix-socket-path socket)))) (mkdir-p socket-directory) (chown socket-directory (passwd:uid user) (passwd:gid user)))) ;; Create state directory. The state directory is owned by ;; the tissue user. (mkdir-p #$state-directory) (chown #$state-directory (passwd:uid user) (passwd:gid user))) ;; Create host directories if they don't exist, and set ;; permissions. Each host directory may be owned by its own ;; user. (for-each (match-lambda ((hostname username) (let ((host-directory (string-append #$state-directory "/" hostname)) (user (getpw username))) (mkdir-p host-directory) (for-each (lambda (file) (chown file (passwd:uid user) (passwd:gid user))) (find-files host-directory #:directories? #t))))) '#$(map (lambda (host) (match-record host (name user) (list name user))) hosts)))))) (define (tissue-shepherd-service config) (match-record config (socket state-directory) (shepherd-service (documentation "Run tissue web server.") (provision '(tissue)) (requirement '(networking)) (start (let ((tissue-conf (computed-file "tissue.conf" (tissue-conf-gexp config)))) #~(make-forkexec-constructor (list #$(least-authority-wrapper (file-append (tissue-configuration-package config) "/bin/tissue") #:name "tissue" #:mappings (cons* (file-system-mapping (source tissue-conf) (target source)) (file-system-mapping (source state-directory) (target source)) (if (forge-unix-socket? socket) (list (file-system-mapping (source (dirname (forge-unix-socket-path socket))) (target source) (writable? #t))) (list))) ;; TODO: If socket is a Unix socket, run in a ;; network namespace. We can't do this yet due to ;; https://yhetil.org/guix/m1ilknoi5r.fsf@fastmail.net/ #:namespaces (delq 'net %namespaces)) "web" (string-append "--config=" #$tissue-conf)) #:user "tissue" #:group "tissue" #:log-file "/var/log/tissue.log"))) (stop #~(make-kill-destructor))))) (define tissue-service-type (service-type (name 'tissue) (description "Run tissue web server.") (extensions (list (service-extension account-service-type (const %tissue-accounts)) (service-extension etc-service-type tissue-etc-files) (service-extension activation-service-type tissue-activation) (service-extension shepherd-root-service-type (compose list tissue-shepherd-service)))) (compose concatenate) (extend (lambda (config host-extensions) (tissue-configuration (inherit config) (hosts (append (tissue-configuration-hosts config) host-extensions))))) (default-value (tissue-configuration))))